1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Jeremie Dimino, Jane Street Europe *)
6 (* *)
7 (* Copyright 2016 Jane Street Group LLC *)
8 (* *)
9 (* All rights reserved. This file is distributed under the terms of *)
10 (* the GNU Lesser General Public License version 2.1, with the *)
11 (* special exception on linking described in the file LICENSE. *)
12 (* *)
13 (**************************************************************************)
14
15 (* Execute a list of phrases from a .ml file and compare the result to the
16 expected output, written inside [%%expect ...] nodes. At the end, create
17 a .corrected file containing the corrected expectations. The test is
18 successful if there is no differences between the two files.
19
20 An [%%expect] node always contains both the expected outcome with and
21 without -principal. When the two differ the expectation is written as
22 follows:
23
24 {[
25 [%%expect {|
26 output without -principal
27 |}, Principal{|
28 output with -principal
29 |}]
30 ]}
31 *)
32
33 [@@@ocaml.warning "-40"]
34
35 open StdLabels
36
37 (* representation of: {tag|str|tag} *)
38 type string_constant =
39 { str : string
40 ; tag : string
41 }
42
43 type expectation =
44 { extid_loc : Location.t (* Location of "expect" in "[%%expect ...]" *)
45 ; payload_loc : Location.t (* Location of the whole payload *)
46 ; normal : string_constant (* expectation without -principal *)
47 ; principal : string_constant (* expectation with -principal *)
48 }
49
50 (* A list of phrases with the expected toplevel output *)
51 type chunk =
52 { phrases : Parsetree.toplevel_phrase list
53 ; expectation : expectation
54 }
55
56 type correction =
57 { corrected_expectations : expectation list
58 ; trailing_output : string
59 }
60
61 let match_expect_extension (ext : Parsetree.extension) =
62 match ext with
63 | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) ->
64 let invalid_payload () =
65 Location.raise_errorf ~loc:extid_loc "invalid [%%%%expect payload]"
66 in
67 let string_constant (e : Parsetree.expression) =
68 match e.pexp_desc with
69 | Pexp_constant (Pconst_string (str, Some tag)) ->
70 { str; tag }
71 | _ -> invalid_payload ()
72 in
73 let expectation =
74 match payload with
75 | PStr [{ pstr_desc = Pstr_eval (e, []) }] ->
76 let normal, principal =
77 match e.pexp_desc with
78 | Pexp_tuple
79 [ a
80 ; { pexp_desc = Pexp_construct
81 ({ txt = Lident "Principal"; _ }, Some b) }
82 ] ->
83 (string_constant a, string_constant b)
84 | _ -> let s = string_constant e in (s, s)
85 in
86 { extid_loc
87 ; payload_loc = e.pexp_loc
88 ; normal
89 ; principal
90 }
91 | PStr [] ->
92 let s = { tag = ""; str = "" } in
93 { extid_loc
94 ; payload_loc = { extid_loc with loc_start = extid_loc.loc_end }
95 ; normal = s
96 ; principal = s
97 }
98 | _ -> invalid_payload ()
99 in
100 Some expectation
101 | _ ->
102 None
103
104 (* Split a list of phrases from a .ml file *)
105 let split_chunks phrases =
106 let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc =
107 match phrases with
108 | [] ->
109 if code_acc = [] then
110 (List.rev acc, None)
111 else
112 (List.rev acc, Some (List.rev code_acc))
113 | phrase :: phrases ->
114 match phrase with
115 | Ptop_def [] -> loop phrases code_acc acc
116 | Ptop_def [{pstr_desc = Pstr_extension(ext, [])}] -> begin
117 match match_expect_extension ext with
118 | None -> loop phrases (phrase :: code_acc) acc
119 | Some expectation ->
120 let chunk =
121 { phrases = List.rev code_acc
122 ; expectation
123 }
124 in
125 loop phrases [] (chunk :: acc)
126 end
127 | _ -> loop phrases (phrase :: code_acc) acc
128 in
129 loop phrases [] []
130
131 module Compiler_messages = struct
132 let capture ppf ~f =
133 Misc.protect_refs
134 [ R (Location.formatter_for_warnings, ppf) ]
135 f
136 end
137
138 let collect_formatters buf pps ~f =
139 let ppb = Format.formatter_of_buffer buf in
140 let out_functions = Format.pp_get_formatter_out_functions ppb () in
141
142 List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
143 let save =
144 List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps
145 in
146 let restore () =
147 List.iter2
148 (fun pp out_functions ->
149 Format.pp_print_flush pp ();
150 Format.pp_set_formatter_out_functions pp out_functions)
151 pps save
152 in
153 List.iter
154 (fun pp -> Format.pp_set_formatter_out_functions pp out_functions)
155 pps;
156 match f () with
157 | x -> restore (); x
158 | exception exn -> restore (); raise exn
159
160 (* Invariant: ppf = Format.formatter_of_buffer buf *)
161 let capture_everything buf ppf ~f =
162 collect_formatters buf [Format.std_formatter; Format.err_formatter]
163 ~f:(fun () -> Compiler_messages.capture ppf ~f)
164
165 let exec_phrase ppf phrase =
166 if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase;
167 if !Clflags.dump_source then Pprintast.top_phrase ppf phrase;
168 Toploop.execute_phrase true ppf phrase
169
170 let parse_contents ~fname contents =
171 let lexbuf = Lexing.from_string contents in
172 Location.init lexbuf fname;
173 Location.input_name := fname;
174 Location.input_lexbuf := Some lexbuf;
175 Parse.use_file lexbuf
176
177 let eval_expectation expectation ~output =
178 let s =
179 if !Clflags.principal then
180 expectation.principal
181 else
182 expectation.normal
183 in
184 if s.str = output then
185 None
186 else
187 let s = { s with str = output } in
188 Some (
189 if !Clflags.principal then
190 { expectation with principal = s }
191 else
192 { expectation with normal = s }
193 )
194
195 let shift_lines delta phrases =
196 let position (pos : Lexing.position) =
197 { pos with pos_lnum = pos.pos_lnum + delta }
198 in
199 let location _this (loc : Location.t) =
200 { loc with
201 loc_start = position loc.loc_start
202 ; loc_end = position loc.loc_end
203 }
204 in
205 let mapper = { Ast_mapper.default_mapper with location } in
206 List.map phrases ~f:(function
207 | Parsetree.Ptop_dir _ as p -> p
208 | Parsetree.Ptop_def st ->
209 Parsetree.Ptop_def (mapper.structure mapper st))
210
211 let rec min_line_number : Parsetree.toplevel_phrase list -> int option =
212 function
213 | [] -> None
214 | (Ptop_dir _ | Ptop_def []) :: l -> min_line_number l
215 | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum
216
217 let eval_expect_file _fname ~file_contents =
218 Warnings.reset_fatal ();
219 let chunks, trailing_code =
220 parse_contents ~fname:"" file_contents |> split_chunks
221 in
222 let buf = Buffer.create 1024 in
223 let ppf = Format.formatter_of_buffer buf in
224 let exec_phrases phrases =
225 let phrases =
226 match min_line_number phrases with
227 | None -> phrases
228 | Some lnum -> shift_lines (1 - lnum) phrases
229 in
230 (* For formatting purposes *)
231 Buffer.add_char buf '\n';
232 let _ : bool =
233 List.fold_left phrases ~init:true ~f:(fun acc phrase ->
234 acc &&
235 let snap = Btype.snapshot () in
236 try
237 exec_phrase ppf phrase
238 with exn ->
239 let bt = Printexc.get_raw_backtrace () in
240 begin try Location.report_exception ppf exn
241 with _ ->
242 Format.fprintf ppf "Uncaught exception: %s\n%s\n"
243 (Printexc.to_string exn)
244 (Printexc.raw_backtrace_to_string bt)
245 end;
246 Btype.backtrack snap;
247 false
248 )
249 in
250 Format.pp_print_flush ppf ();
251 let len = Buffer.length buf in
252 if len > 0 && Buffer.nth buf (len - 1) <> '\n' then
253 (* For formatting purposes *)
254 Buffer.add_char buf '\n';
255 let s = Buffer.contents buf in
256 Buffer.clear buf;
257 Misc.delete_eol_spaces s
258 in
259 let corrected_expectations =
260 capture_everything buf ppf ~f:(fun () ->
261 List.fold_left chunks ~init:[] ~f:(fun acc chunk ->
262 let output = exec_phrases chunk.phrases in
263 match eval_expectation chunk.expectation ~output with
264 | None -> acc
265 | Some correction -> correction :: acc)
266 |> List.rev)
267 in
268 let trailing_output =
269 match trailing_code with
270 | None -> ""
271 | Some phrases ->
272 capture_everything buf ppf ~f:(fun () -> exec_phrases phrases)
273 in
274 { corrected_expectations; trailing_output }
275
276 let output_slice oc s a b =
277 output_string oc (String.sub s ~pos:a ~len:(b - a))
278
279 let output_corrected oc ~file_contents correction =
280 let output_body oc { str; tag } =
281 Printf.fprintf oc "{%s|%s|%s}" tag str tag
282 in
283 let ofs =
284 List.fold_left correction.corrected_expectations ~init:0
285 ~f:(fun ofs c ->
286 output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum;
287 output_body oc c.normal;
288 if c.normal.str <> c.principal.str then begin
289 output_string oc ", Principal";
290 output_body oc c.principal
291 end;
292 c.payload_loc.loc_end.pos_cnum)
293 in
294 output_slice oc file_contents ofs (String.length file_contents);
295 match correction.trailing_output with
296 | "" -> ()
297 | s -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s
298
299 let write_corrected ~file ~file_contents correction =
300 let oc = open_out file in
301 output_corrected oc ~file_contents correction;
302 close_out oc
303
304 let process_expect_file fname =
305 let corrected_fname = fname ^ ".corrected" in
306 let file_contents =
307 let ic = open_in_bin fname in
308 match really_input_string ic (in_channel_length ic) with
309 | s -> close_in ic; Misc.normalise_eol s
310 | exception e -> close_in ic; raise e
311 in
312 let correction = eval_expect_file fname ~file_contents in
313 write_corrected ~file:corrected_fname ~file_contents correction
314
315 let repo_root = ref None
316 let keep_original_error_size = ref false
317
318 let main fname =
319 if not !keep_original_error_size then
320 Clflags.error_size := 0;
321 Toploop.override_sys_argv
322 (Array.sub Sys.argv ~pos:!Arg.current
323 ~len:(Array.length Sys.argv - !Arg.current));
324 (* Ignore OCAMLRUNPARAM=b to be reproducible *)
325 Printexc.record_backtrace false;
326 if not !Clflags.no_std_include then begin
327 match !repo_root with
328 | None -> ()
329 | Some dir ->
330 (* If we pass [-repo-root], use the stdlib from inside the
331 compiler, not the installed one. We use
332 [Compenv.last_include_dirs] to make sure that the stdlib
333 directory is the last one. *)
334 Clflags.no_std_include := true;
335 Compenv.last_include_dirs := [Filename.concat dir "stdlib"]
336 end;
337 Compmisc.init_path ();
338 Toploop.initialize_toplevel_env ();
339 Sys.interactive := false;
340 process_expect_file fname;
341 exit 0
342
343 module Options = Main_args.Make_bytetop_options (struct
344 include Main_args.Default.Topmain
345 let _stdin () = (* disabled *) ()
346 let _args = Arg.read_arg
347 let _args0 = Arg.read_arg0
348 let anonymous s = main s
349 end);;
350
351 let args =
352 Arg.align
353 ( [ "-repo-root", Arg.String (fun s -> repo_root := Some s),
354 "<dir> root of the OCaml repository. This causes the tool to use \
355 the stdlib from the current source tree rather than the installed one."
356 ; "-keep-original-error-size", Arg.Set keep_original_error_size,
357 " truncate long error messages as the compiler would"
358 ] @ Options.list
359 )
360
361 let usage = "Usage: expect_test <options> [script-file [arguments]]\n\
362 options are:"
363
364 let () =
365 Clflags.color := Some Misc.Color.Never;
366 try
367 Arg.parse args main usage;
368 Printf.eprintf "expect_test: no input file\n";
369 exit 2
370 with exn ->
371 Location.report_exception Format.err_formatter exn;
372 exit 2
373