Skip to content

Commit 9ffd542

Browse files
bobzhangbobzhang
committed
factor out cmd line ppx from parsing
1 parent 785e32b commit 9ffd542

File tree

5 files changed

+134
-127
lines changed

5 files changed

+134
-127
lines changed

‎jscomp/common/ml_binary.ml

+7-1
Original file line numberDiff line numberDiff line change
@@ -48,4 +48,10 @@ let write_ast (type t) (kind : t kind)
4848
| Mli -> Config.ast_intf_magic_number in
4949
output_string oc magic ;
5050
output_value oc fname;
51-
output_value oc pt
51+
output_value oc pt
52+
53+
let magic_of_kind : type a . a kind -> string = function
54+
| Ml -> Config.ast_impl_magic_number
55+
| Mli -> Config.ast_intf_magic_number
56+
57+

‎jscomp/common/ml_binary.mli

+3-1
Original file line numberDiff line numberDiff line change
@@ -32,4 +32,6 @@ type _ kind =
3232
val read_ast : 'a kind -> in_channel -> 'a
3333

3434
val write_ast :
35-
'a kind -> string -> 'a -> out_channel -> unit
35+
'a kind -> string -> 'a -> out_channel -> unit
36+
37+
val magic_of_kind : 'a kind -> string

‎jscomp/core/cmd_ast_exception.ml

+27
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
type error =
2+
| CannotRun of string
3+
| WrongMagic of string
4+
5+
exception Error of error
6+
7+
8+
let report_error ppf = function
9+
| CannotRun cmd ->
10+
Format.fprintf ppf "Error while running external preprocessor@.\
11+
Command line: %s@." cmd
12+
| WrongMagic cmd ->
13+
Format.fprintf ppf "External preprocessor does not produce a valid file@.\
14+
Command line: %s@." cmd
15+
16+
let () =
17+
Location.register_error_of_exn
18+
(function
19+
| Error err -> Some (Location.error_of_printer_file report_error err)
20+
| _ -> None
21+
)
22+
23+
let cannot_run comm =
24+
raise (Error (CannotRun comm))
25+
26+
let wrong_magic magic =
27+
raise (Error (WrongMagic magic))

‎jscomp/core/cmd_ppx_apply.ml

+83
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,83 @@
1+
2+
3+
(* Note: some of the functions here should go to Ast_mapper instead,
4+
which would encapsulate the "binary AST" protocol. *)
5+
6+
let write_ast (type a) (kind : a Ml_binary.kind) fn (ast : a) =
7+
let oc = open_out_bin fn in
8+
output_string oc (Ml_binary.magic_of_kind kind);
9+
output_value oc (!Location.input_name : string);
10+
output_value oc (ast : a);
11+
close_out oc
12+
13+
let apply_rewriter kind fn_in ppx =
14+
let magic = Ml_binary.magic_of_kind kind in
15+
let fn_out = Filename.temp_file "camlppx" "" in
16+
let comm =
17+
Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
18+
in
19+
let ok = Ccomp.command comm = 0 in
20+
Misc.remove_file fn_in;
21+
if not ok then begin
22+
Misc.remove_file fn_out;
23+
Cmd_ast_exception.cannot_run comm
24+
end;
25+
if not (Sys.file_exists fn_out) then
26+
Cmd_ast_exception.cannot_run comm;
27+
(* check magic before passing to the next ppx *)
28+
let ic = open_in_bin fn_out in
29+
let buffer =
30+
try really_input_string ic (String.length magic) with End_of_file -> "" in
31+
close_in ic;
32+
if buffer <> magic then begin
33+
Misc.remove_file fn_out;
34+
Cmd_ast_exception.wrong_magic buffer;
35+
end;
36+
fn_out
37+
38+
let read_ast (type a) (kind : a Ml_binary.kind) fn : a =
39+
let ic = open_in_bin fn in
40+
try
41+
let magic = Ml_binary.magic_of_kind kind in
42+
let buffer = really_input_string ic (String.length magic) in
43+
assert(buffer = magic); (* already checked by apply_rewriter *)
44+
Location.set_input_name @@ (input_value ic : string);
45+
let ast = (input_value ic : a) in
46+
close_in ic;
47+
Misc.remove_file fn;
48+
ast
49+
with exn ->
50+
close_in ic;
51+
Misc.remove_file fn;
52+
raise exn
53+
let rewrite kind ppxs ast =
54+
let fn = Filename.temp_file "camlppx" "" in
55+
write_ast kind fn ast;
56+
let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
57+
read_ast kind fn
58+
59+
let apply_rewriters_str ?(restore = true) ~tool_name ast =
60+
match !Clflags.all_ppx with
61+
| [] -> ast
62+
| ppxs ->
63+
ast
64+
|> Ast_mapper.add_ppx_context_str ~tool_name
65+
|> rewrite Ml ppxs
66+
|> Ast_mapper.drop_ppx_context_str ~restore
67+
68+
let apply_rewriters_sig ?(restore = true) ~tool_name ast =
69+
match !Clflags.all_ppx with
70+
| [] -> ast
71+
| ppxs ->
72+
ast
73+
|> Ast_mapper.add_ppx_context_sig ~tool_name
74+
|> rewrite Mli ppxs
75+
|> Ast_mapper.drop_ppx_context_sig ~restore
76+
77+
let apply_rewriters ?restore ~tool_name
78+
(type a) (kind : a Ml_binary.kind) (ast : a) : a =
79+
match kind with
80+
| Ml_binary.Ml ->
81+
apply_rewriters_str ?restore ~tool_name ast
82+
| Ml_binary.Mli ->
83+
apply_rewriters_sig ?restore ~tool_name ast

