compiler/src/lib/tiger/tiger_test.ml

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