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
58 let color_to_ansi_code = function
60 | Yellow -> "\027[0;33m"
61 | Green -> "\027[0;32m"
63 let color color string =
64 let color_on = color_to_ansi_code color in
65 let color_off = "\027[0m" in
66 sprintf "%s%s%s" color_on string color_off
68 let status indicator info =
71 | _ -> sprintf "%s: %s" indicator info
73 (* TODO: Perhaps a global option whether to print non-fail info? *)
74 let status_pass ?(info="") () =
75 status (color Green "Pass") info
77 let status_fail ?(info="") () =
78 status (color Red "Fail") info
80 let status_skip ?(info="") () =
81 status (color Yellow "Skip") info
86 ?(is_error_expected_semant=None)
94 ; is_error_expected_semant
97 let bar_sep = String.make 80 '-'
98 let bar_end = String.make 80 '='
101 let unit_spaces = 2 in
103 String.make (n * unit_spaces) ' '
105 let lexbuf_set_filename lb filename
108 let Lexing.({lex_start_p; lex_curr_p; _}) = lb in
109 lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename};
110 lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename}
112 let lexbuf_create ~filename ~code =
113 let lb = Lexing.from_string code in
114 lexbuf_set_filename lb filename;
117 let pass_lexing ~fake_filename ~code
118 : (Tiger_parser.token list, string) result
120 let lexbuf = lexbuf_create ~filename:fake_filename ~code in
122 let token = Tiger_lexer.token lexbuf in
123 (* Avoiding fragile pattern-matching *)
124 if token = Tiger_parser.EOF then [] else token :: tokens ()
127 | exception e -> Error (Printexc.to_string e)
128 | tokens -> Ok tokens
130 let pass_parsing ~fake_filename ~code
131 : (Tiger_absyn.t, string) result
133 let lb = lexbuf_create ~filename:fake_filename ~code in
134 match Tiger_parser.program Tiger_lexer.token lb with
135 | exception Parsing.Parse_error ->
136 let module L = Lexing in
137 let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
138 let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
143 let pass_semant (absyn_opt : Tiger_absyn.t option)
144 : (unit, string) result
148 Error "AST not provided"
150 Ok (Tiger_semant.transProg absyn)
154 let p_ln = print_newline
155 let p_indent n = p "%s" (indent n)
158 let failure_count = ref 0 in
159 let run_pass ~f ~expect_output ~is_error_expected =
160 let is_error_expected =
161 match is_error_expected with
162 | None -> (fun _ -> false)
165 let output_status = "n/a" in
166 let output_value = None in
169 let execution_status =
171 | Tiger_error.T e when is_error_expected e ->
172 status_pass () (*~info:(Tiger_error.to_string e)*)
175 status_fail () ~info:(Tiger_error.to_string e)
178 status_fail () ~info:(Printexc.to_string e)
187 ( status_fail ~info ()
192 let execution_status = status_pass () in
195 Option.map expect_output (fun expected -> expected = produced)
198 status_skip () (*~info:"expected output not provided"*)
205 let output_value = Some produced in
206 (execution_status, output_status, output_value)
208 let test_case_count = ref 0 in
215 ; is_error_expected_semant
218 incr test_case_count;
219 let (stat_lex_exe, stat_lex_out_cmp, _) =
221 ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
222 ~expect_output:out_lexing
223 ~is_error_expected:None
225 let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) =
227 ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
228 ~expect_output:out_parsing
229 ~is_error_expected:None
231 let (stat_semant_exe, stat_semant_out_cmp, _) =
233 ~f:(fun () -> pass_semant absyn_opt)
234 ~expect_output:(Some ())
235 ~is_error_expected:is_error_expected_semant
237 p "%s" bar_sep; p_ln ();
238 p "Test: %S" name; p_ln ();
239 p_indent 1; p "Lexing:"; p_ln ();
240 p_indent 2; p "exe: %s" stat_lex_exe ; p_ln ();
241 p_indent 2; p "out: %s" stat_lex_out_cmp; p_ln ();
242 p_indent 1; p "Parsing:"; p_ln ();
243 p_indent 2; p "exe: %s" stat_pars_exe ; p_ln ();
244 p_indent 2; p "out: %s" stat_pars_out_cmp; p_ln ();
245 p_indent 1; p "Semantic Analysis:"; p_ln ();
246 p_indent 2; p "exe: %s" stat_semant_exe ; p_ln ();
247 p_indent 2; p "out: %s" stat_semant_out_cmp; p_ln ();
249 p "%s" bar_end; p_ln ();
252 s "%d failures in %d test cases" !failure_count !test_case_count
254 match !failure_count with
255 | 0 -> status_pass () ~info
256 | _ -> status_fail () ~info
259 p "%s" bar_end; p_ln ();