* out foo | OK | ... | ERROR
*
* *)
+(* TODO: Perhaps a global option whether to print non-fail info? *)
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
+module Err = Tiger_error
+module Opt = Tiger_opt
(* TODO: ~expect:Output of 'a | Exception of (exn -> bool) *)
type t =
type color =
| Red
| Red_bold
- | Yellow
- | Green
| Green_bold
| Grey_bold
| Grey_bold -> "\027[1;30m"
| Red -> "\027[0;31m"
| Red_bold -> "\027[1;31m"
- | Yellow -> "\027[0;33m"
- | Green -> "\027[0;32m"
| Green_bold -> "\027[1;32m"
let color_off = "\027[0m"
let color_on = color_to_ansi_code color in
sprintf "%s%s%s" color_on string color_off
-let colorize str = function
+let color_opt str = function
| Some c -> (color_to_ansi_code c) ^ str ^ color_off
| None -> str
| Fail -> "X"
| Skip -> "-"
-let status indicator info =
- match info with
- | "" -> indicator
- | _ -> sprintf "%s: %s" indicator info
-
-(* TODO: Perhaps a global option whether to print non-fail info? *)
-let status_pass ?(info="") () =
- status (color Green "P") info
-
-let status_fail ?(info="") () =
- status (color Red "F") info
-
-let status_skip ?(info="") () =
- (*let indicator = (color Yellow "Skip") in*)
- let indicator = "S" in
- status indicator info
-
let case
?(out_lexing=None)
?(out_parsing=None)
let bar_horiz_major = color Grey_bold (String.make 80 '=')
let bar_vert = color Grey_bold "|"
-let indent =
- let unit_spaces = 2 in
- fun n ->
- String.make (n * unit_spaces) ' '
-
let lexbuf_set_filename lb filename
: unit
=
lb
let pass_lexing ~fake_filename ~code
-: (Tiger_parser.token list, string) result
+: Tiger_parser.token list
=
let lexbuf = lexbuf_create ~filename:fake_filename ~code in
let rec tokens () =
(* 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
+ tokens ()
let pass_parsing ~fake_filename ~code
-: (Tiger_absyn.t, string) result
+: Tiger_absyn.t
=
- 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
- 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
+ Tiger_parser.program
+ Tiger_lexer.token
+ (lexbuf_create ~filename:fake_filename ~code)
let pass_semant (absyn : Tiger_absyn.t)
-: (unit, string) result
+: unit
=
- Ok (Tiger_semant.transProg absyn)
+ 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 0 take 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 exn_to_string = function
+ | Tiger_error.T e -> Tiger_error.to_string e
+ | e -> Printexc.to_string e
+
let s = sprintf
let p = printf
let p_ln = print_newline
-let p_indent n = p "%s" (indent n)
let run tests =
Printexc.record_backtrace true;
- let count_fail_all = ref 0 in
+ let fail, fail_count =
+ let count_fail_all = ref 0 in
+ ( (fun () -> incr count_fail_all; Fail)
+ , (fun () -> !count_fail_all)
+ )
+ 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 backtrace = Printexc.get_backtrace () in
- let (exe_stat, exe_msg) =
- (match e with
- | Tiger_error.T e when is_error_expected e ->
- (Pass, (Tiger_error.to_string e))
- | Tiger_error.T e ->
- incr count_fail_all;
- (Fail, (Tiger_error.to_string e))
- | e ->
- incr count_fail_all;
- (Fail, (Printexc.to_string e))
- )
- in
- { exe_stat
- ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace
+ let execution = match f () with exception e -> `Exn e | o -> `Out o in
+ (match execution, is_error_expected with
+ | `Exn (Err.T e), Some is_error_expected when is_error_expected e ->
+ { exe_stat = Pass
+ ; exe_msg = ""
; out_stat = Skip
; out_val = None
- ; out_msg = "" (* old "info" goes here *)
+ ; out_msg = ""
}
- | Error info ->
- incr count_fail_all;
- { exe_stat = Fail
- ; exe_msg = info
+ | `Exn e, Some _
+ | `Exn e, None ->
+ let b = Printexc.get_backtrace () in
+ let e = exn_to_string e in
+ { exe_stat = fail ()
+ ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" e b
; out_stat = Skip
; out_val = None
- ; out_msg = "" (* old "info" goes here *)
+ ; out_msg = ""
}
- | Ok produced ->
+ | `Out output, Some _ ->
+ { exe_stat = fail ()
+ ; exe_msg = "Expected exception, but got output."
+ ; out_stat = fail ()
+ ; out_val = Some output (* TODO: Do we really want to keep going? *)
+ ; out_msg = "Expected exception, but got output."
+ }
+ | `Out output, None ->
let (out_stat, out_msg) =
match
- Option.map expect_output (fun expected -> expected = produced)
+ Opt.map expect_output (fun expected -> expected = output)
with
| None ->
(Skip, "expected output not provided")
| Some true ->
(Pass, "")
| Some false ->
- incr count_fail_all;
- (* TODO pretty print expected and produced *)
- (Fail, "unexpected output")
+ (* TODO pretty print expected and output *)
+ (fail (), "unexpected output")
in
{ exe_stat = Pass
; exe_msg = "" (* old "info" goes here *)
; out_stat
- ; out_val = Some produced
+ ; out_val = Some output
; out_msg
}
+ )
in
let test_case_count = ref 0 in
- let col_1_width = 25 in
- let col_i_width = 10 in
+ let col_1_width = 30 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 "" (List.init ~len:width ~f:(function
+ p "%s" (String.concat ~sep:"" (List.init ~len:width ~f:(function
| 0 -> " "
| 1 -> bar_vert
| 2 -> " "
- | 3 -> colorize (status_to_str exe) (status_to_color exe)
- | 4 -> colorize (status_to_str out) (status_to_color out)
+ | 3 -> color_opt (status_to_str exe) (status_to_color exe)
+ | 4 -> color_opt (status_to_str out) (status_to_color out)
| _ -> " "
)))
);
);
p "%s" bar_horiz_major; p_ln ();
- p "%s"
- ( let info =
- s "%d failures in %d test cases" !count_fail_all !test_case_count
- in
- match !count_fail_all with
- | 0 -> status_pass () ~info
- | _ -> status_fail () ~info
- );
+ p "%s %d failures in %d test cases"
+ (match fail_count () with
+ | 0 -> color_opt (status_to_str Pass) (status_to_color Pass)
+ | _ -> color_opt (status_to_str Fail) (status_to_color Fail)
+ )
+ (fail_count ())
+ !test_case_count;
p_ln ();
p "%s" bar_horiz_major; p_ln ();
- exit !count_fail_all
+ exit (fail_count ())
home / code / tiger.ml.git / blobdiff