|
|
|
|
From stdpp Require Import gmap base relations tactics.
|
|
|
|
|
From iris Require Import prelude.
|
|
|
|
|
From semantics.ts.stlc Require Import lang notation.
|
|
|
|
|
From semantics.ts.stlc Require untyped types.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** README: Please also download the assigment sheet as a *.pdf from here:
|
|
|
|
|
https://cms.sic.saarland/semantics_ws2324/materials/
|
|
|
|
|
It contains additional explanation and excercises. **)
|
|
|
|
|
|
|
|
|
|
(** ** Exercise 1: Prove that the structural and contextual semantics are equivalent. *)
|
|
|
|
|
(** You will find it very helpful to separately derive the structural rules of the
|
|
|
|
|
structural semantics for the contextual semantics. *)
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_beta x e e':
|
|
|
|
|
is_val e' → contextual_step ((λ: x, e) e') (subst' x e' e).
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hval. eapply base_contextual_step, BetaS; done.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_app_r (e1 e2 e2': expr) :
|
|
|
|
|
contextual_step e2 e2' →
|
|
|
|
|
contextual_step (e1 e2) (e1 e2').
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hval. by eapply fill_contextual_step with (K := AppRCtx e1 HoleCtx).
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_app_l (e1 e1' e2: expr) :
|
|
|
|
|
is_val e2 →
|
|
|
|
|
contextual_step e1 e1' →
|
|
|
|
|
contextual_step (e1 e2) (e1' e2).
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hval. eapply is_val_spec in Hval as [v Hval].
|
|
|
|
|
eapply of_to_val in Hval as <-.
|
|
|
|
|
eapply fill_contextual_step with (K := (AppLCtx HoleCtx v)).
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_plus_red (n1 n2 n3: Z) :
|
|
|
|
|
(n1 + n2)%Z = n3 →
|
|
|
|
|
contextual_step (n1 + n2)%E n3.
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hval. eapply base_contextual_step, PlusS; done.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_plus_r e1 e2 e2' :
|
|
|
|
|
contextual_step e2 e2' →
|
|
|
|
|
contextual_step (Plus e1 e2) (Plus e1 e2').
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hval. by eapply fill_contextual_step with (K := (PlusRCtx e1 HoleCtx)).
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_plus_l e1 e1' e2 :
|
|
|
|
|
is_val e2 →
|
|
|
|
|
contextual_step e1 e1' →
|
|
|
|
|
contextual_step (Plus e1 e2) (Plus e1' e2).
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hval. eapply is_val_spec in Hval as [v Hval].
|
|
|
|
|
eapply of_to_val in Hval as <-.
|
|
|
|
|
eapply fill_contextual_step with (K := (PlusLCtx HoleCtx v)).
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
(** We register these lemmas as hints for [eauto]. *)
|
|
|
|
|
#[global]
|
|
|
|
|
Hint Resolve contextual_step_beta contextual_step_app_l contextual_step_app_r contextual_step_plus_red contextual_step_plus_l contextual_step_plus_r : core.
|
|
|
|
|
|
|
|
|
|
Lemma step_contextual_step e1 e2: step e1 e2 → contextual_step e1 e2.
|
|
|
|
|
Proof.
|
|
|
|
|
(* The hints above make sure eauto uses the right lemmas. *)
|
|
|
|
|
induction 1; eauto.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
(** Now the other direction. *)
|
|
|
|
|
(* You may find it helpful to introduce intermediate lemmas. *)
|
|
|
|
|
|
|
|
|
|
Lemma base_step_step e1 e2:
|
|
|
|
|
base_step e1 e2 → step e1 e2.
|
|
|
|
|
Proof.
|
|
|
|
|
destruct 1; subst.
|
|
|
|
|
- eauto.
|
|
|
|
|
- by econstructor.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma fill_step K e1 e2:
|
|
|
|
|
step e1 e2 → step (fill K e1) (fill K e2).
|
|
|
|
|
Proof.
|
|
|
|
|
induction K; simpl; eauto.
|
|
|
|
|
Qed.
|
|
|
|
|
Lemma contextual_step_step e1 e2:
|
|
|
|
|
contextual_step e1 e2 → step e1 e2.
|
|
|
|
|
Proof.
|
|
|
|
|
destruct 1 as [K h1 h2 -> -> Hstep].
|
|
|
|
|
eapply fill_step, base_step_step, Hstep.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** ** Exercise 2: Scott encodings *)
|
|
|
|
|
Section scott.
|
|
|
|
|
(* take a look at untyped.v for usefull lemmas and definitions *)
|
|
|
|
|
Import semantics.ts.stlc.untyped.
|
|
|
|
|
|
|
|
|
|
(** Scott encoding of Booleans *)
|
|
|
|
|
Definition true_scott : val := λ: "t" "f", "t".
|
|
|
|
|
Definition false_scott : val := λ: "t" "f", "f".
|
|
|
|
|
|
|
|
|
|
Lemma true_red (v1 v2 : val) :
|
|
|
|
|
closed [] v1 →
|
|
|
|
|
closed [] v2 →
|
|
|
|
|
rtc step (true_scott v1 v2) v1.
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hcl1 Hcl2.
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor; first auto.
|
|
|
|
|
econstructor. auto.
|
|
|
|
|
}
|
|
|
|
|
simpl.
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor; auto. }
|
|
|
|
|
simpl.
|
|
|
|
|
rewrite subst_closed_nil; done.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma false_red (v1 v2 : val) :
|
|
|
|
|
closed [] v1 →
|
|
|
|
|
closed [] v2 →
|
|
|
|
|
rtc step (false_scott v1 v2) v2.
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hcl1 Hcl2.
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor; first auto.
|
|
|
|
|
econstructor. auto.
|
|
|
|
|
}
|
|
|
|
|
simpl.
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor; auto. }
|
|
|
|
|
simpl. done.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
(** Scott encoding of Pairs *)
|
|
|
|
|
Definition pair_scott : val := λ: "v1" "v2", λ: "d", "d" "v1" "v2".
|
|
|
|
|
|
|
|
|
|
Definition fst_scott : val := λ: "p", "p" (λ: "a" "b", "a").
|
|
|
|
|
Definition snd_scott : val := λ: "p", "p" (λ: "a" "b", "b").
|
|
|
|
|
|
|
|
|
|
Lemma fst_red (v1 v2 : val) :
|
|
|
|
|
is_closed [] v1 →
|
|
|
|
|
is_closed [] v2 →
|
|
|
|
|
rtc step (fst_scott (pair_scott v1 v2)) v1.
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hcl1 Hcl2.
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor 3. econstructor; first auto.
|
|
|
|
|
econstructor. auto.
|
|
|
|
|
}
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor 3. econstructor; first auto. }
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor. done. }
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor. done. }
|
|
|
|
|
simpl.
|
|
|
|
|
rewrite !(subst_closed_nil v1); [ | done..].
|
|
|
|
|
rewrite subst_closed_nil; last done.
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor; first auto.
|
|
|
|
|
econstructor. auto.
|
|
|
|
|
}
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor; first auto. }
|
|
|
|
|
simpl. rewrite subst_closed_nil; done.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma snd_red (v1 v2 : val) :
|
|
|
|
|
is_closed [] v1 →
|
|
|
|
|
is_closed [] v2 →
|
|
|
|
|
rtc step (snd_scott (pair_scott v1 v2)) v2.
|
|
|
|
|
Proof.
|
|
|
|
|
intros Hcl1 Hcl2.
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor 3. econstructor; first auto.
|
|
|
|
|
econstructor. auto.
|
|
|
|
|
}
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor 3. econstructor; first auto. }
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor. done. }
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor. done. }
|
|
|
|
|
simpl.
|
|
|
|
|
rewrite !(subst_closed_nil v2); [ | done..].
|
|
|
|
|
rewrite !(subst_closed_nil v1); [ | done..].
|
|
|
|
|
eapply rtc_l.
|
|
|
|
|
{ econstructor; first auto.
|
|
|
|
|
econstructor. auto.
|
|
|
|
|
}
|
|
|
|
|
simpl. eapply rtc_l.
|
|
|
|
|
{ econstructor; first auto. }
|
|
|
|
|
simpl. done.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
End scott.
|
|
|
|
|
|
|
|
|
|
Import semantics.ts.stlc.types.
|
|
|
|
|
|
|
|
|
|
(** ** Exercise 3: type erasure *)
|
|
|
|
|
(** Source terms *)
|
|
|
|
|
Inductive src_expr :=
|
|
|
|
|
| ELitInt (n: Z)
|
|
|
|
|
(* Base lambda calculus *)
|
|
|
|
|
| EVar (x : string)
|
|
|
|
|
| ELam (x : binder) (A: type) (e : src_expr)
|
|
|
|
|
| EApp (e1 e2 : src_expr)
|
|
|
|
|
(* Base types and their operations *)
|
|
|
|
|
| EPlus (e1 e2 : src_expr).
|
|
|
|
|
|
|
|
|
|
(** The erasure function *)
|
|
|
|
|
Fixpoint erase (E: src_expr) : expr :=
|
|
|
|
|
match E with
|
|
|
|
|
| ELitInt n => LitInt n
|
|
|
|
|
| EVar x => Var x
|
|
|
|
|
| ELam x A E => Lam x (erase E)
|
|
|
|
|
| EApp E1 E2 => App (erase E1) (erase E2)
|
|
|
|
|
| EPlus E1 E2 => Plus (erase E1) (erase E2)
|
|
|
|
|
end.
|
|
|
|
|
|
|
|
|
|
Reserved Notation "Γ '⊢S' e : A" (at level 74, e, A at next level).
|
|
|
|
|
Inductive src_typed : typing_context → src_expr → type → Prop :=
|
|
|
|
|
| src_typed_var Γ x A :
|
|
|
|
|
Γ !! x = Some A →
|
|
|
|
|
Γ ⊢S (EVar x) : A
|
|
|
|
|
| src_typed_lam Γ x E A B :
|
|
|
|
|
(<[ x := A]> Γ) ⊢S E : B →
|
|
|
|
|
Γ ⊢S (ELam (BNamed x) A E) : (A → B)
|
|
|
|
|
| src_typed_int Γ z :
|
|
|
|
|
Γ ⊢S (ELitInt z) : Int
|
|
|
|
|
| src_typed_app Γ E1 E2 A B :
|
|
|
|
|
Γ ⊢S E1 : (A → B) →
|
|
|
|
|
Γ ⊢S E2 : A →
|
|
|
|
|
Γ ⊢S EApp E1 E2 : B
|
|
|
|
|
| src_typed_add Γ E1 E2 :
|
|
|
|
|
Γ ⊢S E1 : Int →
|
|
|
|
|
Γ ⊢S E2 : Int →
|
|
|
|
|
Γ ⊢S EPlus E1 E2 : Int
|
|
|
|
|
where "Γ '⊢S' E : A" := (src_typed Γ E%E A%ty) : FType_scope.
|
|
|
|
|
#[export] Hint Constructors src_typed : core.
|
|
|
|
|
|
|
|
|
|
Lemma type_erasure_correctness Γ E A:
|
|
|
|
|
(Γ ⊢S E : A)%ty → (Γ ⊢ erase E : A)%ty.
|
|
|
|
|
Proof.
|
|
|
|
|
induction 1; simpl; eauto.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
(** ** Exercise 4: Unique Typing *)
|
|
|
|
|
Lemma src_typing_unique Γ E A B:
|
|
|
|
|
(Γ ⊢S E : A)%ty → (Γ ⊢S E : B)%ty → A = B.
|
|
|
|
|
Proof.
|
|
|
|
|
induction 1 as [ | ????? H1 IH1 | | ????? H1 IH1 H2 IH2 | ??? H1 IH1 H2 IH2] in B |-*; inversion 1; subst; try congruence.
|
|
|
|
|
- f_equal. eauto.
|
|
|
|
|
- rename select (_ ⊢S _ : (_ → _))%ty into Ha.
|
|
|
|
|
eapply IH1 in Ha. by injection Ha.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
(** TODO: Is runtime typing (Curry-style) also unique? Prove it or give a counterexample. *)
|
|
|
|
|
(** Runtime typing is not unique! *)
|
|
|
|
|
Lemma id_int: (∅ ⊢ (λ: "x", "x") : (Int → Int))%ty.
|
|
|
|
|
Proof. eauto. Qed.
|
|
|
|
|
|
|
|
|
|
Lemma id_int_to_int: (∅ ⊢ (λ: "x", "x") : ((Int → Int) → (Int → Int)))%ty.
|
|
|
|
|
Proof. eauto. Qed.
|
|
|
|
|
|
|
|
|
|
(** ** Exercise 5: Type Inference *)
|
|
|
|
|
|
|
|
|
|
Fixpoint type_eq A B :=
|
|
|
|
|
match A, B with
|
|
|
|
|
| Int, Int => true
|
|
|
|
|
| Fun A B, Fun A' B' => type_eq A A' && type_eq B B'
|
|
|
|
|
| _, _ => false
|
|
|
|
|
end.
|
|
|
|
|
|
|
|
|
|
Lemma type_eq_iff A B: type_eq A B ↔ A = B.
|
|
|
|
|
Proof.
|
|
|
|
|
induction A in B |-*; destruct B; simpl; naive_solver.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Notation ctx := (gmap string type).
|
|
|
|
|
Fixpoint infer_type (Γ: ctx) E :=
|
|
|
|
|
match E with
|
|
|
|
|
| EVar x => Γ !! x
|
|
|
|
|
| ELam (BNamed x) A E =>
|
|
|
|
|
match infer_type (<[x := A]> Γ) E with
|
|
|
|
|
| Some B => Some (Fun A B)
|
|
|
|
|
| None => None
|
|
|
|
|
end
|
|
|
|
|
| ELitInt l => Some Int
|
|
|
|
|
| EApp E1 E2 =>
|
|
|
|
|
match infer_type Γ E1, infer_type Γ E2 with
|
|
|
|
|
| Some (Fun A B), Some C => if type_eq A C then Some B else None
|
|
|
|
|
| _, _ => None
|
|
|
|
|
end
|
|
|
|
|
| EPlus E1 E2 =>
|
|
|
|
|
match infer_type Γ E1, infer_type Γ E2 with
|
|
|
|
|
| Some Int, Some Int => Some Int
|
|
|
|
|
| _, _ => None
|
|
|
|
|
end
|
|
|
|
|
| ELam BAnon A E => None
|
|
|
|
|
end.
|
|
|
|
|
|
|
|
|
|
(** Prove both directions of the correctness theorem. *)
|
|
|
|
|
Lemma infer_type_typing Γ E A:
|
|
|
|
|
infer_type Γ E = Some A → (Γ ⊢S E : A)%ty.
|
|
|
|
|
Proof.
|
|
|
|
|
induction E as [l|x|x B E IH|E1 IH1 E2 IH2|E1 IH1 E2 IH2] in Γ, A |-*; simpl.
|
|
|
|
|
- destruct l; naive_solver.
|
|
|
|
|
- eauto.
|
|
|
|
|
- destruct x as [|x]; first naive_solver.
|
|
|
|
|
destruct infer_type eqn: Heq; last naive_solver.
|
|
|
|
|
eapply IH in Heq. injection 1 as <-. eauto.
|
|
|
|
|
- destruct infer_type as [B|] eqn: Heq1; last naive_solver.
|
|
|
|
|
destruct B as [|B1 B2]; try naive_solver.
|
|
|
|
|
destruct (infer_type Γ E2) as [C|] eqn: Heq2; last naive_solver.
|
|
|
|
|
destruct type_eq eqn: Heq3; last naive_solver.
|
|
|
|
|
injection 1 as <-. eapply Is_true_eq_left in Heq3.
|
|
|
|
|
eapply type_eq_iff in Heq3 as ->.
|
|
|
|
|
eauto.
|
|
|
|
|
- destruct infer_type as [B|] eqn: Heq1; last naive_solver.
|
|
|
|
|
destruct B; try naive_solver.
|
|
|
|
|
destruct (infer_type Γ E2) as [C|] eqn: Heq2; last naive_solver.
|
|
|
|
|
destruct C; naive_solver.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma typing_infer_type Γ E A:
|
|
|
|
|
(Γ ⊢S E : A)%ty → infer_type Γ E = Some A.
|
|
|
|
|
Proof.
|
|
|
|
|
induction 1; simpl; eauto.
|
|
|
|
|
- by rewrite IHsrc_typed.
|
|
|
|
|
- rewrite IHsrc_typed1 IHsrc_typed2.
|
|
|
|
|
rewrite (Is_true_eq_true (type_eq A A)) //=.
|
|
|
|
|
by eapply type_eq_iff.
|
|
|
|
|
- by rewrite IHsrc_typed1 IHsrc_typed2.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** ** Exercise 6: untypable, safe term *)
|
|
|
|
|
|
|
|
|
|
(* The exercise asks you to:
|
|
|
|
|
"Give one example if there is such an expression, otherwise prove their non-existence."
|
|
|
|
|
So either finish one section or the other.
|
|
|
|
|
*)
|
|
|
|
|
|
|
|
|
|
Section give_example.
|
|
|
|
|
Definition ust : expr := (λ: "f", 5) (λ: "x", 0 0)%E.
|
|
|
|
|
|
|
|
|
|
Lemma ust_safe e':
|
|
|
|
|
rtc step ust e' → is_val e' ∨ reducible e'.
|
|
|
|
|
Proof.
|
|
|
|
|
inversion 1 as [ | x y z H1 H2]; subst.
|
|
|
|
|
- right. eexists. eapply StepBeta. done.
|
|
|
|
|
- inversion H1 as [??? Ha | ??? Ha Hb | ??? Ha | | ??? Ha Hb | ??? Ha ]; subst.
|
|
|
|
|
+ simpl in H2. inversion H2 as [ | ??? [] _]; subst; eauto.
|
|
|
|
|
+ inversion Hb.
|
|
|
|
|
+ inversion Ha.
|
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
Lemma ust_no_type Γ A:
|
|
|
|
|
¬ (Γ ⊢ ust : A)%ty.
|
|
|
|
|
Proof.
|
|
|
|
|
intros H. inversion H; subst.
|
|
|
|
|
inversion H5; subst. inversion H6; subst.
|
|
|
|
|
inversion H4.
|
|
|
|
|
Qed.
|
|
|
|
|
End give_example.
|
|
|
|
|
|
|
|
|
|
Section prove_non_existence.
|
|
|
|
|
Lemma no_ust :
|
|
|
|
|
∀ e, (∀ e', rtc step e e' → is_val e' ∨ reducible e') → ∃ A, (∅ ⊢ e : A)%ty.
|
|
|
|
|
Proof.
|
|
|
|
|
(* This is not possible as shown above *)
|
|
|
|
|
Abort.
|
|
|
|
|
End prove_non_existence.
|