X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=fe84ef8bc215ad04e8b7826b52e0f0cc07cf67f8;hb=8e47ed20c781e65940089e6f71e9a8ac6ea27d73;hp=83e9890584aaca794051ef06291bd91e549f30f3;hpb=df6377392ff2959a614242615a1dda51f5b97176;p=tiger.ml.git

diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml
index 83e9890..fe84ef8 100644
--- a/compiler/src/lib/tiger/tiger_test.ml
+++ b/compiler/src/lib/tiger/tiger_test.ml
@@ -21,6 +21,7 @@
  * out foo  | OK     | ... | ERROR
  *
  * *)
+(* TODO: Perhaps a global option whether to print non-fail info? *)
 
 open Printf
 
@@ -40,34 +41,68 @@ end = struct
     | Some x -> Some (f x)
 end
 
+(* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *)
 type t =
   { name        : string
   ; code        : string
   ; out_lexing  : (Tiger_parser.token list) option
   ; out_parsing : Tiger_absyn.t option
-  ; is_error_expected : (Tiger_error.t -> bool)
+  ; is_error_expected_parsing : (Tiger_error.t -> bool) option
+  ; is_error_expected_semant : (Tiger_error.t -> bool) option
+  }
+
+type status =
+  | Pass
+  | Fail
+  | Skip
+
+type 'a t_result =
+  { exe_stat : status
+  ; exe_msg  : string
+  ; out_stat : status
+  ; out_val  : 'a option
+  ; out_msg  : string
   }
 
 type color =
   | Red
-  | Yellow
-  | Green
+  | Red_bold
+  | Green_bold
+  | Grey_bold
 
 
 let color_to_ansi_code = function
-  | Red    -> "\027[0;31m"
-  | Yellow -> "\027[0;33m"
-  | Green  -> "\027[0;32m"
+  | Grey_bold  -> "\027[1;30m"
+  | Red        -> "\027[0;31m"
+  | Red_bold   -> "\027[1;31m"
+  | Green_bold -> "\027[1;32m"
+
+let color_off = "\027[0m"
 
 let color color string =
   let color_on  = color_to_ansi_code color in
-  let color_off = "\027[0m" in
   sprintf "%s%s%s" color_on string color_off
 
+let color_opt str = function
+  | Some c -> (color_to_ansi_code c) ^ str ^ color_off
+  | None   -> str
+
+let status_to_color = function
+  | Pass -> Some Green_bold
+  | Fail -> Some Red_bold
+  | Skip -> Some Grey_bold
+
+let status_to_str = function
+  (* Expected to be a single character, but using string to allow unicode. *)
+  | Pass -> "✓"
+  | Fail -> "X"
+  | Skip -> "-"
+
 let case
-    ?(out_lexing)
-    ?(out_parsing)
-    ?(is_error_expected=(fun _ -> false))
+    ?(out_lexing=None)
+    ?(out_parsing=None)
+    ?(is_error_expected_parsing=None)
+    ?(is_error_expected_semant=None)
     ~code
     name
   =
@@ -75,19 +110,30 @@ let case
   ; code
   ; out_lexing
   ; out_parsing
-  ; is_error_expected
+  ; is_error_expected_parsing
+  ; is_error_expected_semant
   }
 
-let bar_sep = String.make 80 '-'
-let bar_end = String.make 80 '='
+let bar_horiz_minor = color Grey_bold (String.make 80 '-')
+let bar_horiz_major = color Grey_bold (String.make 80 '=')
+let bar_vert        = color Grey_bold "|"
+
+let lexbuf_set_filename lb filename
+: unit
+=
+  let Lexing.({lex_start_p; lex_curr_p; _}) = lb in
+  lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename};
+  lb.Lexing.lex_curr_p  <- {lex_curr_p  with Lexing.pos_fname = filename}
 
-let indent =
-  let unit_spaces = 2 in
-  fun n ->
-    String.make (n * unit_spaces) ' '
+let lexbuf_create ~filename ~code =
+  let lb = Lexing.from_string code in
+  lexbuf_set_filename lb filename;
+  lb
 
-let pass_lexing code : (Tiger_parser.token list, string) result =
-  let lexbuf = Lexing.from_string code in
+let pass_lexing ~fake_filename ~code
+: (Tiger_parser.token list, string) result
+=
+  let lexbuf = lexbuf_create ~filename:fake_filename ~code in
   let rec tokens () =
     let token = Tiger_lexer.token lexbuf in
     (* Avoiding fragile pattern-matching *)
