-
Notifications
You must be signed in to change notification settings - Fork 5
/
main.ml
147 lines (122 loc) · 4.59 KB
/
main.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
module B = Bytes
open Core_kernel.Std
open Lexing
open Types
let print_sexp sx =
print_endline (Sexp.to_string_hum ~indent:2 sx)
let print_prog parse_tree =
parse_tree |>
sexp_of_parse_tree |>
print_sexp
let print_cprog cprog =
print_sexp (sexp_of_cprog cprog)
let print_iprog iprog =
let rprog = BackEnd.rprog_of_iprog ~prefix:"ss" iprog in
BackEnd.print_to_stdout rprog
(* Our lexer can handle UTF-8 encoded files as long as all the non-ASCII characters
* are inside comments or quoted strings. However, it can't deal with the Byte-Order-Mark
* that Notepad and some other windows editors might add to the file *)
let skip_utf8_BOM chan =
let bom = "\xEF\xBB\xBF" in
let bom_len = String.length bom in
let orig_pos = In_channel.pos chan in
let buf = B.make bom_len '\x00' in
let n = In_channel.input chan ~buf ~pos:0 ~len:bom_len in
if not (n = bom_len && String.equal bom (B.to_string buf)) then
In_channel.seek chan orig_pos
let compile in_filename =
let exit_with_error errname pos errinfo =
(match pos with
| None -> ()
| Some pos -> fprintf stderr "Line %d, column %d:\n" (pos_lnum pos) (pos_cnum pos));
fprintf stderr "%s" errname;
(match errinfo with
| None -> ()
| Some s -> fprintf stderr ": %s" s);
fprintf stderr "\n";
exit 1
in
if not (FilePath.check_extension in_filename "scfg") then
exit_with_error "Error" None
(Some (sprintf "`%s' does not have a .scfg extension" in_filename))
;
let in_chan =
try In_channel.create ~binary:false in_filename
with Sys_error(msg) -> exit_with_error "Error" None (Some msg)
in
skip_utf8_BOM in_chan;
let in_buf = Lexing.from_channel in_chan in
in_buf.lex_curr_p <- { in_buf.lex_curr_p with pos_fname = in_filename };
try
let parse_tree = Parser.prog (Lexer.create()) in_buf in
let cprog = FrontEnd.parse_tree_to_cprog parse_tree in
(*print_endline "CPROG =============";
print_cprog cprog;*)
let iprog = BackEnd.cprog_to_iprog cprog in
(*print_endline "IPROG =============";
print_iprog iprog;*)
let iprog = BackEnd.inline_constant_aliases iprog in
(*print_endline "INLINE =============";
print_iprog iprog;*)
let iprog = BackEnd.lift_constant_aliases iprog in
(*print_endline "LIFT =============";
print_iprog iprog;*)
(* Now we know there will be no compilation errors so
* its OK to overwrite any output files *)
let main_filename = FilePath.replace_extension in_filename "cfg" in
let outdir = FilePath.chop_extension in_filename in
let basename = FilePath.basename outdir in
(* the filename is used to generate internal alias names *)
if not (String.for_all basename ~f:(fun c -> Char.is_alphanum c || c = '_'))
then
exit_with_error "Error" None
(Some "The name of the input file must contain only letters, numbers and underscores")
;
let (main_lines, helper_files) = BackEnd.rprog_of_iprog iprog ~prefix:basename in
FileUtil.rm [main_filename];
FileUtil.rm ~recurse:true [outdir];
if not (List.is_empty helper_files) then
FileUtil.mkdir outdir
;
let out_files =
(main_filename, main_lines) ::
List.map helper_files ~f:(fun (b, lines) ->
(FilePath.concat outdir b, lines))
in
List.iter out_files ~f:(fun (filename, lines) ->
Out_channel.with_file ~binary:false filename ~f:(fun file ->
Out_channel.output_string file
"//This file was automatically generated by scfgc. Do not edit it by hand.\n";
Out_channel.output_lines file lines
));
()
with
| Lexer.LexerError s ->
exit_with_error "Lexer Error" (Some in_buf.lex_curr_p) (Some s)
| Parser.Error ->
exit_with_error "Syntax Error" (Some in_buf.lex_curr_p) None
| CompilationError(errs) ->
List.iter errs ~f:(fun (pos, msg) ->
exit_with_error "Error" (Some pos) (Some msg))
(* ----- *)
open Cmdliner
let filename =
let doc = "Source .scfg file" in
Arg.(required @@ pos 0 (some @@ file) None @@ info [] ~doc ~docv:"filename")
let cmd =
let doc = "Super Source Config compiler" in
let man = [
`S "DESCRIPTION";
`P "$(tname) is a config script generator for Source games such as Dota2. \
It compiles a high-level config language down to the native \
config language that the game understands.";
`S "BUGS";
`P "Send bugs and suggestions to https://github.com/hugomg/scfgc";
] in
Term.(
pure compile $ filename,
info "scfgc" ~version:"0.3" ~doc ~man)
let () =
match Term.eval cmd with
| `Version | `Help | `Ok _ -> exit 0
| `Error _ -> exit 1