Define (some) semantic errors

[tiger.ml.git] / compiler / src / lib / tiger / tiger_test.ml

(*
 * 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