inferno-experimental/client/test/TestF.ml

672 lines
16 KiB
OCaml
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

open Client
(* -------------------------------------------------------------------------- *)
(* AST helper functions *)
let (-->) ty1 ty2 =
F.TyArrow (ty1, ty2)
let unit =
F.Tuple (F.dummy_range, [])
let unit_type =
F.TyProduct []
let unit_pattern =
F.PTuple (F.dummy_range, [])
let var x =
F.(Var (dummy_range, x))
let annot ty t =
F.(Annot (dummy_range, ty, t))
let abs x ty t =
F.(Abs (dummy_range, x, ty, t))
let app t u =
F.(App (dummy_range, t, u))
let tyabs x t =
F.(TyAbs (dummy_range, x, t))
let tyapp t ty =
F.(TyApp (dummy_range, t, ty))
let tuple ts =
F.(Tuple (dummy_range, ts))
let letprod xs t u =
F.(LetProd (dummy_range, xs, t, u))
let variant lbl datatype t =
F.(Variant (dummy_range, lbl, datatype, t))
let match_ ty scrutinee branches =
F.(Match (dummy_range, ty, scrutinee, branches))
let absurd ty =
F.(Absurd (dummy_range, ty))
let refl ty =
F.(Refl (dummy_range, ty))
let use t u =
F.(Use (dummy_range, t, u))
let pvar x =
F.(PVar (dummy_range, x))
let pwildcard =
F.(PWildcard dummy_range)
let ptuple ps =
F.(PTuple (dummy_range, ps))
let pvariant lbl datatype t =
F.(PVariant (dummy_range, lbl, datatype, t))
(* -------------------------------------------------------------------------- *)
(* ∀a b. ({} -> (a * (a -> b))) -> b
Λa b. fun (p : {} -> (a * (a -> b))) ->
let (x, f) = p () in f x
*)
let let_prod =
let alpha, beta = 0, 1 in
let p, f, x = "p", "f", "x" in
tyabs alpha @@
tyabs beta @@
abs p (unit_type --> F.(TyProduct [TyVar alpha; TyVar alpha --> TyVar beta])) @@
letprod [x; f]
(app (var p) (tuple []))
(app (var f) (var x))
(* Λαβ. λ(x:{α*β}. match x with (_, y) -> y end *)
let match_with_prod =
let alpha, beta = 1, 0 in
tyabs alpha @@
tyabs beta @@
abs "x" (F.TyProduct [ F.TyVar alpha ; F.TyVar beta ]) @@
match_ (F.TyVar beta) (var "x") [
(ptuple [ pwildcard ; pvar "y" ]) , var"y"
]
(* option *)
let option_env =
let option_typedecl =
let open Datatype in {
name = Type "option";
type_params = [ 0 ];
data_kind = Variant;
labels_descr = [
{
label_name = Label "None";
type_name = Type "option";
arg_type = F.TyProduct [];
} ; {
label_name = Label "Some";
type_name = Type "option";
arg_type = F.TyVar 0;
}
];
}
in
Datatype.Env.add_decl Datatype.Env.empty option_typedecl
(* None *)
let none =
let alpha = 0 in
let label = Datatype.Label "None" in
let datatype = Datatype.Type "option", [F.TyForall (alpha, F.TyVar alpha)] in
variant label datatype unit
let none_pattern =
let alpha = 0 in
let label = Datatype.Label "None" in
let datatype = Datatype.Type "option", [F.TyForall (alpha, F.TyVar alpha)] in
pvariant label datatype unit_pattern
(* Some Λα.λx:α.x *)
let some =
let alpha = 0 in
let label = Datatype.Label "Some" in
let datatype = Datatype.Type "option",
[ F.TyForall (alpha, F.TyVar alpha --> F.TyVar alpha) ] in
variant label datatype @@
tyabs alpha @@
abs "x" (F.TyVar alpha) @@
var "x"
let some_pattern =
let alpha = 0 in
let label = Datatype.Label "Some" in
let datatype = Datatype.Type "option", [ F.TyForall (alpha, F.TyVar alpha) ] in
pvariant label datatype pwildcard
(* Λα. match None with
| None -> ()
| Some (_) -> ()
*)
let match_none =
let alpha = 0 in
tyabs alpha @@
match_ unit_type none @@ [
(none_pattern , unit);
(some_pattern , unit);
]
(* ( refl_{} : Eq(∀α.{} , {}) ) *)
let type_eq =
let alpha = 0 in
annot (refl unit_type) @@
F.TyEq (F.TyForall (alpha, unit_type),
unit_type)
(* Λ α. use (Refl_α : eq (α,α)) in λ (x:α). x *)
let introduce_type_eq =
let alpha = 0 in
let x = "x" in
tyabs alpha @@
use
(annot (refl (F.TyVar alpha)) (F.TyEq (F.TyVar alpha, F.TyVar alpha))) @@
abs x (F.TyVar alpha) (var x)
(* Λ αβ. λ (x : eq (α)). use x in (Refl_β : eq (β,α))
* ∀ αβ. eq (α) -> eq (β,α) *)
let sym =
let alpha = 1 in
let beta = 0 in
let x = "x" in
annot
(tyabs alpha @@
tyabs beta @@
abs x (F.TyEq (F.TyVar alpha, F.TyVar beta)) @@
use (var x) @@
annot (refl (F.TyVar beta)) (F.TyEq (F.TyVar beta, F.TyVar alpha)))
@@
F.TyForall (alpha,
F.TyForall (beta,
F.TyEq (F.TyVar alpha, F.TyVar beta)
--> F.TyEq (F.TyVar beta, F.TyVar alpha)))
(* Λ αβγ.
λ (x : eq (α)).
λ (y : eq (β,γ)).
use x in
use y in
(Refl_γ : eq (α,γ))
∀αβγ. eq (α) -> eq (β,γ) -> eq (α,γ) *)
let trans =
let alpha = 2 in
let beta = 1 in
let gamma = 0 in
let x = "x" in
let y = "y" in
annot
(tyabs alpha @@
tyabs beta @@
tyabs gamma @@
abs x (F.TyEq (F.TyVar alpha, F.TyVar beta)) @@
abs y (F.TyEq (F.TyVar beta, F.TyVar gamma)) @@
use (var x) @@
use (var y) @@
annot (refl (F.TyVar gamma)) (F.TyEq (F.TyVar alpha, F.TyVar gamma)))
@@
F.TyForall (alpha,
F.TyForall (beta,
F.TyForall (gamma,
F.TyEq (F.TyVar alpha, F.TyVar beta)
--> (F.TyEq (F.TyVar beta, F.TyVar gamma)
--> F.TyEq (F.TyVar alpha, F.TyVar gamma)))))
let bool_env =
let bool_typedecl =
let open Datatype in {
name = Type "bool";
type_params = [];
data_kind = Variant;
labels_descr = [
{
label_name = Label "True";
type_name = Type "bool";
arg_type = F.TyProduct [];
} ; {
label_name = Label "False";
type_name = Type "bool";
arg_type = F.TyProduct [];
}
]
}
in
Datatype.Env.add_decl option_env bool_typedecl
let bool_datatype =
Datatype.Type "bool", []
let int_env =
let int_typedecl =
let open Datatype in {
name = Type "int";
type_params = [];
data_kind = Variant;
labels_descr = [
{
label_name = Label "O";
type_name = Type "int";
arg_type = F.TyProduct [];
} ; {
label_name = Label "S";
type_name = Type "int";
arg_type = F.TyConstr (Type "int", []);
}
]
}
in
Datatype.Env.add_decl bool_env int_typedecl
let int_datatype =
Datatype.Type "int", []
(* small gadt *)
let small_gadt_env =
let small_gadt_typedecl =
let alpha = 0 in
let open Datatype in {
name = Type "ty";
type_params = [ alpha ];
data_kind = Variant;
labels_descr = [
{
label_name = Label "Int";
type_name = Type "ty";
arg_type = F.TyEq (F.TyVar alpha, F.TyConstr int_datatype);
} ; {
label_name = Label "Bool";
type_name = Type "ty";
arg_type = F.TyEq (F.TyVar alpha, F.TyConstr bool_datatype);
}
];
}
in
Datatype.Env.add_decl int_env small_gadt_typedecl
let int_pattern arg_type pat =
pvariant
(Datatype.Label "Int")
(Datatype.Type "ty", arg_type)
pat
let bool_pattern arg_type pat =
pvariant
(Datatype.Label "Bool")
(Datatype.Type "ty", arg_type)
pat
(*
Λα.
λ(x : μβ. {} * β).
x
*)
let mu_under_forall =
let alpha = 1 in
let beta = 0 in
let x = "x" in
tyabs alpha @@
abs x (F.TyMu (beta, F.TyProduct [unit_type ; F.TyVar beta])) @@
var x
(*
Λα.
λ(w : Eq(α,int)).
use w in
( O : α )
*)
let cast =
let alpha = 0 in
tyabs alpha @@
abs "w" (F.TyEq (F.TyVar alpha, F.TyConstr int_datatype)) @@
use (var "w") @@
annot (variant (Datatype.Label "O") int_datatype unit) (F.TyVar alpha)
(*
Λα.
λ(n : α ty).
match_α n with
| Int p ->
use (p : Eq(α,int)) in (O : α)
| Bool p ->
use (p : Eq(α,bool)) in (True : α)
*)
let match_gadt_default =
let alpha = 0 in
let int_pat =
int_pattern [F.TyVar alpha] (pvar "p")
in
let int_payoff =
use
(annot
(var "p")
(F.TyEq (F.TyVar alpha, F.TyConstr int_datatype)))
(annot
(variant
(Datatype.Label "O")
int_datatype
unit)
(F.TyVar alpha))
in
let bool_pat =
bool_pattern [F.TyVar alpha] (pvar "p")
in
let bool_payoff =
use
(annot
(var "p")
(F.TyEq (F.TyVar alpha, F.TyConstr bool_datatype)))
(annot
(variant
(Datatype.Label "True")
bool_datatype
unit)
(F.TyVar alpha))
in
tyabs alpha @@
abs "n" (F.TyConstr (Datatype.Type "ty", [F.TyVar alpha])) @@
match_ (F.TyVar alpha) (var "n") [
(int_pat , int_payoff);
(bool_pat , bool_payoff)
]
(*
(Λα.
λ(n : α ty).
match_α n with
| Int p ->
use (p : Eq(α,int)) in (O : α)
| Bool p ->
use (p : Eq(α,bool)) in (True : α))
int
(Int (refl_int))
*)
let default_int =
app
(tyapp match_gadt_default (F.TyConstr int_datatype))
(variant
(Datatype.Label "Int")
(Datatype.Type "ty", [F.TyConstr int_datatype])
(refl (F.TyConstr int_datatype)))
(*
(Λα.
λ(n : α ty).
match_α n with
| Int p ->
use (p : Eq(α,int)) in (O : α)
| Bool p ->
use (p : Eq(α,bool)) in (True : α))
bool
(Bool (refl_bool))
*)
let default_bool =
app
(tyapp match_gadt_default (F.TyConstr bool_datatype))
(variant
(Datatype.Label "Bool")
(Datatype.Type "ty", [F.TyConstr bool_datatype])
(refl (F.TyConstr bool_datatype)))
(*
(Λα.
λ(n : α ty).
match_α n with
| Int p ->
use (p : Eq(α,int)) in (O : α)
| Bool p ->
use (p : Eq(α,bool)) in (True : α))
bool
(Bool (refl_bool))
*)
let default_absurd_wrong =
let alpha = 0 in
let int_pat =
int_pattern [F.TyVar alpha] (pvar "p")
in
let int_payoff =
use (annot (var "p") (F.TyEq (F.TyVar alpha, F.TyConstr int_datatype))) @@
annot
(variant
(Datatype.Label "O")
int_datatype
(absurd unit_type))
(F.TyVar alpha)
in
let bool_pat =
bool_pattern [F.TyVar alpha] (pvar "p")
in
let bool_payoff =
use (annot (var "p") (F.TyEq (F.TyVar alpha, F.TyConstr bool_datatype))) @@
annot
(variant
(Datatype.Label "True")
bool_datatype
(absurd unit_type))
(F.TyVar alpha)
in
tyabs alpha @@
abs "n" (F.TyConstr (Datatype.Type "ty", [F.TyVar alpha])) @@
match_ (F.TyVar alpha) (var "n") [
(int_pat , int_payoff);
(bool_pat , bool_payoff)
]
(*
Λα.
λ(x : α ty).
λ(y : α ty).
match (x, y) with
| (Int p1, Int p2) ->
payoff1
| (Bool p1, Bool p2) ->
payoff2
| (Int p1, Bool p2) ->
payoff3
| (Bool p1, Int p2) ->
payoff4
*)
let test_absurd payoff1 payoff2 payoff3 payoff4 =
let alpha = 0 in
let variant_ty lbl pat =
pvariant
(Datatype.Label lbl)
(Datatype.Type "ty", [F.TyVar alpha])
pat
in
(* Helper functions for payoff *)
(* use (p1 : Eq(α,dt1)) in use (p2 : Eq(α,dt2)) in payoff *)
let double_use datatype1 datatype2 payoff=
use (annot (var "p1") (F.TyEq (F.TyVar alpha, F.TyConstr datatype1))) @@
use (annot (var "p2") (F.TyEq (F.TyVar alpha, F.TyConstr datatype2))) @@
payoff
in
(*
(Int p1, Int p2) ->
use (p1 : Eq(α,int)) in use (p2 : Eq(α,int)) in payoff1
*)
let int_int_branch =
ptuple [
(variant_ty "Int" (pvar "p1"));
(variant_ty "Int" (pvar "p2"));
] ,
double_use int_datatype int_datatype payoff1
(*
(Bool p1, Bool p2) ->
use (p1 : Eq(α,bool)) in use (p2 : Eq(α,bool)) in payoff2
*)
and bool_bool_branch =
ptuple [
(variant_ty "Bool" (pvar "p1"));
(variant_ty "Bool" (pvar "p2"));
] ,
double_use bool_datatype bool_datatype payoff2
(*
(Int p1, Bool p2) ->
use (p1 : Eq(α,int)) in use (p2 : Eq(α,bool)) in payoff3
*)
and int_bool_branch =
ptuple [
(variant_ty "Int" (pvar "p1"));
(variant_ty "Bool" (pvar "p2"));
] ,
double_use int_datatype bool_datatype payoff3
(*
(Bool p1, Int p2) ->
use (p1 : Eq(α,bool)) in use (p2 : Eq(α,int)) in payoff4
*)
and bool_int_branch =
ptuple [
(variant_ty "Bool" (pvar "p1"));
(variant_ty "Int" (pvar "p2"));
] ,
double_use bool_datatype int_datatype payoff4
in
tyabs alpha @@
abs "x" (F.TyConstr (Datatype.Type "ty", [F.TyVar alpha])) @@
abs "y" (F.TyConstr (Datatype.Type "ty", [F.TyVar alpha])) @@
match_ unit_type (tuple [ var "x"; var "y" ]) [
int_int_branch ;
bool_bool_branch;
int_bool_branch;
bool_int_branch;
]
(*
Λα.
λ(x : α ty).
λ(y : α ty).
match (x, y) with
| (Int p1, Int p2) ->
()
| (Bool p1, Bool p2) ->
()
| (Int p1, Bool p2) ->
.
| (Bool p1, Int p2) ->
.
*)
(* This example is ok : the two last branches are unreachable. *)
let test_absurd_ok =
test_absurd
unit
unit
(absurd unit_type)
(absurd unit_type)
(*
Λα.
λ(x : α ty).
λ(y : α ty).
match (x, y) with
| (Int p1, Int p2) ->
()
| (Bool p1, Bool p2) ->
()
| (Int p1, Bool p2) ->
()
| (Bool p1, Int p2) ->
()
*)
(* This example is ok : the two last branches are unreachable, but it is not
mandatory to declare them as such. *)
let test_absurd_ok2 =
test_absurd
unit
unit
unit
unit
(*
Λα.
λ(x : α ty).
λ(y : α ty).
match (x, y) with
| (Int p1, Int p2) ->
.
| (Bool p1, Bool p2) ->
.
| (Int p1, Bool p2) ->
.
| (Bool p1, Int p2) ->
.
*)
(* This example is wrong : the first two branches are reachable, i.e. they
don't introduce type inconsistencies in the environment *)
let test_absurd_wrong =
test_absurd
(absurd unit_type)
(absurd unit_type)
(absurd unit_type)
(absurd unit_type)
let test_ok_from_ast msg datatype_env t =
let test_ok () =
Alcotest.(check unit) "type inference" (Test.CheckF.test datatype_env t) ()
in
Alcotest.(test_case msg `Quick test_ok)
let test_type_error msg datatype_env t =
let test_error () =
Alcotest.(check unit) "type inference"
(Test.CheckF.test_error datatype_env t) ()
in
Alcotest.(test_case msg `Quick test_error)
let test_suite =
[(
"test F ast",
[ test_ok_from_ast "let prod" Datatype.Env.empty let_prod;
test_ok_from_ast "match with prod" Datatype.Env.empty match_with_prod;
test_ok_from_ast "unit" option_env unit;
test_ok_from_ast "none" option_env none;
test_ok_from_ast "some" option_env some;
test_ok_from_ast "match none" option_env match_none;
test_type_error "type equality" Datatype.Env.empty type_eq;
test_ok_from_ast "introduce type equality" Datatype.Env.empty introduce_type_eq;
test_ok_from_ast "symmetry" Datatype.Env.empty sym;
test_ok_from_ast "transitivity" Datatype.Env.empty trans;
test_ok_from_ast "mu under forall" Datatype.Env.empty mu_under_forall;
test_ok_from_ast "cast" int_env cast;
test_ok_from_ast "default" small_gadt_env match_gadt_default;
test_ok_from_ast "default int" small_gadt_env default_int;
test_ok_from_ast "default bool" small_gadt_env default_bool;
test_type_error "default absurd wrong" small_gadt_env default_absurd_wrong;
test_ok_from_ast "pair of gadt" small_gadt_env test_absurd_ok;
test_ok_from_ast "pair of gadt" small_gadt_env test_absurd_ok2;
test_type_error "pair of gadt" small_gadt_env test_absurd_wrong;
]
)]
let () =
Alcotest.run "F test suite" test_suite