‎jscomp/core/pparse_driver.ml

+14-125
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,5 @@
11

22

3-
type error =
4-
| CannotRun of string
5-
| WrongMagic of string
6-
7-
exception Error of error
83

94
(* Optionally preprocess a source file *)
105

@@ -15,7 +10,7 @@ let call_external_preprocessor sourcefile pp =
1510
in
1611
if Ccomp.command comm <> 0 then begin
1712
Misc.remove_file tmpfile;
18-
raise (Error (CannotRun comm));
13+
Cmd_ast_exception.cannot_run comm
1914
end;
2015
tmpfile
2116

@@ -32,122 +27,29 @@ let remove_preprocessed inputfile =
3227
| Some _ -> Misc.remove_file inputfile
3328

3429

35-
let magic_of_kind : type a . a Ml_binary.kind -> string = function
36-
| Ml_binary.Ml -> Config.ast_impl_magic_number
37-
| Ml_binary.Mli -> Config.ast_intf_magic_number
3830

39-
(* Note: some of the functions here should go to Ast_mapper instead,
40-
which would encapsulate the "binary AST" protocol. *)
4131

42-
let write_ast (type a) (kind : a Ml_binary.kind) fn (ast : a) =
43-
let oc = open_out_bin fn in
44-
output_string oc (magic_of_kind kind);
45-
output_value oc (!Location.input_name : string);
46-
output_value oc (ast : a);
47-
close_out oc
4832

49-
let apply_rewriter kind fn_in ppx =
50-
let magic = magic_of_kind kind in
51-
let fn_out = Filename.temp_file "camlppx" "" in
52-
let comm =
53-
Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
54-
in
55-
let ok = Ccomp.command comm = 0 in
56-
Misc.remove_file fn_in;
57-
if not ok then begin
58-
Misc.remove_file fn_out;
59-
raise (Error (CannotRun comm));
60-
end;
61-
if not (Sys.file_exists fn_out) then
62-
raise (Error (WrongMagic comm));
63-
(* check magic before passing to the next ppx *)
64-
let ic = open_in_bin fn_out in
65-
let buffer =
66-
try really_input_string ic (String.length magic) with End_of_file -> "" in
67-
close_in ic;
68-
if buffer <> magic then begin
69-
Misc.remove_file fn_out;
70-
raise (Error (WrongMagic comm));
71-
end;
72-
fn_out
73-
74-
let read_ast (type a) (kind : a Ml_binary.kind) fn : a =
75-
let ic = open_in_bin fn in
76-
try
77-
let magic = magic_of_kind kind in
78-
let buffer = really_input_string ic (String.length magic) in
79-
assert(buffer = magic); (* already checked by apply_rewriter *)
80-
Location.set_input_name @@ (input_value ic : string);
81-
let ast = (input_value ic : a) in
82-
close_in ic;
83-
Misc.remove_file fn;
84-
ast
85-
with exn ->
86-
close_in ic;
87-
Misc.remove_file fn;
88-
raise exn
89-
90-
let rewrite kind ppxs ast =
91-
let fn = Filename.temp_file "camlppx" "" in
92-
write_ast kind fn ast;
93-
let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
94-
read_ast kind fn
95-
96-
let apply_rewriters_str ?(restore = true) ~tool_name ast =
97-
match !Clflags.all_ppx with
98-
| [] -> ast
99-
| ppxs ->
100-
ast
101-
|> Ast_mapper.add_ppx_context_str ~tool_name
102-
|> rewrite Ml ppxs
103-
|> Ast_mapper.drop_ppx_context_str ~restore
104-
105-
let apply_rewriters_sig ?(restore = true) ~tool_name ast =
106-
match !Clflags.all_ppx with
107-
| [] -> ast
108-
| ppxs ->
109-
ast
110-
|> Ast_mapper.add_ppx_context_sig ~tool_name
111-
|> rewrite Mli ppxs
112-
|> Ast_mapper.drop_ppx_context_sig ~restore
113-
114-
let apply_rewriters ?restore ~tool_name
115-
(type a) (kind : a Ml_binary.kind) (ast : a) : a =
116-
match kind with
117-
| Ml_binary.Ml ->
118-
apply_rewriters_str ?restore ~tool_name ast
119-
| Ml_binary.Mli ->
120-
apply_rewriters_sig ?restore ~tool_name ast
12133

