[tiger.ml.git] / compiler / src / exe / tiger_tests.ml

(*
 * 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

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 Test : sig
  type t

  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 =
  let code =
    "\
    /* A program to solve the 8-queens problem */ \n\
 \n\
    let \n\
      var N := 8 \n\
 \n\
      type intArray = array of int \n\
 \n\
      var row := intArray [ N ] of 0 \n\
      var col := intArray [ N ] of 0 \n\
      var diag1 := intArray [N+N-1] of 0 \n\
      var diag2 := intArray [N+N-1] of 0 \n\
 \n\
      function printboard() = ( \n\
        for i := 0 to N-1 do ( \n\
          for j := 0 to N-1 do print(if col[i]=j then \" O\" else \" .\"); \n\
          print(\"\n\") \n\
        ); \n\
        print(\"\n\") \n\
      ) \n\
 \n\
      function try(c:int) = ( \n\
        /*  for i:= 0 to c do print(\".\"); print(\"\n\"); flush();*/ \n\
        if c=N \n\
        then printboard() \n\
        else \n\
          for r := 0 to N-1 \n\
          do \n\
            if row[r]=0 & diag1[r+c]=0 & diag2[r+7-c]=0 \n\
            then ( \n\
              row[r]       := 1; \n\
              diag1[r+c]   := 1; \n\
              diag2[r+7-c] := 1; \n\
              col[c]       := r; \n\
              try(c+1); \n\
              row[r]       := 0; \n\
              diag1[r+c]   := 0; \n\
              diag2[r+7-c] := 0 \n\
            ) \n\
      ) \n\
    in \n\
      try(0) \n\
    end \n\
    "
  in
  (code, code, [])
*)

let tests_micro_cases =
  let open Tiger.Parser in
  [ 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]

  ; Test.case "abc[0] := foo()" ~code:"abc[0] := foo()" ~out_lexing:
      [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN]

  ; Test.case "abc [5] of nil" ~code:"abc [5] of nil" ~out_lexing:
      [ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL]

  ; 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]
  ]

let tests =
  test_cases_from_book  @ tests_micro_cases 

let () =
  Test.run tests
Commit	Line	Data
f752b2c7 SK	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
543d3420 SK	22	open Printf
543d3420 SK	23
78c9eca5	24	module List = ListLabels
f752b2c7	25	module String = StringLabels
78c9eca5	26
f752b2c7 SK	27	module Option : sig
f752b2c7 SK	28	type 'a t = 'a option
8543fc37	29
f752b2c7 SK	30	val map : 'a t -> ('a -> 'b) -> 'b t
	31	end = struct
	32	type 'a t = 'a option
8543fc37	33
f752b2c7 SK	34	let map t f =
	35	match t with
	36	\| None -> None
	37	\| Some x -> Some (f x)
	38	end
78c9eca5	39
f752b2c7 SK	40	module Test : sig
f752b2c7 SK	41	type t
1946b457	42
f752b2c7 SK	43	val case
	44	: ?out_lexing : Tiger.Parser.token list
	45	-> ?out_parsing : Tiger.Absyn.t
	46	-> code : string
	47	-> string
	48	-> t
	49
	50	val run : t list -> unit
	51	end = struct
	52	type t =
	53	{ name : string
	54	; code : string
	55	; out_lexing : (Tiger.Parser.token list) option
	56	; out_parsing : Tiger.Absyn.t option
	57	}
	58
	59	type color =
	60	\| Red
	61	\| Yellow
	62	\| Green
	63
	64
	65	let color_to_ansi_code = function
	66	\| Red -> "\027[0;31m"
	67	\| Yellow -> "\027[0;33m"
	68	\| Green -> "\027[0;32m"
	69
	70	let color color string =
	71	let color_on = color_to_ansi_code color in
	72	let color_off = "\027[0m" in
	73	sprintf "%s%s%s" color_on string color_off
	74
	75	let case ?(out_lexing) ?(out_parsing) ~code name =
	76	{ name
	77	; code
	78	; out_lexing
	79	; out_parsing
	80	}
	81
	82	let bar_sep = String.make 80 '-'
	83	let bar_end = String.make 80 '='
	84
	85	let indent =
	86	let unit_spaces = 2 in
	87	fun n ->
	88	String.make (n * unit_spaces) ' '
	89
	90	let pass_lexing code : (Tiger.Parser.token list, string) result =
	91	let lexbuf = Lexing.from_string code in
	92	let rec tokens () =
	93	let token = Tiger.Lexer.token lexbuf in
	94	(* Avoiding fragile pattern-matching *)
	95	if token = Tiger.Parser.EOF then [] else token :: tokens ()
	96	in
	97	match tokens () with
	98	\| exception e -> Error (Printexc.to_string e)
	99	\| tokens -> Ok tokens
	100
	101	let pass_parsing code =
	102	let lb = Lexing.from_string code in
	103	match Tiger.Parser.program Tiger.Lexer.token lb with
	104	\| exception Parsing.Parse_error ->
	105	let module L = Lexing in
	106	let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in
