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