Use OUnit for the ML test suite.

This commit is contained in:
Olivier 2021-06-29 15:50:18 +02:00
parent 8d89520d61
commit fbeb059436
2 changed files with 64 additions and 61 deletions

View File

@ -7,6 +7,6 @@
(library
(name client)
(libraries pprint inferno)
(libraries pprint ounit2 inferno)
(flags "-w" "@1..66-4-44")
)

View File

@ -219,15 +219,15 @@ let () =
(*************************************************************************)
exception ParsingError
(* Main parsing function *)
let parse = MLParser.prog MLLexer.read
(* Currently unused *)
let ast_from_string s =
let lexbuf = Lexing.from_string s in
parse lexbuf
exception ParsingError
try parse lexbuf
with _ -> raise ParsingError
let letify (typedecl_env, xts) =
let rec aux xts =
@ -241,71 +241,51 @@ let letify (typedecl_env, xts) =
in
(typedecl_env, aux xts)
let test_from_string typedecl s expected on_same on_different on_error =
let s = typedecl ^ "\nlet _ = " ^ s in
let t =
try Ok (ast_from_string s |> letify)
with e -> print_endline s; raise e (*Error ()*)
in
match t with
| Ok (datatype_env, t) ->
if t = expected then
begin
assert (test datatype_env t);
on_same ();
end
else
on_different ()
| Error () ->
on_error ()
let test_ok ?(typedecl="") s expected =
test_from_string typedecl s expected
(fun () -> ())
(fun () -> prerr_endline ("different: " ^ s); raise ParsingError)
(fun () -> prerr_endline ("error: " ^ s); raise ParsingError)
let s = typedecl ^ "\nlet _ = " ^ s in
let (datatype_env, t) = ast_from_string s |> letify in
OUnit2.assert_equal ~printer:MLPrinter.to_string expected t;
OUnit2.assert_bool "typing" (test datatype_env t)
let test_error _s _expected = (*
test_from_string "" s expected
(fun () -> prerr_endline s; raise ParsingError)
(fun () -> ())
(fun () -> ()) *) ()
let test_error_parsing ?(typedecl="") (s : string) =
let s = typedecl ^ "\nlet _ = " ^ s in
OUnit2.assert_raises ParsingError (fun () -> ast_from_string s)
let test_id =
let test_id _ =
test_ok "fun x -> x" id
let test_delta_delta_error =
test_error "(fun x -> x x (fun x -> x x)" deltadelta
let test_delta_delta_error _ =
test_error_parsing "(fun x -> x x (fun x -> x x)"
let test_idid =
let test_idid _ =
test_ok "(fun x -> x) (fun x -> x)" idid
let test_idid_error =
test_error "fun x -> x fun x -> x" idid
let test_idid_error _ =
test_error_parsing "fun x -> x fun x -> x"
let test_unit =
let test_unit _ =
test_ok "()" unit
let test_abs_match_with =
let test_abs_match_with _ =
test_ok "fun x -> match () with () -> () end" abs_match_with
let test_let =
let test_let _ =
test_ok "let y = fun x -> x in ()" (ML.Let("y", id, unit))
let test_let_prod_singleton =
let test_let_prod_singleton _ =
test_ok "let (y,) = (fun x -> x,) in ()"
(ML.LetProd (["y"], ML.Tuple [id], unit))
let test_let_prod =
let test_let_prod _ =
test_ok "let (y,z) = (fun x -> x, ()) in ()"
(ML.LetProd (["y";"z"], ML.Tuple [id;unit], unit))
let test_singleton =
let test_singleton _ =
test_ok
"(fun x -> x,)"
(ML.Tuple [id])
let test_pair_tuple =
let test_pair_tuple _ =
test_ok
"(fun x -> x, fun x -> x)"
(ML.Tuple [id; id])
@ -313,25 +293,19 @@ let test_pair_tuple =
let option_env_str =
"type option 'a = None | Some of 'a"
let test_none =
let test_none _ =
test_ok
~typedecl:option_env_str
"None"
none
let test_none_unit =
test_ok
~typedecl:option_env_str
"None"
none
let test_some =
let test_some _ =
test_ok
~typedecl:option_env_str
"Some (fun x -> x)"
some
let test_some_pair =
let test_some_pair _ =
test_ok
~typedecl:option_env_str
"Some (fun x -> x, fun x -> x)"
@ -339,25 +313,25 @@ let test_some_pair =
let list_env_str = "type list 'a = Nil | Cons of {'a * list 'a}"
let test_list_nil =
let test_list_nil _ =
test_ok
~typedecl:list_env_str
"Nil"
nil
let test_list_cons =
let test_list_cons _ =
test_ok
~typedecl:list_env_str
"Cons (fun x -> x, Nil)"
list
let test_arrow =
let test_arrow _ =
test_ok
~typedecl:"type func 'a 'b = Func of 'a -> 'b"
"Func (fun x -> x)"
(ML.Variant (Datatype.Label "Func", Some id))
let test_match_tuple =
let test_match_tuple _ =
test_ok
"match (fun x -> x, ()) with (f, ()) -> f end"
(ML.Match
@ -365,7 +339,7 @@ let test_match_tuple =
[ (ML.PTuple[ML.PVar "f"; ML.PTuple[]], ML.Var "f") ]
))
let test_match_none =
let test_match_none _ =
test_ok
~typedecl:option_env_str
"match None with
@ -374,7 +348,7 @@ let test_match_none =
end"
match_none
let test_match_some =
let test_match_some _ =
test_ok
~typedecl:option_env_str
"match Some (fun x -> x) with
@ -383,7 +357,7 @@ let test_match_some =
end"
match_some
let test_match_some_annotated =
let test_match_some_annotated _ =
test_ok
~typedecl:option_env_str
"match Some (fun x -> x) with
@ -391,3 +365,32 @@ let test_match_some_annotated =
| (Some _ : some 'a. option 'a) -> None
end"
match_some_annotated
let test_suite = OUnit2.(
"ML test suite" >::: [
"id" >:: test_id;
"delta delta error" >:: test_delta_delta_error;
"id id" >:: test_idid;
"id id error" >:: test_idid_error;
"unit" >:: test_unit;
"abs match with" >:: test_abs_match_with;
"let" >:: test_let;
"let prod singleton" >:: test_let_prod_singleton;
"let prod" >:: test_let_prod;
"singleton" >:: test_singleton;
"pair tuple" >:: test_pair_tuple;
"none" >:: test_none;
"some" >:: test_some;
"some pair" >:: test_some_pair;
"list nil" >:: test_list_nil;
"list cons" >:: test_list_cons;
"arrow" >:: test_arrow;
"match tuple" >:: test_match_tuple;
"match none" >:: test_match_none;
"match some" >:: test_match_some;
"match some annotated" >:: test_match_some_annotated;
]
)
let () =
OUnit2.run_test_tt_main test_suite