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