@@ -97,8 +143,10 @@ let pass_lexing code : (Tiger_parser.token list, string) result =
   | exception e -> Error (Printexc.to_string e)
   | tokens      -> Ok tokens
 
-let pass_parsing code : (Tiger_absyn.t, string) result =
-  let lb = Lexing.from_string code in
+let pass_parsing ~fake_filename ~code
+: (Tiger_absyn.t, string) result
+=
+  let lb = lexbuf_create ~filename:fake_filename ~code in
   match Tiger_parser.program Tiger_lexer.token lb with
   | exception Parsing.Parse_error ->
       let module L = Lexing in
@@ -108,85 +156,187 @@ let pass_parsing code : (Tiger_absyn.t, string) result =
   | ast ->
       Ok ast
 
+let pass_semant (absyn : Tiger_absyn.t)
+: (unit, string) result
+=
+  Ok (Tiger_semant.transProg absyn)
+
+let str_exact str exact =
+  let len = String.length str in
+  let take = if len > exact then exact else len in
+  let str = String.sub str ~pos:0 ~len:take in
+  let pad = exact - take in
+  let pad = String.make pad ' ' in
+  str ^ pad
+
 let s = sprintf
 let p = printf
 let p_ln = print_newline
-let p_indent n = p "%s" (indent n)
 
 let run tests =
-  let error_count = ref 0 in
-  let run_pass ~f ~input ~expect_output ~is_error_expected =
-    let output_status = "n/a" in
-    let output_value  = None in
-    match f input with
+  Printexc.record_backtrace true;
+  let count_fail_all = ref 0 in
+  let run_pass ~f ~expect_output ~is_error_expected =
+    let is_error_expected =
+      match is_error_expected with
+      | None -> (fun _ -> false)
+      | Some f -> f
+    in
+    match f () with
     | exception e ->
-        let status_text, error_text =
+        let backtrace = Printexc.get_backtrace () in
+        let (exe_stat, exe_msg) =
           (match e with
           | Tiger_error.T e when is_error_expected e ->
-              ((color Green "OK"), Tiger_error.to_string e)
+              (Pass, (Tiger_error.to_string e))
           | Tiger_error.T e ->
-              incr error_count;
-              ((color Red "ERROR"), Tiger_error.to_string e)
+              incr count_fail_all;
+              (Fail, (Tiger_error.to_string e))
           | e ->
-              incr error_count;
-              ((color Red "ERROR"), Printexc.to_string e)
+              incr count_fail_all;
+              (Fail, (Printexc.to_string e))
           )
         in
-        ( s "%s: %s" status_text error_text
-        , output_status
-        , output_value
-        )
-    | Error msg ->
-        incr error_count;
-        ( s "%s: %s" (color Red "ERROR") msg
-        , output_status
-        , output_value
-        )
+        { exe_stat
+        ; exe_msg  = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace
+        ; out_stat = Skip
+        ; out_val  = None
+        ; out_msg  = ""  (* old "info" goes here *)
+        }
+    | Error info ->
+        incr count_fail_all;
+        { exe_stat = Fail
+        ; exe_msg  = info
+        ; out_stat = Skip
+        ; out_val  = None
+        ; out_msg  = ""  (* old "info" goes here *)
+        }
     | Ok produced ->
-        let execution_status = s "%s" (color Green "OK") in
-        let output_status =
+        let (out_stat, out_msg) =
           match
             Option.map expect_output (fun expected -> expected = produced)
           with
           | None ->
-              s "%s" (color Yellow "expected output not provided")
+              (Skip, "expected output not provided")
           | Some true ->
-              s "%s" (color Green "OK")
+              (Pass, "")
           | Some false ->
-              incr error_count;
-              s "%s" (color Red "ERROR")
+              incr count_fail_all;
+              (* TODO pretty print expected and produced *)
+              (Fail, "unexpected output")
         in
-        let output_value = Some produced in
-        (execution_status, output_status, output_value)
+        { exe_stat = Pass
+        ; exe_msg  = ""  (* old "info" goes here *)
+        ; out_stat
+        ; out_val  = Some produced
+        ; out_msg
+        }
   in
