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)
46 ; out_lexing : (Tiger_parser.token list) option
47 ; out_parsing : Tiger_absyn.t option
48 ; is_error_expected_semant : (Tiger_error.t -> bool)
57 let color_to_ansi_code = function
59 | Yellow -> "\027[0;33m"
60 | Green -> "\027[0;32m"
62 let color color string =
63 let color_on = color_to_ansi_code color in
64 let color_off = "\027[0m" in
65 sprintf "%s%s%s" color_on string color_off
67 let status indicator info =
70 | _ -> sprintf "%s: %s" indicator info
72 let status_pass ?(info="") () =
73 status (color Green "Pass") info
75 let status_fail ?(info="") () =
76 status (color Red "Fail") info
78 let status_skip ?(info="") () =
79 status (color Yellow "Skip") info
84 ?(is_error_expected_semant=(fun _ -> false))
92 ; is_error_expected_semant
95 let bar_sep = String.make 80 '-'
96 let bar_end = String.make 80 '='
99 let unit_spaces = 2 in
101 String.make (n * unit_spaces) ' '
103 let pass_lexing code : (Tiger_parser.token list, string) result =
104 let lexbuf = Lexing.from_string code in
106 let token = Tiger_lexer.token lexbuf in
107 (* Avoiding fragile pattern-matching *)
108 if token = Tiger_parser.EOF then [] else token :: tokens ()
111 | exception e -> Error (Printexc.to_string e)
112 | tokens -> Ok tokens
114 let pass_parsing code : (Tiger_absyn.t, string) result =
115 let lb = Lexing.from_string code in
116 match Tiger_parser.program Tiger_lexer.token lb with
117 | exception Parsing.Parse_error ->
118 let module L = Lexing in
119 let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
120 let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
125 let pass_semant (absyn_opt : Tiger_absyn.t option) : (unit, string) result =
128 Error "AST not provided"
130 Ok (Tiger_semant.transProg absyn)
134 let p_ln = print_newline
135 let p_indent n = p "%s" (indent n)
138 let error_count = ref 0 in
139 let run_pass ~f ~input ~expect_output ~is_error_expected =
140 let output_status = "n/a" in
141 let output_value = None in
144 let execution_status =
146 | Tiger_error.T e when is_error_expected e ->
147 status_pass () ~info:(Tiger_error.to_string e)
150 status_fail () ~info:(Tiger_error.to_string e)
153 status_fail () ~info:(Printexc.to_string e)
162 ( status_fail ~info ()
167 let execution_status = status_pass () in
170 Option.map expect_output (fun expected -> expected = produced)
173 status_skip () ~info:"expected output not provided"
180 let output_value = Some produced in
181 (execution_status, output_status, output_value)
189 ; is_error_expected_semant
192 let (stat_lex_exe, stat_lex_out_cmp, _) =
196 ~expect_output:out_lexing
197 ~is_error_expected:(fun _ -> false)
199 let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) =
203 ~expect_output:out_parsing
204 ~is_error_expected:(fun _ -> false)
206 let (stat_semant_exe, stat_semant_out_cmp, _) =
210 ~expect_output:(Some ())
211 ~is_error_expected:is_error_expected_semant
213 p "%s" bar_sep; p_ln ();
214 p "Test: %S" name; p_ln ();
215 p_indent 1; p "Lexing:"; p_ln ();
216 p_indent 2; p "exe: %s" stat_lex_exe ; p_ln ();
217 p_indent 2; p "out: %s" stat_lex_out_cmp; p_ln ();
218 p_indent 1; p "Parsing:"; p_ln ();
219 p_indent 2; p "exe: %s" stat_pars_exe ; p_ln ();
220 p_indent 2; p "out: %s" stat_pars_out_cmp; p_ln ();
221 p_indent 1; p "Semantic Analysis:"; p_ln ();
222 p_indent 2; p "exe: %s" stat_semant_exe ; p_ln ();
223 p_indent 2; p "out: %s" stat_semant_out_cmp; p_ln ();
225 p "%s" bar_end; p_ln ();
226 let failures = !error_count in
227 let clr = (if failures = 0 then Green else Red) in
228 p "Failures: %s" (color clr (string_of_int failures)); p_ln ();
229 p "%s" bar_end; p_ln ();