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