inferno-experimental/client/test/TestML.ml

473 lines
12 KiB
OCaml

open Client
(* A few manually constructed terms. *)
let dummy_pos = ML.dummy_pos
let hole =
ML.Hole (dummy_pos, [])
let x =
ML.Var (dummy_pos, "x")
let y =
ML.Var (dummy_pos, "y")
let id =
ML.Abs (dummy_pos, "x", x)
let delta =
ML.Abs (dummy_pos, "x", ML.App (dummy_pos, x, x))
let deltadelta =
ML.App (dummy_pos, delta, delta)
let idid =
ML.App (dummy_pos, id, id)
let k =
ML.Abs (dummy_pos, "x", ML.Abs (dummy_pos, "y", x))
let genid =
ML.Let (dummy_pos, "x", id, x)
let genidid =
ML.Let (dummy_pos, "x", id, ML.App (dummy_pos, x, x))
let genkidid =
ML.Let (dummy_pos, "x", ML.App (dummy_pos, k, id), ML.App (dummy_pos, x, id))
let genkidid2 =
ML.Let (dummy_pos, "x", ML.App (dummy_pos, ML.App (dummy_pos, k, id), id), x)
let app_pair = (* ill-typed *)
ML.App (dummy_pos, ML.Tuple (dummy_pos, [id; id]), id)
let unit =
ML.Tuple (dummy_pos, [])
(* "let x1 = (...[], ...[]) in ...[] x1" *)
let regression1 =
ML.Let (dummy_pos, "x1", ML.Tuple (dummy_pos, [ ML.Hole (dummy_pos, []) ;
ML.Hole (dummy_pos, []) ]),
ML.App (dummy_pos, ML.Hole (dummy_pos, []), ML.Var (dummy_pos, "x1")))
(* "let f = fun x ->
let g = fun y -> (x, y) in
g
in
fun x -> fun y -> f" *)
let regression2 =
ML.(
Let (dummy_pos,
"f",
Abs (dummy_pos,
"x",
Let (dummy_pos,
"g",
Abs (dummy_pos,
"y",
Tuple (dummy_pos, [x; y])
),
Var (dummy_pos, "g")
)),
Abs(dummy_pos,
"x",
Abs(dummy_pos,
"y",
Var (dummy_pos, "f"))))
)
let abs_match_with =
ML.(
Abs(
dummy_pos,
"x",
Match(
dummy_pos,
Tuple (dummy_pos, []),
[ (PTuple (dummy_pos, []), Tuple (dummy_pos, [])) ]
)
)
)
(* option *)
let option_env =
(* type 'a option = None | Some of 'a *)
let option_typedecl =
let open Datatype in {
name = Type "option";
type_params = [ "'a" ];
data_kind = Variant;
labels_descr = [
{
label_name = Label"None";
type_name = Type "option";
arg_type = None;
} ; {
label_name = Label "Some";
type_name = Type "option";
arg_type = Some (ML.TyVar (dummy_pos,"'a"));
}
]
} in
Datatype.Env.add_decl Datatype.Env.empty option_typedecl
let none = ML.Variant (dummy_pos, Datatype.Label "None" , None )
let some =
ML.Variant (
dummy_pos,
Datatype.Label "Some",
Some id
)
let match_none = ML.(
Match (dummy_pos, none, [
PVariant (dummy_pos, Datatype.Label "None", None), none ;
PVariant (dummy_pos, Datatype.Label "Some", Some (PVar (dummy_pos, "x"))), x ;
])
)
let match_some = ML.(
Match (dummy_pos, some, [
PVariant (dummy_pos, Datatype.Label "None", None), none ;
PVariant (dummy_pos, Datatype.Label "Some", Some (PWildcard dummy_pos)), none
])
)
let match_some_annotated = ML.(
Match (dummy_pos, some, [
( PVariant (dummy_pos, Datatype.Label "None", None), none );
( PAnnot (dummy_pos,
PVariant (dummy_pos, Datatype.Label "Some",
Some (PWildcard dummy_pos)),
(["'a"], TyConstr (dummy_pos, Datatype.Type "option",
[ TyVar (dummy_pos, "'a") ]))),
none );
])
)
(* list *)
let list_env =
(* type 'a list = Nil | Cons of 'a * 'a list *)
let list_typedecl =
let open Datatype in {
name = Type "list";
type_params = [ "'a" ];
data_kind = Variant;
labels_descr = [
{
label_name = Label "Nil";
type_name = Type "list";
arg_type = None;
} ; {
label_name = Label "Cons";
type_name = Type "list";
arg_type = Some (ML.(TyProduct (dummy_pos,
[ TyVar (dummy_pos, "'a") ;
TyConstr (dummy_pos,
Type "list",
[ TyVar (dummy_pos, "'a") ])
]
)));
}
]
} in
Datatype.Env.add_decl option_env list_typedecl
let nil = ML.Variant (dummy_pos, Datatype.Label "Nil" , None )
let cons =
ML.Variant (
dummy_pos,
Datatype.Label "Cons",
Some (ML.Tuple (dummy_pos, [ id ; nil ]))
)
let list_annotated =
let open ML in
Annot (
dummy_pos,
Variant (
dummy_pos,
Datatype.Label "Cons",
Some (Tuple (dummy_pos, [
Annot (dummy_pos, id,
(["'a"], TyArrow (dummy_pos,
TyVar (dummy_pos, "'a"),
TyVar (dummy_pos, "'a"))));
nil ]))
),
(["'a"; "'b"], TyConstr (dummy_pos,
Datatype.Type "list",
[TyArrow (dummy_pos,
TyVar (dummy_pos, "'a"),
TyVar (dummy_pos, "'b"))]))
)
(* tree *)
let tree_env =
(* type 'a tree = Leaf | Node of 'a tree * 'a * 'a tree *)
let tree_typedecl =
let open Datatype in {
name = Type "tree";
type_params = [ "'a" ];
data_kind = Variant;
labels_descr = [
{
label_name = Label "Leaf";
type_name = Type "tree";
arg_type = None
} ; {
label_name = Label "Node";
type_name = Type "tree";
arg_type = Some (ML.(TyProduct (dummy_pos, [
TyConstr (dummy_pos, Type "tree", [ TyVar (dummy_pos, "'a") ]);
TyVar (dummy_pos, "'a");
TyConstr (dummy_pos, Type "tree", [ TyVar (dummy_pos, "'a") ]);
])))
}
];
} in
Datatype.Env.add_decl list_env tree_typedecl
let leaf = ML.Variant (dummy_pos, Datatype.Label "Leaf" , None )
let node =
ML.Variant (
dummy_pos,
Datatype.Label "Node",
Some (ML.Tuple (dummy_pos, [
leaf ;
id ;
leaf ;
]))
)
let test_ok_from_ast datatype_env t () =
Alcotest.(check bool) "type inference"
(Test.CheckML.test ~rectypes:false datatype_env t)
true
let test_case msg datatype_env t =
Alcotest.(test_case msg `Quick (test_ok_from_ast datatype_env t))
let test_suite =
(
"test ML ast",
[ test_case "hole" Datatype.Env.empty hole ;
test_case "id" Datatype.Env.empty id ;
test_case "id id" Datatype.Env.empty idid ;
test_case "gen id" Datatype.Env.empty genid ;
test_case "gen id id" Datatype.Env.empty genidid ;
test_case "gen k id id" Datatype.Env.empty genkidid ;
test_case "gen k id id 2" Datatype.Env.empty genkidid2 ;
test_case "none" option_env none ;
test_case "some" option_env some ;
test_case "nil" list_env nil ;
test_case "list" list_env cons ;
test_case "leaf" tree_env leaf ;
test_case "node" tree_env node ;
test_case "abs match with" Datatype.Env.empty abs_match_with ;
test_case "match none" option_env match_none ;
test_case "match some" option_env match_some
]
)
(* -------------------------------------------------------------------------- *)
let testable_term =
let pprint fmt t =
PPrint.ToFormatter.pretty 0.9 80 fmt (MLPrinter.print_term t)
in
Alcotest.testable pprint Test.CheckML.equal_term
let test_ok ?(typedecl="") s expected =
let (datatype_env, t) = Test.CheckML.from_string typedecl s in
Alcotest.check' testable_term ~msg:"equal" ~expected ~actual:t;
Alcotest.(check bool) "type inference" (Test.CheckML.test ~rectypes:false datatype_env t) true
let test_error_parsing ?(typedecl="") s =
let test_parsing () = ignore (Test.CheckML.from_string typedecl s) in
Alcotest.check_raises "parsing" Test.CheckML.ParsingError test_parsing
let test_id () =
test_ok "fun x -> x" id
let test_delta_delta_error () =
test_error_parsing "(fun x -> x x (fun x -> x x)"
let test_idid () =
test_ok "(fun x -> x) (fun x -> x)" idid
let test_idid_error () =
test_error_parsing "fun x -> x fun x -> x"
let test_unit () =
test_ok "()" unit
let test_abs_match_with () =
test_ok "fun x -> match () with () -> () end" abs_match_with
let test_let () =
test_ok "let y = fun x -> x in ()" (ML.Let(dummy_pos, "y", id, unit))
let test_let_prod_singleton () =
test_ok "let (y,) = (fun x -> x,) in ()"
(ML.LetProd (dummy_pos, ["y"], ML.Tuple (dummy_pos, [id]), unit))
let test_let_prod () =
test_ok "let (y,z) = (fun x -> x, ()) in ()"
(ML.LetProd (dummy_pos, ["y";"z"], ML.Tuple (dummy_pos, [id;unit]), unit))
let test_singleton () =
test_ok
"(fun x -> x,)"
(ML.Tuple (dummy_pos, [id]))
let test_pair_tuple () =
test_ok
"(fun x -> x, fun x -> x)"
(ML.Tuple (dummy_pos, [id; id]))
let option_env_str =
"type option 'a = None | Some of 'a"
let test_none () =
test_ok
~typedecl:option_env_str
"None"
none
let test_some () =
test_ok
~typedecl:option_env_str
"Some (fun x -> x)"
some
let test_some_pair () =
test_ok
~typedecl:option_env_str
"Some (fun x -> x, fun x -> x)"
(ML.Variant (dummy_pos, Datatype.Label "Some",
Some (ML.Tuple (dummy_pos, [id;id]))))
let list_env_str = "type list 'a = Nil | Cons of {'a * list 'a}"
let test_list_nil () =
test_ok
~typedecl:list_env_str
"Nil"
nil
let test_list_cons () =
test_ok
~typedecl:list_env_str
"Cons (fun x -> x, Nil)"
cons
let test_arrow () =
test_ok
~typedecl:"type func 'a 'b = Func of 'a -> 'b"
"Func (fun x -> x)"
(ML.Variant (dummy_pos, Datatype.Label "Func", Some id))
let test_match_tuple () =
test_ok
"match (fun x -> x, ()) with (f, ()) -> f end"
(ML.Match
(dummy_pos,
ML.Tuple (dummy_pos, [id;unit]),
[ (ML.PTuple (dummy_pos, [ML.PVar (dummy_pos, "f");
ML.PTuple (dummy_pos, [])]),
ML.Var (dummy_pos, "f")) ]
))
let test_match_none () =
test_ok
~typedecl:option_env_str
{|match None with
| None -> None
| Some x -> x
end|}
match_none
let test_match_some () =
test_ok
~typedecl:option_env_str
{|match Some (fun x -> x) with
| None -> None
| Some _ -> None
end|}
match_some
let test_match_some_annotated () =
test_ok
~typedecl:option_env_str
{|match Some (fun x -> x) with
| None -> None
| (Some _ : some 'a. option 'a) -> None
end|}
match_some_annotated
(** Regressions *)
let test_regression1 () =
test_ok
"let x1 = (...[], ...[]) in ...[] x1"
regression1
let test_regression2 () =
test_ok
"let f = fun x -> let g = fun y -> (x, y) in g in fun x -> fun y -> f"
regression2
let test_suite =
let open Alcotest in
test_suite ::
[
(
"basics",
[ test_case "id" `Quick test_id;
test_case "id id" `Quick test_idid;
test_case "id id error" `Quick test_idid_error;
test_case "delta delta error" `Quick test_delta_delta_error;
test_case "unit" `Quick test_unit;
test_case "regression1" `Quick test_regression1;
test_case "regression2" `Quick test_regression2;
test_case "abs match with" `Quick test_abs_match_with;
test_case "let" `Quick test_let;
test_case "let prod singleton" `Quick test_let_prod_singleton;
test_case "let prod" `Quick test_let_prod;
test_case "singleton" `Quick test_singleton;
]
) ; (
"data structures",
[
test_case "pair tuple" `Quick test_pair_tuple;
test_case "none" `Quick test_none;
test_case "some" `Quick test_some;
test_case "some pair" `Quick test_some_pair;
test_case "list nil" `Quick test_list_nil;
test_case "list cons" `Quick test_list_cons;
test_case "arrow" `Quick test_arrow;
]
) ; (
"pattern matching",
[
test_case "match tuple" `Quick test_match_tuple;
test_case "match none" `Quick test_match_tuple;
test_case "match some" `Quick test_match_some;
test_case "match some annotated" `Quick test_match_some_annotated;
]
)
]
let () =
Alcotest.run ~verbose:false "ML test suite" test_suite