X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=fdfa989250ac48675ab8da5209fd30c5786ed0d2;hb=753f38382d7a2952c23521fd6c75093c8bd63199;hp=81f549da1f4abd9890103736201c764021f249e3;hpb=217e963845b596d25400ec28035a15d64478e6da;p=tiger.ml.git diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml index 81f549d..fdfa989 100644 --- a/compiler/src/lib/tiger/tiger_test.ml +++ b/compiler/src/lib/tiger/tiger_test.ml @@ -21,24 +21,15 @@ * 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 = @@ -66,8 +57,6 @@ type 'a t_result = type color = | Red | Red_bold - | Yellow - | Green | Green_bold | Grey_bold @@ -76,8 +65,6 @@ let color_to_ansi_code = function | 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" @@ -86,7 +73,7 @@ let color color string = 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 @@ -101,23 +88,6 @@ let status_to_str = function | 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) @@ -138,11 +108,6 @@ 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 indent = - let unit_spaces = 2 in - fun n -> - String.make (n * unit_spaces) ' ' - let lexbuf_set_filename lb filename : unit = @@ -156,7 +121,7 @@ let lexbuf_create ~filename ~code = 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 () = @@ -164,113 +129,104 @@ let pass_lexing ~fake_filename ~code (* 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) | _ -> " " ))) @@ -357,14 +313,13 @@ let run tests = ); ); 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 ())