X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=e54f1600bbdf74f1bf05186b3f64c9e5ad22bad9;hb=38ffcb1fc99ecb7a48097cbcf97b9a3062c8bfa0;hp=89e317f3c3731c257f0730a380fc5998247667ec;hpb=5da420a8c9d88111ef4ccabd6b0a0c65cddb73af;p=tiger.ml.git

diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml
index 89e317f..e54f160 100644
--- a/compiler/src/lib/tiger/tiger_test.ml
+++ b/compiler/src/lib/tiger/tiger_test.ml
@@ -40,12 +40,13 @@ 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_semant : (Tiger_error.t -> bool)
+  ; is_error_expected_semant : (Tiger_error.t -> bool) option
   }
 
 type color =
@@ -79,9 +80,9 @@ let status_skip ?(info="") () =
   status (color Yellow "Skip") info
 
 let case
-    ?(out_lexing)
-    ?(out_parsing)
-    ?(is_error_expected_semant=(fun _ -> false))
+    ?(out_lexing=None)
+    ?(out_parsing=None)
+    ?(is_error_expected_semant=None)
     ~code
     name
   =
@@ -100,8 +101,22 @@ let indent =
   fun n ->
     String.make (n * unit_spaces) ' '
 
-let pass_lexing code : (Tiger_parser.token list, string) result =
-  let lexbuf = Lexing.from_string code in
+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 lexbuf_create ~filename ~code =
+  let lb = Lexing.from_string code in
+  lexbuf_set_filename lb filename;
+  lb
+
+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 *)
@@ -111,8 +126,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
@@ -122,7 +139,9 @@ let pass_parsing code : (Tiger_absyn.t, string) result =
   | ast ->
       Ok ast
 
-let pass_semant (absyn_opt : Tiger_absyn.t option) : (unit, string) result =
+let pass_semant (absyn_opt : Tiger_absyn.t option)
+: (unit, string) result
+=
   match absyn_opt with
   | None ->
       Error "AST not provided"
@@ -135,21 +154,26 @@ 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 failure_count = 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
     let output_status = "n/a" in
     let output_value  = None in
-    match f input with
+    match f () with
     | exception e ->
         let execution_status =
           (match e with
           | Tiger_error.T e when is_error_expected e ->
               status_pass () ~info:(Tiger_error.to_string e)
           | Tiger_error.T e ->
-              incr error_count;
+              incr failure_count;
               status_fail () ~info:(Tiger_error.to_string e)
           | e ->
-              incr error_count;
+              incr failure_count;
               status_fail () ~info:(Printexc.to_string e)
           )
         in
@@ -158,7 +182,7 @@ let run tests =
         , output_value
         )
     | Error info ->
-        incr error_count;
+        incr failure_count;
         ( status_fail ~info ()
         , output_status
         , output_value
@@ -174,12 +198,13 @@ let run tests =
           | Some true ->
               status_pass ()
           | Some false ->
-              incr error_count;
+              incr failure_count;
               status_fail ()
         in
         let output_value = Some produced in
         (execution_status, output_status, output_value)
   in
+  let test_case_count = ref 0 in
   List.iter tests ~f:(
     fun
       { name
@@ -189,24 +214,22 @@ let run tests =
       ; is_error_expected_semant
       }
     ->
+      incr test_case_count;
       let (stat_lex_exe, stat_lex_out_cmp, _) =
         run_pass
-          ~f:pass_lexing
-          ~input:code
+          ~f:(fun () -> pass_lexing ~fake_filename:name ~code)
           ~expect_output:out_lexing
-          ~is_error_expected:(fun _ -> false)
+          ~is_error_expected:None
       in
       let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) =
         run_pass
-          ~f:pass_parsing
-          ~input:code
+          ~f:(fun () -> pass_parsing ~fake_filename:name ~code)
           ~expect_output:out_parsing
-          ~is_error_expected:(fun _ -> false)
+          ~is_error_expected:None
       in
       let (stat_semant_exe, stat_semant_out_cmp, _) =
         run_pass
-          ~f:pass_semant
-          ~input:absyn_opt
+          ~f:(fun () -> pass_semant absyn_opt)
           ~expect_output:(Some ())
           ~is_error_expected:is_error_expected_semant
       in
@@ -223,8 +246,14 @@ let run tests =
           p_indent 2; p "out: %s" stat_semant_out_cmp; p_ln ();
   );
   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"
+    ( let info =
+        s "%d failures in %d test cases" !failure_count !test_case_count
+      in
+      match !failure_count with
+      | 0 -> status_pass () ~info
+      | _ -> status_fail () ~info
+    );
+    p_ln ();
   p "%s" bar_end; p_ln ();
-  exit failures
+  exit !failure_count