107	let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in
108	Error msg
109	\| ast ->
110	Ok ast
111
112	let s = sprintf
113	let p = printf
114	let p_ln = print_newline
115	let p_indent n = p "%s" (indent n)
116
117	let run tests =
118	let error_count = ref 0 in
119	let run_pass f input output : string * string =
120	match f input with
121	\| exception e ->
122	incr error_count;
123	( s "%s: %s" (color Red "ERROR") (Printexc.to_string e)
124	, "n/a"
125	)
126	\| Error msg ->
127	incr error_count;
128	( s "%s: %s" (color Red "ERROR") msg
129	, "n/a"
130	)
131	\| Ok produced ->
132	let exe = s "%s" (color Green "OK") in
133	let out =
134	match
135	Option.map output (fun expected -> expected = produced)
136	with
137	\| None ->
138	s "%s" (color Yellow "n/a")
139	\| Some true ->
140	s "%s" (color Green "OK")
141	\| Some false ->
142	incr error_count;
143	s "%s" (color Red "ERROR")
144	in
145	(exe, out)
146	in
147	List.iter tests ~f:(
148	fun {name; code; out_lexing; out_parsing} ->
149	let ( lexing_exe, lexing_out) = run_pass pass_lexing code out_lexing in
150	let (parsing_exe, parsing_out) = run_pass pass_parsing code out_parsing in
151	p "%s" bar_sep; p_ln ();
152	p "Test: %S" name; p_ln ();
153	p_indent 1; p "Lexing:"; p_ln ();
154	p_indent 2; p "exe: %s" lexing_exe; p_ln ();
155	p_indent 2; p "out: %s" lexing_out; p_ln ();
156	p_indent 1; p "Parsing:"; p_ln ();
157	p_indent 2; p "exe: %s" parsing_exe; p_ln ();
158	p_indent 2; p "out: %s" parsing_out; p_ln ();
159	);
160	p "%s" bar_end; p_ln ();
161	exit !error_count
162	end
163
164	let test_cases_from_book =
165	[ Test.case
166	"Book test 1: an array type and an array variable"
167	~code:
168	" \
169	/* an array type and an array variable */ \
170	let \
171	type arrtype = array of int \
172	var arr1:arrtype := \
173	arrtype [10] of 0 \
174	in \
175	arr1 \
176	end \
177	"
178	~out_lexing:(
179	let open Tiger.Parser in
180	[ LET;
181	TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "int";
182	VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN;
183	ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0;
184	IN;
185	ID "arr1";
186	END
187	]
188	)
189	; Test.case
190	"Book test 2: arr1 is valid since expression 0 is int = myint"
191	~code:
192	" \
193	/* arr1 is valid since expression 0 is int = myint */ \
194	let \
195	type myint = int \
196	type arrtype = array of myint \
197	var arr1:arrtype := \
198	arrtype [10] of 0 \
199	in \
200	arr1 \
201	end \
202	"
203	~out_lexing:(
204	let open Tiger.Parser in
205	[ LET;
206	TYPE; ID "myint"; EQ; ID "int";
207	TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "myint";
208	VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN;
209	ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0;
210	IN;
211	ID "arr1";
212	END
213	]
214	)
215	; Test.case
216	"Book test 3: a record type and a record variable"
217	~code:
218	" \
219	/* a record type and a record variable */ \
220	let \
221	type rectype = \
222	{ name : string \
223	, age : int \
224	} \
225	var rec1 : rectype := \
226	rectype \
227	{ name = \"Nobody\" \
228	, age = 1000 \
229	} \
230	in \
231	rec1.name := \"Somebody\"; \
232	rec1 \
233	end \
234	"
235	~out_lexing:(
236	let open Tiger.Parser in
237	[ LET;
238	TYPE; ID "rectype"; EQ;
239	LBRACE; ID "name"; COLON; ID "string";
240	COMMA; ID "age"; COLON; ID "int";
241	RBRACE;
242	VAR; ID "rec1"; COLON; ID "rectype"; ASSIGN;
243	ID "rectype";
244	LBRACE; ID "name"; EQ; STRING "Nobody";
245	COMMA; ID "age"; EQ; INT 1000;
246	RBRACE;
247	IN;
248	ID "rec1"; DOT; ID "name"; ASSIGN; STRING "Somebody"; SEMICOLON;
249	ID "rec1";
250	END
251	]
252	)
253	; Test.case
254	"Book test 4: define a recursive function"
255	~code:
256	" \
257	/* define a recursive function */ \
258	let \
259	\
260	/* calculate n! */ \
261	function nfactor(n: int): int = \
262	if n = 0 \
263	then 1 \
264	else n * nfactor(n-1) \
265	\
266	in \
267	nfactor(10) \
268	end \
269	"
270	~out_lexing:(
271	let open Tiger.Parser in
272	[ LET;
273	FUNCTION; ID "nfactor"; LPAREN; ID "n"; COLON; ID "int"; RPAREN; COLON; ID "int"; EQ;
274	IF; ID "n"; EQ; INT 0;
275	THEN; INT 1;
276	ELSE; ID "n"; TIMES; ID "nfactor"; LPAREN; ID "n"; MINUS; INT 1; RPAREN;
277	IN;
278	ID "nfactor"; LPAREN; INT 10; RPAREN;
279	END
280	]
281	)
282	; Test.case
283	"Book test 9: error : types of then - else differ"
284	~code:
285	" \
286	/* error : types of then - else differ */ \
287	if (5>4) then 13 else \" \" \
288	"
289	~out_lexing:(
290	let open Tiger.Parser in
291	[ IF; LPAREN; INT 5; GT; INT 4; RPAREN; THEN; INT 13; ELSE; STRING " "
292	]
293	)
294	]
cb00a20d	295
15ade902	296	(*
68a223c2	297	let test_case_from_book_queens =
82e73e6c	298	let code =
68a223c2	299	"\
82e73e6c SK	300	/* A program to solve the 8-queens problem */ \n\
	301	\n\
	302	let \n\
	303	var N := 8 \n\
	304	\n\
	305	type intArray = array of int \n\
	306	\n\
	307	var row := intArray [ N ] of 0 \n\
	308	var col := intArray [ N ] of 0 \n\
	309	var diag1 := intArray [N+N-1] of 0 \n\
	310	var diag2 := intArray [N+N-1] of 0 \n\
	311	\n\
	312	function printboard() = ( \n\
	313	for i := 0 to N-1 do ( \n\
	314	for j := 0 to N-1 do print(if col[i]=j then \" O\" else \" .\"); \n\
	315	print(\"\n\") \n\
	316	); \n\
	317	print(\"\n\") \n\
	318	) \n\
	319	\n\
	320	function try(c:int) = ( \n\
	321	/* for i:= 0 to c do print(\".\"); print(\"\n\"); flush();*/ \n\
	322	if c=N \n\
	323	then printboard() \n\
	324	else \n\
	325	for r := 0 to N-1 \n\
	326	do \n\
	327	if row[r]=0 & diag1[r+c]=0 & diag2[r+7-c]=0 \n\
	328	then ( \n\
	329	row[r] := 1; \n\
	330	diag1[r+c] := 1; \n\
	331	diag2[r+7-c] := 1; \n\
	332	col[c] := r; \n\
	333	try(c+1); \n\
	334	row[r] := 0; \n\
	335	diag1[r+c] := 0; \n\
	336	diag2[r+7-c] := 0 \n\
	337	) \n\
	338	) \n\
	339	in \n\
	340	try(0) \n\
	341	end \n\
	342	"
	343	in
	344	(code, code, [])
15ade902	345	*)
82e73e6c	346
68a223c2 SK	347	let tests_micro_cases =
68a223c2 SK	348	let open Tiger.Parser in
f752b2c7 SK	349	[ Test.case "nil" ~code:"nil" ~out_lexing:[NIL]
	350	; Test.case "5" ~code:"5" ~out_lexing:[INT 5]
	351	; Test.case "-5" ~code:"-5" ~out_lexing:[MINUS; INT 5]
	352	; Test.case "f()" ~code:"f()" ~out_lexing:[ID "f"; LPAREN; RPAREN]
	353	; Test.case "abc.i" ~code:"abc.i" ~out_lexing:[ID "abc"; DOT; ID "i"]
	354	; Test.case "abc[0]" ~code:"abc[0]" ~out_lexing:[ID "abc"; LBRACK; INT 0; RBRACK]
78c9eca5	355
f752b2c7 SK	356	; Test.case "abc[0] := foo()" ~code:"abc[0] := foo()" ~out_lexing:
f752b2c7 SK	357	[ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN]
68a223c2	358
f752b2c7 SK	359	; Test.case "abc [5] of nil" ~code:"abc [5] of nil" ~out_lexing:
f752b2c7 SK	360	[ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL]
543d3420	361
f752b2c7 SK	362	; Test.case "f(\"a\", 3, foo)" ~code:"f(\"a\", 3, foo)" ~out_lexing:
	363	[ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN]
	364	]
543d3420	365
f752b2c7 SK	366	let tests =
f752b2c7 SK	367	test_cases_from_book @ tests_micro_cases
543d3420	368
f752b2c7 SK	369	let () =
f752b2c7 SK	370	Test.run tests