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 | ||
43 | type t = | |
44 | { name : string | |
45 | ; code : string | |
46 | ; out_lexing : (Tiger_parser.token list) option | |
47 | ; out_parsing : Tiger_absyn.t option | |
e69e4e8b | 48 | ; is_error_expected : (Tiger_error.t -> bool) |
d3bdde4b SK |
49 | } |
50 | ||
51 | type color = | |
52 | | Red | |
53 | | Yellow | |
54 | | Green | |
55 | ||
56 | ||
57 | let color_to_ansi_code = function | |
58 | | Red -> "\027[0;31m" | |
59 | | Yellow -> "\027[0;33m" | |
60 | | Green -> "\027[0;32m" | |
61 | ||
62 | let color color string = | |
63 | let color_on = color_to_ansi_code color in | |
64 | let color_off = "\027[0m" in | |
65 | sprintf "%s%s%s" color_on string color_off | |
66 | ||
e69e4e8b SK |
67 | let case |
68 | ?(out_lexing) | |
69 | ?(out_parsing) | |
70 | ?(is_error_expected=(fun _ -> false)) | |
71 | ~code | |
72 | name | |
73 | = | |
d3bdde4b SK |
74 | { name |
75 | ; code | |
76 | ; out_lexing | |
77 | ; out_parsing | |
e69e4e8b | 78 | ; is_error_expected |
d3bdde4b SK |
79 | } |
80 | ||
81 | let bar_sep = String.make 80 '-' | |
82 | let bar_end = String.make 80 '=' | |
83 | ||
84 | let indent = | |
85 | let unit_spaces = 2 in | |
86 | fun n -> | |
87 | String.make (n * unit_spaces) ' ' | |
88 | ||
89 | let pass_lexing code : (Tiger_parser.token list, string) result = | |
90 | let lexbuf = Lexing.from_string code in | |
91 | let rec tokens () = | |
92 | let token = Tiger_lexer.token lexbuf in | |
93 | (* Avoiding fragile pattern-matching *) | |
94 | if token = Tiger_parser.EOF then [] else token :: tokens () | |
95 | in | |
96 | match tokens () with | |
97 | | exception e -> Error (Printexc.to_string e) | |
98 | | tokens -> Ok tokens | |
99 | ||
e69e4e8b | 100 | let pass_parsing code : (Tiger_absyn.t, string) result = |
d3bdde4b SK |
101 | let lb = Lexing.from_string code in |
102 | match Tiger_parser.program Tiger_lexer.token lb with | |
103 | | exception Parsing.Parse_error -> | |
104 | let module L = Lexing in | |
105 | let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in | |
106 | let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in | |
107 | Error msg | |
108 | | ast -> | |
109 | Ok ast | |
110 | ||
ea3f5e0c SK |
111 | let pass_semant (absyn_opt : Tiger_absyn.t option) : (unit, string) result = |
112 | match absyn_opt with | |
113 | | None -> | |
114 | Error "AST not provided" | |
115 | | Some absyn -> | |
116 | Ok (Tiger_semant.transProg absyn) | |
117 | ||
d3bdde4b SK |
118 | let s = sprintf |
119 | let p = printf | |
120 | let p_ln = print_newline | |
121 | let p_indent n = p "%s" (indent n) | |
122 | ||
123 | let run tests = | |
124 | let error_count = ref 0 in | |
e69e4e8b SK |
125 | let run_pass ~f ~input ~expect_output ~is_error_expected = |
126 | let output_status = "n/a" in | |
127 | let output_value = None in | |
d3bdde4b SK |
128 | match f input with |
129 | | exception e -> | |
df637739 | 130 | let status_text, error_text = |
e69e4e8b SK |
131 | (match e with |
132 | | Tiger_error.T e when is_error_expected e -> | |
df637739 | 133 | ((color Green "OK"), Tiger_error.to_string e) |
e69e4e8b SK |
134 | | Tiger_error.T e -> |
135 | incr error_count; | |
df637739 | 136 | ((color Red "ERROR"), Tiger_error.to_string e) |
e69e4e8b SK |
137 | | e -> |
138 | incr error_count; | |
df637739 | 139 | ((color Red "ERROR"), Printexc.to_string e) |
e69e4e8b SK |
140 | ) |
141 | in | |
df637739 | 142 | ( s "%s: %s" status_text error_text |
e69e4e8b SK |
143 | , output_status |
144 | , output_value | |
d3bdde4b SK |
145 | ) |
146 | | Error msg -> | |
147 | incr error_count; | |
148 | ( s "%s: %s" (color Red "ERROR") msg | |
e69e4e8b SK |
149 | , output_status |
150 | , output_value | |
d3bdde4b SK |
151 | ) |
152 | | Ok produced -> | |
e69e4e8b SK |
153 | let execution_status = s "%s" (color Green "OK") in |
154 | let output_status = | |
d3bdde4b | 155 | match |
e69e4e8b | 156 | Option.map expect_output (fun expected -> expected = produced) |
d3bdde4b SK |
157 | with |
158 | | None -> | |
e69e4e8b | 159 | s "%s" (color Yellow "expected output not provided") |
d3bdde4b SK |
160 | | Some true -> |
161 | s "%s" (color Green "OK") | |
162 | | Some false -> | |
163 | incr error_count; | |
164 | s "%s" (color Red "ERROR") | |
165 | in | |
e69e4e8b SK |
166 | let output_value = Some produced in |
167 | (execution_status, output_status, output_value) | |
d3bdde4b SK |
168 | in |
169 | List.iter tests ~f:( | |
e69e4e8b SK |
170 | fun {name; code; out_lexing; out_parsing; is_error_expected} -> |
171 | let (stat_lex_exe, stat_lex_out_cmp, _) = | |
172 | run_pass | |
173 | ~f:pass_lexing | |
174 | ~input:code | |
175 | ~expect_output:out_lexing | |
176 | ~is_error_expected | |
177 | in | |
ea3f5e0c | 178 | let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) = |
e69e4e8b SK |
179 | run_pass |
180 | ~f:pass_parsing | |
181 | ~input:code | |
182 | ~expect_output:out_parsing | |
183 | ~is_error_expected | |
184 | in | |
ea3f5e0c SK |
185 | let (stat_semant_exe, stat_semant_out_cmp, _) = |
186 | run_pass | |
187 | ~f:pass_semant | |
188 | ~input:absyn_opt | |
189 | ~expect_output:(Some ()) | |
190 | ~is_error_expected | |
191 | in | |
d3bdde4b SK |
192 | p "%s" bar_sep; p_ln (); |
193 | p "Test: %S" name; p_ln (); | |
194 | p_indent 1; p "Lexing:"; p_ln (); | |
e69e4e8b SK |
195 | p_indent 2; p "exe: %s" stat_lex_exe ; p_ln (); |
196 | p_indent 2; p "out: %s" stat_lex_out_cmp; p_ln (); | |
d3bdde4b | 197 | p_indent 1; p "Parsing:"; p_ln (); |
e69e4e8b SK |
198 | p_indent 2; p "exe: %s" stat_pars_exe ; p_ln (); |
199 | p_indent 2; p "out: %s" stat_pars_out_cmp; p_ln (); | |
ea3f5e0c SK |
200 | p_indent 1; p "Semantic Analysis:"; p_ln (); |
201 | p_indent 2; p "exe: %s" stat_semant_exe ; p_ln (); | |
202 | p_indent 2; p "out: %s" stat_semant_out_cmp; p_ln (); | |
d3bdde4b SK |
203 | ); |
204 | p "%s" bar_end; p_ln (); | |
205 | let failures = !error_count in | |
206 | let clr = (if failures = 0 then Green else Red) in | |
207 | p "Failures: %s" (color clr (string_of_int failures)); p_ln (); | |
208 | p "%s" bar_end; p_ln (); | |
209 | exit failures |