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