473 lines
12 KiB
OCaml
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
|