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