X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=fdfa989250ac48675ab8da5209fd30c5786ed0d2;hb=753f38382d7a2952c23521fd6c75093c8bd63199;hp=12ddb227ccfd2c2b270d0d27033ff5f9fef804bf;hpb=9949f15ba89b08c877b64e7f1d16e53cacc2999b;p=tiger.ml.git diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml index 12ddb22..fdfa989 100644 --- a/compiler/src/lib/tiger/tiger_test.ml +++ b/compiler/src/lib/tiger/tiger_test.ml @@ -21,67 +21,78 @@ * 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 = { name : string ; code : string ; out_lexing : (Tiger_parser.token list) option ; out_parsing : Tiger_absyn.t option - ; is_error_expected : (Tiger_error.t -> bool) + ; 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) - ?(out_parsing) - ?(is_error_expected=(fun _ -> false)) + ?(out_lexing=None) + ?(out_parsing=None) + ?(is_error_expected_parsing=None) + ?(is_error_expected_semant=None) ~code name = @@ -89,135 +100,226 @@ let case ; code ; out_lexing ; out_parsing - ; is_error_expected + ; is_error_expected_parsing + ; is_error_expected_semant } -let bar_sep = String.make 80 '-' -let bar_end = String.make 80 '=' +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 += + let Lexing.({lex_start_p; lex_curr_p; _}) = lb in + lb.Lexing.lex_start_p <- {lex_start_p with Lexing.pos_fname = filename}; + lb.Lexing.lex_curr_p <- {lex_curr_p with Lexing.pos_fname = filename} -let pass_lexing code : (Tiger_parser.token list, string) result = - let lexbuf = Lexing.from_string code in +let lexbuf_create ~filename ~code = + let lb = Lexing.from_string code in + lexbuf_set_filename lb filename; + lb + +let pass_lexing ~fake_filename ~code +: Tiger_parser.token list += + let lexbuf = lexbuf_create ~filename:fake_filename ~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 + tokens () -let pass_parsing code : (Tiger_absyn.t, string) result = - 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 pass_semant (absyn_opt : Tiger_absyn.t option) : (unit, string) result = - match absyn_opt with - | None -> - Error "AST not provided" - | Some absyn -> - Ok (Tiger_semant.transProg absyn) +let pass_parsing ~fake_filename ~code +: Tiger_absyn.t += + Tiger_parser.program + Tiger_lexer.token + (lexbuf_create ~filename:fake_filename ~code) + +let pass_semant (absyn : Tiger_absyn.t) +: unit += + 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 error_count = ref 0 in - let run_pass ~f ~input ~expect_output ~is_error_expected = - let output_status = "n/a" in - let output_value = None in - match f input 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 error_count; - status_fail () ~info:(Tiger_error.to_string e) - | e -> - incr error_count; - status_fail () ~info:(Printexc.to_string e) - ) - in - ( execution_status - , output_status - , output_value - ) - | Error info -> - incr error_count; - ( status_fail ~info () - , output_status - , output_value - ) - | Ok produced -> - let execution_status = status_pass () in - let output_status = + 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 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 error_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} -> - let (stat_lex_exe, stat_lex_out_cmp, _) = + fun + { name + ; code + ; out_lexing + ; out_parsing + ; is_error_expected_parsing + ; is_error_expected_semant + } + -> + incr test_case_count; + let res_lex = run_pass - ~f:pass_lexing - ~input:code + ~f:(fun () -> pass_lexing ~fake_filename:name ~code) ~expect_output:out_lexing - ~is_error_expected + ~is_error_expected:None in - let (stat_pars_exe, stat_pars_out_cmp, absyn_opt) = + let res_pars = run_pass - ~f:pass_parsing - ~input:code + ~f:(fun () -> pass_parsing ~fake_filename:name ~code) ~expect_output:out_parsing - ~is_error_expected + ~is_error_expected:is_error_expected_parsing in - let (stat_semant_exe, stat_semant_out_cmp, _) = - run_pass - ~f:pass_semant - ~input:absyn_opt - ~expect_output:(Some ()) - ~is_error_expected + 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 + 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 - 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 (); + 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_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 + 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_horiz_major; p_ln (); + exit (fail_count ())