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