X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_test.ml;h=fe84ef8bc215ad04e8b7826b52e0f0cc07cf67f8;hb=8e47ed20c781e65940089e6f71e9a8ac6ea27d73;hp=47939dfc2f3c1dbbc685bd37f734c9ba2e6c0b7f;hpb=b53d50d3d7395376979b6fb90863901b5dd69cfe;p=tiger.ml.git diff --git a/compiler/src/lib/tiger/tiger_test.ml b/compiler/src/lib/tiger/tiger_test.ml index 47939df..fe84ef8 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,6 +47,7 @@ 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 } @@ -65,8 +67,6 @@ type 'a t_result = type color = | Red | Red_bold - | Yellow - | Green | Green_bold | Grey_bold @@ -75,8 +75,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" @@ -85,7 +83,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 @@ -100,26 +98,10 @@ 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) + ?(is_error_expected_parsing=None) ?(is_error_expected_semant=None) ~code name @@ -128,6 +110,7 @@ let case ; code ; out_lexing ; out_parsing + ; is_error_expected_parsing ; is_error_expected_semant } @@ -135,11 +118,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 = @@ -178,19 +156,15 @@ 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 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 @@ -198,7 +172,6 @@ let str_exact str exact = 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; @@ -261,17 +234,16 @@ let run tests = in let test_case_count = ref 0 in let col_1_width = 25 in - let col_i_width = 10 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) | _ -> " " ))) @@ -291,6 +263,7 @@ let run tests = ; code ; out_lexing ; out_parsing + ; is_error_expected_parsing ; is_error_expected_semant } -> @@ -305,13 +278,23 @@ let run tests = 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 res_sem = - run_pass - ~f:(fun () -> pass_semant res_pars.out_val) - ~expect_output:(Some ()) - ~is_error_expected:is_error_expected_semant + (* 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 *) @@ -347,14 +330,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 !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_horiz_major; p_ln (); exit !count_fail_all