X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;fp=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=b2820fa499af4322da14d3780544612cc16c67c3;hb=d3bdde4b6b0b1a8cb41ee4de4fa73cd472ed23a4;hp=0000000000000000000000000000000000000000;hpb=5f295d042a33a89b68a50d80e4ce18e3f2b1cfe6;p=tiger.ml.git

diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml
new file mode 100644
index 0000000..b2820fa
--- /dev/null
+++ b/compiler/src/lib/tiger/tiger_test.ml
@@ -0,0 +1,153 @@
+(*
+ * code |> pass_a_exe |> pass_a_out |> ... |> pass_z_exe |> pass_z_out
+ *
+ * pass a:
+ *  exe: OK
+ *  out: n/a
+ * pass b:
+ *  exe: OK
+ *  out: OK
+ * pass c:
+ *  exe: OK
+ *  out: ERROR
+ * ...
+ *
+ * name     | pass a | ... | pass z
+ * ---------+--------+-----+--------
+ * exe foo  | OK     | ... | OK
+ * out foo  | OK     | ... | ERROR
+ *
+ * *)
+
+open Printf
+
+module List = ListLabels
+module String = StringLabels
+
+module Option : sig
+  type 'a t = 'a option
+
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end = struct
+  type 'a t = 'a option
+
+  let map t f =
+    match t with
+    | None   -> None
+    | Some x -> Some (f x)
+end
+
+type t =
+  { name        : string
+  ; code        : string
+  ; out_lexing  : (Tiger_parser.token list) option
+  ; out_parsing : Tiger_absyn.t option
+  }
+
+type color =
+  | Red
+  | Yellow
+  | Green
+
+
+let color_to_ansi_code = function
+  | Red    -> "\027[0;31m"
+  | Yellow -> "\027[0;33m"
+  | Green  -> "\027[0;32m"
+
+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 case ?(out_lexing) ?(out_parsing) ~code name =
+  { name
+  ; code
+  ; out_lexing
+  ; out_parsing
+  }
+
+let bar_sep = String.make 80 '-'
+let bar_end = String.make 80 '='
+
+let indent =
+  let unit_spaces = 2 in
+  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 rec tokens () =
+    let token = Tiger_lexer.token lexbuf in
+    (* Avoiding fragile pattern-matching *)
+    if token = Tiger_parser.EOF then [] else token :: tokens ()
+  in
+  match tokens () with
+  | exception e -> Error (Printexc.to_string e)
+  | tokens      -> Ok tokens
+
+let pass_parsing code =
+  let lb = Lexing.from_string code in
+  match Tiger_parser.program Tiger_lexer.token lb with
+  | exception Parsing.Parse_error ->
+      let module L = Lexing in
+      let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
+      let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
+      Error msg
+  | ast ->
+      Ok ast
+
+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 output : string * string =
+    match f input with
+    | exception e ->
+        incr error_count;
+        ( s "%s: %s" (color Red "ERROR") (Printexc.to_string e)
+        , "n/a"
+        )
+    | Error msg ->
+        incr error_count;
+        ( s "%s: %s" (color Red "ERROR") msg
+        , "n/a"
+        )
+    | Ok produced ->
+        let exe = s "%s" (color Green "OK") in
+        let out =
+          match
+            Option.map output (fun expected -> expected = produced)
+          with
+          | None ->
+              s "%s" (color Yellow "n/a")
+          | Some true ->
+              s "%s" (color Green "OK")
+          | Some false ->
+              incr error_count;
+              s "%s" (color Red "ERROR")
+        in
+        (exe, out)
+  in
+  List.iter tests ~f:(
+    fun {name; code; out_lexing; out_parsing} ->
+      let ( lexing_exe,  lexing_out) = run_pass pass_lexing  code out_lexing in
+      let (parsing_exe, parsing_out) = run_pass pass_parsing code out_parsing 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" lexing_exe; p_ln ();
+          p_indent 2; p "out: %s" lexing_out; p_ln ();
+        p_indent 1; p "Parsing:"; p_ln ();
+          p_indent 2; p "exe: %s" parsing_exe; p_ln ();
+          p_indent 2; p "out: %s" parsing_out; 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" bar_end; p_ln ();
+  exit failures