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