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