| 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 | (* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *) |
| 44 | type t = |
| 45 | { name : string |
| 46 | ; code : string |
| 47 | ; out_lexing : (Tiger_parser.token list) option |
| 48 | ; out_parsing : Tiger_absyn.t option |
| 49 | ; is_error_expected_parsing : (Tiger_error.t -> bool) option |
| 50 | ; is_error_expected_semant : (Tiger_error.t -> bool) option |
| 51 | } |
| 52 | |
| 53 | type status = |
| 54 | | Pass |
| 55 | | Fail |
| 56 | | Skip |
| 57 | |
| 58 | type 'a t_result = |
| 59 | { exe_stat : status |
| 60 | ; exe_msg : string |
| 61 | ; out_stat : status |
| 62 | ; out_val : 'a option |
| 63 | ; out_msg : string |
| 64 | } |
| 65 | |
| 66 | type color = |
| 67 | | Red |
| 68 | | Red_bold |
| 69 | | Yellow |
| 70 | | Green |
| 71 | | Green_bold |
| 72 | | Grey_bold |
| 73 | |
| 74 | |
| 75 | let color_to_ansi_code = function |
| 76 | | Grey_bold -> "\027[1;30m" |
| 77 | | Red -> "\027[0;31m" |
| 78 | | Red_bold -> "\027[1;31m" |
| 79 | | Yellow -> "\027[0;33m" |
| 80 | | Green -> "\027[0;32m" |
| 81 | | Green_bold -> "\027[1;32m" |
| 82 | |
| 83 | let color_off = "\027[0m" |
| 84 | |
| 85 | let color color string = |
| 86 | let color_on = color_to_ansi_code color in |
| 87 | sprintf "%s%s%s" color_on string color_off |
| 88 | |
| 89 | let colorize str = function |
| 90 | | Some c -> (color_to_ansi_code c) ^ str ^ color_off |
| 91 | | None -> str |
| 92 | |
| 93 | let status_to_color = function |
| 94 | | Pass -> Some Green_bold |
| 95 | | Fail -> Some Red_bold |
| 96 | | Skip -> Some Grey_bold |
| 97 | |
| 98 | let status_to_str = function |
| 99 | (* Expected to be a single character, but using string to allow unicode. *) |
| 100 | | Pass -> "✓" |
| 101 | | Fail -> "X" |
| 102 | | Skip -> "-" |
| 103 | |
| 104 | let status indicator info = |
| 105 | match info with |
| 106 | | "" -> indicator |
| 107 | | _ -> sprintf "%s: %s" indicator info |
| 108 | |
| 109 | (* TODO: Perhaps a global option whether to print non-fail info? *) |
| 110 | let status_pass ?(info="") () = |
| 111 | status (color Green "P") info |
| 112 | |
| 113 | let status_fail ?(info="") () = |
| 114 | status (color Red "F") info |
| 115 | |
| 116 | let status_skip ?(info="") () = |
| 117 | (*let indicator = (color Yellow "Skip") in*) |
| 118 | let indicator = "S" in |
| 119 | status indicator info |
| 120 | |
| 121 | let case |
| 122 | ?(out_lexing=None) |
| 123 | ?(out_parsing=None) |
| 124 | ?(is_error_expected_parsing=None) |
| 125 | ?(is_error_expected_semant=None) |
| 126 | ~code |
| 127 | name |
| 128 | = |
| 129 | { name |
| 130 | ; code |
| 131 | ; out_lexing |
| 132 | ; out_parsing |
| 133 | ; is_error_expected_parsing |
| 134 | ; is_error_expected_semant |
| 135 | } |
| 136 | |
| 137 | let bar_horiz_minor = color Grey_bold (String.make 80 '-') |
| 138 | let bar_horiz_major = color Grey_bold (String.make 80 '=') |
| 139 | let bar_vert = color Grey_bold "|" |
| 140 | |
| 141 | let indent = |
| 142 | let unit_spaces = 2 in |
| 143 | fun n -> |
| 144 | String.make (n * unit_spaces) ' ' |
| 145 | |
| 146 | let lexbuf_set_filename lb filename |
| 147 | : unit |
| 148 | = |
| 149 | let Lexing.({lex_start_p; lex_curr_p; _}) = lb in |
| 150 | lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename}; |
| 151 | lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename} |
| 152 | |
| 153 | let lexbuf_create ~filename ~code = |
| 154 | let lb = Lexing.from_string code in |
| 155 | lexbuf_set_filename lb filename; |
| 156 | lb |
| 157 | |
| 158 | let pass_lexing ~fake_filename ~code |
| 159 | : (Tiger_parser.token list, string) result |
| 160 | = |
| 161 | let lexbuf = lexbuf_create ~filename:fake_filename ~code in |
| 162 | let rec tokens () = |
| 163 | let token = Tiger_lexer.token lexbuf in |
| 164 | (* Avoiding fragile pattern-matching *) |
| 165 | if token = Tiger_parser.EOF then [] else token :: tokens () |
| 166 | in |
| 167 | match tokens () with |
| 168 | | exception e -> Error (Printexc.to_string e) |
| 169 | | tokens -> Ok tokens |
| 170 | |
| 171 | let pass_parsing ~fake_filename ~code |
| 172 | : (Tiger_absyn.t, string) result |
| 173 | = |
| 174 | let lb = lexbuf_create ~filename:fake_filename ~code in |
| 175 | match Tiger_parser.program Tiger_lexer.token lb with |
| 176 | | exception Parsing.Parse_error -> |
| 177 | let module L = Lexing in |
| 178 | let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in |
| 179 | let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in |
| 180 | Error msg |
| 181 | | ast -> |
| 182 | Ok ast |
| 183 | |
| 184 | let pass_semant (absyn : Tiger_absyn.t) |
| 185 | : (unit, string) result |
| 186 | = |
| 187 | Ok (Tiger_semant.transProg absyn) |
| 188 | |
| 189 | let str_exact str exact = |
| 190 | let len = String.length str in |
| 191 | let take = if len > exact then exact else len in |
| 192 | let str = String.sub str 0 take in |
| 193 | let pad = exact - take in |
| 194 | let pad = String.make pad ' ' in |
| 195 | str ^ pad |
| 196 | |
| 197 | let s = sprintf |
| 198 | let p = printf |
| 199 | let p_ln = print_newline |
| 200 | let p_indent n = p "%s" (indent n) |
| 201 | |
| 202 | let run tests = |
| 203 | Printexc.record_backtrace true; |
| 204 | let count_fail_all = ref 0 in |
| 205 | let run_pass ~f ~expect_output ~is_error_expected = |
| 206 | let is_error_expected = |
| 207 | match is_error_expected with |
| 208 | | None -> (fun _ -> false) |
| 209 | | Some f -> f |
| 210 | in |
| 211 | match f () with |
| 212 | | exception e -> |
| 213 | let backtrace = Printexc.get_backtrace () in |
| 214 | let (exe_stat, exe_msg) = |
| 215 | (match e with |
| 216 | | Tiger_error.T e when is_error_expected e -> |
| 217 | (Pass, (Tiger_error.to_string e)) |
| 218 | | Tiger_error.T e -> |
| 219 | incr count_fail_all; |
| 220 | (Fail, (Tiger_error.to_string e)) |
| 221 | | e -> |
| 222 | incr count_fail_all; |
| 223 | (Fail, (Printexc.to_string e)) |
| 224 | ) |
| 225 | in |
| 226 | { exe_stat |
| 227 | ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace |
| 228 | ; out_stat = Skip |
| 229 | ; out_val = None |
| 230 | ; out_msg = "" (* old "info" goes here *) |
| 231 | } |
| 232 | | Error info -> |
| 233 | incr count_fail_all; |
| 234 | { exe_stat = Fail |
| 235 | ; exe_msg = info |
| 236 | ; out_stat = Skip |
| 237 | ; out_val = None |
| 238 | ; out_msg = "" (* old "info" goes here *) |
| 239 | } |
| 240 | | Ok produced -> |
| 241 | let (out_stat, out_msg) = |
| 242 | match |
| 243 | Option.map expect_output (fun expected -> expected = produced) |
| 244 | with |
| 245 | | None -> |
| 246 | (Skip, "expected output not provided") |
| 247 | | Some true -> |
| 248 | (Pass, "") |
| 249 | | Some false -> |
| 250 | incr count_fail_all; |
| 251 | (* TODO pretty print expected and produced *) |
| 252 | (Fail, "unexpected output") |
| 253 | in |
| 254 | { exe_stat = Pass |
| 255 | ; exe_msg = "" (* old "info" goes here *) |
| 256 | ; out_stat |
| 257 | ; out_val = Some produced |
| 258 | ; out_msg |
| 259 | } |
| 260 | in |
| 261 | let test_case_count = ref 0 in |
| 262 | let col_1_width = 25 in |
| 263 | let col_i_width = 10 in |
| 264 | let p_stat width (exe, out) = |
| 265 | (* All this gymnastics to ignore color codes in cell width *) |
| 266 | let min = 5 in |
| 267 | let width = if width > min then width else min in |
| 268 | p "%s" (String.concat "" (List.init ~len:width ~f:(function |
| 269 | | 0 -> " " |
| 270 | | 1 -> bar_vert |
| 271 | | 2 -> " " |
| 272 | | 3 -> colorize (status_to_str exe) (status_to_color exe) |
| 273 | | 4 -> colorize (status_to_str out) (status_to_color out) |
| 274 | | _ -> " " |
| 275 | ))) |
| 276 | |
| 277 | in |
| 278 | p "%s" bar_horiz_major; p_ln (); |
| 279 | p "%s" (str_exact "Test case" col_1_width); |
| 280 | List.iter ~f:(fun header -> p " %s %s" bar_vert header) |
| 281 | [ "Lexing" |
| 282 | ; "Parsing" |
| 283 | ; "Semant" |
| 284 | ]; |
| 285 | p_ln (); |
| 286 | p "%s" bar_horiz_major; p_ln (); |
| 287 | List.iter tests ~f:( |
| 288 | fun |
| 289 | { name |
| 290 | ; code |
| 291 | ; out_lexing |
| 292 | ; out_parsing |
| 293 | ; is_error_expected_parsing |
| 294 | ; is_error_expected_semant |
| 295 | } |
| 296 | -> |
| 297 | incr test_case_count; |
| 298 | let res_lex = |
| 299 | run_pass |
| 300 | ~f:(fun () -> pass_lexing ~fake_filename:name ~code) |
| 301 | ~expect_output:out_lexing |
| 302 | ~is_error_expected:None |
| 303 | in |
| 304 | let res_pars = |
| 305 | run_pass |
| 306 | ~f:(fun () -> pass_parsing ~fake_filename:name ~code) |
| 307 | ~expect_output:out_parsing |
| 308 | ~is_error_expected:is_error_expected_parsing |
| 309 | in |
| 310 | let res_sem = |
| 311 | (* TODO: Replace this hack with general test-dependency checking *) |
| 312 | match res_pars.out_val with |
| 313 | | None -> |
| 314 | { exe_stat = Skip |
| 315 | ; exe_msg = "No AST provided" |
| 316 | ; out_stat = Skip |
| 317 | ; out_val = None |
| 318 | ; out_msg = "" |
| 319 | } |
| 320 | | Some absyn -> |
| 321 | run_pass |
| 322 | ~f:(fun () -> pass_semant absyn) |
| 323 | ~expect_output:(Some ()) |
| 324 | ~is_error_expected:is_error_expected_semant |
| 325 | in |
| 326 | let results = |
| 327 | (* Replacing out_val for type compatibility *) |
| 328 | [ "Lexing" , {res_lex with out_val = None} |
| 329 | ; "Parsing" , {res_pars with out_val = None} |
| 330 | ; "Semant" , {res_sem with out_val = None} |
| 331 | ] |
| 332 | in |
| 333 | if !test_case_count > 1 then (p "%s" bar_horiz_minor; p_ln ()); |
| 334 | p "%s" (str_exact name col_1_width); |
| 335 | List.iter results ~f:(fun (stage, {exe_stat=e; out_stat=o; _}) -> |
| 336 | p_stat ((String.length stage) + 3) (e, o) |
| 337 | ); |
| 338 | p_ln (); |
| 339 | let printed_error = ref false in |
| 340 | List.iter results ~f:( |
| 341 | fun (stage, {exe_stat; exe_msg; out_stat; out_msg; _}) -> |
| 342 | (match exe_stat with |
| 343 | | Pass -> () |
| 344 | | Skip -> () |
| 345 | | Fail -> |
| 346 | printed_error := true; |
| 347 | p "%s: %s" (color Grey_bold stage) (color Red exe_msg); |
| 348 | p_ln () |
| 349 | ); |
| 350 | (match out_stat with |
| 351 | | Pass -> () |
| 352 | | Skip -> () |
| 353 | | Fail -> |
| 354 | printed_error := true; |
| 355 | p "%s: %s" (color Grey_bold stage) (color Red out_msg) |
| 356 | ); |
| 357 | ); |
| 358 | ); |
| 359 | p "%s" bar_horiz_major; p_ln (); |
| 360 | p "%s" |
| 361 | ( let info = |
| 362 | s "%d failures in %d test cases" !count_fail_all !test_case_count |
| 363 | in |
| 364 | match !count_fail_all with |
| 365 | | 0 -> status_pass () ~info |
| 366 | | _ -> status_fail () ~info |
| 367 | ); |
| 368 | p_ln (); |
| 369 | p "%s" bar_horiz_major; p_ln (); |
| 370 | exit !count_fail_all |