X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=038cd84c5323b459ebfb81757c41981dbadb4807;hb=d5517328dcf93c5bd74f1895262e47b70d2e4313;hp=0ee46d2ae5060c3f0bea7f8b372160b918c474c7;hpb=f5fc22dd6a095ad3787283f1f18c410444e441cc;p=tiger.ml.git diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml index 0ee46d2..038cd84 100644 --- a/compiler/src/lib/tiger/tiger_test.ml +++ b/compiler/src/lib/tiger/tiger_test.ml @@ -21,6 +21,7 @@ * out foo | OK | ... | ERROR * * *) +(* TODO: Perhaps a global option whether to print non-fail info? *) open Printf @@ -46,45 +47,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 - -(* TODO: Perhaps a global option whether to print non-fail 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="") () = - (*let indicator = (color Yellow "Skip") in*) - let indicator = "Skip" in - status indicator 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 @@ -93,16 +110,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 @@ -142,121 +156,187 @@ let pass_parsing ~fake_filename ~code | ast -> Ok ast -let pass_semant (absyn_opt : Tiger_absyn.t option) +let pass_semant (absyn : Tiger_absyn.t) : (unit, string) result = - match absyn_opt with - | None -> - Error "AST not provided" - | Some absyn -> - Ok (Tiger_semant.transProg absyn) + Ok (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 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 count_fail_all = ref 0 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 = + let backtrace = Printexc.get_backtrace () in + let (exe_stat, exe_msg) = (match e with | Tiger_error.T e when is_error_expected e -> - status_pass () (*~info:(Tiger_error.to_string e)*) + (Pass, (Tiger_error.to_string e)) | Tiger_error.T e -> - incr failure_count; - status_fail () ~info:(Tiger_error.to_string e) + incr count_fail_all; + (Fail, (Tiger_error.to_string e)) | e -> - incr failure_count; - status_fail () ~info:(Printexc.to_string e) + incr count_fail_all; + (Fail, (Printexc.to_string e)) ) in - ( execution_status - , output_status - , output_value - ) + { exe_stat + ; exe_msg = s "\n\tException: %s.\n\tBacktrace: %s" exe_msg backtrace + ; out_stat = Skip + ; out_val = None + ; out_msg = "" (* old "info" goes here *) + } | Error info -> - incr failure_count; - ( status_fail ~info () - , output_status - , output_value - ) + incr count_fail_all; + { exe_stat = Fail + ; exe_msg = info + ; out_stat = Skip + ; out_val = None + ; out_msg = "" (* old "info" goes here *) + } | Ok produced -> - let execution_status = status_pass () in - let output_status = + let (out_stat, out_msg) = match Option.map expect_output (fun expected -> expected = produced) 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 () + incr count_fail_all; + (* TODO pretty print expected and produced *) + (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 produced + ; 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 !count_fail_all with + | 0 -> color_opt (status_to_str Pass) (status_to_color Pass) + | _ -> color_opt (status_to_str Fail) (status_to_color Fail) + ) + !count_fail_all + !test_case_count; p_ln (); - p "%s" bar_end; p_ln (); - exit !failure_count + p "%s" bar_horiz_major; p_ln (); + exit !count_fail_all