|
|
From stdpp Require Import base relations.
|
|
|
From iris Require Import prelude.
|
|
|
From semantics.lib Require Import maps.
|
|
|
From semantics.ts.stlc_extended Require Import lang notation ctxstep_sol.
|
|
|
|
|
|
(** ** Syntactic typing *)
|
|
|
Inductive type : Type :=
|
|
|
| Int
|
|
|
| Fun (A B : type)
|
|
|
| Prod (A B : type)
|
|
|
| Sum (A B : type).
|
|
|
|
|
|
Definition typing_context := gmap string type.
|
|
|
Implicit Types
|
|
|
(Γ : typing_context)
|
|
|
(v : val)
|
|
|
(e : expr).
|
|
|
|
|
|
Declare Scope FType_scope.
|
|
|
Delimit Scope FType_scope with ty.
|
|
|
Bind Scope FType_scope with type.
|
|
|
Infix "→" := Fun : FType_scope.
|
|
|
Notation "(→)" := Fun (only parsing) : FType_scope.
|
|
|
Infix "×" := Prod (at level 70) : FType_scope.
|
|
|
Notation "(×)" := Prod (only parsing) : FType_scope.
|
|
|
Infix "+" := Sum : FType_scope.
|
|
|
Notation "(+)" := Sum (only parsing) : FType_scope.
|
|
|
|
|
|
Reserved Notation "Γ ⊢ e : A" (at level 74, e, A at next level).
|
|
|
|
|
|
Inductive syn_typed : typing_context → expr → type → Prop :=
|
|
|
| typed_var Γ x A :
|
|
|
Γ !! x = Some A →
|
|
|
Γ ⊢ (Var x) : A
|
|
|
| typed_lam Γ x e A B :
|
|
|
(<[ x := A]> Γ) ⊢ e : B →
|
|
|
Γ ⊢ (Lam (BNamed x) e) : (A → B)
|
|
|
| typed_lam_anon Γ e A B :
|
|
|
Γ ⊢ e : B →
|
|
|
Γ ⊢ (Lam BAnon e) : (A → B)
|
|
|
| typed_int Γ z : Γ ⊢ (LitInt z) : Int
|
|
|
| typed_app Γ e1 e2 A B :
|
|
|
Γ ⊢ e1 : (A → B) →
|
|
|
Γ ⊢ e2 : A →
|
|
|
Γ ⊢ (e1 e2)%E : B
|
|
|
| typed_add Γ e1 e2 :
|
|
|
Γ ⊢ e1 : Int →
|
|
|
Γ ⊢ e2 : Int →
|
|
|
Γ ⊢ e1 + e2 : Int
|
|
|
| typed_pair Γ e1 e2 A B :
|
|
|
Γ ⊢ e1 : A →
|
|
|
Γ ⊢ e2 : B →
|
|
|
Γ ⊢ (e1, e2) : A × B
|
|
|
| typed_fst Γ e A B :
|
|
|
Γ ⊢ e : A × B →
|
|
|
Γ ⊢ Fst e : A
|
|
|
| typed_snd Γ e A B :
|
|
|
Γ ⊢ e : A × B →
|
|
|
Γ ⊢ Snd e : B
|
|
|
| typed_injl Γ e A B :
|
|
|
Γ ⊢ e : A →
|
|
|
Γ ⊢ InjL e : A + B
|
|
|
| typed_injr Γ e A B :
|
|
|
Γ ⊢ e : B →
|
|
|
Γ ⊢ InjR e : A + B
|
|
|
| typed_case Γ e e1 e2 A B C :
|
|
|
Γ ⊢ e : B + C →
|
|
|
Γ ⊢ e1 : (B → A) →
|
|
|
Γ ⊢ e2 : (C → A) →
|
|
|
Γ ⊢ Case e e1 e2 : A
|
|
|
where "Γ ⊢ e : A" := (syn_typed Γ e%E A%ty).
|
|
|
#[export] Hint Constructors syn_typed : core.
|
|
|
|
|
|
(** Examples *)
|
|
|
Goal ∅ ⊢ (λ: "x", "x")%E : (Int → Int).
|
|
|
Proof. eauto. Qed.
|
|
|
|
|
|
Lemma syn_typed_closed Γ e A X :
|
|
|
Γ ⊢ e : A →
|
|
|
(∀ x, x ∈ dom Γ → x ∈ X) →
|
|
|
is_closed X e.
|
|
|
Proof.
|
|
|
(* TODO: you will need to add the new cases, i.e. "|"'s to the intro pattern. The proof then should go through *)
|
|
|
induction 1 as [ | ?????? IH | | | | | | | | | | ] in X |-*; simpl; intros Hx; try done.
|
|
|
{ (* var *) apply bool_decide_pack, Hx. apply elem_of_dom; eauto. }
|
|
|
{ (* lam *) apply IH.
|
|
|
intros y. rewrite elem_of_dom lookup_insert_is_Some.
|
|
|
intros [<- | [? Hy]]; first by apply elem_of_cons; eauto.
|
|
|
apply elem_of_cons. right. eapply Hx. by apply elem_of_dom.
|
|
|
}
|
|
|
{ (* anon lam *) naive_solver. }
|
|
|
(* everything else *)
|
|
|
all: repeat match goal with
|
|
|
| |- Is_true (_ && _) => apply andb_True; split
|
|
|
end.
|
|
|
all: try naive_solver.
|
|
|
Qed.
|
|
|
|
|
|
Lemma typed_weakening Γ Δ e A:
|
|
|
Γ ⊢ e : A →
|
|
|
Γ ⊆ Δ →
|
|
|
Δ ⊢ e : A.
|
|
|
Proof.
|
|
|
(* TODO: here you will need to add the new cases to the intro pattern as well. The proof then should go through *)
|
|
|
induction 1 as [| Γ x e A B Htyp IH | | | | | | | | | |] in Δ |-*; intros Hsub; eauto.
|
|
|
- (* var *) econstructor. by eapply lookup_weaken.
|
|
|
- (* lam *) econstructor. eapply IH; eauto. by eapply insert_mono.
|
|
|
Qed.
|
|
|
|
|
|
(** Typing inversion lemmas *)
|
|
|
Lemma var_inversion Γ (x: string) A: Γ ⊢ x : A → Γ !! x = Some A.
|
|
|
Proof. inversion 1; subst; auto. Qed.
|
|
|
|
|
|
Lemma lam_inversion Γ (x: string) e C:
|
|
|
Γ ⊢ (λ: x, e) : C →
|
|
|
∃ A B, C = (A → B)%ty ∧ <[x:=A]> Γ ⊢ e : B.
|
|
|
Proof. inversion 1; subst; eauto 10. Qed.
|
|
|
|
|
|
Lemma lam_anon_inversion Γ e C:
|
|
|
Γ ⊢ (λ: <>, e) : C →
|
|
|
∃ A B, C = (A → B)%ty ∧ Γ ⊢ e : B.
|
|
|
Proof. inversion 1; subst; eauto 10. Qed.
|
|
|
|
|
|
Lemma app_inversion Γ e1 e2 B:
|
|
|
Γ ⊢ e1 e2 : B →
|
|
|
∃ A, Γ ⊢ e1 : (A → B) ∧ Γ ⊢ e2 : A.
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
Lemma plus_inversion Γ e1 e2 B:
|
|
|
Γ ⊢ e1 + e2 : B →
|
|
|
B = Int ∧ Γ ⊢ e1 : Int ∧ Γ ⊢ e2 : Int.
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
|
|
|
(* There are the inversion lemmas for the new typing rules *)
|
|
|
Lemma pair_inversion Γ e1 e2 C :
|
|
|
Γ ⊢ (e1, e2) : C →
|
|
|
∃ A B, C = (A × B)%ty ∧ Γ ⊢ e1 : A ∧ Γ ⊢ e2 : B.
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
Lemma fst_inversion Γ e A :
|
|
|
Γ ⊢ Fst e : A →
|
|
|
∃ B, Γ ⊢ e : A × B.
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
Lemma snd_inversion Γ e B :
|
|
|
Γ ⊢ Snd e : B →
|
|
|
∃ A, Γ ⊢ e : A × B.
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
Lemma injl_inversion Γ e C :
|
|
|
Γ ⊢ InjL e : C →
|
|
|
∃ A B, C = (A + B)%ty ∧ Γ ⊢ e : A.
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
Lemma injr_inversion Γ e C :
|
|
|
Γ ⊢ InjR e : C →
|
|
|
∃ A B, C = (A + B)%ty ∧ Γ ⊢ e : B.
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
Lemma case_inversion Γ e e1 e2 A :
|
|
|
Γ ⊢ Case e e1 e2 : A →
|
|
|
∃ B C, Γ ⊢ e : B + C ∧ Γ ⊢ e1 : (B → A) ∧ Γ ⊢ e2 : (C → A).
|
|
|
Proof. inversion 1; subst; eauto. Qed.
|
|
|
|
|
|
Lemma typed_substitutivity e e' Γ (x: string) A B :
|
|
|
∅ ⊢ e' : A →
|
|
|
(<[x := A]> Γ) ⊢ e : B →
|
|
|
Γ ⊢ lang.subst x e' e : B.
|
|
|
Proof.
|
|
|
intros He'. revert B Γ; induction e as [y | y | | | | | | | | | ]; intros B Γ; simpl.
|
|
|
- intros Hp % var_inversion.
|
|
|
destruct (decide (x = y)).
|
|
|
+ subst. rewrite lookup_insert in Hp. injection Hp as ->.
|
|
|
eapply typed_weakening; [done| ]. apply map_empty_subseteq.
|
|
|
+ rewrite lookup_insert_ne in Hp; last done. auto.
|
|
|
- destruct y as [ | y].
|
|
|
{ intros (A' & C & -> & Hty) % lam_anon_inversion.
|
|
|
econstructor. destruct decide as [Heq|].
|
|
|
+ congruence.
|
|
|
+ eauto.
|
|
|
}
|
|
|
intros (A' & C & -> & Hty) % lam_inversion.
|
|
|
econstructor. destruct decide as [Heq|].
|
|
|
+ injection Heq as [= ->]. by rewrite insert_insert in Hty.
|
|
|
+ rewrite insert_commute in Hty; last naive_solver. eauto.
|
|
|
- intros (C & Hty1 & Hty2) % app_inversion. eauto.
|
|
|
- inversion 1; subst; auto.
|
|
|
- intros (-> & Hty1 & Hty2)%plus_inversion; eauto.
|
|
|
- intros (? & ? & -> & ? & ?) % pair_inversion. eauto.
|
|
|
- intros (? & ?)%fst_inversion. eauto.
|
|
|
- intros (? & ?)%snd_inversion. eauto.
|
|
|
- intros (? & ? & -> & ?)%injl_inversion. eauto.
|
|
|
- intros (? & ? & -> & ?)%injr_inversion. eauto.
|
|
|
- intros (? & ? & ? & ? & ?)%case_inversion. eauto.
|
|
|
Qed.
|
|
|
|
|
|
(** Canonical values *)
|
|
|
Lemma canonical_values_arr Γ e A B:
|
|
|
Γ ⊢ e : (A → B) →
|
|
|
is_val e →
|
|
|
∃ x e', e = (λ: x, e')%E.
|
|
|
Proof.
|
|
|
inversion 1; simpl; naive_solver.
|
|
|
Qed.
|
|
|
|
|
|
Lemma canonical_values_int Γ e:
|
|
|
Γ ⊢ e : Int →
|
|
|
is_val e →
|
|
|
∃ n: Z, e = (#n)%E.
|
|
|
Proof.
|
|
|
inversion 1; simpl; naive_solver.
|
|
|
Qed.
|
|
|
|
|
|
(* canonical forms lemmas for the new types *)
|
|
|
Lemma canonical_values_prod Γ e A B :
|
|
|
Γ ⊢ e : A × B →
|
|
|
is_val e →
|
|
|
∃ e1 e2, e = (e1, e2)%E ∧ is_val e1 ∧ is_val e2.
|
|
|
Proof.
|
|
|
inversion 1; simpl; naive_solver.
|
|
|
Qed.
|
|
|
|
|
|
Lemma canonical_values_sum Γ e A B :
|
|
|
Γ ⊢ e : A + B →
|
|
|
is_val e →
|
|
|
(∃ e', e = InjL e' ∧ is_val e') ∨ (∃ e', e = InjR e' ∧ is_val e').
|
|
|
Proof.
|
|
|
inversion 1; simpl; naive_solver.
|
|
|
Qed.
|
|
|
|
|
|
(** Progress *)
|
|
|
Lemma typed_progress e A:
|
|
|
∅ ⊢ e : A → is_val e ∨ reducible e.
|
|
|
Proof.
|
|
|
remember ∅ as Γ.
|
|
|
(* TODO: you will need to extend the intro pattern *)
|
|
|
induction 1 as [| | | | Γ e1 e2 A B Hty IH1 _ IH2 | Γ e1 e2 Hty1 IH1 Hty2 IH2 | Γ e1 e2 A B Hty1 IH1 Hty2 IH2 | Γ e A B Hty IH | Γ e A B Hty IH | Γ e A B Hty IH | Γ e A B Hty IH| Γ e e1 e2 A B C Htye IHe Htye1 IHe1 Htye2 IHe2].
|
|
|
- subst. naive_solver.
|
|
|
- left. done.
|
|
|
- left. done.
|
|
|
- (* int *)left. done.
|
|
|
- (* app *)
|
|
|
destruct (IH2 HeqΓ) as [H2|H2]; [destruct (IH1 HeqΓ) as [H1|H1]|].
|
|
|
+ eapply canonical_values_arr in Hty as (x & e & ->); last done.
|
|
|
right. eexists.
|
|
|
eapply base_contextual_step, BetaS; eauto.
|
|
|
+ right. destruct H1 as [e1' Hstep].
|
|
|
eexists. eauto.
|
|
|
+ right. destruct H2 as [e2' H2].
|
|
|
eexists. eauto.
|
|
|
- (* plus *)
|
|
|
destruct (IH2 HeqΓ) as [H2|H2]; [destruct (IH1 HeqΓ) as [H1|H1]|].
|
|
|
+ right. eapply canonical_values_int in Hty1 as [n1 ->]; last done.
|
|
|
eapply canonical_values_int in Hty2 as [n2 ->]; last done.
|
|
|
subst. eexists; eapply base_contextual_step. eauto.
|
|
|
+ right. destruct H1 as [e1' Hstep]. eexists. eauto.
|
|
|
+ right. destruct H2 as [e2' H2]. eexists. eauto.
|
|
|
- (* pair *)
|
|
|
destruct (IH2 HeqΓ) as [H2|H2]; [destruct (IH1 HeqΓ) as [H1|H1]|].
|
|
|
+ left. done.
|
|
|
+ right. destruct H1 as [e1' Hstep]. eexists. eauto.
|
|
|
+ right. destruct H2 as [e2' H2]. eexists. eauto.
|
|
|
- (* fst *)
|
|
|
destruct (IH HeqΓ) as [H | H].
|
|
|
+ eapply canonical_values_prod in Hty as (e1 & e2 & -> & ? & ?); last done.
|
|
|
right. eexists. eapply base_contextual_step. econstructor; done.
|
|
|
+ right. destruct H as [e' H]. eexists. eauto.
|
|
|
- (* snd *)
|
|
|
destruct (IH HeqΓ) as [H | H].
|
|
|
+ eapply canonical_values_prod in Hty as (e1 & e2 & -> & ? & ?); last done.
|
|
|
right. eexists. eapply base_contextual_step. econstructor; done.
|
|
|
+ right. destruct H as [e' H]. eexists. eauto.
|
|
|
- (* injl *)
|
|
|
destruct (IH HeqΓ) as [H | H].
|
|
|
+ left. done.
|
|
|
+ right. destruct H as [e' H]. eexists. eauto.
|
|
|
- (* injr *)
|
|
|
destruct (IH HeqΓ) as [H | H].
|
|
|
+ left. done.
|
|
|
+ right. destruct H as [e' H]. eexists. eauto.
|
|
|
- (* case *)
|
|
|
right. destruct (IHe HeqΓ) as [H1|H1].
|
|
|
+ eapply canonical_values_sum in Htye as [(e' & -> & ?) | (e' & -> & ?)]; last done.
|
|
|
* eexists. eapply base_contextual_step. econstructor. done.
|
|
|
* eexists. eapply base_contextual_step. econstructor. done.
|
|
|
+ destruct H1 as [e' H1]. eexists. eauto.
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
Definition ectx_typing (K: ectx) (A B: type) :=
|
|
|
∀ e, ∅ ⊢ e : A → ∅ ⊢ (fill K e) : B.
|
|
|
|
|
|
Lemma fill_typing_decompose K e A:
|
|
|
∅ ⊢ fill K e : A →
|
|
|
∃ B, ∅ ⊢ e : B ∧ ectx_typing K B A.
|
|
|
Proof.
|
|
|
unfold ectx_typing; induction K in e,A |-*; simpl; eauto.
|
|
|
all: inversion 1; subst; edestruct IHK as [? [Hit Hty]]; eauto.
|
|
|
Qed.
|
|
|
|
|
|
Lemma fill_typing_compose K e A B:
|
|
|
∅ ⊢ e : B →
|
|
|
ectx_typing K B A →
|
|
|
∅ ⊢ fill K e : A.
|
|
|
Proof.
|
|
|
intros H1 H2; by eapply H2.
|
|
|
Qed.
|
|
|
|
|
|
Lemma typed_preservation_base_step e e' A:
|
|
|
∅ ⊢ e : A →
|
|
|
base_step e e' →
|
|
|
∅ ⊢ e' : A.
|
|
|
Proof.
|
|
|
intros Hty Hstep.
|
|
|
destruct Hstep as [ ]; subst.
|
|
|
- eapply app_inversion in Hty as (B & H1 & H2).
|
|
|
destruct x as [|x].
|
|
|
{ eapply lam_anon_inversion in H1 as (C & D & [= -> ->] & Hty). done. }
|
|
|
eapply lam_inversion in H1 as (C & D & Heq & Hty).
|
|
|
injection Heq as -> ->.
|
|
|
eapply typed_substitutivity; eauto.
|
|
|
- eapply plus_inversion in Hty as (-> & Hty1 & Hty2). constructor.
|
|
|
- by eapply fst_inversion in Hty as (B & (? & ? & [= <- <-] & ? & ?)%pair_inversion).
|
|
|
- by eapply snd_inversion in Hty as (B & (? & ? & [= <- <-] & ? & ?)%pair_inversion).
|
|
|
- eapply case_inversion in Hty as (B & C & (? & ? & [= <- <-] & Hty)%injl_inversion & ? & ?).
|
|
|
eauto.
|
|
|
- eapply case_inversion in Hty as (B & C & (? & ? & [= <- <-] & Hty )%injr_inversion & ? & ?).
|
|
|
eauto.
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
Lemma typed_preservation e e' A:
|
|
|
∅ ⊢ e : A →
|
|
|
contextual_step e e' →
|
|
|
∅ ⊢ e' : A.
|
|
|
Proof.
|
|
|
intros Hty Hstep. destruct Hstep as [K e1 e2 -> -> Hstep].
|
|
|
eapply fill_typing_decompose in Hty as [B [H1 H2]].
|
|
|
eapply fill_typing_compose; last done.
|
|
|
by eapply typed_preservation_base_step.
|
|
|
Qed.
|
|
|
|
|
|
Lemma type_safety e1 e2 A:
|
|
|
∅ ⊢ e1 : A →
|
|
|
rtc contextual_step e1 e2 →
|
|
|
is_val e2 ∨ reducible e2.
|
|
|
Proof.
|
|
|
induction 2; eauto using typed_progress, typed_preservation.
|
|
|
Qed.
|