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 color =
  53   | Red
  54   | Yellow
  55   | Green
  56
  57
  58 let color_to_ansi_code = function
  59   | Red    -> "\027[0;31m"
  60   | Yellow -> "\027[0;33m"
  61   | Green  -> "\027[0;32m"
  62
  63 let color color string =
  64   let color_on  = color_to_ansi_code color in
  65   let color_off = "\027[0m" in
  66   sprintf "%s%s%s" color_on string color_off
  67
  68 let status indicator info =
  69   match info with
  70   | "" -> indicator
  71   | _  -> sprintf "%s: %s" indicator info
  72
  73 (* TODO: Perhaps a global option whether to print non-fail info? *)
  74 let status_pass ?(info="") () =
  75   status (color Green "Pass") info
  76
  77 let status_fail ?(info="") () =
  78   status (color Red "Fail") info
  79
  80 let status_skip ?(info="") () =
  81   status (color Yellow "Skip") info
  82
  83 let case
  84     ?(out_lexing=None)
  85     ?(out_parsing=None)
  86     ?(is_error_expected_semant=None)
  87     ~code
  88     name
  89   =
  90   { name
  91   ; code
  92   ; out_lexing
  93   ; out_parsing
  94   ; is_error_expected_semant
  95   }
  96
  97 let bar_sep = String.make 80 '-'
  98 let bar_end = String.make 80 '='
  99
 100 let indent =
 101   let unit_spaces = 2 in
 102   fun n ->
 103     String.make (n * unit_spaces) ' '
 104
 105 let lexbuf_set_filename lb filename
 106 : unit
 107 =
 108   let Lexing.({lex_start_p; lex_curr_p; _}) = lb in
 109   lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename};
 110   lb.Lexing.lex_curr_p  <- {lex_curr_p  with Lexing.pos_fname = filename}
 111
 112 let lexbuf_create ~filename ~code =
 113   let lb = Lexing.from_string code in
 114   lexbuf_set_filename lb filename;
 115   lb
 116
 117 let pass_lexing ~fake_filename ~code
 118 : (Tiger_parser.token list, string) result
 119 =
 120   let lexbuf = lexbuf_create ~filename:fake_filename ~code in
 121   let rec tokens () =
 122     let token = Tiger_lexer.token lexbuf in
 123     (* Avoiding fragile pattern-matching *)
 124     if token = Tiger_parser.EOF then [] else token :: tokens ()
 125   in
 126   match tokens () with
 127   | exception e -> Error (Printexc.to_string e)
 128   | tokens      -> Ok tokens
 129
 130 let pass_parsing ~fake_filename ~code
 131 : (Tiger_absyn.t, string) result
 132 =
 133   let lb = lexbuf_create ~filename:fake_filename ~code in
 134   match Tiger_parser.program Tiger_lexer.token lb with
 135   | exception Parsing.Parse_error ->
 136       let module L = Lexing in
 137       let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
 138       let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
 139       Error msg
 140   | ast ->
 141       Ok ast
 142
 143 let pass_semant (absyn_opt : Tiger_absyn.t option)
 144 : (unit, string) result
 145 =
 146   match absyn_opt with
 147   | None ->
 148       Error "AST not provided"
 149   | Some absyn ->
 150       Ok (Tiger_semant.transProg absyn)
 151
 152 let s = sprintf
 153 let p = printf
 154 let p_ln = print_newline
 155 let p_indent n = p "%s" (indent n)
 156
 157 let run tests =
 158   let failure_count = ref 0 in
 159   let run_pass ~f ~expect_output ~is_error_expected =
 160     let is_error_expected =
 161       match is_error_expected with
 162       | None -> (fun _ -> false)
 163       | Some f -> f
 164     in
 165     let output_status = "n/a" in
 166     let output_value  = None in
 167     match f () with
 168     | exception e ->
 169         let execution_status =
 170           (match e with
 171           | Tiger_error.T e when is_error_expected e ->
 172               status_pass () (*~info:(Tiger_error.to_string e)*)
 173           | Tiger_error.T e ->
 174               incr failure_count;
 175               status_fail () ~info:(Tiger_error.to_string e)
 176           | e ->
 177               incr failure_count;
 178               status_fail () ~info:(Printexc.to_string e)
 179           )
 180         in
 181         ( execution_status
 182         , output_status
 183         , output_value
 184         )
 185     | Error info ->
 186         incr failure_count;
 187         ( status_fail ~info ()
 188         , output_status
 189         , output_value
 190         )
 191     | Ok produced ->
 192         let execution_status = status_pass () in
 193         let output_status =
 194           match
 195             Option.map expect_output (fun expected -> expected = produced)
 196           with
 197           | None ->
 198               status_skip () (*~info:"expected output not provided"*)
 199           | Some true ->
 200               status_pass ()
 201           | Some false ->
 202               incr failure_count;
 203               status_fail ()
 204         in
 205         let output_value = Some produced in
 206         (execution_status, output_status, output_value)
 207   in
 208   let test_case_count = ref 0 in
 209   List.iter tests ~f:(
 210     fun
 211       { name
 212       ; code
 213       ; out_lexing
 214       ; out_parsing
 215       ; is_error_expected_semant
 216       }
 217     ->
 218       incr test_case_count;
 219       let (stat_lex_exe, stat_lex_out_cmp, _) =
 220         run_pass
 221           ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
 222           ~expect_output:out_lexing
 223           ~is_error_expected:None
 224       in
 225       let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) =
 226         run_pass
 227           ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
 228           ~expect_output:out_parsing
 229           ~is_error_expected:None
 230       in
 231       let (stat_semant_exe, stat_semant_out_cmp, _) =
 232         run_pass
 233           ~f:(fun () -> pass_semant absyn_opt)
 234           ~expect_output:(Some ())
 235           ~is_error_expected:is_error_expected_semant
 236       in
 237       p "%s" bar_sep; p_ln ();
 238       p "Test: %S" name; p_ln ();
 239         p_indent 1; p "Lexing:"; p_ln ();
 240           p_indent 2; p "exe: %s" stat_lex_exe    ; p_ln ();
 241           p_indent 2; p "out: %s" stat_lex_out_cmp; p_ln ();
 242         p_indent 1; p "Parsing:"; p_ln ();
 243           p_indent 2; p "exe: %s" stat_pars_exe    ; p_ln ();
 244           p_indent 2; p "out: %s" stat_pars_out_cmp; p_ln ();
 245         p_indent 1; p "Semantic Analysis:"; p_ln ();
 246           p_indent 2; p "exe: %s" stat_semant_exe    ; p_ln ();
 247           p_indent 2; p "out: %s" stat_semant_out_cmp; p_ln ();
 248   );
 249   p "%s" bar_end; p_ln ();
 250   p "%s"
 251     ( let info =
 252         s "%d failures in %d test cases" !failure_count !test_case_count
 253       in
 254       match !failure_count with
 255       | 0 -> status_pass () ~info
 256       | _ -> status_fail () ~info
 257     );
 258     p_ln ();
 259   p "%s" bar_end; p_ln ();
 260   exit !failure_count