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
24 (* TODO: Perhaps a global option whether to print non-fail info? *)
28 module List = ListLabels
29 module String = StringLabels
34 val map : 'a t -> ('a -> 'b) -> 'b t
41 | Some x -> Some (f x)
44 (* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *)
48 ; out_lexing : (Tiger_parser.token list) option
49 ; out_parsing : Tiger_absyn.t option
50 ; is_error_expected_parsing : (Tiger_error.t -> bool) option
51 ; is_error_expected_semant : (Tiger_error.t -> bool) option
76 let color_to_ansi_code = function
77 | Grey_bold -> "\027[1;30m"
79 | Red_bold -> "\027[1;31m"
80 | Yellow -> "\027[0;33m"
81 | Green -> "\027[0;32m"
82 | Green_bold -> "\027[1;32m"
84 let color_off = "\027[0m"
86 let color color string =
87 let color_on = color_to_ansi_code color in
88 sprintf "%s%s%s" color_on string color_off
90 let color_opt str = function
91 | Some c -> (color_to_ansi_code c) ^ str ^ color_off
94 let status_to_color = function
95 | Pass -> Some Green_bold
96 | Fail -> Some Red_bold
97 | Skip -> Some Grey_bold
99 let status_to_str = function
100 (* Expected to be a single character, but using string to allow unicode. *)
105 let status indicator info =
108 | _ -> sprintf "%s: %s" indicator info
113 ?(is_error_expected_parsing=None)
114 ?(is_error_expected_semant=None)
122 ; is_error_expected_parsing
123 ; is_error_expected_semant
126 let bar_horiz_minor = color Grey_bold (String.make 80 '-')
127 let bar_horiz_major = color Grey_bold (String.make 80 '=')
128 let bar_vert = color Grey_bold "|"
131 let unit_spaces = 2 in
133 String.make (n * unit_spaces) ' '
135 let lexbuf_set_filename lb filename
138 let Lexing.({lex_start_p; lex_curr_p; _}) = lb in
139 lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename};
140 lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename}
142 let lexbuf_create ~filename ~code =
143 let lb = Lexing.from_string code in
144 lexbuf_set_filename lb filename;
147 let pass_lexing ~fake_filename ~code
148 : (Tiger_parser.token list, string) result
150 let lexbuf = lexbuf_create ~filename:fake_filename ~code in
152 let token = Tiger_lexer.token lexbuf in
153 (* Avoiding fragile pattern-matching *)
154 if token = Tiger_parser.EOF then [] else token :: tokens ()
157 | exception e -> Error (Printexc.to_string e)
158 | tokens -> Ok tokens
160 let pass_parsing ~fake_filename ~code
161 : (Tiger_absyn.t, string) result
163 let lb = lexbuf_create ~filename:fake_filename ~code in
164 match Tiger_parser.program Tiger_lexer.token lb with
165 | exception Parsing.Parse_error ->
166 let module L = Lexing in
167 let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
168 let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
173 let pass_semant (absyn : Tiger_absyn.t)
174 : (unit, string) result
176 Ok (Tiger_semant.transProg absyn)
178 let str_exact str exact =
179 let len = String.length str in
180 let take = if len > exact then exact else len in
181 let str = String.sub str 0 take in
182 let pad = exact - take in
183 let pad = String.make pad ' ' in
188 let p_ln = print_newline
189 let p_indent n = p "%s" (indent n)
192 Printexc.record_backtrace true;
193 let count_fail_all = ref 0 in
194 let run_pass ~f ~expect_output ~is_error_expected =
195 let is_error_expected =
196 match is_error_expected with
197 | None -> (fun _ -> false)
202 let backtrace = Printexc.get_backtrace () in
203 let (exe_stat, exe_msg) =
205 | Tiger_error.T e when is_error_expected e ->
206 (Pass, (Tiger_error.to_string e))
209 (Fail, (Tiger_error.to_string e))
212 (Fail, (Printexc.to_string e))
216 ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace
219 ; out_msg = "" (* old "info" goes here *)
227 ; out_msg = "" (* old "info" goes here *)
230 let (out_stat, out_msg) =
232 Option.map expect_output (fun expected -> expected = produced)
235 (Skip, "expected output not provided")
240 (* TODO pretty print expected and produced *)
241 (Fail, "unexpected output")
244 ; exe_msg = "" (* old "info" goes here *)
246 ; out_val = Some produced
250 let test_case_count = ref 0 in
251 let col_1_width = 25 in
252 let col_i_width = 10 in
253 let p_stat width (exe, out) =
254 (* All this gymnastics to ignore color codes in cell width *)
256 let width = if width > min then width else min in
257 p "%s" (String.concat "" (List.init ~len:width ~f:(function
261 | 3 -> color_opt (status_to_str exe) (status_to_color exe)
262 | 4 -> color_opt (status_to_str out) (status_to_color out)
267 p "%s" bar_horiz_major; p_ln ();
268 p "%s" (str_exact "Test case" col_1_width);
269 List.iter ~f:(fun header -> p " %s %s" bar_vert header)
275 p "%s" bar_horiz_major; p_ln ();
282 ; is_error_expected_parsing
283 ; is_error_expected_semant
286 incr test_case_count;
289 ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
290 ~expect_output:out_lexing
291 ~is_error_expected:None
295 ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
296 ~expect_output:out_parsing
297 ~is_error_expected:is_error_expected_parsing
300 (* TODO: Replace this hack with general test-dependency checking *)
301 match res_pars.out_val with
304 ; exe_msg = "No AST provided"
311 ~f:(fun () -> pass_semant absyn)
312 ~expect_output:(Some ())
313 ~is_error_expected:is_error_expected_semant
316 (* Replacing out_val for type compatibility *)
317 [ "Lexing" , {res_lex with out_val = None}
318 ; "Parsing" , {res_pars with out_val = None}
319 ; "Semant" , {res_sem with out_val = None}
322 if !test_case_count > 1 then (p "%s" bar_horiz_minor; p_ln ());
323 p "%s" (str_exact name col_1_width);
324 List.iter results ~f:(fun (stage, {exe_stat=e; out_stat=o; _}) ->
325 p_stat ((String.length stage) + 3) (e, o)
328 let printed_error = ref false in
329 List.iter results ~f:(
330 fun (stage, {exe_stat; exe_msg; out_stat; out_msg; _}) ->
335 printed_error := true;
336 p "%s: %s" (color Grey_bold stage) (color Red exe_msg);
343 printed_error := true;
344 p "%s: %s" (color Grey_bold stage) (color Red out_msg)
348 p "%s" bar_horiz_major; p_ln ();
349 p "%s %d failures in %d test cases"
350 (match !count_fail_all with
351 | 0 -> color_opt (status_to_str Pass) (status_to_color Pass)
352 | _ -> color_opt (status_to_str Fail) (status_to_color Fail)
357 p "%s" bar_horiz_major; p_ln ();