From: Siraaj Khandkar Date: Sun, 3 Jun 2018 18:02:57 +0000 (-0400) Subject: Refactor testing framework X-Git-Url: https://git.xandkar.net/?p=tiger.ml.git;a=commitdiff_plain;h=f752b2c7bc4dbc50500f3590c45e9db7f4c96263 Refactor testing framework --- diff --git a/compiler/src/exe/tiger_tests.ml b/compiler/src/exe/tiger_tests.ml index e22a046..a14aac3 100644 --- a/compiler/src/exe/tiger_tests.ml +++ b/compiler/src/exe/tiger_tests.ml @@ -1,151 +1,297 @@ +(* + * code |> pass_a_exe |> pass_a_out |> ... |> pass_z_exe |> pass_z_out + * + * pass a: + * exe: OK + * out: n/a + * pass b: + * exe: OK + * out: OK + * pass c: + * exe: OK + * out: ERROR + * ... + * + * name | pass a | ... | pass z + * ---------+--------+-----+-------- + * exe foo | OK | ... | OK + * out foo | OK | ... | ERROR + * + * *) + open Printf module List = ListLabels +module String = StringLabels -let test_case_from_book_01 = - let name = "an array type and an array variable" in - let code = - " \ - /* "^name^" */ \ - let \ - type arrtype = array of int \ - var arr1:arrtype := \ - arrtype [10] of 0 \ - in \ - arr1 \ - end \ - " - in - let tokens = - let open Tiger.Parser in - [ LET; - TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "int"; - VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; - ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; - IN; - ID "arr1"; - END - ] - in - (name, code, tokens) +module Option : sig + type 'a t = 'a option -let test_case_from_book_02 = - let name = "arr1 is valid since expression 0 is int = myint" in - let code = - " \ - /* "^name^" */ \ - let \ - type myint = int \ - type arrtype = array of myint \ - var arr1:arrtype := \ - arrtype [10] of 0 \ - in \ - arr1 \ - end \ - " - in - let tokens = - let open Tiger.Parser in - [ LET; - TYPE; ID "myint"; EQ; ID "int"; - TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "myint"; - VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; - ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; - IN; - ID "arr1"; - END - ] - in - (name, code, tokens) + val map : 'a t -> ('a -> 'b) -> 'b t +end = struct + type 'a t = 'a option -let test_case_from_book_03 = - let name = "a record type and a record variable" in - let code = - " \ - /* "^name^" */ \ - let \ - type rectype = \ - { name : string \ - , age : int \ - } \ - var rec1 : rectype := \ - rectype \ - { name = \"Nobody\" \ - , age = 1000 \ - } \ - in \ - rec1.name := \"Somebody\"; \ - rec1 \ - end \ - " - in - let tokens = - let open Tiger.Parser in - [ LET; - TYPE; ID "rectype"; EQ; - LBRACE; ID "name"; COLON; ID "string"; - COMMA; ID "age"; COLON; ID "int"; - RBRACE; - VAR; ID "rec1"; COLON; ID "rectype"; ASSIGN; - ID "rectype"; - LBRACE; ID "name"; EQ; STRING "Nobody"; - COMMA; ID "age"; EQ; INT 1000; - RBRACE; - IN; - ID "rec1"; DOT; ID "name"; ASSIGN; STRING "Somebody"; SEMICOLON; - ID "rec1"; - END - ] - in - (name, code, tokens) + let map t f = + match t with + | None -> None + | Some x -> Some (f x) +end -let test_case_from_book_04 = - let name = "define a recursive function" in - let code = - " \ - /* "^name^" */ \ - let \ - \ - /* calculate n! */ \ - function nfactor(n: int): int = \ - if n = 0 \ - then 1 \ - else n * nfactor(n-1) \ - \ - in \ - nfactor(10) \ - end \ - " - in - let tokens = - let open Tiger.Parser in - [ LET; - FUNCTION; ID "nfactor"; LPAREN; ID "n"; COLON; ID "int"; RPAREN; COLON; ID "int"; EQ; - IF; ID "n"; EQ; INT 0; - THEN; INT 1; - ELSE; ID "n"; TIMES; ID "nfactor"; LPAREN; ID "n"; MINUS; INT 1; RPAREN; - IN; - ID "nfactor"; LPAREN; INT 10; RPAREN; - END - ] - in - (name, code, tokens) +module Test : sig + type t -let test_case_from_book_09 = - let name = "error : types of then - else differ" in - let code = - " \ - /* "^name^" */ \ - if (5>4) then 13 else \" \" \ - " - in - let tokens = - let open Tiger.Parser in - [ IF; LPAREN; INT 5; GT; INT 4; RPAREN; THEN; INT 13; ELSE; STRING " " - ] - in - (* TODO: Type error test case *) - (name, code, tokens) + val case + : ?out_lexing : Tiger.Parser.token list + -> ?out_parsing : Tiger.Absyn.t + -> code : string + -> string + -> t + + val run : t list -> unit +end = struct + type t = + { name : string + ; code : string + ; out_lexing : (Tiger.Parser.token list) option + ; out_parsing : Tiger.Absyn.t option + } + + type color = + | Red + | Yellow + | Green + + + let color_to_ansi_code = function + | Red -> "\027[0;31m" + | Yellow -> "\027[0;33m" + | Green -> "\027[0;32m" + + 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 case ?(out_lexing) ?(out_parsing) ~code name = + { name + ; code + ; out_lexing + ; out_parsing + } + + 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 pass_lexing code : (Tiger.Parser.token list, string) result = + let lexbuf = Lexing.from_string 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 + + let pass_parsing code = + 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 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 output : string * string = + match f input with + | exception e -> + incr error_count; + ( s "%s: %s" (color Red "ERROR") (Printexc.to_string e) + , "n/a" + ) + | Error msg -> + incr error_count; + ( s "%s: %s" (color Red "ERROR") msg + , "n/a" + ) + | Ok produced -> + let exe = s "%s" (color Green "OK") in + let out = + match + Option.map output (fun expected -> expected = produced) + with + | None -> + s "%s" (color Yellow "n/a") + | Some true -> + s "%s" (color Green "OK") + | Some false -> + incr error_count; + s "%s" (color Red "ERROR") + in + (exe, out) + in + List.iter tests ~f:( + fun {name; code; out_lexing; out_parsing} -> + let ( lexing_exe, lexing_out) = run_pass pass_lexing code out_lexing in + let (parsing_exe, parsing_out) = run_pass pass_parsing code out_parsing 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" lexing_exe; p_ln (); + p_indent 2; p "out: %s" lexing_out; p_ln (); + p_indent 1; p "Parsing:"; p_ln (); + p_indent 2; p "exe: %s" parsing_exe; p_ln (); + p_indent 2; p "out: %s" parsing_out; p_ln (); + ); + p "%s" bar_end; p_ln (); + exit !error_count +end + +let test_cases_from_book = + [ Test.case + "Book test 1: an array type and an array variable" + ~code: + " \ + /* an array type and an array variable */ \ + let \ + type arrtype = array of int \ + var arr1:arrtype := \ + arrtype [10] of 0 \ + in \ + arr1 \ + end \ + " + ~out_lexing:( + let open Tiger.Parser in + [ LET; + TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "int"; + VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; + ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; + IN; + ID "arr1"; + END + ] + ) + ; Test.case + "Book test 2: arr1 is valid since expression 0 is int = myint" + ~code: + " \ + /* arr1 is valid since expression 0 is int = myint */ \ + let \ + type myint = int \ + type arrtype = array of myint \ + var arr1:arrtype := \ + arrtype [10] of 0 \ + in \ + arr1 \ + end \ + " + ~out_lexing:( + let open Tiger.Parser in + [ LET; + TYPE; ID "myint"; EQ; ID "int"; + TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "myint"; + VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; + ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; + IN; + ID "arr1"; + END + ] + ) + ; Test.case + "Book test 3: a record type and a record variable" + ~code: + " \ + /* a record type and a record variable */ \ + let \ + type rectype = \ + { name : string \ + , age : int \ + } \ + var rec1 : rectype := \ + rectype \ + { name = \"Nobody\" \ + , age = 1000 \ + } \ + in \ + rec1.name := \"Somebody\"; \ + rec1 \ + end \ + " + ~out_lexing:( + let open Tiger.Parser in + [ LET; + TYPE; ID "rectype"; EQ; + LBRACE; ID "name"; COLON; ID "string"; + COMMA; ID "age"; COLON; ID "int"; + RBRACE; + VAR; ID "rec1"; COLON; ID "rectype"; ASSIGN; + ID "rectype"; + LBRACE; ID "name"; EQ; STRING "Nobody"; + COMMA; ID "age"; EQ; INT 1000; + RBRACE; + IN; + ID "rec1"; DOT; ID "name"; ASSIGN; STRING "Somebody"; SEMICOLON; + ID "rec1"; + END + ] + ) + ; Test.case + "Book test 4: define a recursive function" + ~code: + " \ + /* define a recursive function */ \ + let \ + \ + /* calculate n! */ \ + function nfactor(n: int): int = \ + if n = 0 \ + then 1 \ + else n * nfactor(n-1) \ + \ + in \ + nfactor(10) \ + end \ + " + ~out_lexing:( + let open Tiger.Parser in + [ LET; + FUNCTION; ID "nfactor"; LPAREN; ID "n"; COLON; ID "int"; RPAREN; COLON; ID "int"; EQ; + IF; ID "n"; EQ; INT 0; + THEN; INT 1; + ELSE; ID "n"; TIMES; ID "nfactor"; LPAREN; ID "n"; MINUS; INT 1; RPAREN; + IN; + ID "nfactor"; LPAREN; INT 10; RPAREN; + END + ] + ) + ; Test.case + "Book test 9: error : types of then - else differ" + ~code: + " \ + /* error : types of then - else differ */ \ + if (5>4) then 13 else \" \" \ + " + ~out_lexing:( + let open Tiger.Parser in + [ IF; LPAREN; INT 5; GT; INT 4; RPAREN; THEN; INT 13; ELSE; STRING " " + ] + ) + ] (* let test_case_from_book_queens = @@ -198,159 +344,27 @@ let test_case_from_book_queens = (code, code, []) *) -let test_cases_from_book = - [ test_case_from_book_01 - ; test_case_from_book_02 - ; test_case_from_book_03 - ; test_case_from_book_04 - ; test_case_from_book_09 - (*; test_case_from_book_queens*) - ] - let tests_micro_cases = let open Tiger.Parser in - [ ( - let code = - "nil" - in - let tokens = - [NIL] - in - (code, code, tokens) - ) - ; ( - let code = - "5" - in - let tokens = - [INT 5] - in - (code, code, tokens) - ) - ; ( - let code = - "-5" - in - let tokens = - [MINUS; INT 5] - in - (code, code, tokens) - ) - ; ( - let code = - "f()" - in - let tokens = - [ID "f"; LPAREN; RPAREN] - in - (code, code, tokens) - ) - ; ( - let code = - "f(\"a\", 3, foo)" - in - let tokens = - [ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN] - in - (code, code, tokens) - ) - ; ( - let code = - "abc.i" - in - let tokens = - [ID "abc"; DOT; ID "i"] - in - (code, code, tokens) - ) - ; ( - let code = - "abc [5] of nil" - in - let tokens = - [ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL] - in - (code, code, tokens) - ) - ; ( - let code = - "abc[0]" - in - let tokens = - [ID "abc"; LBRACK; INT 0; RBRACK] - in - (code, code, tokens) - ) - ; ( - let code = - "abc[0] := foo()" - in - let tokens = - [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN] - in - (code, code, tokens) - ) - ] + [ Test.case "nil" ~code:"nil" ~out_lexing:[NIL] + ; Test.case "5" ~code:"5" ~out_lexing:[INT 5] + ; Test.case "-5" ~code:"-5" ~out_lexing:[MINUS; INT 5] + ; Test.case "f()" ~code:"f()" ~out_lexing:[ID "f"; LPAREN; RPAREN] + ; Test.case "abc.i" ~code:"abc.i" ~out_lexing:[ID "abc"; DOT; ID "i"] + ; Test.case "abc[0]" ~code:"abc[0]" ~out_lexing:[ID "abc"; LBRACK; INT 0; RBRACK] -let tests = - test_cases_from_book @ tests_micro_cases + ; Test.case "abc[0] := foo()" ~code:"abc[0] := foo()" ~out_lexing: + [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN] -let () = - let tokens_of_code code = - let lexbuf = Lexing.from_string 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 - tokens () - in - let parsetree_of_code code = - 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 - | absyn -> - Ok (Tiger.Absyn.to_string absyn) - ) - in - let bar_sep = String.make 80 '-' in - let bar_end = String.make 80 '=' in - let indent n = String.make (2 * n) ' ' in - let color_on_green = "\027[0;32m" in - let color_on_red = "\027[1;31m" in - let color_off = "\027[0m" in - List.iteri tests ~f:(fun i (name, code, tokens_expected) -> - let i = i + 1 in (* Because iteri starts with 0 *) - printf "%s\n%sTest %d : %S\n" bar_sep (indent 0) i name; + ; Test.case "abc [5] of nil" ~code:"abc [5] of nil" ~out_lexing: + [ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL] - printf "%sLexing : " (indent 1); - let tokens_emitted = tokens_of_code code in - (try - assert (tokens_emitted = tokens_expected); - printf "%sOK%s\n" color_on_green color_off; - with Assert_failure _ -> - let tokens_to_string tokens = - String.concat "; " (List.map ~f:Tiger.Parser_token.to_string tokens) - in - printf - "%sERROR%s\n%sExpected: %s\n%sEmitted : %s\n\n" - color_on_red - color_off - (indent 2) - (tokens_to_string tokens_expected) - (indent 2) - (tokens_to_string tokens_emitted) - ); + ; Test.case "f(\"a\", 3, foo)" ~code:"f(\"a\", 3, foo)" ~out_lexing: + [ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN] + ] - printf "%sParsing: " (indent 1); - (match parsetree_of_code code with - | Error errmsg -> printf "%sERROR:%s %s\n" color_on_red color_off errmsg - | Ok parsetree -> printf "%sOK:%s\n\n%s\n\n" color_on_green color_off parsetree - ); +let tests = + test_cases_from_book @ tests_micro_cases - ); - print_endline bar_end; +let () = + Test.run tests