(** Some derived lemmas for ectx-based languages *)
From iris.proofmode Require Import proofmode.
From iris.program_logic Require Export ectx_language.
From semantics.pl.program_logic Require Export sequential_wp lifting.
From iris.prelude Require Import options.

Section wp.
Context {Λ : ectxLanguage} `{!irisGS Λ Σ} {Hinh : Inhabited (state Λ)}.
Implicit Types s : stuckness.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Local Hint Resolve head_prim_reducible head_reducible_prim_step : core.
Local Definition reducible_not_val_inhabitant e := reducible_not_val e inhabitant.
Local Hint Resolve reducible_not_val_inhabitant : core.
Local Hint Resolve head_stuck_stuck : core.

Lemma wp_lift_head_step_fupd {s E1 E2 Φ} e1 :
  to_val e1 = None →
  (|={E1, ∅}=> ∀ σ1, state_interp σ1 ={∅,∅}=∗
    ⌜head_reducible e1 σ1⌝ ∗
    ∀ e2 σ2 κ efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅}=>
      state_interp σ2 ∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗
      WP e2 @ s; ∅; E2 {{ Φ }})
  ⊢ WP e1 @ s; E1; E2 {{ Φ }}.
Proof.
  iIntros (?) "H". iApply wp_lift_step_fupd=>//. iMod "H". iIntros "!>" (σ1) "Hσ".
  iMod ("H" with "Hσ") as "[% H]"; iModIntro.
  iSplit; first by destruct s; eauto. iIntros (e2 σ2 κ efs ?).
  iApply (step_fupd_wand with "(H []) []"); first eauto.
  iIntros "($ & $ & $)".
Qed.

Lemma wp_lift_head_step {s E1 E2 Φ} e1 :
  to_val e1 = None →
  (|={E1, ∅}=> ∀ σ1, state_interp σ1 ={∅}=∗
    ⌜head_reducible e1 σ1⌝ ∗
    ▷ ∀ e2 σ2 κ efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅}=∗
      state_interp σ2 ∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ WP e2 @ s; ∅; E2 {{ Φ }})
  ⊢ WP e1 @ s; E1; E2 {{ Φ }}.
Proof.
  iIntros (?) "H". iApply wp_lift_head_step_fupd; [done|]. iMod "H".
  iIntros "!>" (?) "?".
  iMod ("H" with "[$]") as "[$ H]". iIntros "!>" (e2 σ2 κ efs ?) "!> !>". by iApply "H".
Qed.

Lemma wp_lift_head_step_fupd_nomask {s E1 E2 E3 Φ} e1 :
  to_val e1 = None →
  (∀ σ1, state_interp σ1 ={E1}=∗
    ⌜head_reducible e1 σ1⌝ ∗
    ∀ e2 σ2 κ efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E1}[E3]▷=∗
      state_interp σ2 ∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗
      WP e2 @ s; E1; E2 {{ Φ }})
  ⊢ WP e1 @ s; E1; E2 {{ Φ }}.
Proof.
  iIntros (?) "H". iApply wp_lift_step_fupd_nomask; [done|].
  iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
  iSplit; first by destruct s; auto. iIntros (e2 σ2 κ efs Hstep).
  iApply (step_fupd_wand with "(H []) []"); first by eauto.
  iIntros "($ & $)".
Qed.

Lemma wp_lift_pure_det_head_step {s E1 E2 E' Φ} e1 e2 :
  to_val e1 = None →
  (∀ σ1, head_reducible e1 σ1) →
  (∀ σ1 κ e2' σ2 efs',
    head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
  (|={E1}[E']▷=> WP e2 @ s; E1; E2 {{ Φ }}) ⊢ WP e1 @ s; E1; E2 {{ Φ }}.
Proof using Hinh.
  intros. rewrite -(wp_lift_pure_det_step e1 e2); eauto.
  destruct s; by auto.
Qed.

Lemma wp_lift_pure_det_head_step' {s E1 E2 Φ} e1 e2 :
  to_val e1 = None →
  (∀ σ1, head_reducible e1 σ1) →
  (∀ σ1 κ e2' σ2 efs',
    head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
  ▷ WP e2 @ s; E1; E2 {{ Φ }} ⊢ WP e1 @ s; E1; E2 {{ Φ }}.
Proof using Hinh.
  intros. rewrite -[(WP e1 @ s; _ {{ _ }})%I]wp_lift_pure_det_head_step //.
  rewrite -step_fupd_intro //.
Qed.
End wp.