From iris.proofmode Require Import tactics monpred.
From iris.algebra Require Import frac.
From iris.base_logic Require Import base_logic.
From iris.base_logic.lib Require Import invariants cancelable_invariants na_invariants.

Section base_logic_tests.
  Context {M : ucmraT}.
  Implicit Types P Q R : uPred M.

  (* Test scopes for bupd *)
  Definition use_bupd_uPred (n : nat) : uPred M :=
    □ |==> ∃ m : nat , ⌜ n = 2 ⌝.
  Definition use_plainly_uPred (n : nat) : uPred M :=
    ■ |==> ∃ m : nat , ⌜ n = 2 ⌝.

  Lemma test_random_stuff (P1 P2 P3 : nat → uPred M) :
    ⊢ ∀ (x y : nat) a b,
      x ≡ y →
      □ (uPred_ownM (a ⋅ b) -∗
      (∃ y1 y2 c, P1 ((x + y1) + y2) ∧ True ∧ □ uPred_ownM c) -∗
      □ ▷ (∀ z, P2 z ∨ True → P2 z) -∗
      ▷ (∀ n m : nat, P1 n → □ ((True ∧ P2 n) → □ (⌜n = n⌝ ↔ P3 n))) -∗
      ▷ ⌜x = 0⌝ ∨ ∃ x z, ▷ P3 (x + z) ∗ uPred_ownM b ∗ uPred_ownM (core b)).
  Proof.
    iIntros (i [|j] a b ?) "!> [Ha Hb] H1 #H2 H3"; setoid_subst.
    { iLeft. by iNext. }
    iRight.
    iDestruct "H1" as (z1 z2 c) "(H1&_&#Hc)".
    iPoseProof "Hc" as "foo".
    iRevert (a b) "Ha Hb". iIntros (b a) "Hb {foo} Ha".
    iAssert (uPred_ownM (a ⋅ core a)) with "[Ha]" as "[Ha #Hac]".
    { by rewrite cmra_core_r. }
    iIntros "{$Hac $Ha}".
    iExists (S j + z1), z2.
    iNext.
    iApply ("H3" $! _ 0 with "[$]").
    - iSplit. done. iApply "H2". iLeft. iApply "H2". by iRight.
    - done.
  Qed.

  Lemma test_iFrame_pure (x y z : M) :
    ✓ x → ⌜y ≡ z⌝ -∗ (✓ x ∧ ✓ x ∧ y ≡ z : uPred M).
  Proof. iIntros (Hv) "Hxy". by iFrame (Hv) "Hxy". Qed.

  Lemma test_iAssert_modality P : (|==> False) -∗ |==> P.
  Proof. iIntros. iAssert False%I with "[> - //]" as %[]. Qed.

  Lemma test_iStartProof_1 P : P -∗ P.
  Proof. iStartProof. iStartProof. iIntros "$". Qed.
  Lemma test_iStartProof_2 P : P -∗ P.
  Proof. iStartProof (uPred _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_3 P : P -∗ P.
  Proof. iStartProof (uPredI _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_4 P : P -∗ P.
  Proof. iStartProof (uPredI _). iStartProof (uPred _). iIntros "$". Qed.
End base_logic_tests.

Section iris_tests.
  Context `{!invG Σ, !cinvG Σ, !na_invG Σ}.
  Implicit Types P Q R : iProp Σ.

  (* Test scopes for bupd and fupd *)
  Definition use_bupd_iProp (n : nat) : iProp Σ :=
    □ |==> ∃ m : nat , ⌜ n = 2 ⌝.
  Definition use_fupd_iProp (n : nat) : iProp Σ :=
    □ |={⊤}=> ∃ m : nat , ⌜ n = 2 ⌝.

  Lemma test_masks  N E P Q R :
    ↑N ⊆ E →
    (True -∗ P -∗ inv N Q -∗ True -∗ R) -∗ P -∗ ▷ Q ={E}=∗ R.
  Proof.
    iIntros (?) "H HP HQ".
    iApply ("H" with "[% //] [$] [> HQ] [> //]").
    by iApply inv_alloc.
  Qed.

  Lemma test_iInv_0 N P: inv N (<pers> P) ={⊤}=∗ ▷ P.
  Proof.
    iIntros "#H".
    iInv N as "#H2". Show.
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_0_with_close N P: inv N (<pers> P) ={⊤}=∗ ▷ P.
  Proof.
    iIntros "#H".
    iInv N as "#H2" "Hclose". Show.
    iMod ("Hclose" with "H2").
    iModIntro. by iNext.
  Qed.

  Lemma test_iInv_1 N E P:
    ↑N ⊆ E →
    inv N (<pers> P) ={E}=∗ ▷ P.
  Proof.
    iIntros (?) "#H".
    iInv N as "#H2".
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_2 γ p N P:
    cinv N γ (<pers> P) ∗ cinv_own γ p ={⊤}=∗ cinv_own γ p ∗ ▷ P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)". Show.
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_2_with_close γ p N P:
    cinv N γ (<pers> P) ∗ cinv_own γ p ={⊤}=∗ cinv_own γ p ∗ ▷ P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)" "Hclose". Show.
    iMod ("Hclose" with "HP").
    iModIntro. iFrame. by iNext.
  Qed.

  Lemma test_iInv_3 γ p1 p2 N P:
    cinv N γ (<pers> P) ∗ cinv_own γ p1 ∗ cinv_own γ p2
      ={⊤}=∗ cinv_own γ p1 ∗ cinv_own γ p2  ∗ ▷ P.
  Proof.
    iIntros "(#?&Hown1&Hown2)".
    iInv N with "[Hown2 //]" as "(#HP&Hown2)".
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_4 t N E1 E2 P:
    ↑N ⊆ E2 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
         ⊢ |={⊤}=> na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)". Show.
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_4_with_close t N E1 E2 P:
    ↑N ⊆ E2 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
         ⊢ |={⊤}=> na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)" "Hclose". Show.
    iMod ("Hclose" with "[HP Hown2]").
    { iFrame. done. }
    iModIntro. iFrame. by iNext.
  Qed.

  (* test named selection of which na_own to use *)
  Lemma test_iInv_5 t N E1 E2 P:
    ↑N ⊆ E2 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown2" as "(#HP&Hown2)".
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_6 t N E1 E2 P:
    ↑N ⊆ E1 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test robustness in presence of other invariants *)
  Lemma test_iInv_7 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 →
    inv N1 P ∗ na_inv t N3 (<pers> P) ∗ inv N2 P  ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&#?&#?&Hown1&Hown2)".
    iInv N3 with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* iInv should work even where we have "inv N P" in which P contains an evar *)
  Lemma test_iInv_8 N : ∃ P, inv N P ={⊤}=∗ P ≡ True ∧ inv N P.
  Proof.
    eexists. iIntros "#H".
    iInv N as "HP". iFrame "HP". auto.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_9 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 →
    inv N1 P ∗ na_inv t N3 (<pers> P) ∗ inv N2 P  ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_10 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 →
    inv N1 P ∗ na_inv t N3 (<pers> P) ∗ inv N2 P  ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by ident name *)
  Lemma test_iInv_11 N P: inv N (<pers> P) ={⊤}=∗ ▷ P.
  Proof.
    let H := iFresh in
    (iIntros H; iInv H as "#H2"). auto.
  Qed.

  (* error messages *)
  Check "test_iInv_12".
  Lemma test_iInv_12 N P: inv N (<pers> P) ={⊤}=∗ True.
  Proof.
    iIntros "H".
    Fail iInv 34 as "#H2".
    Fail iInv nroot as "#H2".
    Fail iInv "H2" as "#H2".
    done.
  Qed.

  (* test destruction of existentials when opening an invariant *)
  Lemma test_iInv_13 N:
    inv N (∃ (v1 v2 v3 : nat), emp ∗ emp ∗ emp) ={⊤}=∗ ▷ emp.
  Proof.
    iIntros "H"; iInv "H" as (v1 v2 v3) "(?&?&_)".
    eauto.
  Qed.

  Theorem test_iApply_inG `{!inG Σ A} γ (x x' : A) :
    x' ≼ x →
    own γ x -∗ own γ x'.
  Proof. intros. by iApply own_mono. Qed.

  Check "test_frac_split_combine".
  Lemma test_frac_split_combine `{!inG Σ fracR} γ :
    own γ 1%Qp -∗ own γ 1%Qp.
  Proof.
    iIntros "[H1 H2]". Show.
    iCombine "H1 H2" as "H". Show.
    iExact "H".
  Qed.

End iris_tests.

Section monpred_tests.
  Context `{!invG Σ}.
  Context {I : biIndex}.
  Local Notation monPred := (monPred I (iPropI Σ)).
  Local Notation monPredI := (monPredI I (iPropI Σ)).
  Implicit Types P Q R : monPred.
  Implicit Types 𝓟 𝓠 𝓡 : iProp Σ.

  Check "test_iInv".
  Lemma test_iInv N E 𝓟 :
    ↑N ⊆ E →
    ⎡inv N 𝓟⎤ ⊢@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP". Show.
    iFrame "HP". auto.
  Qed.

  Check "test_iInv_with_close".
  Lemma test_iInv_with_close N E 𝓟 :
    ↑N ⊆ E →
    ⎡inv N 𝓟⎤ ⊢@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP" "Hclose". Show.
    iMod ("Hclose" with "HP"). auto.
  Qed.

End monpred_tests.


Require Import
  HoTT.Types.Universe
  HoTT.Types.Sigma
  HoTT.Types.Prod
  HoTT.Types.Arrow.
Require Export
  HoTT.Classes.interfaces.abstract_algebra.
Require Import HoTT.Classes.theory.rings.

Module SemiRings.

Class Operations
  := operations : sigT (fun T => Plus T * Mult T * Zero T * One T)%type.

Definition BuildOperations (T : Type) `{Plus T} `{Mult T} `{Zero T} `{One T}
  : Operations
  := existT _ T (plus,mult,zero,one).

Coercion SR_carrier (s : Operations) : Type := s.1.
Instance SR_plus (s : Operations) : Plus s := fst (fst (fst s.2)).
Instance SR_mult (s : Operations) : Mult s := snd (fst (fst s.2)).
Instance SR_zero (s : Operations) : Zero s := snd (fst s.2).
Instance SR_one (s : Operations) : One s := snd s.2.

Arguments SR_plus !_ / _ _.
Arguments SR_mult !_ / _ _.
Arguments SR_zero !_ /.
Arguments SR_one !_ /.

Section contents.
Universe U V.
Context `{Funext} `{Univalence}.
Context (A B : Operations@{U V}).

Context (f : A -> B) `{!IsEquiv f} `{!IsSemiRingPreserving f}.

Lemma iso_same_semirings : A = B.
Proof.
apply path_sigma_uncurried.
destruct A as [TA [[[plA mlA] zA] uA]], B as [TB [[[plB mlB] zB] uB]];simpl in *.
change plA with (@plus TA plA);change plB with (@plus TB plB);
change mlA with (@mult TA mlA);change mlB with (@mult TB mlB);
change zA with (@zero TA zA);change zB with (@zero TB zB);
change uA with (@one TA uA);change uB with (@one TB uB).
exists (path_universe f).
rewrite !transport_prod;simpl.
unfold Plus,Mult,Zero,One.
repeat apply path_prod;simpl;try
( apply path_forall;intros x;rewrite transport_arrow;
  apply path_forall;intros y;rewrite transport_arrow);
rewrite transport_path_universe, ?transport_path_universe_V.
- rewrite (preserves_plus (f:=f)).
  apply ap011;apply eisretr.
- rewrite (preserves_mult (f:=f)).
  apply ap011;apply eisretr.
- apply preserves_0.
- apply preserves_1.
Qed.

Lemma iso_leibnitz : forall P : Operations -> Type, P A -> P B.
Proof.
intros P;apply transport.
(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
first [exact iso_same_semirings|exact iso_same_semirings@{V V}].
Qed.

End contents.

End SemiRings.

Module Rings.

Class Operations
  := operations : sigT (fun T => Plus T * Mult T * Zero T * One T * Negate T)%type.

Definition BuildOperations (T : Type)
  `{Plus T} `{Mult T} `{Zero T} `{One T} `{Negate T}
  : Operations
  := existT _ T (plus,mult,zero,one,negate).

Coercion R_carrier (s : Operations) : Type := s.1.
Instance R_plus (s : Operations) : Plus s := fst (fst (fst (fst s.2))).
Instance R_mult (s : Operations) : Mult s := snd (fst (fst (fst s.2))).
Instance R_zero (s : Operations) : Zero s := snd (fst (fst s.2)).
Instance R_one (s : Operations) : One s := snd (fst s.2).
Instance R_negate (s : Operations) : Negate s := snd s.2.

Arguments R_plus !_ / _ _.
Arguments R_mult !_ / _ _.
Arguments R_zero !_ /.
Arguments R_one !_ /.
Arguments R_negate !_ / _.

Section contents.
Universe U V.
Context `{Funext} `{Univalence}.
Context (A B : Operations@{U V}).

(* NB: we need to know they're rings for preserves_negate *)
Context (f : A -> B) `{!IsEquiv f} `{!IsRing A} `{!IsRing B} `{!IsSemiRingPreserving f}.

Lemma iso_same_rings : A = B.
Proof.
apply path_sigma_uncurried.
destruct A as [TA [[[[plA mlA] zA] uA] nA]],
  B as [TB [[[[plB mlB] zB] uB] nB]];simpl in *.
change plA with (@plus TA plA);change plB with (@plus TB plB);
change mlA with (@mult TA mlA);change mlB with (@mult TB mlB);
change zA with (@zero TA zA);change zB with (@zero TB zB);
change uA with (@one TA uA);change uB with (@one TB uB);
change nA with (@negate TA nA);change nB with (@negate TB nB).
exists (path_universe f).
rewrite !transport_prod;simpl.
unfold Plus,Mult,Zero,One,Negate.
repeat apply path_prod;simpl;try
( apply path_forall;intros x;rewrite transport_arrow;
  try (apply path_forall;intros y;rewrite transport_arrow));
rewrite transport_path_universe, ?transport_path_universe_V.
- rewrite (preserves_plus (f:=f)).
  apply ap011;apply eisretr.
- rewrite (preserves_mult (f:=f)).
  apply ap011;apply eisretr.
- apply preserves_0.
- apply preserves_1.
- rewrite (preserves_negate (f:=f)).
  apply ap,eisretr.
Qed.

Lemma iso_leibnitz : forall P : Operations -> Type, P A -> P B.
Proof.
intros P;apply transport.
(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
first [exact iso_same_rings|exact iso_same_rings@{V V}].
Qed.

End contents.

End Rings.


(* *********************************************************************)
(*                                                                     *)
(*           Original GARUDA Example Policies and Extractions          *)
(*                                                                     *)
(* *********************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Arith ZArith.
Require Import Vector.
Require Import String.
Require Import JMeq.
Require Import List. Import ListNotations.

Require Import Integers.
Require Import lang.
Require Import extraction.
Require Import syntax.
Require Import combinators.

(* ************************)
(*  SecJmp Example Policy *)
(* ************************)
Section test_secjmp.
  Variables i o : id TVec64.
  (*High-order 10 bits of immediate address are zeroed. Because the effective
    address of the jump is calculated in MIPS as pc[0:3]++imm_addr[0:25]++[0;0],
    this enforces that all jumps are within a 2^16 offset of the higher-order 4
    bits of any instruction. Note that this policy doesn't deal with branches
    or indirect jumps. Note also that it's possible in principle to check
    statically that direct jumps are policy compliant.*)
  Definition sec_addr := BFieldRange ImmAddr (ofromz 10) (ofromz 0).
  Definition sec_jmp : pol TVec64 TVec64 :=
    `IF` jump `THEN` PTest sec_addr PId `ELSE` PId.
End test_secjmp.

(* *************************************)
(*  Secure Control Flow Example Policy *)
(* *************************************)
Section scf.
  (*A control-flow isolation policy. We assume that the effective address
    is pre-calculated in the top 32 bits of the input vector. *)
  Variables i o : id TVec64.
  Definition control_domain := ofromz 0.
  Definition sec_addr32 := BFieldRange EffAddr (ofromz 10) control_domain.
  Definition scf: pol TVec64 TVec64 :=
    `IF` ctrl `THEN` PTest (BNeg sec_addr32) PId `ELSE` PId.
  (*We define a second version of this policy that applies just to indirect
    control flows (direct flows could be checked statically).*)
  Definition scf2: pol TVec64 TVec64 :=
    `IF` jump_indirect `THEN` PTest (BNeg sec_addr32) PId `ELSE` PId.
End scf.

(* ****************************************)
(*  Secure Failt Isolation Example Policy *)
(* ****************************************)
Section sfi.
  (*A write isolation policy, which we called SFI in the original paper. Note that
    SFI sometimes refers to a combination of write isolation and control-flow isolation
    (a point the paper clarifies). Below, the logical fault domain (lfd_mask)
    is the sub-address space beginning with higher-order bits 0^8.*)
  Variables ri ro : id TVec64.

  Definition lfd_start := ofromz 11673330234144325632. (*162<<56*)
  Definition lfd_mask := ofromz 72057594037927935. (*0^8 1^56*)

  Definition mask e := EBinop OAnd (EVal lfd_mask) e.
  Definition force_range e := EBinop OOr (EVal lfd_start) e.

  Definition sfi: pol TVec64 TVec64 :=
    `IF` store `THEN` PConcat (PUpd mask) (PUpd force_range) `ELSE` PId.
End sfi.

(* ******************************)
(*  Simple Taint Example Policy *)
(* ******************************)
Section taint.
  (*Taint tracking through ALU operations only (the monitors could be extended to
    support other taint propagation rules).*)
  Definition rs_taint := TaintBit (ofromz 63).
  Definition rt_taint := TaintBit (ofromz 62).
  Definition pc_taint := TaintBit (ofromz 61).
  Definition TAINTED := ofromz 1.
  Definition NOT_TAINTED := ofromz 0.
  Definition tainted_Itype: pred TVec64 :=
    BField pc_taint TAINTED `orpred` BField rs_taint TAINTED.
  Definition tainted_Rtype: pred TVec64 := BField rt_taint TAINTED.
  Definition taint64: pol TVec64 TVec64 :=
    `IF` tainted_Itype `orpred` (R_type `andpred` tainted_Rtype)
     `THEN` PUpd (fun _ => EVal TAINTED)
     `ELSE` PUpd (fun _ => EVal NOT_TAINTED).

  (*Here's an alternative implementation of taint64 that inputs just the required bits:
    in[0] = is_rtype, in[1] = rs_taint, in[2] = rt_taint, in[3] = pc_taint.*)
  Definition TaintTy := TArr 4 TBit.
  Lemma zlt4: 0 < 4. omega. Qed.
  Lemma olt4: 1 < 4. omega. Qed.
  Lemma tlt4: 2 < 4. omega. Qed.
  Lemma thlt4: 3 < 4. omega. Qed.
  Definition taint: pol TaintTy TBit :=
    let rtype_idx := @Fin.of_nat_lt 0 4 zlt4 in
    let rs_taint_idx := @Fin.of_nat_lt 1 4 olt4 in
    let rt_taint_idx := @Fin.of_nat_lt 2 4 tlt4 in
    let pc_taint_idx := @Fin.of_nat_lt 3 4 thlt4 in
    @PUpd TaintTy TBit _ _ (fun ax: exp TaintTy =>
            match ax with
            | EVar _ a =>
              let is_rtype := EDeref rtype_idx a in
              let rs_taint := EDeref rs_taint_idx a in
              let rt_taint := EDeref rt_taint_idx a in
              let pc_taint := EDeref pc_taint_idx a in
              EBinop OOr pc_taint (EBinop OOr rs_taint (EBinop OAnd is_rtype rt_taint))
            | _ => @EVal TBit _ false (*BOGUS: Can't occur by defn. of compile_pol.*)
            end).
End taint.

(* *********************)
(*  Print the Programs *)
(* *********************)
Require Import extraction.

(* ****************)
(*  Define Fields *)
(* ****************)
Definition i : id TVec64 := "i".
Definition o : id TVec64 := "o".
Definition ri : id TVec64 := "ri".
Definition ro : id TVec64 := "ro".
(* These don't really mean anything: *)
(*
Definition Es : id TVec64 := "Es".
Definition Eos : id TVec64 := "Eos".
Definition Mos : id TVec64 := "Mos".
Definition Ms : id TVec64 := "Ms".
*)

(* ***********************)
(*  Define Pols Compiled *)
(* ***********************)
Definition sec_jmp_compiled : prog := compile i o sec_jmp.
Definition SFI_compiled : prog := compile ri ro sfi.
Definition sec_jmp_sfi_compiled : prog := compile i o (PConcat sec_jmp sfi).
Opaque sec_jmp.
Opaque sfi.

Definition taint_i: id TaintTy := "ti".
Definition taint_o: id TBit := "to".
Definition taint_compiled : prog := compile taint_i taint_o taint.

Definition scf_compiled : prog := compile i o scf.

(* ****************************)
(*  Define HS Print Functions *)
(* ****************************)
Definition pretty_print_sec_jmp :=
  pretty_print_tb "secjmp" sec_jmp_compiled.
Definition pretty_print_SFI :=
  pretty_print_tb "SFI" SFI_compiled.
Definition pretty_print_taint :=
  pretty_print_tb "taint" taint_compiled.
Definition pretty_print_SCF :=
  pretty_print_tb "SCF" scf_compiled.
Definition pretty_print_SJSFI :=
  pretty_print_tb "SJSFI" sec_jmp_sfi_compiled.

(* ************************)
(*  Extraction to Haskell *)
(* ************************)
(* run the program 'secjmp.hs' and pipe to a file to get verilog       *)
(* Ignore warnings on opacity, see the end of the section on realizing *)
(* axioms for a proper explanation on why this is safe to do so:       *)
(* https://coq.inria.fr/refman/addendum/extraction.html?highlight=extraction%20warning#realizing-axioms *)
Extract Constant main => "Prelude.putStrLn pretty_print_sec_jmp".
Extraction "secjmp.hs" pretty_print_sec_jmp main.
Extract Constant main => "Prelude.putStrLn pretty_print_SFI".
Extraction "SFI.hs" pretty_print_SFI main.
Extract Constant main => "Prelude.putStrLn pretty_print_taint".
Extraction "taint.hs" pretty_print_taint main.
Extract Constant main => "Prelude.putStrLn pretty_print_SCF".
Extraction "SCF.hs" pretty_print_SCF main.
Extract Constant main => "Prelude.putStrLn pretty_print_SJSFI".
Extraction "SJSFI.hs" pretty_print_SJSFI main.


From stdpp Require Export list fin_maps.
From iris.program_logic Require Import hoare.
From iris.heap_lang Require Export lifting notation.
From iris_hashtable Require Import util.

Class Hashable Σ `{heapG Σ} (Key : Type) `{EqDecision Key} (Hash : Key -> nat) :=
  { equalf : val;
    hashf : val;
    as_key : val -> option Key;

    equal_spec (k1 k2: Key) (v1 v2: val) :
      as_key v1 = Some k1 ->
      as_key v2 = Some k2 ->
      WP equalf v1 v2 {{u, ⌜u = #(bool_decide (k1 = k2))⌝}}%I;

    hash_spec k v : as_key v = Some k -> WP hashf v {{u, ⌜u = #(Hash k)⌝}}%I }.

Section model.
  Context {Σ Key Hash map} `{FinMap Key map, heapG Σ, !Hashable Σ Key Hash}.

  Implicit Type m : map (list val).

  Definition insert_val m k x := (<[k := x :: from_option id [] (m !! k)]>m).

  Definition remove_val m k := match m !! k with
                               | Some (x :: y :: l) => <[k := y :: l]> m
                               | Some _ => delete k m
                               | None => m
                               end.

                                 (*(<[ k := tail (lookup_all M k)]>M).*)

  Definition all_elements m := map_fold (fun k l acc => ((fun v => (k, v)) <$> l) ++ acc) [] m.

  Definition table_wf m := map_Forall (fun _ l => exists x xs, l = x :: xs) m.

  Lemma table_wf_empty : table_wf ∅.
  Proof. apply map_Forall_empty. Qed.

  Lemma table_wf_insert_val m k x : table_wf m -> table_wf (insert_val m k x).
  Proof. apply map_Forall_insert_2. eauto. Qed.

  Lemma table_wf_remove_val m k : table_wf m -> table_wf (remove_val m k).
  Proof.
    unfold remove_val.
    case_eq (m !! k) ; last done.
    intros [|?[|]] Hlookup ; last (apply map_Forall_insert_2 ; eauto).
    all: rewrite -{1}(insert_id _ _ _ Hlookup) -insert_delete ;
      apply map_Forall_insert_12, lookup_delete.
  Qed.

  Definition lookup_insert_val_ne m k k' x :
    k ≠ k' -> (insert_val m k x) !! k' = m !! k'.
  Proof.
    intros Hne. rewrite /insert_val lookup_insert_ne //.
  Qed.

  Definition lookup_remove_val_ne m k k' :
    k ≠ k' -> (remove_val m k) !! k' = m !! k'.
  Proof.
    intros Hne. unfold remove_val.
    case_eq (m !! k) ; last done.
    intros [|?[|]] Hlookup ; [apply lookup_delete_ne ..| apply lookup_insert_ne] ; done.
  Qed.

  Inductive removal : map (list val) -> list (val * val) -> map (list val) -> Prop :=
  | RemovalNil {m} : removal m [] m
  | RemovalCons {k k' x xs l m m' } :
      as_key k = Some k' ->
      m !! k' = Some (x :: xs) ->
      removal (remove_val m k') l m' ->
      removal m ((k, x) :: l) m'.

  Lemma removal_app_1 m seq m' seq' m'':
    removal m seq m' ->
    removal m' seq' m'' ->
    removal m (seq ++ seq') m''.
  Proof.
    intro HRem. induction HRem as [|] ; [done | econstructor ; eauto].
  Qed.

  Lemma removal_app_2 m m' seq seq' :
    removal m (seq ++ seq') m' ->
    exists m'', removal m seq m'' /\ removal m'' seq' m'.
  Proof.
    revert m.
    induction seq as [|[k x] seq IH].
    - simpl. intros m ?. exists m. split. by constructor 1. assumption.
    - simpl. intros m Hrem. inversion Hrem as [| ? k' ??????? Hrem']. simplify_eq.
      specialize (IH (remove_val m k') Hrem'). destruct IH as [m'' [Hseq Hseq']].
      exists m''. split.
      by econstructor. assumption.
  Qed.

  Definition permitted m seq := exists m', removal m seq m'.
  Definition complete m seq := removal m seq ∅ .

  Lemma complete_all_elements m seq:
    complete m seq ->
    exists seq', Forall2 (fun '(k, x) '(k', x') => x = x' /\ as_key k' = Some k) seq' seq /\
                 seq' ≡ₚ all_elements m.
  Proof.
    assert (forall (k : Key) (l : list val),
               Proper (Permutation ==> Permutation) (fun acc => ((fun x => (k, x)) <$> l) ++ acc)).
    { solve_proper. }
    assert ( forall A (l1 l2 l3 : list A),
               l1 ++ l2 ++ l3 ≡ₚ l2 ++ l1 ++ l3).
    { intros. do 2 rewrite app_assoc. f_equiv. apply Permutation_app_comm. }
    revert m. induction seq as [|[k x] seq IH].
    - intros m HCom. exists [].
      split ; first done. inversion HCom.
       by rewrite  /all_elements map_fold_empty.
    - intros m HCom. inversion HCom as [| ??k'?????? Hlookup HRem].
      specialize (IH _ HRem). destruct IH as [seq' [Hforall HPerm]].
      exists ((k', x) :: seq'). split.
      + by apply Forall2_cons.
      + rewrite HPerm /all_elements /remove_val Hlookup. destruct xs.
        * rewrite -{2}(insert_id m k' [x]) // -insert_delete.
          rewrite (map_fold_insert Permutation) //. apply lookup_delete.
        * rewrite -insert_delete (map_fold_insert Permutation) // ; last apply lookup_delete.
          rewrite app_comm_cons  -fmap_cons.
          rewrite -{2}(insert_id m k' (x :: v :: xs)) // -insert_delete.
          rewrite (map_fold_insert Permutation) //. apply lookup_delete.
  Qed.

End model.

Structure table Σ key hash map `{FinMap key map, heapG Σ, !Hashable Σ key hash} : Type :=
  { table_create : val ;
    table_insert : val ;
    table_remove : val ;
    table_lookup : val ;
    table_fold : val ;
    table_cascade : val ;

    table_state : Type ;
    table_in_state : map (list val) -> table_state -> val -> iProp Σ ;
    is_cascade : map (list val) -> val -> list (val * val) -> table_state -> val -> iProp Σ ;

    table_in_state_wf m state t : (table_in_state m state t → ⌜table_wf m⌝)%I ;
    is_cascade_persistent m f seq state t : PersistentP (is_cascade m f seq state t) ;

    table_create_spec (n : nat) : (n > 0)%nat -> WP table_create #n {{t, ∃ state, table_in_state ∅ state t}}%I ;

    table_insert_spec (t k x : val) m state k' :
      as_key k = Some k' ->
      {{{table_in_state m state t}}}
        table_insert t k x
        {{{state', RET #(); table_in_state (insert_val m k' x) state' t}}} ;

    table_remove_spec m state t k k' :
      as_key k = Some k' ->
      {{{table_in_state m state t}}}
        table_remove t k
      {{{ state', RET match m !! k' with
                      | Some (v :: _) => SOMEV v
                      | _ => NONEV end ;
          table_in_state (remove_val m k') state' t }}} ;

    table_lookup_spec m state t k k' :
      as_key k = Some k' ->
      {{{table_in_state m state t}}}
        table_lookup t k
        {{{ RET match m !! k' with
                | Some (v :: _) => SOMEV v
                | _ => NONEV end ;
            table_in_state m state t }}} ;

    table_fold_spec m state I (f t a : val) :
      {{{(∀ k x seq (a' : val),
              {{⌜permitted m (seq ++ [(k,x)])⌝ ∗I seq a'}}
                f k x a'
              {{v, I (seq ++ [(k,x)]) v }}) ∗
         table_in_state m state t ∗ I [] a}}}
        table_fold f t a
      {{{v seq, RET v; ⌜complete m seq⌝ ∗ table_in_state m state t ∗ I seq v}}} ;

    is_cascade_spec m f seq state t:
      {{{ is_cascade m f seq state t ∗ table_in_state m state t }}}
        f #()
      {{{v k x f' , RET v; table_in_state m state t ∗
                           ((⌜v = NONEV⌝ ∗ ⌜complete m seq⌝) ∨
                            (⌜v = SOMEV ((k, x), f')⌝ ∗
                             ⌜permitted m (seq ++ [(k, x)])⌝ ∗
                             is_cascade m f' (seq ++ [(k, x)]) state t)) }}};

    table_cascade_spec m state t:
      {{{table_in_state m state t}}}
        table_cascade t
        {{{f, RET f; is_cascade m f [] state t ∗ table_in_state m state t }}}
  }.
Arguments table_create {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_insert {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_remove {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_lookup {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_fold {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_cascade {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_state {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_in_state {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _.
Arguments is_cascade {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _.
Arguments table_in_state_wf {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _.
Arguments is_cascade_persistent {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _.
Arguments table_create_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _.
Arguments table_insert_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _ _ _.
Arguments table_remove_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _ _.
Arguments table_lookup_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _ _.
Arguments table_fold_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _.
Arguments is_cascade_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _.
Arguments table_cascade_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _.

Existing Instance is_cascade_persistent.