Use OUnit for the ML test suite.
This commit is contained in:
parent
8d89520d61
commit
fbeb059436
|
@ -7,6 +7,6 @@
|
|||
|
||||
(library
|
||||
(name client)
|
||||
(libraries pprint inferno)
|
||||
(libraries pprint ounit2 inferno)
|
||||
(flags "-w" "@1..66-4-44")
|
||||
)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue