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