1 (* "exe" is for status of execution (whether any exceptions were raised)
2 * "out" is for status of output comparison (whether what was outputted is
5 * code |> pass_a_exe |> pass_a_out |> ... |> pass_z_exe |> pass_z_out
18 * name | pass a | ... | pass z
19 * ---------+--------+-----+--------
20 * exe foo | OK | ... | OK
21 * out foo | OK | ... | ERROR
27 module List = ListLabels
28 module String = StringLabels
33 val map : 'a t -> ('a -> 'b) -> 'b t
40 | Some x -> Some (f x)
43 (* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *)
47 ; out_lexing : (Tiger_parser.token list) option
48 ; out_parsing : Tiger_absyn.t option
49 ; is_error_expected_semant : (Tiger_error.t -> bool) option
74 let color_to_ansi_code = function
75 | Grey_bold -> "\027[1;30m"
77 | Red_bold -> "\027[1;31m"
78 | Yellow -> "\027[0;33m"
79 | Green -> "\027[0;32m"
80 | Green_bold -> "\027[1;32m"
82 let color_off = "\027[0m"
84 let color color string =
85 let color_on = color_to_ansi_code color in
86 sprintf "%s%s%s" color_on string color_off
88 let colorize str = function
89 | Some c -> (color_to_ansi_code c) ^ str ^ color_off
92 let status_to_color = function
93 | Pass -> Some Green_bold
94 | Fail -> Some Red_bold
95 | Skip -> Some Grey_bold
97 let status_to_str = function
98 (* Expected to be a single character, but using string to allow unicode. *)
103 let status indicator info =
106 | _ -> sprintf "%s: %s" indicator info
108 (* TODO: Perhaps a global option whether to print non-fail info? *)
109 let status_pass ?(info="") () =
110 status (color Green "P") info
112 let status_fail ?(info="") () =
113 status (color Red "F") info
115 let status_skip ?(info="") () =
116 (*let indicator = (color Yellow "Skip") in*)
117 let indicator = "S" in
118 status indicator info
123 ?(is_error_expected_semant=None)
131 ; is_error_expected_semant
134 let bar_horiz_minor = color Grey_bold (String.make 80 '-')
135 let bar_horiz_major = color Grey_bold (String.make 80 '=')
136 let bar_vert = color Grey_bold "|"
139 let unit_spaces = 2 in
141 String.make (n * unit_spaces) ' '
143 let lexbuf_set_filename lb filename
146 let Lexing.({lex_start_p; lex_curr_p; _}) = lb in
147 lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename};
148 lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename}
150 let lexbuf_create ~filename ~code =
151 let lb = Lexing.from_string code in
152 lexbuf_set_filename lb filename;
155 let pass_lexing ~fake_filename ~code
156 : (Tiger_parser.token list, string) result
158 let lexbuf = lexbuf_create ~filename:fake_filename ~code in
160 let token = Tiger_lexer.token lexbuf in
161 (* Avoiding fragile pattern-matching *)
162 if token = Tiger_parser.EOF then [] else token :: tokens ()
165 | exception e -> Error (Printexc.to_string e)
166 | tokens -> Ok tokens
168 let pass_parsing ~fake_filename ~code
169 : (Tiger_absyn.t, string) result
171 let lb = lexbuf_create ~filename:fake_filename ~code in
172 match Tiger_parser.program Tiger_lexer.token lb with
173 | exception Parsing.Parse_error ->
174 let module L = Lexing in
175 let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
176 let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
181 let pass_semant (absyn_opt : Tiger_absyn.t option)
182 : (unit, string) result
186 Error "AST not provided"
188 Ok (Tiger_semant.transProg absyn)
190 let str_exact str exact =
191 let len = String.length str in
192 let take = if len > exact then exact else len in
193 let str = String.sub str 0 take in
194 let pad = exact - take in
195 let pad = String.make pad ' ' in
200 let p_ln = print_newline
201 let p_indent n = p "%s" (indent n)
204 Printexc.record_backtrace true;
205 let count_fail_all = ref 0 in
206 let run_pass ~f ~expect_output ~is_error_expected =
207 let is_error_expected =
208 match is_error_expected with
209 | None -> (fun _ -> false)
214 let backtrace = Printexc.get_backtrace () in
215 let (exe_stat, exe_msg) =
217 | Tiger_error.T e when is_error_expected e ->
218 (Pass, (Tiger_error.to_string e))
221 (Fail, (Tiger_error.to_string e))
224 (Fail, (Printexc.to_string e))
228 ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace
231 ; out_msg = "" (* old "info" goes here *)
239 ; out_msg = "" (* old "info" goes here *)
242 let (out_stat, out_msg) =
244 Option.map expect_output (fun expected -> expected = produced)
247 (Skip, "expected output not provided")
252 (* TODO pretty print expected and produced *)
253 (Fail, "unexpected output")
256 ; exe_msg = "" (* old "info" goes here *)
258 ; out_val = Some produced
262 let test_case_count = ref 0 in
263 let col_1_width = 25 in
264 let col_i_width = 10 in
265 let p_stat width (exe, out) =
266 (* All this gymnastics to ignore color codes in cell width *)
268 let width = if width > min then width else min in
269 p "%s" (String.concat "" (List.init ~len:width ~f:(function
273 | 3 -> colorize (status_to_str exe) (status_to_color exe)
274 | 4 -> colorize (status_to_str out) (status_to_color out)
279 p "%s" bar_horiz_major; p_ln ();
280 p "%s" (str_exact "Test case" col_1_width);
281 List.iter ~f:(fun header -> p " %s %s" bar_vert header)
287 p "%s" bar_horiz_major; p_ln ();
294 ; is_error_expected_semant
297 incr test_case_count;
300 ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
301 ~expect_output:out_lexing
302 ~is_error_expected:None
306 ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
307 ~expect_output:out_parsing
308 ~is_error_expected:None
312 ~f:(fun () -> pass_semant res_pars.out_val)
313 ~expect_output:(Some ())
314 ~is_error_expected:is_error_expected_semant
317 (* Replacing out_val for type compatibility *)
318 [ "Lexing" , {res_lex with out_val = None}
319 ; "Parsing" , {res_pars with out_val = None}
320 ; "Semant" , {res_sem with out_val = None}
323 if !test_case_count > 1 then (p "%s" bar_horiz_minor; p_ln ());
324 p "%s" (str_exact name col_1_width);
325 List.iter results ~f:(fun (stage, {exe_stat=e; out_stat=o; _}) ->
326 p_stat ((String.length stage) + 3) (e, o)
329 let printed_error = ref false in
330 List.iter results ~f:(
331 fun (stage, {exe_stat; exe_msg; out_stat; out_msg; _}) ->
336 printed_error := true;
337 p "%s: %s" (color Grey_bold stage) (color Red exe_msg);
344 printed_error := true;
345 p "%s: %s" (color Grey_bold stage) (color Red out_msg)
349 p "%s" bar_horiz_major; p_ln ();
352 s "%d failures in %d test cases" !count_fail_all !test_case_count
354 match !count_fail_all with
355 | 0 -> status_pass () ~info
356 | _ -> status_fail () ~info
359 p "%s" bar_horiz_major; p_ln ();