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 | * *) | |
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 | ||
38ffcb1f | 43 | (* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *) |
d3bdde4b SK |
44 | type t = |
45 | { name : string | |
46 | ; code : string | |
47 | ; out_lexing : (Tiger_parser.token list) option | |
48 | ; out_parsing : Tiger_absyn.t option | |
38ffcb1f | 49 | ; is_error_expected_semant : (Tiger_error.t -> bool) option |
d3bdde4b SK |
50 | } |
51 | ||
52 | type color = | |
53 | | Red | |
54 | | Yellow | |
55 | | Green | |
56 | ||
57 | ||
58 | let color_to_ansi_code = function | |
59 | | Red -> "\027[0;31m" | |
60 | | Yellow -> "\027[0;33m" | |
61 | | Green -> "\027[0;32m" | |
62 | ||
63 | let color color string = | |
64 | let color_on = color_to_ansi_code color in | |
65 | let color_off = "\027[0m" in | |
66 | sprintf "%s%s%s" color_on string color_off | |
67 | ||
39dd0869 SK |
68 | let status indicator info = |
69 | match info with | |
70 | | "" -> indicator | |
71 | | _ -> sprintf "%s: %s" indicator info | |
72 | ||
9949f15b SK |
73 | let status_pass ?(info="") () = |
74 | status (color Green "Pass") info | |
39dd0869 | 75 | |
9949f15b SK |
76 | let status_fail ?(info="") () = |
77 | status (color Red "Fail") info | |
39dd0869 | 78 | |
9949f15b SK |
79 | let status_skip ?(info="") () = |
80 | status (color Yellow "Skip") info | |
39dd0869 | 81 | |
e69e4e8b | 82 | let case |
38ffcb1f SK |
83 | ?(out_lexing=None) |
84 | ?(out_parsing=None) | |
85 | ?(is_error_expected_semant=None) | |
e69e4e8b SK |
86 | ~code |
87 | name | |
88 | = | |
d3bdde4b SK |
89 | { name |
90 | ; code | |
91 | ; out_lexing | |
92 | ; out_parsing | |
5da420a8 | 93 | ; is_error_expected_semant |
d3bdde4b SK |
94 | } |
95 | ||
96 | let bar_sep = String.make 80 '-' | |
97 | let bar_end = String.make 80 '=' | |
98 | ||
99 | let indent = | |
100 | let unit_spaces = 2 in | |
101 | fun n -> | |
102 | String.make (n * unit_spaces) ' ' | |
103 | ||
38ffcb1f SK |
104 | let lexbuf_set_filename lb filename |
105 | : unit | |
106 | = | |
107 | let Lexing.({lex_start_p; lex_curr_p; _}) = lb in | |
108 | lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename}; | |
109 | lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename} | |
110 | ||
111 | let lexbuf_create ~filename ~code = | |
112 | let lb = Lexing.from_string code in | |
113 | lexbuf_set_filename lb filename; | |
114 | lb | |
115 | ||
116 | let pass_lexing ~fake_filename ~code | |
117 | : (Tiger_parser.token list, string) result | |
118 | = | |
119 | let lexbuf = lexbuf_create ~filename:fake_filename ~code in | |
d3bdde4b SK |
120 | let rec tokens () = |
121 | let token = Tiger_lexer.token lexbuf in | |
122 | (* Avoiding fragile pattern-matching *) | |
123 | if token = Tiger_parser.EOF then [] else token :: tokens () | |
124 | in | |
125 | match tokens () with | |
126 | | exception e -> Error (Printexc.to_string e) | |
127 | | tokens -> Ok tokens | |
128 | ||
38ffcb1f SK |
129 | let pass_parsing ~fake_filename ~code |
130 | : (Tiger_absyn.t, string) result | |
131 | = | |
132 | let lb = lexbuf_create ~filename:fake_filename ~code in | |
d3bdde4b SK |
133 | match Tiger_parser.program Tiger_lexer.token lb with |
134 | | exception Parsing.Parse_error -> | |
135 | let module L = Lexing in | |
136 | let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in | |
137 | let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in | |
138 | Error msg | |
139 | | ast -> | |
140 | Ok ast | |
141 | ||
38ffcb1f SK |
142 | let pass_semant (absyn_opt : Tiger_absyn.t option) |
143 | : (unit, string) result | |
144 | = | |
ea3f5e0c SK |
145 | match absyn_opt with |
146 | | None -> | |
147 | Error "AST not provided" | |
148 | | Some absyn -> | |
149 | Ok (Tiger_semant.transProg absyn) | |
150 | ||
d3bdde4b SK |
151 | let s = sprintf |
152 | let p = printf | |
153 | let p_ln = print_newline | |
154 | let p_indent n = p "%s" (indent n) | |
155 | ||
156 | let run tests = | |
b762cacb | 157 | let failure_count = ref 0 in |
38ffcb1f SK |
158 | let run_pass ~f ~expect_output ~is_error_expected = |
159 | let is_error_expected = | |
160 | match is_error_expected with | |
161 | | None -> (fun _ -> false) | |
162 | | Some f -> f | |
163 | in | |
e69e4e8b SK |
164 | let output_status = "n/a" in |
165 | let output_value = None in | |
38ffcb1f | 166 | match f () with |
d3bdde4b | 167 | | exception e -> |
39dd0869 | 168 | let execution_status = |
e69e4e8b SK |
169 | (match e with |
170 | | Tiger_error.T e when is_error_expected e -> | |
9949f15b | 171 | status_pass () ~info:(Tiger_error.to_string e) |
e69e4e8b | 172 | | Tiger_error.T e -> |
b762cacb | 173 | incr failure_count; |
9949f15b | 174 | status_fail () ~info:(Tiger_error.to_string e) |
e69e4e8b | 175 | | e -> |
b762cacb | 176 | incr failure_count; |
9949f15b | 177 | status_fail () ~info:(Printexc.to_string e) |
e69e4e8b SK |
178 | ) |
179 | in | |
39dd0869 | 180 | ( execution_status |
e69e4e8b SK |
181 | , output_status |
182 | , output_value | |
d3bdde4b | 183 | ) |
39dd0869 | 184 | | Error info -> |
b762cacb | 185 | incr failure_count; |
9949f15b | 186 | ( status_fail ~info () |
e69e4e8b SK |
187 | , output_status |
188 | , output_value | |
d3bdde4b SK |
189 | ) |
190 | | Ok produced -> | |
9949f15b | 191 | let execution_status = status_pass () in |
e69e4e8b | 192 | let output_status = |
d3bdde4b | 193 | match |
e69e4e8b | 194 | Option.map expect_output (fun expected -> expected = produced) |
d3bdde4b SK |
195 | with |
196 | | None -> | |
9949f15b | 197 | status_skip () ~info:"expected output not provided" |
d3bdde4b | 198 | | Some true -> |
9949f15b | 199 | status_pass () |
d3bdde4b | 200 | | Some false -> |
b762cacb | 201 | incr failure_count; |
9949f15b | 202 | status_fail () |
d3bdde4b | 203 | in |
e69e4e8b SK |
204 | let output_value = Some produced in |
205 | (execution_status, output_status, output_value) | |
d3bdde4b | 206 | in |
0f031bf2 | 207 | let test_case_count = ref 0 in |
d3bdde4b | 208 | List.iter tests ~f:( |
5da420a8 SK |
209 | fun |
210 | { name | |
211 | ; code | |
212 | ; out_lexing | |
213 | ; out_parsing | |
214 | ; is_error_expected_semant | |
215 | } | |
216 | -> | |
0f031bf2 | 217 | incr test_case_count; |
e69e4e8b SK |
218 | let (stat_lex_exe, stat_lex_out_cmp, _) = |
219 | run_pass | |
38ffcb1f | 220 | ~f:(fun () -> pass_lexing ~fake_filename:name ~code) |
e69e4e8b | 221 | ~expect_output:out_lexing |
38ffcb1f | 222 | ~is_error_expected:None |
e69e4e8b | 223 | in |
ea3f5e0c | 224 | let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) = |
e69e4e8b | 225 | run_pass |
38ffcb1f | 226 | ~f:(fun () -> pass_parsing ~fake_filename:name ~code) |
e69e4e8b | 227 | ~expect_output:out_parsing |
38ffcb1f | 228 | ~is_error_expected:None |
e69e4e8b | 229 | in |
ea3f5e0c SK |
230 | let (stat_semant_exe, stat_semant_out_cmp, _) = |
231 | run_pass | |
38ffcb1f | 232 | ~f:(fun () -> pass_semant absyn_opt) |
ea3f5e0c | 233 | ~expect_output:(Some ()) |
5da420a8 | 234 | ~is_error_expected:is_error_expected_semant |
ea3f5e0c | 235 | in |
d3bdde4b SK |
236 | p "%s" bar_sep; p_ln (); |
237 | p "Test: %S" name; p_ln (); | |
238 | p_indent 1; p "Lexing:"; p_ln (); | |
e69e4e8b SK |
239 | p_indent 2; p "exe: %s" stat_lex_exe ; p_ln (); |
240 | p_indent 2; p "out: %s" stat_lex_out_cmp; p_ln (); | |
d3bdde4b | 241 | p_indent 1; p "Parsing:"; p_ln (); |
e69e4e8b SK |
242 | p_indent 2; p "exe: %s" stat_pars_exe ; p_ln (); |
243 | p_indent 2; p "out: %s" stat_pars_out_cmp; p_ln (); | |
ea3f5e0c SK |
244 | p_indent 1; p "Semantic Analysis:"; p_ln (); |
245 | p_indent 2; p "exe: %s" stat_semant_exe ; p_ln (); | |
246 | p_indent 2; p "out: %s" stat_semant_out_cmp; p_ln (); | |
d3bdde4b SK |
247 | ); |
248 | p "%s" bar_end; p_ln (); | |
b762cacb | 249 | p "%s" |
0f031bf2 SK |
250 | ( let info = |
251 | s "%d failures in %d test cases" !failure_count !test_case_count | |
252 | in | |
253 | match !failure_count with | |
254 | | 0 -> status_pass () ~info | |
255 | | _ -> status_fail () ~info | |
b762cacb SK |
256 | ); |
257 | p_ln (); | |
d3bdde4b | 258 | p "%s" bar_end; p_ln (); |
b762cacb | 259 | exit !failure_count |