Define (some) semantic errors
[tiger.ml.git] / compiler / src / lib / tiger / tiger_test.ml
1 (*
2 * code |> pass_a_exe |> pass_a_out |> ... |> pass_z_exe |> pass_z_out
3 *
4 * pass a:
5 * exe: OK
6 * out: n/a
7 * pass b:
8 * exe: OK
9 * out: OK
10 * pass c:
11 * exe: OK
12 * out: ERROR
13 * ...
14 *
15 * name | pass a | ... | pass z
16 * ---------+--------+-----+--------
17 * exe foo | OK | ... | OK
18 * out foo | OK | ... | ERROR
19 *
20 * *)
21
22 open Printf
23
24 module List = ListLabels
25 module String = StringLabels
26
27 module Option : sig
28 type 'a t = 'a option
29
30 val map : 'a t -> ('a -> 'b) -> 'b t
31 end = struct
32 type 'a t = 'a option
33
34 let map t f =
35 match t with
36 | None -> None
37 | Some x -> Some (f x)
38 end
39
40 type t =
41 { name : string
42 ; code : string
43 ; out_lexing : (Tiger_parser.token list) option
44 ; out_parsing : Tiger_absyn.t option
45 }
46
47 type color =
48 | Red
49 | Yellow
50 | Green
51
52
53 let color_to_ansi_code = function
54 | Red -> "\027[0;31m"
55 | Yellow -> "\027[0;33m"
56 | Green -> "\027[0;32m"
57
58 let color color string =
59 let color_on = color_to_ansi_code color in
60 let color_off = "\027[0m" in
61 sprintf "%s%s%s" color_on string color_off
62
63 let case ?(out_lexing) ?(out_parsing) ~code name =
64 { name
65 ; code
66 ; out_lexing
67 ; out_parsing
68 }
69
70 let bar_sep = String.make 80 '-'
71 let bar_end = String.make 80 '='
72
73 let indent =
74 let unit_spaces = 2 in
75 fun n ->
76 String.make (n * unit_spaces) ' '
77
78 let pass_lexing code : (Tiger_parser.token list, string) result =
79 let lexbuf = Lexing.from_string code in
80 let rec tokens () =
81 let token = Tiger_lexer.token lexbuf in
82 (* Avoiding fragile pattern-matching *)
83 if token = Tiger_parser.EOF then [] else token :: tokens ()
84 in
85 match tokens () with
86 | exception e -> Error (Printexc.to_string e)
87 | tokens -> Ok tokens
88
89 let pass_parsing code =
90 let lb = Lexing.from_string code in
91 match Tiger_parser.program Tiger_lexer.token lb with
92 | exception Parsing.Parse_error ->
93 let module L = Lexing in
94 let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
95 let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
96 Error msg
97 | ast ->
98 Ok ast
99
100 let s = sprintf
101 let p = printf
102 let p_ln = print_newline
103 let p_indent n = p "%s" (indent n)
104
105 let run tests =
106 let error_count = ref 0 in
107 let run_pass f input output : string * string =
108 match f input with
109 | exception e ->
110 incr error_count;
111 ( s "%s: %s" (color Red "ERROR") (Printexc.to_string e)
112 , "n/a"
113 )
114 | Error msg ->
115 incr error_count;
116 ( s "%s: %s" (color Red "ERROR") msg
117 , "n/a"
118 )
119 | Ok produced ->
120 let exe = s "%s" (color Green "OK") in
121 let out =
122 match
123 Option.map output (fun expected -> expected = produced)
124 with
125 | None ->
126 s "%s" (color Yellow "n/a")
127 | Some true ->
128 s "%s" (color Green "OK")
129 | Some false ->
130 incr error_count;
131 s "%s" (color Red "ERROR")
132 in
133 (exe, out)
134 in
135 List.iter tests ~f:(
136 fun {name; code; out_lexing; out_parsing} ->
137 let ( lexing_exe, lexing_out) = run_pass pass_lexing code out_lexing in
138 let (parsing_exe, parsing_out) = run_pass pass_parsing code out_parsing in
139 p "%s" bar_sep; p_ln ();
140 p "Test: %S" name; p_ln ();
141 p_indent 1; p "Lexing:"; p_ln ();
142 p_indent 2; p "exe: %s" lexing_exe; p_ln ();
143 p_indent 2; p "out: %s" lexing_out; p_ln ();
144 p_indent 1; p "Parsing:"; p_ln ();
145 p_indent 2; p "exe: %s" parsing_exe; p_ln ();
146 p_indent 2; p "out: %s" parsing_out; p_ln ();
147 );
148 p "%s" bar_end; p_ln ();
149 let failures = !error_count in
150 let clr = (if failures = 0 then Green else Red) in
151 p "Failures: %s" (color clr (string_of_int failures)); p_ln ();
152 p "%s" bar_end; p_ln ();
153 exit failures
This page took 0.122131 seconds and 5 git commands to generate.