X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=fdfa989250ac48675ab8da5209fd30c5786ed0d2;hb=753f38382d7a2952c23521fd6c75093c8bd63199;hp=e54f1600bbdf74f1bf05186b3f64c9e5ad22bad9;hpb=38ffcb1fc99ecb7a48097cbcf97b9a3062c8bfa0;p=tiger.ml.git diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml index e54f160..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 = @@ -46,42 +37,61 @@ type t = ; code : string ; out_lexing : (Tiger_parser.token list) option ; out_parsing : Tiger_absyn.t option + ; is_error_expected_parsing : (Tiger_error.t -> bool) option ; is_error_expected_semant : (Tiger_error.t -> bool) option } +type status = + | Pass + | Fail + | Skip + +type 'a t_result = + { exe_stat : status + ; exe_msg : string + ; out_stat : status + ; out_val : 'a option + ; out_msg : string + } + type color = | Red - | Yellow - | Green + | Red_bold + | Green_bold + | Grey_bold let color_to_ansi_code = function - | Red -> "\027[0;31m" - | Yellow -> "\027[0;33m" - | Green -> "\027[0;32m" + | Grey_bold -> "\027[1;30m" + | Red -> "\027[0;31m" + | Red_bold -> "\027[1;31m" + | Green_bold -> "\027[1;32m" + +let color_off = "\027[0m" 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 status indicator info = - match info with - | "" -> indicator - | _ -> sprintf "%s: %s" indicator info - -let status_pass ?(info="") () = - status (color Green "Pass") info +let color_opt str = function + | Some c -> (color_to_ansi_code c) ^ str ^ color_off + | None -> str -let status_fail ?(info="") () = - status (color Red "Fail") info +let status_to_color = function + | Pass -> Some Green_bold + | Fail -> Some Red_bold + | Skip -> Some Grey_bold -let status_skip ?(info="") () = - status (color Yellow "Skip") info +let status_to_str = function + (* Expected to be a single character, but using string to allow unicode. *) + | Pass -> "✓" + | Fail -> "X" + | Skip -> "-" let case ?(out_lexing=None) ?(out_parsing=None) + ?(is_error_expected_parsing=None) ?(is_error_expected_semant=None) ~code name @@ -90,16 +100,13 @@ let case ; code ; out_lexing ; out_parsing + ; is_error_expected_parsing ; is_error_expected_semant } -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 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 lexbuf_set_filename lb filename : unit @@ -114,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 () = @@ -122,138 +129,197 @@ 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_opt : Tiger_absyn.t option) -: (unit, string) result +let pass_semant (absyn : Tiger_absyn.t) +: unit = - match absyn_opt with - | None -> - Error "AST not provided" - | Some absyn -> - 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 ~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 = - let failure_count = ref 0 in + Printexc.record_backtrace true; + 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 - let output_status = "n/a" in - let output_value = None in - 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 failure_count; - status_fail () ~info:(Tiger_error.to_string e) - | e -> - incr failure_count; - status_fail () ~info:(Printexc.to_string e) - ) - in - ( execution_status - , output_status - , output_value - ) - | Error info -> - incr failure_count; - ( status_fail ~info () - , output_status - , output_value - ) - | Ok produced -> - let execution_status = status_pass () in - let output_status = + 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 = "" + } + | `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 = "" + } + | `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 -> - status_skip () ~info:"expected output not provided" + (Skip, "expected output not provided") | Some true -> - status_pass () + (Pass, "") | Some false -> - incr failure_count; - status_fail () + (* TODO pretty print expected and output *) + (fail (), "unexpected output") in - let output_value = Some produced in - (execution_status, output_status, output_value) + { exe_stat = Pass + ; exe_msg = "" (* old "info" goes here *) + ; out_stat + ; out_val = Some output + ; out_msg + } + ) in let test_case_count = ref 0 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 ~sep:"" (List.init ~len:width ~f:(function + | 0 -> " " + | 1 -> bar_vert + | 2 -> " " + | 3 -> color_opt (status_to_str exe) (status_to_color exe) + | 4 -> color_opt (status_to_str out) (status_to_color out) + | _ -> " " + ))) + + in + p "%s" bar_horiz_major; p_ln (); + p "%s" (str_exact "Test case" col_1_width); + List.iter ~f:(fun header -> p " %s %s" bar_vert header) + [ "Lexing" + ; "Parsing" + ; "Semant" + ]; + p_ln (); + p "%s" bar_horiz_major; p_ln (); List.iter tests ~f:( fun { name ; code ; out_lexing ; out_parsing + ; is_error_expected_parsing ; is_error_expected_semant } -> incr test_case_count; - let (stat_lex_exe, stat_lex_out_cmp, _) = + let res_lex = run_pass ~f:(fun () -> pass_lexing ~fake_filename:name ~code) ~expect_output:out_lexing ~is_error_expected:None in - let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) = + let res_pars = run_pass ~f:(fun () -> pass_parsing ~fake_filename:name ~code) ~expect_output:out_parsing - ~is_error_expected:None + ~is_error_expected:is_error_expected_parsing in - let (stat_semant_exe, stat_semant_out_cmp, _) = - run_pass - ~f:(fun () -> pass_semant absyn_opt) - ~expect_output:(Some ()) - ~is_error_expected:is_error_expected_semant + let res_sem = + (* TODO: Replace this hack with general test-dependency checking *) + match res_pars.out_val with + | None -> + { exe_stat = Skip + ; exe_msg = "No AST provided" + ; out_stat = Skip + ; out_val = None + ; out_msg = "" + } + | Some absyn -> + run_pass + ~f:(fun () -> pass_semant absyn) + ~expect_output:(Some ()) + ~is_error_expected:is_error_expected_semant 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" stat_lex_exe ; p_ln (); - p_indent 2; p "out: %s" stat_lex_out_cmp; p_ln (); - p_indent 1; p "Parsing:"; p_ln (); - p_indent 2; p "exe: %s" stat_pars_exe ; p_ln (); - p_indent 2; p "out: %s" stat_pars_out_cmp; p_ln (); - p_indent 1; p "Semantic Analysis:"; p_ln (); - p_indent 2; p "exe: %s" stat_semant_exe ; p_ln (); - p_indent 2; p "out: %s" stat_semant_out_cmp; p_ln (); - ); - p "%s" bar_end; p_ln (); - p "%s" - ( let info = - s "%d failures in %d test cases" !failure_count !test_case_count + let results = + (* Replacing out_val for type compatibility *) + [ "Lexing" , {res_lex with out_val = None} + ; "Parsing" , {res_pars with out_val = None} + ; "Semant" , {res_sem with out_val = None} + ] in - match !failure_count with - | 0 -> status_pass () ~info - | _ -> status_fail () ~info - ); + if !test_case_count > 1 then (p "%s" bar_horiz_minor; p_ln ()); + p "%s" (str_exact name col_1_width); + List.iter results ~f:(fun (stage, {exe_stat=e; out_stat=o; _}) -> + p_stat ((String.length stage) + 3) (e, o) + ); + p_ln (); + let printed_error = ref false in + List.iter results ~f:( + fun (stage, {exe_stat; exe_msg; out_stat; out_msg; _}) -> + (match exe_stat with + | Pass -> () + | Skip -> () + | Fail -> + printed_error := true; + p "%s: %s" (color Grey_bold stage) (color Red exe_msg); + p_ln () + ); + (match out_stat with + | Pass -> () + | Skip -> () + | Fail -> + printed_error := true; + p "%s: %s" (color Grey_bold stage) (color Red out_msg) + ); + ); + ); + p "%s" bar_horiz_major; p_ln (); + 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_end; p_ln (); - exit !failure_count + p "%s" bar_horiz_major; p_ln (); + exit (fail_count ())