Set Implicit Arguments.
Require Export Coq.Program.Equality.
(* ---------------------------------------------------------------------------- *)
(* The syntax of terms. *)
(* We set things up so that terms do not refer to types. Thus, term variables appear in terms, and type variables appear in types. This makes things much simpler as compared to a setup where type variables appear in types and in terms. *)
Inductive term :=
| TVar: nat -> term
| TAbs: term -> term
| TApp: term -> term -> term
| TTyAbs: term -> term
| TTyApp: term -> term.
(* ---------------------------------------------------------------------------- *)
(* The binding structure of terms. *)
Instance Var_term : Var term := {
var := TVar (* avoid eta-expansion *)
}.
Fixpoint traverse_term (f : nat -> nat -> term) l t :=
match t with
| TVar x =>
f l x
| TAbs t =>
TAbs (traverse_term f (1 + l) t)
| TApp t1 t2 =>
TApp (traverse_term f l t1) (traverse_term f l t2)
| TTyAbs t =>
TTyAbs (traverse_term f l t)
| TTyApp t =>
TTyApp (traverse_term f l t)
end.
Instance Traverse_term : Traverse term term := {
traverse := traverse_term
}.
Instance TraverseVarInjective_term : @TraverseVarInjective term _ term _.
Instance TraverseFunctorial_term : @TraverseFunctorial term _ term _.
Instance TraverseRelative_term : @TraverseRelative term term _.
Instance TraverseIdentifiesVar_term : @TraverseIdentifiesVar term _ _.
Instance TraverseVarIsIdentity_term : @TraverseVarIsIdentity term _ term _.
(* ---------------------------------------------------------------------------- *)
(* Reduction semantics. *)
Inductive red : term -> term -> Prop :=
| RedBeta:
forall t1 t2,
red (TApp (TAbs t1) t2)
(subst t2 0 t1)
| RedTyBeta:
forall t,
red (TTyApp (TTyAbs t)) t
| RedContextTAbs:
forall t1 t2,
red t1 t2 ->
red (TAbs t1) (TAbs t2)
| RedContextTAppLeft:
forall t1 t2 t,
red t1 t2 ->
red (TApp t1 t) (TApp t2 t)
| RedContextTAppRight:
forall t1 t2 t,
red t1 t2 ->
red (TApp t t1) (TApp t t2)
| RedContextTTyAbs:
forall t1 t2,
red t1 t2 ->
red (TTyAbs t1) (TTyAbs t2)
| RedContextTTyApp:
forall t1 t2,
red t1 t2 ->
red (TTyApp t1) (TTyApp t2).
(* ---------------------------------------------------------------------------- *)
(* The syntax of System F types. *)
Inductive ty :=
| TyVar: nat -> ty
| TyArrow: ty -> ty -> ty
| TyForall: ty -> ty.
(* ---------------------------------------------------------------------------- *)
(* The binding structure of types. *)
Instance Var_ty : Var ty := {
var := TyVar (* avoid eta-expansion *)
}.
Fixpoint traverse_ty (f : nat -> nat -> ty) l T :=
match T with
| TyVar x =>
f l x
| TyArrow T1 T2 =>
TyArrow (traverse_ty f l T1) (traverse_ty f l T2)
| TyForall T =>
TyForall (traverse_ty f (1 + l) T)
end.
Instance Traverse_ty : Traverse ty ty := {
traverse := traverse_ty
}.
Instance TraverseVarInjective_ty : @TraverseVarInjective ty _ ty _.
Instance TraverseFunctorial_ty : @TraverseFunctorial ty _ ty _.
Instance TraverseRelative_ty : @TraverseRelative ty ty _.
Instance TraverseIdentifiesVar_ty : @TraverseIdentifiesVar ty _ _.
Instance TraverseVarIsIdentity_ty : @TraverseVarIsIdentity ty _ ty _.
(* ---------------------------------------------------------------------------- *)
(* The typing judgement of System F. *)
Inductive j : env ty -> term -> ty -> Prop :=
| JVar:
forall E x T,
lookup x E = Some T ->
j E (TVar x) T
| JAbs:
forall E t T1 T2,
j (insert 0 T1 E) t T2 ->
j E (TAbs t) (TyArrow T1 T2)
| JApp:
forall E t1 t2 T1 T2,
j E t1 (TyArrow T1 T2) ->
j E t2 T1 ->
j E (TApp t1 t2) T2
| JTyAbs:
forall E t T,
j (map (shift 0) E) t T ->
j E (TTyAbs t) (TyForall T)
| JTyApp:
forall E t T U U',
j E t (TyForall T) ->
(* an explicit equality facilitates the use of this axiom by [eauto] *)
subst U 0 T = U' ->
j E (TTyApp t) U'.
Hint Constructors j : j.
(* ---------------------------------------------------------------------------- *)
(* Type preservation. *)
Ltac j_inversion :=
match goal with
| h: j _ (TAbs _) _ |- _ =>
inversion h; clear h; subst
| h: j _ (TTyAbs _) _ |- _ =>
inversion h; clear h; subst
end.

Lemma type_preservation:
forall t1 t2,
red t1 t2 ->
forall E T,
j E t1 T ->
j E t2 T.