12234
(* Parse a file or get a dumped syntax tree from it *)
12335

124-
exception Outdated_version
125-
126-
let open_and_check_magic inputfile ast_magic =
127-
let ic = open_in_bin inputfile in
128-
let is_ast_file =
129-
try
130-
let buffer = really_input_string ic (String.length ast_magic) in
131-
if buffer = ast_magic then true
132-
else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
133-
raise Outdated_version
134-
else false
135-
with
136-
Outdated_version ->
137-
Misc.fatal_error "OCaml and preprocessor have incompatible versions"
138-
| _ -> false
139-
in
140-
(ic, is_ast_file)
141-
14236
let parse (type a) (kind : a Ml_binary.kind) lexbuf : a =
14337
match kind with
14438
| Ml_binary.Ml -> Parse.implementation lexbuf
14539
| Ml_binary.Mli -> Parse.interface lexbuf
14640

14741
let file_aux ppf inputfile (type a) (parse_fun : _ -> a)
14842
(kind : a Ml_binary.kind) : a =
149-
let ast_magic = magic_of_kind kind in
150-
let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
43+
let ast_magic = Ml_binary.magic_of_kind kind in
44+
let ic = open_in_bin inputfile in
45+
let is_ast_file =
46+
match really_input_string ic (String.length ast_magic) with
47+
| exception _ -> false
48+
| buffer ->
49+
if buffer = ast_magic then true
50+
else if Ext_string.starts_with buffer "Caml1999" then
51+
Cmd_ast_exception.wrong_magic buffer
52+
else false in
15153
let ast =
15254
try
15355
if is_ast_file then begin
@@ -169,20 +71,7 @@ let file_aux ppf inputfile (type a) (parse_fun : _ -> a)
16971

17072

17173

172-
let report_error ppf = function
173-
| CannotRun cmd ->
174-
Format.fprintf ppf "Error while running external preprocessor@.\
175-
Command line: %s@." cmd
176-
| WrongMagic cmd ->
177-
Format.fprintf ppf "External preprocessor does not produce a valid file@.\
178-
Command line: %s@." cmd
179-
180-
let () =
181-
Location.register_error_of_exn
182-
(function
183-
| Error err -> Some (Location.error_of_printer_file report_error err)
184-
| _ -> None
185-
)
74+
18675

18776
let parse_file kind ppf sourcefile =
18877
Location.set_input_name sourcefile;
@@ -200,8 +89,8 @@ let parse_file kind ppf sourcefile =
20089

20190

20291
let parse_implementation ppf ~tool_name sourcefile =
203-
apply_rewriters ~restore:false ~tool_name Ml (parse_file
92+
Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name Ml (parse_file
20493
Ml ppf sourcefile)
20594
let parse_interface ppf ~tool_name sourcefile =
206-
apply_rewriters ~restore:false ~tool_name Mli (parse_file
95+
Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name Mli (parse_file
20796
Mli ppf sourcefile)

0 commit comments

Comments
 (0)