parent 2463dae8
 ... ... @@ -3,28 +3,29 @@ From iris.proofmode Require Import tactics. From iris_logrel.F_mu Require Import rules. From iris.algebra Require Export upred_big_op. Definition log_typed {Σ} (Γ : list type) (e : expr) (τ : type) := ∀ Δ vs, @env_PersistentP Σ Δ → Definition log_typed `{irisG lang Σ} (Γ : list type) (e : expr) (τ : type) := ∀ Δ vs, env_PersistentP Δ → ⟦ Γ ⟧* Δ vs ⊢ ⟦ τ ⟧ₑ Δ e.[env_subst vs]. Notation "Γ ⊨ e : τ" := (log_typed Γ e τ) (at level 74, e, τ at next level). Section fundamental. Context {Σ : iFunctor}. Notation D := (valC -n> iProp lang Σ). Context `{irisG lang Σ}. Notation D := (valC -n> iProp Σ). Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) constr(Hv) uconstr(Hp) := iApply (@wp_bind _ _ _ [ctx]); iApply (wp_bind [ctx]); iApply wp_wand_l; iSplitL; [|iApply Hp; trivial]; cbn; iIntros {v} Hv. iIntros (v) Hv. Local Ltac value_case := iApply wp_value; cbn; rewrite ?to_of_val; trivial. Theorem fundamental Γ e τ : Γ ⊢ₜ e : τ → log_typed (Σ:=Σ) Γ e τ. Theorem fundamental Γ e τ : Γ ⊢ₜ e : τ → log_typed Γ e τ. Proof. induction 1; iIntros {Δ vs HΔ} "#HΓ"; cbn. induction 1; iIntros (Δ vs HΔ) "#HΓ"; cbn. - (* var *) iDestruct (interp_env_Some_l with "HΓ") as {v} "[% ?]"; first done. iDestruct (interp_env_Some_l with "HΓ") as (v) "[% ?]"; first done. rewrite /env_subst. simplify_option_eq. by value_case. - (* unit *) value_case. - (* pair *) ... ... @@ -33,11 +34,11 @@ Section fundamental. value_case; eauto 10. - (* fst *) smart_wp_bind (FstCtx) v "# Hv" IHtyped; cbn. iDestruct "Hv" as {w1 w2} "#[% [H2 H3]]"; subst. iDestruct "Hv" as (w1 w2) "#[% [H2 H3]]"; subst. iApply wp_fst; eauto using to_of_val. - (* snd *) smart_wp_bind (SndCtx) v "# Hv" IHtyped; cbn. iDestruct "Hv" as {w1 w2} "#[% [H2 H3]]"; subst. iDestruct "Hv" as (w1 w2) "#[% [H2 H3]]"; subst. iApply wp_snd; eauto using to_of_val. - (* injl *) smart_wp_bind (InjLCtx) v "# Hv" IHtyped; cbn. ... ... @@ -48,7 +49,7 @@ Section fundamental. - (* case *) smart_wp_bind (CaseCtx _ _) v "#Hv" IHtyped1; cbn. iDestruct (interp_env_length with "HΓ") as %?. iDestruct "Hv" as "[Hv|Hv]"; iDestruct "Hv" as {w} "[% Hw]"; simplify_eq/=. iDestruct "Hv" as "[Hv|Hv]"; iDestruct "Hv" as (w) "[% Hw]"; simplify_eq/=. + iApply wp_case_inl; auto 1 using to_of_val; asimpl. iNext. erewrite typed_subst_head_simpl by naive_solver. iApply (IHtyped2 Δ (w :: vs)). iApply interp_env_cons; auto. ... ... @@ -56,7 +57,7 @@ Section fundamental. erewrite typed_subst_head_simpl by naive_solver. iApply (IHtyped3 Δ (w :: vs)). iApply interp_env_cons; auto. - (* lam *) value_case; iAlways; iIntros {w} "#Hw". value_case; iAlways; iIntros (w) "#Hw". iDestruct (interp_env_length with "HΓ") as %?. iApply wp_lam; auto 1 using to_of_val. iNext. asimpl. erewrite typed_subst_head_simpl by naive_solver. ... ... @@ -67,25 +68,25 @@ Section fundamental. iApply wp_mono; [|iApply "Hv"]; auto. - (* TLam *) value_case. iAlways; iIntros { τi } "%". iApply wp_TLam; iNext. iAlways; iIntros (τi) "%". iApply wp_tlam; iNext. iApply IHtyped. by iApply interp_env_ren. - (* TApp *) smart_wp_bind TAppCtx v "#Hv" IHtyped; cbn. iApply wp_wand_r; iSplitL; [iApply ("Hv" \$! (⟦ τ' ⟧ Δ)); iPureIntro; apply _|]. iIntros {w} "?". by rewrite interp_subst. iIntros (w) "?". by rewrite interp_subst. - (* Fold *) iApply (@wp_bind _ _ _ [FoldCtx]); iApply (wp_bind [FoldCtx]); iApply wp_wand_l; iSplitL; [|iApply (IHtyped Δ vs); auto]. iIntros {v} "#Hv". value_case. iIntros (v) "#Hv". value_case. rewrite /= -interp_subst fixpoint_unfold /=. iAlways; eauto. - (* Unfold *) iApply (@wp_bind _ _ _ [UnfoldCtx]); iApply (wp_bind [UnfoldCtx]); iApply wp_wand_l; iSplitL; [|iApply IHtyped; trivial]. iIntros {v} "#Hv". rewrite /= fixpoint_unfold. iIntros (v) "#Hv". rewrite /= fixpoint_unfold. change (fixpoint _) with (⟦ TRec τ ⟧ Δ); simpl. iDestruct "Hv" as {w} "#[% Hw]"; subst. iApply wp_Fold; cbn; auto using to_of_val. by rewrite -interp_subst. iDestruct "Hv" as (w) "#[% Hw]"; subst; simpl. iApply wp_fold. by rewrite to_of_val. iNext. by rewrite -interp_subst. Qed. End fundamental.
 From iris.proofmode Require Import tactics. From iris.program_logic Require Export weakestpre. From iris_logrel.F_mu Require Export lang typing. From iris.algebra Require Import list upred_big_op. Import uPred. (** interp : is a unary logical relation. *) Section logrel. Context {Σ : iFunctor}. Notation D := (valC -n> iProp lang Σ). Context `{irisG lang Σ}. Notation D := (valC -n> iProp Σ). Implicit Types τi : D. Implicit Types Δ : listC D. Implicit Types interp : listC D → D. ... ... @@ -45,15 +46,15 @@ Section logrel. Global Instance interp_rec1_contractive (interp : listC D -n> D) (Δ : listC D) : Contractive (interp_rec1 interp Δ). Proof. intros n τi1 τi2 H w; cbn. intros n τi1 τi2 Hτi w; cbn. apply always_ne, exist_ne; intros v; apply and_ne; trivial. apply later_contractive =>i Hi. by rewrite H. apply later_contractive =>i Hi. by rewrite Hτi. Qed. Program Definition interp_rec (interp : listC D -n> D) : listC D -n> D := λne Δ, fixpoint (interp_rec1 interp Δ). Next Obligation. intros interp n Δ1 Δ2 H; apply fixpoint_ne => τi w. solve_proper. intros interp n Δ1 Δ2 HΔ; apply fixpoint_ne => τi w. solve_proper. Qed. Fixpoint interp (τ : type) : listC D -n> D := ... ... @@ -69,11 +70,11 @@ Section logrel. Notation "⟦ τ ⟧" := (interp τ). Definition interp_env (Γ : list type) (Δ : listC D) (vs : list val) : iProp lang Σ := (Δ : listC D) (vs : list val) : iProp Σ := (length Γ = length vs ∧ [∧] zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vs)%I. Notation "⟦ Γ ⟧*" := (interp_env Γ). Definition interp_expr (τ : type) (Δ : listC D) (e : expr) : iProp lang Σ := Definition interp_expr (τ : type) (Δ : listC D) (e : expr) : iProp Σ := WP e {{ ⟦ τ ⟧ Δ }}%I. Class env_PersistentP Δ := ... ... @@ -97,7 +98,7 @@ Section logrel. env_PersistentP Δ → PersistentP (⟦ Γ ⟧* Δ vs) := _. Lemma interp_weaken Δ1 Π Δ2 τ : ⟦ τ.[iter (length Δ1) up (ren (+ length Π))] ⟧ (Δ1 ++ Π ++ Δ2) ⟦ τ.[upn (length Δ1) (ren (+ length Π))] ⟧ (Δ1 ++ Π ++ Δ2) ≡ ⟦ τ ⟧ (Δ1 ++ Δ2). Proof. revert Δ1 Π Δ2. induction τ=> Δ1 Π Δ2; simpl; auto. ... ... @@ -108,14 +109,13 @@ Section logrel. properness; auto. apply (IHτ (_ :: _)). - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl. { by rewrite !lookup_app_l. } change (uPredC (iResUR lang Σ)) with (iProp lang Σ). rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia. done. - intros w; simpl; properness; auto. apply (IHτ (_ :: _)). Qed. Lemma interp_subst_up Δ1 Δ2 τ τ' : ⟦ τ ⟧ (Δ1 ++ interp τ' Δ2 :: Δ2) ≡ ⟦ τ.[iter (length Δ1) up (τ' .: ids)] ⟧ (Δ1 ++ Δ2). ≡ ⟦ τ.[upn (length Δ1) (τ' .: ids)] ⟧ (Δ1 ++ Δ2). Proof. revert Δ1 Δ2; induction τ=> Δ1 Δ2; simpl. - done. ... ... @@ -126,11 +126,9 @@ Section logrel. properness; auto. apply (IHτ (_ :: _)). - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl. { by rewrite !lookup_app_l. } change (uPredC (iResUR lang Σ)) with (iProp lang Σ). rewrite !lookup_app_r; [|lia ..]. destruct (x - length Δ1) as [|n] eqn:?; simpl. { symmetry. asimpl. apply (interp_weaken [] Δ1 Δ2 τ'). } change (uPredC (iResUR lang Σ)) with (iProp lang Σ). rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia. done. - intros w; simpl; properness; auto. apply (IHτ (_ :: _)). Qed. ... ... @@ -144,7 +142,7 @@ Section logrel. Lemma interp_env_Some_l Δ Γ vs x τ : Γ !! x = Some τ → ⟦ Γ ⟧* Δ vs ⊢ ∃ v, vs !! x = Some v ∧ ⟦ τ ⟧ Δ v. Proof. iIntros {?} "[Hlen HΓ]"; iDestruct "Hlen" as %Hlen. iIntros (?) "[Hlen HΓ]"; iDestruct "Hlen" as %Hlen. destruct (lookup_lt_is_Some_2 vs x) as [v Hv]. { by rewrite -Hlen; apply lookup_lt_Some with τ. } iExists v; iSplit. done. iApply (big_and_elem_of with "HΓ"). ... ...