Library PLF.Records
Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Stdlib Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
Adding Records
(ST_Rcd) {i1=v1, ..., im=vm, in=tn, ...} ==> {i1=v1, ..., im=vm, in=tn', ...}
(ST_Proj1) t1.i ==> t1'.i
(ST_ProjRcd) {..., i=vi, ...}.i ==> vi
(T_Rcd) Gamma |-- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}
(T_Proj) Gamma |-- t0.i : Ti
Syntax and Operational Semantics
Module FirstTry.
Definition alist (X : Type) := list (string × X).
Inductive ty : Type :=
| Base : string → ty
| Arrow : ty → ty → ty
| TRcd : (alist ty) → ty.
Unfortunately, we encounter here a limitation in Coq: this type
does not automatically give us the induction principle we expect:
the induction hypothesis in the TRcd case doesn't give us
any information about the ty elements of the list, making it
useless for the proofs we want to do.
It is possible to get a better induction principle out of Coq, but
the details of how this is done are not very pretty, and the
principle we obtain is not as intuitive to use as the ones Coq
generates automatically for simple Inductive definitions.
Fortunately, there is a different way of formalizing records that
is, in some ways, even simpler and more natural: instead of using
the standard Coq list type, we can essentially incorporate its
constructors ("nil" and "cons") in the syntax of our types.
Inductive ty : Type :=
| Ty_Base : string → ty
| Ty_Arrow : ty → ty → ty
| Ty_RNil : ty
| Ty_RCons : string → ty → ty → ty.
Similarly, at the level of terms, we have constructors trnil,
for the empty record, and rcons, which adds a single field to
the front of a list of fields.
Inductive tm : Type :=
| tm_var : string → tm
| tm_app : tm → tm → tm
| tm_abs : string → ty → tm → tm
| tm_rproj : tm → string → tm
| tm_rnil : tm
| tm_rcons : string → tm → tm → tm.
Notation "x" := x (in custom stlc_ty at level 0, x global) : stlc_scope.
Notation "<{{ x }}>" := x (x custom stlc_ty).
Notation "( t )" := t (in custom stlc_ty at level 0, t custom stlc_ty) : stlc_scope.
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc_ty at level 99, right associativity) : stlc_scope.
Notation "$( t )" := t (in custom stlc_ty at level 0, t constr) : stlc_scope.
Notation "$( x )" := x (in custom stlc_tm at level 0, x constr, only parsing) : stlc_scope.
Notation "x" := x (in custom stlc_tm at level 0, x constr at level 0) : stlc_scope.
Notation "<{ e }>" := e (e custom stlc_tm at level 200) : stlc_scope.
Notation "( x )" := x (in custom stlc_tm at level 0, x custom stlc_tm) : stlc_scope.
Notation "x y" := (tm_app x y) (in custom stlc_tm at level 10, left associativity) : stlc_scope.
Notation "\ x : t , y" :=
(tm_abs x t y) (in custom stlc_tm at level 200, x global,
t custom stlc_ty,
y custom stlc_tm at level 200,
left associativity).
Coercion tm_var : string >-> tm.
Arguments tm_var _%_string.
Notation "'Base' x" := (Ty_Base x) (in custom stlc_ty at level 0, x constr at level 0) : stlc_scope.
Notation " l ':' t1 '::' t2" := (Ty_RCons l t1 t2) (in custom stlc_ty at level 0, l global, t1 custom stlc_ty at level 0, right associativity).
Notation " l := e1 '::' e2" := (tm_rcons l e1 e2) (in custom stlc_tm at level 3, right associativity).
Notation "'nil'" := (Ty_RNil) (in custom stlc_ty).
Notation "'nil'" := (tm_rnil) (in custom stlc_tm).
Notation "o --> l" := (tm_rproj o l) (in custom stlc_tm at level 0).
Some examples...
Open Scope string_scope.
Open Scope stlc_scope.
Notation a := "a".
Notation f := "f".
Notation g := "g".
Notation l := "l".
Notation A := <{{ Base "A" }}>.
Notation B := <{{ Base "B" }}>.
Notation k := "k".
Notation i1 := "i1".
Notation i2 := "i2".
Open Scope stlc_scope.
Notation a := "a".
Notation f := "f".
Notation g := "g".
Notation l := "l".
Notation A := <{{ Base "A" }}>.
Notation B := <{{ Base "B" }}>.
Notation k := "k".
Notation i1 := "i1".
Notation i2 := "i2".
{ i1:A }
{ i1:A→B, i2:A }
One issue with generalizing the abstract syntax for records from
lists to the nil/cons presentation is that it introduces the
possibility of writing strange types like this...
where the "tail" of a record type is not actually a record type!
We'll structure our typing judgement so that no ill-formed types
like weird_type are ever assigned to terms. To support this, we
define predicates record_ty and record_tm, which identify
record types and terms, and well_formed_ty which rules out the
ill-formed types.
First, a type is a record type if it is built with just RNil
and RCons at the outermost level.
Inductive record_ty : ty → Prop :=
| RTnil :
record_ty <{{ nil }}>
| RTcons : ∀ i T1 T2,
record_ty <{{ i : T1 :: T2 }}>.
With this, we can define well-formed types.
Inductive well_formed_ty : ty → Prop :=
| wfBase : ∀ (i : string),
well_formed_ty <{{ Base i }}>
| wfArrow : ∀ T1 T2,
well_formed_ty T1 →
well_formed_ty T2 →
well_formed_ty <{{ T1 → T2 }}>
| wfRNil :
well_formed_ty <{{ nil }}>
| wfRCons : ∀ i T1 T2,
well_formed_ty T1 →
well_formed_ty T2 →
record_ty T2 →
well_formed_ty <{{ i : T1 :: T2 }}>.
Hint Constructors record_ty well_formed_ty : core.
Note that record_ty is not recursive -- it just checks the
outermost constructor. The well_formed_ty property, on the
other hand, verifies that the whole type is well formed in the
sense that the tail of every record (the second argument to
RCons) is a record.
Of course, we should also be concerned about ill-formed terms, not
just types; but typechecking can rule those out without the help
of an extra well_formed_tm definition because it already
examines the structure of terms. All we need is an analog of
record_ty saying that a term is a record term if it is built
with trnil and rcons.
Lemma wf_ty_example: well_formed_ty <{{ i1 : (A → A) :: i2 : (B → B) :: nil }}>.
Proof.
auto.
Qed.
Inductive record_tm : tm → Prop :=
| rtnil :
record_tm <{ nil }>
| rtcons : ∀ i t1 t2,
record_tm <{ i := t1 :: t2 }>.
Hint Constructors record_tm : core.
Proof.
auto.
Qed.
Inductive record_tm : tm → Prop :=
| rtnil :
record_tm <{ nil }>
| rtcons : ∀ i t1 t2,
record_tm <{ i := t1 :: t2 }>.
Hint Constructors record_tm : core.
Reserved Notation "'[' x ':=' s ']' t" (in custom stlc_tm at level 5, x global, s custom stlc_tm,
t custom stlc_tm at next level, right associativity).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
match t with
| tm_var y ⇒
if String.eqb x y then s else t
| <{\y:T, t1}> ⇒
if String.eqb x y then t else <{\y:T, [x:=s] t1}>
| <{t1 t2}> ⇒
<{([x:=s] t1) ([x:=s] t2)}>
| <{ t1 --> i }> ⇒
<{ ( [x := s] t1) --> i }>
| <{ nil }> ⇒
<{ nil }>
| <{ i := t1 :: tr }> ⇒
<{ i := [x := s] t1 :: ( [x := s] tr) }>
end
where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc_tm).
Inductive value : tm → Prop :=
| v_abs : ∀ x T2 t1,
value <{ \ x : T2, t1 }>
| v_rnil : value <{ nil }>
| v_rcons : ∀ i v1 vr,
value v1 →
value vr →
value <{ i := v1 :: vr }>.
Hint Constructors value : core.
To define reduction, we'll need a utility function for extracting
one field from record term:
Fixpoint tlookup (i:string) (tr:tm) : option tm :=
match tr with
| <{ i' := t :: tr'}> ⇒ if String.eqb i i' then Some t else tlookup i tr'
| _ ⇒ None
end.
The step function uses this term-level lookup function in the
projection rule.
Reserved Notation "t '-->' t'" (at level 40).
Inductive step : tm → tm → Prop :=
| ST_AppAbs : ∀ x T2 t1 v2,
value v2 →
<{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
| ST_App1 : ∀ t1 t1' t2,
t1 --> t1' →
<{t1 t2}> --> <{t1' t2}>
| ST_App2 : ∀ v1 t2 t2',
value v1 →
t2 --> t2' →
<{v1 t2}> --> <{v1 t2'}>
| ST_Proj1 : ∀ t1 t1' i,
t1 --> t1' →
<{ t1 --> i }> --> <{ t1' --> i }>
| ST_ProjRcd : ∀ tr i vi,
value tr →
tlookup i tr = Some vi →
<{ tr --> i }> --> vi
| ST_Rcd_Head : ∀ i t1 t1' tr2,
t1 --> t1' →
<{ i := t1 :: tr2 }> --> <{ i := t1' :: tr2 }>
| ST_Rcd_Tail : ∀ i v1 tr2 tr2',
value v1 →
tr2 --> tr2' →
<{ i := v1 :: tr2 }> --> <{ i := v1 :: tr2' }>
where "t '-->' t'" := (step t t').
Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).
Hint Constructors step : core.
Typing
Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
match Tr with
| <{{ i' : T :: Tr' }}> ⇒
if String.eqb i i' then Some T else Tlookup i Tr'
| _ ⇒ None
end.
Definition context := partial_map ty.
Notation "x '|->' v ';' m " := (update m x v)
(in custom stlc_tm at level 0, x constr at level 0, v custom stlc_ty, right associativity) : stlc_scope.
Notation "x '|->' v " := (update empty x v)
(in custom stlc_tm at level 0, x constr at level 0, v custom stlc_ty) : stlc_scope.
Notation "'empty'" := empty (in custom stlc_tm) : stlc_scope.
Reserved Notation "<{ Gamma '|--' t '\in' T }>"
(at level 0, Gamma custom stlc_tm at level 200, t custom stlc_tm, T custom stlc_ty).
Inductive has_type (Gamma : context) :tm → ty → Prop :=
| T_Var : ∀ x T,
Gamma x = Some T →
well_formed_ty T →
<{ Gamma |-- x \in T }>
| T_Abs : ∀ x T11 T12 t12,
well_formed_ty T11 →
<{ x |-> T11; Gamma |-- t12 \in T12 }> →
<{ Gamma |-- \x : T11, t12 \in T11 → T12 }>
| T_App : ∀ T1 T2 t1 t2,
<{ Gamma |-- t1 \in T1 → T2 }> →
<{ Gamma |-- t2 \in T1 }> →
<{ Gamma |-- ( t1 t2) \in T2 }>
| T_Proj : ∀ i t Ti Tr,
<{ Gamma |-- t \in Tr }> →
Tlookup i Tr = Some Ti →
<{ Gamma |-- (t --> i) \in Ti }>
| T_RNil :
<{ Gamma |-- nil \in nil }>
| T_RCons : ∀ i t T tr Tr,
<{ Gamma |-- t \in T }> →
<{ Gamma |-- tr \in Tr }> →
record_ty Tr →
record_tm tr →
<{ Gamma |-- ( i := t :: tr) \in i : T :: Tr }>
where "<{ Gamma '|--' t '\in' T }>" := (has_type Gamma t T).
Hint Constructors has_type : core.
Examples
Exercise: 2 stars, standard (examples)
Lemma typing_example_2 :
<{ empty |-- (\a : ( i1 : (A → A) :: i2 : (B → B) :: nil), a --> i2)
( i1 := (\a : A, a) :: i2 := (\a : B,a ) :: nil ) \in B → B }>.
Proof.
Admitted.
Example typing_nonexample :
¬ ∃ T,
<{ (a |-> <{{ i2 : (A → A) :: nil }}>) |--
( i1 := (\a : B, a) :: a ) \in
T }>.
Proof.
Admitted.
Example typing_nonexample_2 : ∀ y,
¬ ∃ T,
<{ (y |-> A) |--
(\a : ( i1 : A :: nil ), a --> i1 )
( i1 := y :: i2 := y :: nil ) \in T }>.
Proof.
Admitted.
☐
Properties of Typing
Lemma wf_rcd_lookup : ∀ i T Ti,
well_formed_ty T →
Tlookup i T = Some Ti →
well_formed_ty Ti.
Proof with eauto.
intros i T.
induction T; intros; try solve_by_invert.
-
inversion H. subst. unfold Tlookup in H0.
destruct (String.eqb i s)...
inversion H0. subst... Qed.
Lemma step_preserves_record_tm : ∀ tr tr',
record_tm tr →
tr --> tr' →
record_tm tr'.
Proof.
intros tr tr' Hrt Hstp.
inversion Hrt; subst; inversion Hstp; subst; auto.
Qed.
Lemma has_type__wf : ∀ Gamma t T,
<{ Gamma |-- t \in T }> → well_formed_ty T.
Proof with eauto.
intros Gamma t T Htyp.
induction Htyp...
-
inversion IHHtyp1...
-
eapply wf_rcd_lookup...
Qed.
Field Lookup
- If i = i0, then since Tlookup i (RCons i0 T Tr) = Some
Ti we have T = Ti. It follows that t itself satisfies
the theorem.
- On the other hand, suppose i ≠ i0. Then
Tlookup i T = Tlookup i Trandtlookup i t = tlookup i tr,so the result follows from the induction hypothesis. ☐
Lemma lookup_field_in_value : ∀ v T i Ti,
value v →
<{ empty |-- v \in T }> →
Tlookup i T = Some Ti →
∃ ti, tlookup i v = Some ti ∧ <{ empty |-- ti \in Ti }>.
Proof with eauto.
intros v T i Ti Hval Htyp Hget.
remember empty as Gamma.
induction Htyp; subst; try solve_by_invert...
-
simpl in Hget. simpl. destruct (String.eqb i i0).
+
simpl. injection Hget as Hget. subst.
∃ t...
+
destruct IHHtyp2 as [vi [Hgeti Htypi] ]...
inversion Hval... Qed.
Theorem progress : ∀ t T,
<{ empty |-- t \in T }> →
value t ∨ ∃ t', t --> t'.
Proof with eauto.
intros t T Ht.
remember empty as Gamma.
generalize dependent HeqGamma.
induction Ht; intros HeqGamma; subst.
-
inversion H.
-
left...
-
right.
destruct IHHt1; subst...
+
destruct IHHt2; subst...
×
inversion H; subst; try solve_by_invert.
∃ <{ [x:=t2]t0 }>...
×
destruct H0 as [t2' Hstp]. ∃ <{ t1 t2' }>...
+
destruct H as [t1' Hstp]. ∃ <{ t1' t2 }>...
-
right. destruct IHHt...
+
destruct (lookup_field_in_value _ _ _ _ H0 Ht H)
as [ti [Hlkup _] ].
∃ ti...
+
destruct H0 as [t' Hstp]. ∃ <{ t' --> i }>...
-
left...
-
destruct IHHt1...
+
destruct IHHt2; try reflexivity.
×
left...
×
right. destruct H2 as [tr' Hstp].
∃ <{ i := t :: tr'}>...
+
right. destruct H1 as [t' Hstp].
∃ <{ i := t' :: tr }>... Qed.
Lemma weakening : ∀ Gamma Gamma' t T,
includedin Gamma Gamma' →
<{ Gamma |-- t \in T }> →
<{ Gamma' |-- t \in T }>.
Proof.
intros Gamma Gamma' t T H Ht.
generalize dependent Gamma'.
induction Ht; eauto using includedin_update.
Qed.
Lemma weakening_empty : ∀ Gamma t T,
<{ empty |-- t \in T }> →
<{ Gamma |-- t \in T }>.
Proof.
intros Gamma t T.
eapply weakening.
discriminate.
Qed.
Preservation
Lemma substitution_preserves_typing : ∀ Gamma x U t v T,
<{ x |-> U ; Gamma |-- t \in T }> →
<{ empty |-- v \in U }> →
<{ Gamma |-- [x:=v]t \in T }>.
Proof.
intros Gamma x U t v T Ht Hv.
generalize dependent Gamma. generalize dependent T.
induction t; intros T Gamma H;
inversion H; clear H; subst; simpl; eauto.
-
rename s into y. destruct (eqb_spec x y); subst.
+
rewrite update_eq in H1.
injection H1 as H1; subst.
apply weakening_empty. assumption.
+
apply T_Var. rewrite update_neq in H1; auto. assumption.
-
rename s into y, t into T.
destruct (eqb_spec x y); subst; apply T_Abs; try assumption.
+
rewrite update_shadow in H5. assumption.
+
apply IHt.
rewrite update_permute; auto.
-
apply T_RCons; eauto.
inversion H7; subst; simpl; auto.
Qed.
Theorem preservation : ∀ t t' T,
<{ empty |-- t \in T }> →
t --> t' →
<{ empty |-- t' \in T }>.
Proof with eauto.
intros t t' T HT. generalize dependent t'.
remember empty as Gamma.
induction HT;
intros t' HE; subst;
try solve [inversion HE; subst; auto].
-
inversion HE; subst...
+
apply substitution_preserves_typing with T1...
inversion HT1...
-
inversion HE; subst...
destruct (lookup_field_in_value _ _ _ _ H2 HT H)
as [vi [Hget Htyp] ].
rewrite H4 in Hget. injection Hget as Hget. subst...
-
inversion HE; subst...
apply T_RCons... eapply step_preserves_record_tm...
Qed.
End STLCExtendedRecords.