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 | ||
d1fe69d3 | 31 | module Opt = Tiger_opt |
d3bdde4b | 32 | |
38ffcb1f | 33 | (* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *) |
d3bdde4b SK |
34 | type 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 |
43 | type status = |
44 | | Pass | |
45 | | Fail | |
46 | | Skip | |
47 | ||
48 | type '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 |
56 | type color = |
57 | | Red | |
b53d50d3 | 58 | | Red_bold |
b53d50d3 SK |
59 | | Green_bold |
60 | | Grey_bold | |
d3bdde4b SK |
61 | |
62 | ||
63 | let 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 | ||
69 | let color_off = "\027[0m" | |
d3bdde4b SK |
70 | |
71 | let 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 | 75 | let color_opt str = function |
b53d50d3 SK |
76 | | Some c -> (color_to_ansi_code c) ^ str ^ color_off |
77 | | None -> str | |
78 | ||
79 | let status_to_color = function | |
80 | | Pass -> Some Green_bold | |
81 | | Fail -> Some Red_bold | |
82 | | Skip -> Some Grey_bold | |
83 | ||
84 | let 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 | 90 | let 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 |
106 | let bar_horiz_minor = color Grey_bold (String.make 80 '-') |
107 | let bar_horiz_major = color Grey_bold (String.make 80 '=') | |
108 | let bar_vert = color Grey_bold "|" | |
d3bdde4b | 109 | |
38ffcb1f SK |
110 | let 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 | ||
117 | let lexbuf_create ~filename ~code = | |
118 | let lb = Lexing.from_string code in | |
119 | lexbuf_set_filename lb filename; | |
120 | lb | |
121 | ||
122 | let 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 |
135 | let 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 | 148 | let pass_semant (absyn : Tiger_absyn.t) |
38ffcb1f SK |
149 | : (unit, string) result |
150 | = | |
217e9638 | 151 | Ok (Tiger_semant.transProg absyn) |
ea3f5e0c | 152 | |
b53d50d3 SK |
153 | let 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 |
161 | let s = sprintf |
162 | let p = printf | |
163 | let p_ln = print_newline | |
d3bdde4b SK |
164 | |
165 | let 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 |