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