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