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_parsing : (Tiger_error.t -> bool) option
50 ; is_error_expected_semant : (Tiger_error.t -> bool) option
75 let color_to_ansi_code = function
76 | Grey_bold -> "\027[1;30m"
78 | Red_bold -> "\027[1;31m"
79 | Yellow -> "\027[0;33m"
80 | Green -> "\027[0;32m"
81 | Green_bold -> "\027[1;32m"
83 let color_off = "\027[0m"
85 let color color string =
86 let color_on = color_to_ansi_code color in
87 sprintf "%s%s%s" color_on string color_off
89 let colorize str = function
90 | Some c -> (color_to_ansi_code c) ^ str ^ color_off
93 let status_to_color = function
94 | Pass -> Some Green_bold
95 | Fail -> Some Red_bold
96 | Skip -> Some Grey_bold
98 let status_to_str = function
99 (* Expected to be a single character, but using string to allow unicode. *)
104 let status indicator info =
107 | _ -> sprintf "%s: %s" indicator info
109 (* TODO: Perhaps a global option whether to print non-fail info? *)
110 let status_pass ?(info="") () =
111 status (color Green "P") info
113 let status_fail ?(info="") () =
114 status (color Red "F") info
116 let status_skip ?(info="") () =
117 (*let indicator = (color Yellow "Skip") in*)
118 let indicator = "S" in
119 status indicator info
124 ?(is_error_expected_parsing=None)
125 ?(is_error_expected_semant=None)
133 ; is_error_expected_parsing
134 ; is_error_expected_semant
137 let bar_horiz_minor = color Grey_bold (String.make 80 '-')
138 let bar_horiz_major = color Grey_bold (String.make 80 '=')
139 let bar_vert = color Grey_bold "|"
142 let unit_spaces = 2 in
144 String.make (n * unit_spaces) ' '
146 let lexbuf_set_filename lb filename
149 let Lexing.({lex_start_p; lex_curr_p; _}) = lb in
150 lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename};
151 lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename}
153 let lexbuf_create ~filename ~code =
154 let lb = Lexing.from_string code in
155 lexbuf_set_filename lb filename;
158 let pass_lexing ~fake_filename ~code
159 : (Tiger_parser.token list, string) result
161 let lexbuf = lexbuf_create ~filename:fake_filename ~code in
163 let token = Tiger_lexer.token lexbuf in
164 (* Avoiding fragile pattern-matching *)
165 if token = Tiger_parser.EOF then [] else token :: tokens ()
168 | exception e -> Error (Printexc.to_string e)
169 | tokens -> Ok tokens
171 let pass_parsing ~fake_filename ~code
172 : (Tiger_absyn.t, string) result
174 let lb = lexbuf_create ~filename:fake_filename ~code in
175 match Tiger_parser.program Tiger_lexer.token lb with
176 | exception Parsing.Parse_error ->
177 let module L = Lexing in
178 let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
179 let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
184 let pass_semant (absyn_opt : Tiger_absyn.t option)
185 : (unit, string) result
189 Error "AST not provided"
191 Ok (Tiger_semant.transProg absyn)
193 let str_exact str exact =
194 let len = String.length str in
195 let take = if len > exact then exact else len in
196 let str = String.sub str 0 take in
197 let pad = exact - take in
198 let pad = String.make pad ' ' in
203 let p_ln = print_newline
204 let p_indent n = p "%s" (indent n)
207 Printexc.record_backtrace true;
208 let count_fail_all = ref 0 in
209 let run_pass ~f ~expect_output ~is_error_expected =
210 let is_error_expected =
211 match is_error_expected with
212 | None -> (fun _ -> false)
217 let backtrace = Printexc.get_backtrace () in
218 let (exe_stat, exe_msg) =
220 | Tiger_error.T e when is_error_expected e ->
221 (Pass, (Tiger_error.to_string e))
224 (Fail, (Tiger_error.to_string e))
227 (Fail, (Printexc.to_string e))
231 ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace
234 ; out_msg = "" (* old "info" goes here *)
242 ; out_msg = "" (* old "info" goes here *)
245 let (out_stat, out_msg) =
247 Option.map expect_output (fun expected -> expected = produced)
250 (Skip, "expected output not provided")
255 (* TODO pretty print expected and produced *)
256 (Fail, "unexpected output")
259 ; exe_msg = "" (* old "info" goes here *)
261 ; out_val = Some produced
265 let test_case_count = ref 0 in
266 let col_1_width = 25 in
267 let col_i_width = 10 in
268 let p_stat width (exe, out) =
269 (* All this gymnastics to ignore color codes in cell width *)
271 let width = if width > min then width else min in
272 p "%s" (String.concat "" (List.init ~len:width ~f:(function
276 | 3 -> colorize (status_to_str exe) (status_to_color exe)
277 | 4 -> colorize (status_to_str out) (status_to_color out)
282 p "%s" bar_horiz_major; p_ln ();
283 p "%s" (str_exact "Test case" col_1_width);
284 List.iter ~f:(fun header -> p " %s %s" bar_vert header)
290 p "%s" bar_horiz_major; p_ln ();
297 ; is_error_expected_parsing
298 ; is_error_expected_semant
301 incr test_case_count;
304 ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
305 ~expect_output:out_lexing
306 ~is_error_expected:None
310 ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
311 ~expect_output:out_parsing
312 ~is_error_expected:is_error_expected_parsing
316 ~f:(fun () -> pass_semant res_pars.out_val)
317 ~expect_output:(Some ())
318 ~is_error_expected:is_error_expected_semant
321 (* Replacing out_val for type compatibility *)
322 [ "Lexing" , {res_lex with out_val = None}
323 ; "Parsing" , {res_pars with out_val = None}
324 ; "Semant" , {res_sem with out_val = None}
327 if !test_case_count > 1 then (p "%s" bar_horiz_minor; p_ln ());
328 p "%s" (str_exact name col_1_width);
329 List.iter results ~f:(fun (stage, {exe_stat=e; out_stat=o; _}) ->
330 p_stat ((String.length stage) + 3) (e, o)
333 let printed_error = ref false in
334 List.iter results ~f:(
335 fun (stage, {exe_stat; exe_msg; out_stat; out_msg; _}) ->
340 printed_error := true;
341 p "%s: %s" (color Grey_bold stage) (color Red exe_msg);
348 printed_error := true;
349 p "%s: %s" (color Grey_bold stage) (color Red out_msg)
353 p "%s" bar_horiz_major; p_ln ();
356 s "%d failures in %d test cases" !count_fail_all !test_case_count
358 match !count_fail_all with
359 | 0 -> status_pass () ~info
360 | _ -> status_fail () ~info
363 p "%s" bar_horiz_major; p_ln ();