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