+  let test_case_count = ref 0 in
+  let col_1_width = 25 in
+  let p_stat width (exe, out) =
+    (* All this gymnastics to ignore color codes in cell width *)
+    let min = 5 in
+    let width = if width > min then width else min in
+    p "%s" (String.concat ~sep:"" (List.init ~len:width ~f:(function
+      | 0 -> " "
+      | 1 -> bar_vert
+      | 2 -> " "
+      | 3 -> color_opt (status_to_str exe) (status_to_color exe)
+      | 4 -> color_opt (status_to_str out) (status_to_color out)
+      | _ -> " "
+    )))
+
+  in
+  p "%s" bar_horiz_major; p_ln ();
+  p "%s" (str_exact "Test case" col_1_width);
+  List.iter ~f:(fun header -> p " %s %s" bar_vert header)
+    [ "Lexing"
+    ; "Parsing"
+    ; "Semant"
+    ];
+  p_ln ();
+  p "%s" bar_horiz_major; p_ln ();
   List.iter tests ~f:(
-    fun {name; code; out_lexing; out_parsing; is_error_expected} ->
-      let (stat_lex_exe, stat_lex_out_cmp, _) =
+    fun
+      { name
+      ; code
+      ; out_lexing
+      ; out_parsing
+      ; is_error_expected_parsing
+      ; is_error_expected_semant
+      }
+    ->
+      incr test_case_count;
+      let res_lex =
         run_pass
-          ~f:pass_lexing
-          ~input:code
+          ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
           ~expect_output:out_lexing
-          ~is_error_expected
+          ~is_error_expected:None
       in
-      let (stat_pars_exe, stat_pars_out_cmp, _) =
+      let res_pars =
         run_pass
-          ~f:pass_parsing
-          ~input:code
+          ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
           ~expect_output:out_parsing
-          ~is_error_expected
+          ~is_error_expected:is_error_expected_parsing
+      in
+      let res_sem =
+        (* TODO: Replace this hack with general test-dependency checking *)
+        match res_pars.out_val with
+        | None ->
+            { exe_stat = Skip
+            ; exe_msg  = "No AST provided"
+            ; out_stat = Skip
+            ; out_val  = None
+            ; out_msg  = ""
+            }
+        | Some absyn ->
+            run_pass
+              ~f:(fun () -> pass_semant absyn)
+              ~expect_output:(Some ())
+              ~is_error_expected:is_error_expected_semant
+      in
+      let results =
+        (* Replacing out_val for type compatibility *)
+        [ "Lexing"  , {res_lex  with out_val = None}
+        ; "Parsing" , {res_pars with out_val = None}
+        ; "Semant"  , {res_sem  with out_val = None}
+        ]
       in
-      p "%s" bar_sep; p_ln ();
-      p "Test: %S" name; p_ln ();
-        p_indent 1; p "Lexing:"; p_ln ();
-          p_indent 2; p "exe: %s" stat_lex_exe    ; p_ln ();
-          p_indent 2; p "out: %s" stat_lex_out_cmp; p_ln ();
-        p_indent 1; p "Parsing:"; p_ln ();
-          p_indent 2; p "exe: %s" stat_pars_exe    ; p_ln ();
-          p_indent 2; p "out: %s" stat_pars_out_cmp; p_ln ();
+      if !test_case_count > 1 then (p "%s" bar_horiz_minor; p_ln ());
+      p "%s" (str_exact name col_1_width);
+      List.iter results ~f:(fun (stage, {exe_stat=e; out_stat=o; _}) ->
+        p_stat ((String.length stage) + 3) (e, o)
+      );
+      p_ln ();
+      let printed_error = ref false in
+      List.iter results ~f:(
+        fun (stage, {exe_stat; exe_msg; out_stat; out_msg; _}) ->
+          (match exe_stat with
+          | Pass -> ()
+          | Skip -> ()
+          | Fail ->
+              printed_error := true;
+              p "%s: %s" (color Grey_bold stage) (color Red exe_msg);
+              p_ln ()
+          );
+          (match out_stat with
+          | Pass -> ()
+          | Skip -> ()
+          | Fail ->
+              printed_error := true;
+              p "%s: %s" (color Grey_bold stage) (color Red out_msg)
+          );
+      );
   );
-  p "%s" bar_end; p_ln ();
-  let failures = !error_count in
-  let clr = (if failures = 0 then Green else Red) in
-  p "Failures: %s" (color clr (string_of_int failures)); p_ln ();
-  p "%s" bar_end; p_ln ();
-  exit failures
+  p "%s" bar_horiz_major; p_ln ();
+  p "%s %d failures in %d test cases"
+      (match !count_fail_all with
+      | 0 -> color_opt (status_to_str Pass) (status_to_color Pass)
+      | _ -> color_opt (status_to_str Fail) (status_to_color Fail)
+      )
+      !count_fail_all
+      !test_case_count;
+    p_ln ();
+  p "%s" bar_horiz_major; p_ln ();
+  exit !count_fail_all