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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
# 1 "src/ocaml/driver/pparse.ml"
open Std
let {Logger. log} = Logger.for_section "Pparse"
type error =
| CannotRun of string
| WrongMagic of string
let write_ast magic ast =
let fn = Filename.temp_file "camlppx" "" in
let oc = open_out_bin fn in
output_string oc magic;
output_value oc !Location.input_name;
output_value oc ast;
close_out oc;
fn
let report_error = function
| CannotRun cmd ->
log ~title:"report_error"
"Error while running external preprocessor. Command line: %s" cmd
| WrongMagic cmd ->
log ~title:"report_error"
"External preprocessor does not produce a valid file. Command line: %s" cmd
let commandline prog args =
Printf.sprintf "%s %s" prog
(String.concat ~sep:" " (List.map ~f:Filename.quote args))
let apply_rewriter magic ppx (fn_in, failures) =
let title = "apply_rewriter" in
let fn_out = Filename.temp_file "camlppx" "" in
let args = [fn_in; fn_out] in
let comm = commandline ppx.workval args in
log ~title "running %s from directory %S" comm ppx.workdir;
Logger.log_flush ();
let ok =
match
!System.run_in_directory
~prog:ppx.workval
~prog_is_quoted:true
~args
~cwd:ppx.workdir
()
with
| `Finished 0 -> true
| `Finished _ | `Cancelled -> false
in
let failure =
if not ok then Some (CannotRun comm)
else if not (Sys.file_exists fn_out) then
Some (WrongMagic comm)
else
let ic = open_in_bin fn_out in
let buffer =
try really_input_string ic (String.length magic)
with End_of_file -> ""
in
close_in ic;
if buffer <> magic then
Some (WrongMagic comm)
else
None
in
match failure with
| Some err ->
Misc.remove_file fn_out;
let fallback =
let fallback =
Filename.concat (Filename.get_temp_dir_name ())
("camlppx.lastfail" ^ string_of_int failures)
in
match Sys.rename fn_in fallback with
| () -> fallback
| exception exn ->
log ~title "exception while renaming ast: %a"
Logger.exn exn;
fn_in
in
report_error err;
(fallback, failures + 1)
| None ->
Misc.remove_file fn_in;
(fn_out, failures)
let read_ast magic fn =
let ic = open_in_bin fn in
try
let buffer = really_input_string ic (String.length magic) in
assert(buffer = magic);
Location.input_name := input_value ic;
let ast = input_value ic in
close_in ic;
Misc.remove_file fn;
ast
with exn ->
close_in ic;
Misc.remove_file fn;
raise exn
let rewrite magic ast ppxs =
let fn_out, _ =
List.fold_right
~f:(apply_rewriter magic) ~init:(write_ast magic ast, 0) ppxs
in
read_ast magic fn_out
let apply_rewriters_str ~ppx ?(restore = true) ~tool_name ast =
match ppx with
| [] -> ast
| ppxs ->
let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in
let ast = rewrite Config.ast_impl_magic_number ast ppxs in
Ast_mapper.drop_ppx_context_str ~restore ast
let apply_rewriters_sig ~ppx ?(restore = true) ~tool_name ast =
match ppx with
| [] -> ast
| ppxs ->
let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in
let ast = rewrite Config.ast_intf_magic_number ast ppxs in
Ast_mapper.drop_ppx_context_sig ~restore ast
let apply_rewriters ~ppx ?restore ~tool_name = function
| `Interface ast ->
`Interface (apply_rewriters_sig ~ppx ?restore ~tool_name ast)
| `Implementation ast ->
`Implementation (apply_rewriters_str ~ppx ?restore ~tool_name ast)
type ('a, 'b) res = Ok of 'a | Error of 'b
let apply_pp ~workdir ~filename ~source ~pp =
let fn_in = Filename.temp_file "merlinpp" (Filename.basename filename) in
begin
let oc = open_out_bin fn_in in
output_string oc source;
close_out oc
end;
let fn_out = fn_in ^ ".out" in
let args = [fn_in] in
let comm = commandline pp args in
let ok =
match
!System.run_in_directory
~prog:pp
~prog_is_quoted:true
~args
~stdout:fn_out
~cwd:workdir
()
with
| `Finished 0 -> true
| `Finished _ | `Cancelled -> false
in
Misc.remove_file fn_in;
if not ok then begin
Misc.remove_file fn_out;
Error (CannotRun comm)
end else if not (Sys.file_exists fn_out) then
Error (WrongMagic comm)
else
let ic = open_in_bin fn_out in
let result = Misc.string_of_file ic in
close_in ic;
Ok result
let decode_potential_ast source =
let decoder =
if Std.String.is_prefixed ~by:Config.ast_impl_magic_number source then
Some (fun x -> `Implementation (Obj.obj x : Parsetree.structure))
else if Std.String.is_prefixed ~by:Config.ast_intf_magic_number source then
Some (fun x -> `Interface (Obj.obj x : Parsetree.signature))
else
None
in
match decoder with
| None -> `Source source
| Some inj ->
let offset = String.length Config.ast_impl_magic_number in
Location.input_name := Marshal.from_string source offset;
let offset = offset + Marshal.total_size (Bytes.unsafe_of_string source) offset in
let ast = Marshal.from_string source offset in
inj ast
let apply_pp ~workdir ~filename ~source ~pp =
match apply_pp ~workdir ~filename ~source ~pp with
| Ok result -> decode_potential_ast result
| Error err ->
report_error err;
`Source source