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