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