Add CLI options to execute different test suites
[tiger.ml.git] / compiler / src / lib / tiger / tiger_test.ml
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
3 * what was expected)
4 *
5 * code |> pass_a_exe |> pass_a_out |> ... |> pass_z_exe |> pass_z_out
6 *
7 * pass a:
8 * exe: OK
9 * out: n/a
10 * pass b:
11 * exe: OK
12 * out: OK
13 * pass c:
14 * exe: OK
15 * out: ERROR
16 * ...
17 *
18 * name | pass a | ... | pass z
19 * ---------+--------+-----+--------
20 * exe foo | OK | ... | OK
21 * out foo | OK | ... | ERROR
22 *
23 * *)
24 (* TODO: Perhaps a global option whether to print non-fail info? *)
25
26 open Printf
27
28 module List = ListLabels
29 module String = StringLabels
30
31 module Option : sig
32 type 'a t = 'a option
33
34 val map : 'a t -> ('a -> 'b) -> 'b t
35 end = struct
36 type 'a t = 'a option
37
38 let map t f =
39 match t with
40 | None -> None
41 | Some x -> Some (f x)
42 end
43
44 (* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *)
45 type t =
46 { name : string
47 ; code : string
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
52 }
53
54 type status =
55 | Pass
56 | Fail
57 | Skip
58
59 type 'a t_result =
60 { exe_stat : status
61 ; exe_msg : string
62 ; out_stat : status
63 ; out_val : 'a option
64 ; out_msg : string
65 }
66
67 type color =
68 | Red
69 | Red_bold
70 | Green_bold
71 | Grey_bold
72
73
74 let color_to_ansi_code = function
75 | Grey_bold -> "\027[1;30m"
76 | Red -> "\027[0;31m"
77 | Red_bold -> "\027[1;31m"
78 | Green_bold -> "\027[1;32m"
79
80 let color_off = "\027[0m"
81
82 let color color string =
83 let color_on = color_to_ansi_code color in
84 sprintf "%s%s%s" color_on string color_off
85
86 let color_opt str = function
87 | Some c -> (color_to_ansi_code c) ^ str ^ color_off
88 | None -> str
89
90 let status_to_color = function
91 | Pass -> Some Green_bold
92 | Fail -> Some Red_bold
93 | Skip -> Some Grey_bold
94
95 let status_to_str = function
96 (* Expected to be a single character, but using string to allow unicode. *)
97 | Pass -> "✓"
98 | Fail -> "X"
99 | Skip -> "-"
100
101 let case
102 ?(out_lexing=None)
103 ?(out_parsing=None)
104 ?(is_error_expected_parsing=None)
105 ?(is_error_expected_semant=None)
106 ~code
107 name
108 =
109 { name
110 ; code
111 ; out_lexing
112 ; out_parsing
113 ; is_error_expected_parsing
114 ; is_error_expected_semant
115 }
116
117 let bar_horiz_minor = color Grey_bold (String.make 80 '-')
118 let bar_horiz_major = color Grey_bold (String.make 80 '=')
119 let bar_vert = color Grey_bold "|"
120
121 let lexbuf_set_filename lb filename
122 : unit
123 =
124 let Lexing.({lex_start_p; lex_curr_p; _}) = lb in
125 lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename};
126 lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename}
127
128 let lexbuf_create ~filename ~code =
129 let lb = Lexing.from_string code in
130 lexbuf_set_filename lb filename;
131 lb
132
133 let pass_lexing ~fake_filename ~code
134 : (Tiger_parser.token list, string) result
135 =
136 let lexbuf = lexbuf_create ~filename:fake_filename ~code in
137 let rec tokens () =
138 let token = Tiger_lexer.token lexbuf in
139 (* Avoiding fragile pattern-matching *)
140 if token = Tiger_parser.EOF then [] else token :: tokens ()
141 in
142 match tokens () with
143 | exception e -> Error (Printexc.to_string e)
144 | tokens -> Ok tokens
145
146 let pass_parsing ~fake_filename ~code
147 : (Tiger_absyn.t, string) result
148 =
149 let lb = lexbuf_create ~filename:fake_filename ~code in
150 match Tiger_parser.program Tiger_lexer.token lb with
151 | exception Parsing.Parse_error ->
152 let module L = Lexing in
153 let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
154 let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
155 Error msg
156 | ast ->
157 Ok ast
158
159 let pass_semant (absyn : Tiger_absyn.t)
160 : (unit, string) result
161 =
162 Ok (Tiger_semant.transProg absyn)
163
164 let str_exact str exact =
165 let len = String.length str in
166 let take = if len > exact then exact else len in
167 let str = String.sub str ~pos:0 ~len:take in
168 let pad = exact - take in
169 let pad = String.make pad ' ' in
170 str ^ pad
171
172 let s = sprintf
173 let p = printf
174 let p_ln = print_newline
175
176 let run tests =
177 Printexc.record_backtrace true;
178 let count_fail_all = ref 0 in
179 let run_pass ~f ~expect_output ~is_error_expected =
180 let is_error_expected =
181 match is_error_expected with
182 | None -> (fun _ -> false)
183 | Some f -> f
184 in
185 match f () with
186 | exception e ->
187 let backtrace = Printexc.get_backtrace () in
188 let (exe_stat, exe_msg) =
189 (match e with
190 | Tiger_error.T e when is_error_expected e ->
191 (Pass, (Tiger_error.to_string e))
192 | Tiger_error.T e ->
193 incr count_fail_all;
194 (Fail, (Tiger_error.to_string e))
195 | e ->
196 incr count_fail_all;
197 (Fail, (Printexc.to_string e))
198 )
199 in
200 { exe_stat
201 ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace
202 ; out_stat = Skip
203 ; out_val = None
204 ; out_msg = "" (* old "info" goes here *)
205 }
206 | Error info ->
207 incr count_fail_all;
208 { exe_stat = Fail
209 ; exe_msg = info
210 ; out_stat = Skip
211 ; out_val = None
212 ; out_msg = "" (* old "info" goes here *)
213 }
214 | Ok produced ->
215 let (out_stat, out_msg) =
216 match
217 Option.map expect_output (fun expected -> expected = produced)
218 with
219 | None ->
220 (Skip, "expected output not provided")
221 | Some true ->
222 (Pass, "")
223 | Some false ->
224 incr count_fail_all;
225 (* TODO pretty print expected and produced *)
226 (Fail, "unexpected output")
227 in
228 { exe_stat = Pass
229 ; exe_msg = "" (* old "info" goes here *)
230 ; out_stat
231 ; out_val = Some produced
232 ; out_msg
233 }
234 in
235 let test_case_count = ref 0 in
236 let col_1_width = 25 in
237 let p_stat width (exe, out) =
238 (* All this gymnastics to ignore color codes in cell width *)
239 let min = 5 in
240 let width = if width > min then width else min in
241 p "%s" (String.concat ~sep:"" (List.init ~len:width ~f:(function
242 | 0 -> " "
243 | 1 -> bar_vert
244 | 2 -> " "
245 | 3 -> color_opt (status_to_str exe) (status_to_color exe)
246 | 4 -> color_opt (status_to_str out) (status_to_color out)
247 | _ -> " "
248 )))
249
250 in
251 p "%s" bar_horiz_major; p_ln ();
252 p "%s" (str_exact "Test case" col_1_width);
253 List.iter ~f:(fun header -> p " %s %s" bar_vert header)
254 [ "Lexing"
255 ; "Parsing"
256 ; "Semant"
257 ];
258 p_ln ();
259 p "%s" bar_horiz_major; p_ln ();
260 List.iter tests ~f:(
261 fun
262 { name
263 ; code
264 ; out_lexing
265 ; out_parsing
266 ; is_error_expected_parsing
267 ; is_error_expected_semant
268 }
269 ->
270 incr test_case_count;
271 let res_lex =
272 run_pass
273 ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
274 ~expect_output:out_lexing
275 ~is_error_expected:None
276 in
277 let res_pars =
278 run_pass
279 ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
280 ~expect_output:out_parsing
281 ~is_error_expected:is_error_expected_parsing
282 in
283 let res_sem =
284 (* TODO: Replace this hack with general test-dependency checking *)
285 match res_pars.out_val with
286 | None ->
287 { exe_stat = Skip
288 ; exe_msg = "No AST provided"
289 ; out_stat = Skip
290 ; out_val = None
291 ; out_msg = ""
292 }
293 | Some absyn ->
294 run_pass
295 ~f:(fun () -> pass_semant absyn)
296 ~expect_output:(Some ())
297 ~is_error_expected:is_error_expected_semant
298 in
299 let results =
300 (* Replacing out_val for type compatibility *)
301 [ "Lexing" , {res_lex with out_val = None}
302 ; "Parsing" , {res_pars with out_val = None}
303 ; "Semant" , {res_sem with out_val = None}
304 ]
305 in
306 if !test_case_count > 1 then (p "%s" bar_horiz_minor; p_ln ());
307 p "%s" (str_exact name col_1_width);
308 List.iter results ~f:(fun (stage, {exe_stat=e; out_stat=o; _}) ->
309 p_stat ((String.length stage) + 3) (e, o)
310 );
311 p_ln ();
312 let printed_error = ref false in
313 List.iter results ~f:(
314 fun (stage, {exe_stat; exe_msg; out_stat; out_msg; _}) ->
315 (match exe_stat with
316 | Pass -> ()
317 | Skip -> ()
318 | Fail ->
319 printed_error := true;
320 p "%s: %s" (color Grey_bold stage) (color Red exe_msg);
321 p_ln ()
322 );
323 (match out_stat with
324 | Pass -> ()
325 | Skip -> ()
326 | Fail ->
327 printed_error := true;
328 p "%s: %s" (color Grey_bold stage) (color Red out_msg)
329 );
330 );
331 );
332 p "%s" bar_horiz_major; p_ln ();
333 p "%s %d failures in %d test cases"
334 (match !count_fail_all with
335 | 0 -> color_opt (status_to_str Pass) (status_to_color Pass)
336 | _ -> color_opt (status_to_str Fail) (status_to_color Fail)
337 )
338 !count_fail_all
339 !test_case_count;
340 p_ln ();
341 p "%s" bar_horiz_major; p_ln ();
342 exit !count_fail_all
This page took 0.098109 seconds and 5 git commands to generate.