|
|
|
From semantics.ts.stlc_extended Require Export lang.
|
|
|
|
|
|
|
|
(** The stepping relation *)
|
|
|
|
|
|
|
|
Inductive base_step : expr → expr → Prop :=
|
|
|
|
| BetaS x e1 e2 e' :
|
|
|
|
is_val e2 →
|
|
|
|
e' = subst' x e2 e1 →
|
|
|
|
base_step (App (Lam x e1) e2) e'
|
|
|
|
| PlusS e1 e2 (n1 n2 n3 : Z):
|
|
|
|
e1 = (LitInt n1) →
|
|
|
|
e2 = (LitInt n2) →
|
|
|
|
(n1 + n2)%Z = n3 →
|
|
|
|
base_step (Plus e1 e2) (LitInt n3)
|
|
|
|
| FstS v1 v2:
|
|
|
|
is_val v1 →
|
|
|
|
is_val v2 →
|
|
|
|
base_step (Fst (Pair v1 v2)) v1
|
|
|
|
| SndS v1 v2:
|
|
|
|
is_val v1 →
|
|
|
|
is_val v2 →
|
|
|
|
base_step (Snd (Pair v1 v2)) v2
|
|
|
|
| CaseLS v e1 e2:
|
|
|
|
is_val v →
|
|
|
|
base_step (Case (InjL v) e1 e2) (App e1 v)
|
|
|
|
| CaseRS v e1 e2:
|
|
|
|
is_val v →
|
|
|
|
base_step (Case (InjR v) e1 e2) (App e2 v)
|
|
|
|
.
|
|
|
|
|
|
|
|
#[export] Hint Constructors base_step : core.
|
|
|
|
|
|
|
|
(** We define evaluation contexts *)
|
|
|
|
Inductive ectx :=
|
|
|
|
| HoleCtx
|
|
|
|
| AppLCtx (K: ectx) (v2 : val)
|
|
|
|
| AppRCtx (e1 : expr) (K: ectx)
|
|
|
|
| PlusLCtx (K: ectx) (v2 : val)
|
|
|
|
| PlusRCtx (e1 : expr) (K: ectx)
|
|
|
|
| PairLCtx (K: ectx) (v2: val)
|
|
|
|
| PairRCtx (e1: expr) (K: ectx)
|
|
|
|
| FstCtx (K: ectx)
|
|
|
|
| SndCtx (K: ectx)
|
|
|
|
| InjLCtx (K: ectx)
|
|
|
|
| InjRCtx (K: ectx)
|
|
|
|
| CaseCtx (K: ectx) (e1: expr) (e2: expr)
|
|
|
|
.
|
|
|
|
|
|
|
|
Fixpoint fill (K : ectx) (e : expr) : expr :=
|
|
|
|
match K with
|
|
|
|
| HoleCtx => e
|
|
|
|
| AppLCtx K v2 => App (fill K e) (of_val v2)
|
|
|
|
| AppRCtx e1 K => App e1 (fill K e)
|
|
|
|
| PlusLCtx K v2 => Plus (fill K e) (of_val v2)
|
|
|
|
| PlusRCtx e1 K => Plus e1 (fill K e)
|
|
|
|
| PairLCtx K v2 => Pair (fill K e) (of_val v2)
|
|
|
|
| PairRCtx e1 K => Pair e1 (fill K e)
|
|
|
|
| FstCtx K => Fst (fill K e)
|
|
|
|
| SndCtx K => Snd (fill K e)
|
|
|
|
| InjLCtx K => InjL (fill K e)
|
|
|
|
| InjRCtx K => InjR (fill K e)
|
|
|
|
| CaseCtx K e1 e2 => Case (fill K e) e1 e2
|
|
|
|
end.
|
|
|
|
|
|
|
|
Fixpoint comp_ectx (K: ectx) (K' : ectx) : ectx :=
|
|
|
|
match K with
|
|
|
|
| HoleCtx => K'
|
|
|
|
| AppLCtx K v2 => AppLCtx (comp_ectx K K') v2
|
|
|
|
| AppRCtx e1 K => AppRCtx e1 (comp_ectx K K')
|
|
|
|
| PlusLCtx K v2 => PlusLCtx (comp_ectx K K') v2
|
|
|
|
| PlusRCtx e1 K => PlusRCtx e1 (comp_ectx K K')
|
|
|
|
| PairLCtx K v2 => PairLCtx (comp_ectx K K') v2
|
|
|
|
| PairRCtx e1 K => PairRCtx e1 (comp_ectx K K')
|
|
|
|
| FstCtx K => FstCtx (comp_ectx K K')
|
|
|
|
| SndCtx K => SndCtx (comp_ectx K K')
|
|
|
|
| InjLCtx K => InjLCtx (comp_ectx K K')
|
|
|
|
| InjRCtx K => InjRCtx (comp_ectx K K')
|
|
|
|
| CaseCtx K e1 e2 => CaseCtx (comp_ectx K K') e1 e2
|
|
|
|
end.
|
|
|
|
|
|
|
|
(** Contextual steps *)
|
|
|
|
Inductive contextual_step (e1 : expr) (e2 : expr) : Prop :=
|
|
|
|
Ectx_step K e1' e2' :
|
|
|
|
e1 = fill K e1' → e2 = fill K e2' →
|
|
|
|
base_step e1' e2' → contextual_step e1 e2.
|
|
|
|
|
|
|
|
#[export] Hint Constructors contextual_step : core.
|
|
|
|
|
|
|
|
Definition reducible (e : expr) :=
|
|
|
|
∃ e', contextual_step e e'.
|
|
|
|
|
|
|
|
Definition empty_ectx := HoleCtx.
|
|
|
|
|
|
|
|
(** Basic properties about the language *)
|
|
|
|
Lemma fill_empty e : fill empty_ectx e = e.
|
|
|
|
Proof. done. Qed.
|
|
|
|
|
|
|
|
Lemma fill_comp (K1 K2 : ectx) e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e.
|
|
|
|
Proof. induction K1; simpl; congruence. Qed.
|
|
|
|
|
|
|
|
Lemma base_contextual_step e1 e2 :
|
|
|
|
base_step e1 e2 → contextual_step e1 e2.
|
|
|
|
Proof. apply Ectx_step with empty_ectx; by rewrite ?fill_empty. Qed.
|
|
|
|
|
|
|
|
Lemma fill_contextual_step K e1 e2 :
|
|
|
|
contextual_step e1 e2 → contextual_step (fill K e1) (fill K e2).
|
|
|
|
Proof.
|
|
|
|
destruct 1 as [K' e1' e2' -> ->].
|
|
|
|
rewrite !fill_comp. by econstructor.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
(** We derive a few lemmas about contextual steps:
|
|
|
|
these essentially provide rules for structural lifting
|
|
|
|
akin to the structural semantics.
|
|
|
|
*)
|
|
|
|
Lemma contextual_step_app_l e1 e1' e2:
|
|
|
|
is_val e2 →
|
|
|
|
contextual_step e1 e1' →
|
|
|
|
contextual_step (App e1 e2) (App e1' e2).
|
|
|
|
Proof.
|
|
|
|
intros [v <-%of_to_val]%is_val_spec Hcontextual.
|
|
|
|
by eapply (fill_contextual_step (AppLCtx HoleCtx v)).
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
Lemma contextual_step_app_r e1 e2 e2':
|
|
|
|
contextual_step e2 e2' →
|
|
|
|
contextual_step (App e1 e2) (App e1 e2').
|
|
|
|
Proof.
|
|
|
|
intros Hcontextual.
|
|
|
|
by eapply (fill_contextual_step (AppRCtx 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 [v <-%of_to_val]%is_val_spec Hcontextual.
|
|
|
|
by eapply (fill_contextual_step (PlusLCtx HoleCtx v)).
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
Lemma contextual_step_plus_r e1 e2 e2':
|
|
|
|
contextual_step e2 e2' →
|
|
|
|
contextual_step (Plus e1 e2) (Plus e1 e2').
|
|
|
|
Proof.
|
|
|
|
intros Hcontextual.
|
|
|
|
by eapply (fill_contextual_step (PlusRCtx e1 HoleCtx)).
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
Ltac is_val_to_val v H :=
|
|
|
|
rewrite (is_val_spec _) in H; destruct H as [v H]; apply of_to_val in H; symmetry in H.
|
|
|
|
|
|
|
|
Lemma contextual_step_pair_l e1 e1' e2:
|
|
|
|
is_val e2 →
|
|
|
|
contextual_step e1 e1' →
|
|
|
|
contextual_step (Pair e1 e2) (Pair e1' e2).
|
|
|
|
Proof.
|
|
|
|
intros H_val H_ctx.
|
|
|
|
is_val_to_val v2 H_val.
|
|
|
|
rewrite H_val.
|
|
|
|
eapply (fill_contextual_step (PairLCtx HoleCtx v2)).
|
|
|
|
assumption.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
Lemma contextual_step_pair_r e1 e2 e2':
|
|
|
|
contextual_step e2 e2' →
|
|
|
|
contextual_step (Pair e1 e2) (Pair e1 e2').
|
|
|
|
Proof.
|
|
|
|
intro H_ctx.
|
|
|
|
eapply (fill_contextual_step (PairRCtx e1 HoleCtx)).
|
|
|
|
assumption.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_fst e e':
|
|
|
|
contextual_step e e' →
|
|
|
|
contextual_step (Fst e) (Fst e').
|
|
|
|
Proof.
|
|
|
|
intro H_ctx.
|
|
|
|
eapply (fill_contextual_step (FstCtx HoleCtx)).
|
|
|
|
assumption.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_snd e e':
|
|
|
|
contextual_step e e' →
|
|
|
|
contextual_step (Snd e) (Snd e').
|
|
|
|
Proof.
|
|
|
|
intro H_ctx.
|
|
|
|
eapply (fill_contextual_step (SndCtx HoleCtx)).
|
|
|
|
assumption.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_injl e e':
|
|
|
|
contextual_step e e' →
|
|
|
|
contextual_step (InjL e) (InjL e').
|
|
|
|
Proof.
|
|
|
|
intro H_ctx.
|
|
|
|
eapply (fill_contextual_step (InjLCtx HoleCtx)).
|
|
|
|
assumption.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_injr e e':
|
|
|
|
contextual_step e e' →
|
|
|
|
contextual_step (InjR e) (InjR e').
|
|
|
|
Proof.
|
|
|
|
intro H_ctx.
|
|
|
|
eapply (fill_contextual_step (InjRCtx HoleCtx)).
|
|
|
|
assumption.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
Lemma contextual_step_case e e' e1 e2:
|
|
|
|
contextual_step e e' →
|
|
|
|
contextual_step (Case e e1 e2) (Case e' e1 e2).
|
|
|
|
Proof.
|
|
|
|
intro H_ctx.
|
|
|
|
eapply (fill_contextual_step (CaseCtx HoleCtx e1 e2)).
|
|
|
|
assumption.
|
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
|
|
|
#[global]
|
|
|
|
Hint Resolve
|
|
|
|
contextual_step_app_l contextual_step_app_r contextual_step_plus_l contextual_step_plus_r
|
|
|
|
contextual_step_case contextual_step_fst contextual_step_injl contextual_step_injr
|
|
|
|
contextual_step_pair_l contextual_step_pair_r contextual_step_snd : core.
|