Require Import Coqlib Maps Integers Floats Errors Globalenvs.
Require Import AST Linking Values Memory Events.

Record attr : Type := mk_attr {
                          attr_volatile: bool;
                          attr_alignas: option N         (**r log2 of required alignment *)
                        }.

Inductive signedness : Type :=
| Signed: signedness
| Unsigned: signedness.

Inductive intsize : Type :=
| I8: intsize
| I16: intsize
| I32: intsize
| IBool: intsize.

Inductive floatsize : Type :=
| F32: floatsize
| F64: floatsize.

Inductive type : Type :=
| Tvoid: type                                    (**r the [void] type *)
| Tint: intsize -> signedness -> attr -> type    (**r integer types *)
| Tlong: signedness -> attr -> type              (**r 64-bit integer types *)
| Tfloat: floatsize -> attr -> type              (**r floating-point types *)
| Tpointer: type -> attr -> type                 (**r pointer types ([*ty]) *)
| Tarray: type -> Z -> attr -> type              (**r array types ([ty[len]]) *)
| Tfunction: typelist -> type -> calling_convention -> type    (**r function types *)
| Tstruct: ident -> attr -> type                 (**r struct types *)
| Tunion: ident -> attr -> type                  (**r union types *)
with typelist : Type :=
     | Tnil: typelist
     | Tcons: type -> typelist -> typelist.

Inductive expr : Type :=
| Eval (v: val) (ty: type)
| Evar (x: ident) (ty: type)
| Eseqand (r1 r2: expr) (ty: type)
| Econdition (r1 r2 r3: expr) (ty: type)
| Eparen (r: expr) (tycast: type) (ty: type).

Inductive kind : Type := LV | RV.

Inductive context: kind -> kind -> (expr -> expr) -> Prop :=
| ctx_top: forall k,
    context k k (fun x => x)
| ctx_seqand: forall k C r2 ty,
    context k RV C -> context k RV (fun x => Eseqand (C x) r2 ty)
| ctx_condition: forall k C r2 r3 ty,
    context k RV C -> context k RV (fun x => Econdition (C x) r2 r3 ty)
| ctx_paren: forall k C ty tycast,
    context k RV C -> context k RV (fun x => Eparen (C x) tycast ty).

(** Strategy for reducing expressions. We reduce the leftmost innermost
  non-simple subexpression, evaluating its arguments (which are necessarily
  simple expressions) with the big-step semantics.
  If there are none, the whole expression is simple and is evaluated in
  one big step. *)
Definition env := PTree.t block.
Definition empty_env: env := (PTree.empty block).

Section SIMPLE_EXPRS.

  Variable e: env.

  Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop :=
  | esl_var_local: forall x b ty,
      e!x = Some b ->
      eval_simple_lvalue (Evar x ty) b Ptrofs.zero.

  Inductive eval_simple_rvalue: expr -> val -> Prop :=
  | esr_val: forall v ty, eval_simple_rvalue (Eval v ty) v.

End SIMPLE_EXPRS.

Inductive state: Type :=
| ExprState                           (**r reduction of an expression *)
    (r: expr)
    (e: env)
    (m: mem) : state.

Inductive classify_bool_cases : Type :=
| bool_case_i                           (**r integer *)
| bool_case_l                           (**r long *)
| bool_case_f                           (**r double float *)
| bool_case_s                           (**r single float *)
| bool_default.

Definition noattr := {| attr_volatile := false; attr_alignas := None |}.

Definition change_attributes (f: attr -> attr) (ty: type) : type :=
  match ty with
  | Tvoid => ty
  | Tint sz si a => Tint sz si (f a)
  | Tlong si a => Tlong si (f a)
  | Tfloat sz a => Tfloat sz (f a)
  | Tpointer elt a => Tpointer elt (f a)
  | Tarray elt sz a => Tarray elt sz (f a)
  | Tfunction args res cc => ty
  | Tstruct id a => Tstruct id (f a)
  | Tunion id a => Tunion id (f a)
  end.

Definition remove_attributes (ty: type) : type :=
  change_attributes (fun _ => noattr) ty.

Definition typeconv (ty: type) : type :=
  match ty with
  | Tint (I8 | I16 | IBool) _ _ => Tint I32 Signed noattr
  | Tarray t sz a       => Tpointer t noattr
  | Tfunction _ _ _     => Tpointer ty noattr
  | _                   => remove_attributes ty
  end.

Definition classify_bool (ty: type) : classify_bool_cases :=
  match typeconv ty with
  | Tint _ _ _ => bool_case_i
  | Tpointer _ _ => if Archi.ptr64 then bool_case_l else bool_case_i
  | Tfloat F64 _ => bool_case_f
  | Tfloat F32 _ => bool_case_s
  | Tlong _ _ => bool_case_l
  | _ => bool_default
  end.

Definition bool_val (v: val) (t: type) (m: mem) : option bool :=
  match classify_bool t with
  | bool_case_i =>
    match v with
    | Vint n => Some (negb (Int.eq n Int.zero))
    | Vptr b ofs =>
      if Archi.ptr64 then None else
        if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some true else None
    | _ => None
    end
  | bool_case_l =>
    match v with
    | Vlong n => Some (negb (Int64.eq n Int64.zero))
    | Vptr b ofs =>
      if negb Archi.ptr64 then None else
        if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some true else None
    | _ => None
    end
  | bool_case_f =>
    match v with
    | Vfloat f => Some (negb (Float.cmp Ceq f Float.zero))
    | _ => None
    end
  | bool_case_s =>
    match v with
    | Vsingle f => Some (negb (Float32.cmp Ceq f Float32.zero))
    | _ => None
    end
  | bool_default => None
  end.

Definition typeof (a: expr) : type :=
  match a with
  | Evar _ ty => ty
  | Eval _ ty => ty
  | Econdition _ _ _ ty => ty
  | Eseqand _ _ ty => ty
  | Eparen _ _ ty => ty
  end.

Inductive classify_cast_cases : Type :=
  | cast_case_pointer                              (**r between pointer types or intptr_t types *)
  | cast_case_i2i (sz2:intsize) (si2:signedness)   (**r int -> int *)
  | cast_case_f2f                                  (**r double -> double *)
  | cast_case_s2s                                  (**r single -> single *)
  | cast_case_f2s                                  (**r double -> single *)
  | cast_case_s2f                                  (**r single -> double *)
  | cast_case_i2f (si1: signedness)                (**r int -> double *)
  | cast_case_i2s (si1: signedness)                (**r int -> single *)
  | cast_case_f2i (sz2:intsize) (si2:signedness)   (**r double -> int *)
  | cast_case_s2i (sz2:intsize) (si2:signedness)   (**r single -> int *)
  | cast_case_l2l                       (**r long -> long *)
  | cast_case_i2l (si1: signedness)     (**r int -> long *)
  | cast_case_l2i (sz2: intsize) (si2: signedness) (**r long -> int *)
  | cast_case_l2f (si1: signedness)                (**r long -> double *)
  | cast_case_l2s (si1: signedness)                (**r long -> single *)
  | cast_case_f2l (si2:signedness)                 (**r double -> long *)
  | cast_case_s2l (si2:signedness)                 (**r single -> long *)
  | cast_case_i2bool                               (**r int -> bool *)
  | cast_case_l2bool                               (**r long -> bool *)
  | cast_case_f2bool                               (**r double -> bool *)
  | cast_case_s2bool                               (**r single -> bool *)
  | cast_case_struct (id1 id2: ident)              (**r struct -> struct *)
  | cast_case_union  (id1 id2: ident)              (**r union -> union *)
  | cast_case_void                                 (**r any -> void *)
  | cast_case_default.

Lemma intsize_eq: forall (s1 s2: intsize), {s1=s2} + {s1<>s2}.
Proof.
  decide equality.
Defined.

Definition classify_cast (tfrom tto: type) : classify_cast_cases :=
  match tto, tfrom with
  (* To [void] *)
  | Tvoid, _ => cast_case_void
  (* To [_Bool] *)
  | Tint IBool _ _, Tint _ _ _ => cast_case_i2bool
  | Tint IBool _ _, Tlong _ _ => cast_case_l2bool
  | Tint IBool _ _, Tfloat F64 _ => cast_case_f2bool
  | Tint IBool _ _, Tfloat F32 _ => cast_case_s2bool
  | Tint IBool _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
      if Archi.ptr64 then cast_case_l2bool else cast_case_i2bool
  (* To [int] other than [_Bool] *)
  | Tint sz2 si2 _, Tint _ _ _ =>
      if Archi.ptr64 then cast_case_i2i sz2 si2
      else if intsize_eq sz2 I32 then cast_case_pointer
      else cast_case_i2i sz2 si2
  | Tint sz2 si2 _, Tlong _ _ => cast_case_l2i sz2 si2
  | Tint sz2 si2 _, Tfloat F64 _ => cast_case_f2i sz2 si2
  | Tint sz2 si2 _, Tfloat F32 _ => cast_case_s2i sz2 si2
  | Tint sz2 si2 _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
      if Archi.ptr64 then cast_case_l2i sz2 si2
      else if intsize_eq sz2 I32 then cast_case_pointer
      else cast_case_i2i sz2 si2
  (* To [long] *)
  | Tlong _ _, Tlong _ _ =>
      if Archi.ptr64 then cast_case_pointer else cast_case_l2l
  | Tlong _ _, Tint sz1 si1 _ => cast_case_i2l si1
  | Tlong si2 _, Tfloat F64 _ => cast_case_f2l si2
  | Tlong si2 _, Tfloat F32 _ => cast_case_s2l si2
  | Tlong si2 _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
      if Archi.ptr64 then cast_case_pointer else cast_case_i2l si2
  (* To [float] *)
  | Tfloat F64 _, Tint sz1 si1 _ => cast_case_i2f si1
  | Tfloat F32 _, Tint sz1 si1 _ => cast_case_i2s si1
  | Tfloat F64 _, Tlong si1 _ => cast_case_l2f si1
  | Tfloat F32 _, Tlong si1 _ => cast_case_l2s si1
  | Tfloat F64 _, Tfloat F64 _ => cast_case_f2f
  | Tfloat F32 _, Tfloat F32 _ => cast_case_s2s
  | Tfloat F64 _, Tfloat F32 _ => cast_case_s2f
  | Tfloat F32 _, Tfloat F64 _ => cast_case_f2s
  (* To pointer types *)
  | Tpointer _ _, Tint _ _ _ =>
      if Archi.ptr64 then cast_case_i2l Unsigned else cast_case_pointer
  | Tpointer _ _, Tlong _ _ =>
      if Archi.ptr64 then cast_case_pointer else cast_case_l2i I32 Unsigned
  | Tpointer _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_pointer
  (* To struct or union types *)
  | Tstruct id2 _, Tstruct id1 _ => cast_case_struct id1 id2
  | Tunion id2 _, Tunion id1 _ => cast_case_union id1 id2
  (* Catch-all *)
  | _, _ => cast_case_default
  end.

Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int :=
  match sz, sg with
  | I8, Signed => Int.sign_ext 8 i
  | I8, Unsigned => Int.zero_ext 8 i
  | I16, Signed => Int.sign_ext 16 i
  | I16, Unsigned => Int.zero_ext 16 i
  | I32, _ => i
  | IBool, _ => if Int.eq i Int.zero then Int.zero else Int.one
  end.

Definition cast_int_float (si: signedness) (i: int) : float :=
  match si with
  | Signed => Float.of_int i
  | Unsigned => Float.of_intu i
  end.

Definition cast_float_int (si : signedness) (f: float) : option int :=
  match si with
  | Signed => Float.to_int f
  | Unsigned => Float.to_intu f
  end.

Definition cast_int_single (si: signedness) (i: int) : float32 :=
  match si with
  | Signed => Float32.of_int i
  | Unsigned => Float32.of_intu i
  end.

Definition cast_single_int (si : signedness) (f: float32) : option int :=
  match si with
  | Signed => Float32.to_int f
  | Unsigned => Float32.to_intu f
  end.

Definition cast_int_long (si: signedness) (i: int) : int64 :=
  match si with
  | Signed => Int64.repr (Int.signed i)
  | Unsigned => Int64.repr (Int.unsigned i)
  end.

Definition cast_long_float (si: signedness) (i: int64) : float :=
  match si with
  | Signed => Float.of_long i
  | Unsigned => Float.of_longu i
  end.

Definition cast_long_single (si: signedness) (i: int64) : float32 :=
  match si with
  | Signed => Float32.of_long i
  | Unsigned => Float32.of_longu i
  end.

Definition cast_float_long (si : signedness) (f: float) : option int64 :=
  match si with
  | Signed => Float.to_long f
  | Unsigned => Float.to_longu f
  end.

Definition cast_single_long (si : signedness) (f: float32) : option int64 :=
  match si with
  | Signed => Float32.to_long f
  | Unsigned => Float32.to_longu f
  end.

Definition sem_cast (v: val) (t1 t2: type) (m: mem): option val :=
  match classify_cast t1 t2 with
  | cast_case_pointer =>
      match v with
      | Vptr _ _ => Some v
      | Vint _ => if Archi.ptr64 then None else Some v
      | Vlong _ => if Archi.ptr64 then Some v else None
      | _ => None
      end
  | cast_case_i2i sz2 si2 =>
      match v with
      | Vint i => Some (Vint (cast_int_int sz2 si2 i))
      | _ => None
      end
  | cast_case_f2f =>
      match v with
      | Vfloat f => Some (Vfloat f)
      | _ => None
      end
  | cast_case_s2s =>
      match v with
      | Vsingle f => Some (Vsingle f)
      | _ => None
      end
  | cast_case_s2f =>
      match v with
      | Vsingle f => Some (Vfloat (Float.of_single f))
      | _ => None
      end
  | cast_case_f2s =>
      match v with
      | Vfloat f => Some (Vsingle (Float.to_single f))
      | _ => None
      end
  | cast_case_i2f si1 =>
      match v with
      | Vint i => Some (Vfloat (cast_int_float si1 i))
      | _ => None
      end
  | cast_case_i2s si1 =>
      match v with
      | Vint i => Some (Vsingle (cast_int_single si1 i))
      | _ => None
      end
  | cast_case_f2i sz2 si2 =>
      match v with
      | Vfloat f =>
          match cast_float_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | cast_case_s2i sz2 si2 =>
      match v with
      | Vsingle f =>
          match cast_single_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | cast_case_i2bool =>
      match v with
      | Vint n =>
          Some(Vint(if Int.eq n Int.zero then Int.zero else Int.one))
      | Vptr b ofs =>
          if Archi.ptr64 then None else
          if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some Vone else None
      | _ => None
      end
  | cast_case_l2bool =>
      match v with
      | Vlong n =>
          Some(Vint(if Int64.eq n Int64.zero then Int.zero else Int.one))
      | Vptr b ofs =>
          if negb Archi.ptr64 then None else
          if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some Vone else None

      | _ => None
      end
  | cast_case_f2bool =>
      match v with
      | Vfloat f =>
          Some(Vint(if Float.cmp Ceq f Float.zero then Int.zero else Int.one))
      | _ => None
      end
  | cast_case_s2bool =>
      match v with
      | Vsingle f =>
          Some(Vint(if Float32.cmp Ceq f Float32.zero then Int.zero else Int.one))
      | _ => None
      end
  | cast_case_l2l =>
      match v with
      | Vlong n => Some (Vlong n)
      | _ => None
      end
  | cast_case_i2l si =>
      match v with
      | Vint n => Some(Vlong (cast_int_long si n))
      | _ => None
      end
  | cast_case_l2i sz si =>
      match v with
      | Vlong n => Some(Vint (cast_int_int sz si (Int.repr (Int64.unsigned n))))
      | _ => None
      end
  | cast_case_l2f si1 =>
      match v with
      | Vlong i => Some (Vfloat (cast_long_float si1 i))
      | _ => None
      end
  | cast_case_l2s si1 =>
      match v with
      | Vlong i => Some (Vsingle (cast_long_single si1 i))
      | _ => None
      end
  | cast_case_f2l si2 =>
      match v with
      | Vfloat f =>
          match cast_float_long si2 f with
          | Some i => Some (Vlong i)
          | None => None
          end
      | _ => None
      end
  | cast_case_s2l si2 =>
      match v with
      | Vsingle f =>
          match cast_single_long si2 f with
          | Some i => Some (Vlong i)
          | None => None
          end
      | _ => None
      end
  | cast_case_struct id1 id2 =>
      match v with
      | Vptr b ofs =>
          if ident_eq id1 id2 then Some v else None
      | _ => None
      end
  | cast_case_union id1 id2 =>
      match v with
      | Vptr b ofs =>
          if ident_eq id1 id2 then Some v else None
      | _ => None
      end
  | cast_case_void =>
      Some v
  | cast_case_default =>
      None
  end.

Definition type_int32s := Tint I32 Signed noattr.

Definition type_bool := Tint IBool Signed noattr.

Inductive estep: state -> trace -> state -> Prop :=
| step_expr: forall r e m v ty,
    eval_simple_rvalue r v ->
    match r with Eval _ _ => False | _ => True end ->
    ty = typeof r ->
    estep (ExprState r e m)
          E0 (ExprState (Eval v ty) e m)
| step_seqand_true: forall C r1 r2 ty e m v,
    context RV RV C ->
    eval_simple_rvalue r1 v ->
    bool_val v (typeof r1) m = Some true ->
    estep (ExprState (C (Eseqand r1 r2 ty)) e m)
          E0 (ExprState (C (Eparen r2 type_bool ty)) e m)
| step_seqand_false: forall C r1 r2 ty e m v,
    context RV RV C ->
    eval_simple_rvalue r1 v ->
    bool_val v (typeof r1) m = Some false ->
    estep (ExprState (C (Eseqand r1 r2 ty)) e m)
          E0 (ExprState (C (Eval (Vint Int.zero) ty)) e m)
| step_condition: forall C r1 r2 r3 ty e m v b,
    context RV RV C ->
    eval_simple_rvalue r1 v ->
    bool_val v (typeof r1) m = Some b ->
    estep (ExprState (C (Econdition r1 r2 r3 ty)) e m)
          E0 (ExprState (C (Eparen (if b then r2 else r3) ty ty)) e m)
| step_paren: forall C r tycast ty e m v1 v,
    context RV RV C ->
    eval_simple_rvalue r v1 ->
    sem_cast v1 (typeof r) tycast m = Some v ->
    estep (ExprState (C (Eparen r tycast ty)) e m)
          E0 (ExprState (C (Eval v ty)) e m).


From stdpp Require Import namespaces.
From iris.algebra Require Export gmap coPset local_updates.
From iris.algebra Require Import updates proofmode_classes.
From iris.prelude Require Import options.

(** The camera [namespace_map A] over a camera [A] provides the connectives
[namespace_map_data N a], which associates data [a : A] with a namespace [N],
and [namespace_map_token E], which says that no data has been associated with
the namespaces in the mask [E]. The important properties of this camera are:

- The lemma [namespace_map_token_union] enables one to split [namespace_map_token]
  w.r.t. disjoint union. That is, if we have [E1 ## E2], then we get
  [namespace_map_token (E1 ∪ E2) = namespace_map_token E1 ⋅ namespace_map_token E2]
- The lemma [namespace_map_alloc_update] provides a frame preserving update to
  associate data to a namespace [namespace_map_token E ~~> namespace_map_data N a]
  provided [↑N ⊆ E] and [✓ a]. *)

Record namespace_map (A : Type) := NamespaceMap {
  namespace_map_data_proj : gmap positive A;
  namespace_map_token_proj : coPset_disj
}.
Add Printing Constructor namespace_map.
Global Arguments NamespaceMap {_} _ _.
Global Arguments namespace_map_data_proj {_} _.
Global Arguments namespace_map_token_proj {_} _.
Global Instance: Params (@NamespaceMap) 1 := {}.
Global Instance: Params (@namespace_map_data_proj) 1 := {}.
Global Instance: Params (@namespace_map_token_proj) 1 := {}.

(** TODO: [positives_flatten] violates the namespace abstraction. *)
Definition namespace_map_data {A : cmra} (N : namespace) (a : A) : namespace_map A :=
  NamespaceMap {[ positives_flatten N := a ]} ε.
Definition namespace_map_token {A : cmra} (E : coPset) : namespace_map A :=
  NamespaceMap ∅ (CoPset E).
Global Instance: Params (@namespace_map_data) 2 := {}.

(* Ofe *)
Section ofe.
Context {A : ofe}.
Implicit Types x y : namespace_map A.

Local Instance namespace_map_equiv : Equiv (namespace_map A) := λ x y,
  namespace_map_data_proj x ≡ namespace_map_data_proj y ∧
  namespace_map_token_proj x = namespace_map_token_proj y.
Local Instance namespace_map_dist : Dist (namespace_map A) := λ n x y,
  namespace_map_data_proj x ≡{n}≡ namespace_map_data_proj y ∧
  namespace_map_token_proj x = namespace_map_token_proj y.

Global Instance NamespaceMap_ne : NonExpansive2 (@NamespaceMap A).
Proof. by split. Qed.
Global Instance NamespaceMap_proper : Proper ((≡) ==> (=) ==> (≡)) (@NamespaceMap A).
Proof. by split. Qed.
Global Instance namespace_map_data_proj_ne: NonExpansive (@namespace_map_data_proj A).
Proof. by destruct 1. Qed.
Global Instance namespace_map_data_proj_proper :
  Proper ((≡) ==> (≡)) (@namespace_map_data_proj A).
Proof. by destruct 1. Qed.

Definition namespace_map_ofe_mixin : OfeMixin (namespace_map A).
Proof.
  by apply (iso_ofe_mixin
    (λ x, (namespace_map_data_proj x, namespace_map_token_proj x))).
Qed.
Canonical Structure namespace_mapO :=
  Ofe (namespace_map A) namespace_map_ofe_mixin.

Global Instance NamespaceMap_discrete a b :
  Discrete a → Discrete b → Discrete (NamespaceMap a b).
Proof. intros ?? [??] [??]; split; unfold_leibniz; by eapply discrete. Qed.
Global Instance namespace_map_ofe_discrete :
  OfeDiscrete A → OfeDiscrete namespace_mapO.
Proof. intros ? [??]; apply _. Qed.
End ofe.

Global Arguments namespace_mapO : clear implicits.

(* Camera *)
Section cmra.
Context {A : cmra}.
Implicit Types a b : A.
Implicit Types x y : namespace_map A.

Global Instance namespace_map_data_ne i : NonExpansive (@namespace_map_data A i).
Proof. solve_proper. Qed.
Global Instance namespace_map_data_proper N :
  Proper ((≡) ==> (≡)) (@namespace_map_data A N).
Proof. solve_proper. Qed.
Global Instance namespace_map_data_discrete N a :
  Discrete a → Discrete (namespace_map_data N a).
Proof. intros. apply NamespaceMap_discrete; apply _. Qed.
Global Instance namespace_map_token_discrete E : Discrete (@namespace_map_token A E).
Proof. intros. apply NamespaceMap_discrete; apply _. Qed.

Local Instance namespace_map_valid_instance : Valid (namespace_map A) := λ x,
  match namespace_map_token_proj x with
  | CoPset E =>
     ✓ (namespace_map_data_proj x) ∧
     (* dom (namespace_map_data_proj x) ⊥ E *)
     ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
  | CoPsetBot => False
  end.
Global Arguments namespace_map_valid_instance !_ /.
Local Instance namespace_map_validN_instance : ValidN (namespace_map A) := λ n x,
  match namespace_map_token_proj x with
  | CoPset E =>
     ✓{n} (namespace_map_data_proj x) ∧
     (* dom (namespace_map_data_proj x) ⊥ E *)
     ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
  | CoPsetBot => False
  end.
Global Arguments namespace_map_validN_instance !_ /.
Local Instance namespace_map_pcore_instance : PCore (namespace_map A) := λ x,
  Some (NamespaceMap (core (namespace_map_data_proj x)) ε).
Local Instance namespace_map_op_instance : Op (namespace_map A) := λ x y,
  NamespaceMap (namespace_map_data_proj x ⋅ namespace_map_data_proj y)
               (namespace_map_token_proj x ⋅ namespace_map_token_proj y).

Definition namespace_map_valid_eq :
  valid = λ x, match namespace_map_token_proj x with
               | CoPset E =>
                  ✓ (namespace_map_data_proj x) ∧
                  (* dom (namespace_map_data_proj x) ⊥ E *)
                  ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
               | CoPsetBot => False
               end := eq_refl _.
Definition namespace_map_validN_eq :
  validN = λ n x, match namespace_map_token_proj x with
                  | CoPset E =>
                     ✓{n} (namespace_map_data_proj x) ∧
                     (* dom (namespace_map_data_proj x) ⊥ E *)
                     ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
                  | CoPsetBot => False
                  end := eq_refl _.

Lemma namespace_map_included x y :
  x ≼ y ↔
    namespace_map_data_proj x ≼ namespace_map_data_proj y ∧
    namespace_map_token_proj x ≼ namespace_map_token_proj y.
Proof.
  split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
  intros [[z1 Hz1] [z2 Hz2]]; exists (NamespaceMap z1 z2); split; auto.
Qed.

Lemma namespace_map_data_proj_validN n x : ✓{n} x → ✓{n} namespace_map_data_proj x.
Proof. by destruct x as [? [?|]]=> // -[??]. Qed.
Lemma namespace_map_token_proj_validN n x : ✓{n} x → ✓{n} namespace_map_token_proj x.
Proof. by destruct x as [? [?|]]=> // -[??]. Qed.

Lemma namespace_map_cmra_mixin : CmraMixin (namespace_map A).
Proof.
  apply cmra_total_mixin.
  - eauto.
  - by intros n x y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - solve_proper.
  - intros n [m1 [E1|]] [m2 [E2|]] [Hm ?]=> // -[??]; split; simplify_eq/=.
    + by rewrite -Hm.
    + intros i. by rewrite -(dist_None n) -Hm dist_None.
  - intros [m [E|]]; rewrite namespace_map_valid_eq namespace_map_validN_eq /=
      ?cmra_valid_validN; naive_solver eauto using O.
  - intros n [m [E|]]; rewrite namespace_map_validN_eq /=;
      naive_solver eauto using cmra_validN_S.
  - split; simpl; [by rewrite assoc|by rewrite assoc_L].
  - split; simpl; [by rewrite comm|by rewrite comm_L].
  - split; simpl; [by rewrite cmra_core_l|by rewrite left_id_L].
  - split; simpl; [by rewrite cmra_core_idemp|done].
  - intros ??; rewrite! namespace_map_included; intros [??].
    by split; simpl; apply: cmra_core_mono. (* FIXME: FIXME(Coq #6294): needs new unification *)
  - intros n [m1 [E1|]] [m2 [E2|]]=> //=; rewrite namespace_map_validN_eq /=.
    rewrite {1}/op /cmra_op /=. case_decide; last done.
    intros [Hm Hdisj]; split; first by eauto using cmra_validN_op_l.
    intros i. move: (Hdisj i). rewrite lookup_op.
    case: (m1 !! i)=> [a|]; last auto.
    move=> [].
    { by case: (m2 !! i). }
    set_solver.
  - intros n x y1 y2 ? [??]; simpl in *.
    destruct (cmra_extend n (namespace_map_data_proj x)
      (namespace_map_data_proj y1) (namespace_map_data_proj y2))
      as (m1&m2&?&?&?); auto using namespace_map_data_proj_validN.
    destruct (cmra_extend n (namespace_map_token_proj x)
      (namespace_map_token_proj y1) (namespace_map_token_proj y2))
      as (E1&E2&?&?&?); auto using namespace_map_token_proj_validN.
    by exists (NamespaceMap m1 E1), (NamespaceMap m2 E2).
Qed.
Canonical Structure namespace_mapR :=
  Cmra (namespace_map A) namespace_map_cmra_mixin.

Global Instance namespace_map_cmra_discrete :
  CmraDiscrete A → CmraDiscrete namespace_mapR.
Proof.
  split; first apply _.
  intros [m [E|]]; rewrite namespace_map_validN_eq namespace_map_valid_eq //=.
  by intros [?%cmra_discrete_valid ?].
Qed.

Local Instance namespace_map_empty_instance : Unit (namespace_map A) := NamespaceMap ε ε.
Lemma namespace_map_ucmra_mixin : UcmraMixin (namespace_map A).
Proof.
  split; simpl.
  - rewrite namespace_map_valid_eq /=. split; [apply ucmra_unit_valid|]. set_solver.
  - split; simpl; [by rewrite left_id|by rewrite left_id_L].
  - do 2 constructor; [apply (core_id_core _)|done].
Qed.
Canonical Structure namespace_mapUR :=
  Ucmra (namespace_map A) namespace_map_ucmra_mixin.

Global Instance namespace_map_data_core_id N a :
  CoreId a → CoreId (namespace_map_data N a).
Proof. do 2 constructor; simpl; auto. apply core_id_core, _. Qed.

Lemma namespace_map_data_valid N a : ✓ (namespace_map_data N a) ↔ ✓ a.
Proof. rewrite namespace_map_valid_eq /= singleton_valid. set_solver. Qed.
Lemma namespace_map_token_valid E : ✓ (namespace_map_token E).
Proof. rewrite namespace_map_valid_eq /=. split; first done. by left. Qed.
Lemma namespace_map_data_op N a b :
  namespace_map_data N (a ⋅ b) = namespace_map_data N a ⋅ namespace_map_data N b.
Proof.
  by rewrite {2}/op /namespace_map_op_instance /namespace_map_data /= singleton_op left_id_L.
Qed.
Lemma namespace_map_data_mono N a b :
  a ≼ b → namespace_map_data N a ≼ namespace_map_data N b.
Proof. intros [c ->]. rewrite namespace_map_data_op. apply cmra_included_l. Qed.
Global Instance namespace_map_data_is_op N a b1 b2 :
  IsOp a b1 b2 →
  IsOp' (namespace_map_data N a) (namespace_map_data N b1) (namespace_map_data N b2).
Proof. rewrite /IsOp' /IsOp=> ->. by rewrite namespace_map_data_op. Qed.

Lemma namespace_map_token_union E1 E2 :
  E1 ## E2 →
  namespace_map_token (E1 ∪ E2) = namespace_map_token E1 ⋅ namespace_map_token E2.
Proof.
  intros. by rewrite /op /namespace_map_op_instance
    /namespace_map_token /= coPset_disj_union // left_id_L.
Qed.
Lemma namespace_map_token_difference E1 E2 :
  E1 ⊆ E2 →
   namespace_map_token E2 = namespace_map_token E1 ⋅ namespace_map_token (E2 ∖ E1).
Proof.
  intros. rewrite -namespace_map_token_union; last set_solver.
  by rewrite -union_difference_L.
Qed.
Lemma namespace_map_token_valid_op E1 E2 :
  ✓ (namespace_map_token E1 ⋅ namespace_map_token E2) ↔ E1 ## E2.
Proof.
  rewrite namespace_map_valid_eq /= {1}/op /cmra_op /=. case_decide; last done.
  split; [done|]; intros _. split.
  - by rewrite left_id.
  - intros i. rewrite lookup_op lookup_empty. auto.
Qed.

(** [↑N ⊆ E] is stronger than needed, just [positives_flatten N ∈ E] would be
sufficient. However, we do not have convenient infrastructure to prove the
latter, so we use the former. *)
Lemma namespace_map_alloc_update E N a :
  ↑N ⊆ E → ✓ a → namespace_map_token E ~~> namespace_map_data N a.
Proof.
  assert (positives_flatten N ∈ (↑N : coPset)).
  { rewrite nclose_eq. apply elem_coPset_suffixes.
    exists 1%positive. by rewrite left_id_L. }
  intros ??. apply cmra_total_update=> n [mf [Ef|]] //.
  rewrite namespace_map_validN_eq /= {1}/op /cmra_op /=. case_decide; last done.
  rewrite left_id_L {1}left_id. intros [Hmf Hdisj]; split.
  - destruct (Hdisj (positives_flatten N)) as [Hmfi|]; last set_solver.
    move: Hmfi. rewrite lookup_op lookup_empty left_id_L=> Hmfi.
    intros j. rewrite lookup_op.
    destruct (decide (positives_flatten N = j)) as [<-|].
    + rewrite Hmfi lookup_singleton right_id_L. by apply cmra_valid_validN.
    + by rewrite lookup_singleton_ne // left_id_L.
  - intros j. destruct (decide (positives_flatten N = j)); first set_solver.
    rewrite lookup_op lookup_singleton_ne //.
    destruct (Hdisj j) as [Hmfi|?]; last set_solver.
    move: Hmfi. rewrite lookup_op lookup_empty; auto.
Qed.
Lemma namespace_map_updateP P (Q : namespace_map A → Prop) N a :
  a ~~>: P →
  (∀ a', P a' → Q (namespace_map_data N a')) → namespace_map_data N a ~~>: Q.
Proof.
  intros Hup HP. apply cmra_total_updateP=> n [mf [Ef|]] //.
  rewrite namespace_map_validN_eq /= left_id_L. intros [Hmf Hdisj].
  destruct (Hup n (mf !! positives_flatten N)) as (a'&?&?).
  { move: (Hmf (positives_flatten N)).
    by rewrite lookup_op lookup_singleton Some_op_opM. }
  exists (namespace_map_data N a'); split; first by eauto.
  rewrite /= left_id_L. split.
  - intros j. destruct (decide (positives_flatten N = j)) as [<-|].
    + by rewrite lookup_op lookup_singleton Some_op_opM.
    + rewrite lookup_op lookup_singleton_ne // left_id_L.
      move: (Hmf j). rewrite lookup_op. eauto using cmra_validN_op_r.
  - intros j. move: (Hdisj j).
    rewrite !lookup_op !op_None !lookup_singleton_None. naive_solver.
Qed.
Lemma namespace_map_update N a b :
  a ~~> b → namespace_map_data N a ~~> namespace_map_data N b.
Proof.
  rewrite !cmra_update_updateP. eauto using namespace_map_updateP with subst.
Qed.
End cmra.

Global Arguments namespace_mapR : clear implicits.
Global Arguments namespace_mapUR : clear implicits.


Require Import Coq.Strings.String Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.ContextFreeGrammar.Notations.
Require Import Fiat.Parsers.StringLike.String.

Require Import Fiat.Parsers.Grammars.JSON.

Local Arguments Equality.ascii_beq !_ !_.
Local Arguments Equality.string_beq !_ !_.
Local Arguments list_to_productions / _ _ _ _.
Local Arguments ascii_of_nat !_ / .
Local Arguments ascii_of_pos !_ / .

Local Notation LF := (ascii_of_nat 10).
Local Notation CR := (ascii_of_nat 13).
Local Notation TAB := (ascii_of_nat 9).
Local Notation SPACE := " "%char.

Local Coercion test_string_of_ascii (ch : ascii) := String.String ch EmptyString.
Global Arguments test_string_of_ascii / _.

Local Notation newline := (String.String LF EmptyString).

Local Ltac unfolder :=
  unfold Lookup;
  repeat match goal with
         | [ |- context[Operations.List.first_index_error ?f ?ls] ]
           => let c := constr:(Operations.List.first_index_error f ls) in
              let c' := (eval cbv in c) in
              change c with c'
         | _ => progress unfold option_rect
         | _ => progress unfold nth
         end.

Local Ltac safe_step :=
  idtac;
  (match goal with
   | _ => reflexivity
   | [ |- context[Valid_nonterminals ?G] ]
     => let c := constr:(Valid_nonterminals G) in
        let c' := (eval cbv in c) in
        change c with c'
   | [ |- context G[Lookup ?x ?y] ]
     => is_var x;
        let x' := (eval unfold x in x) in
        let G' := context G[Lookup x' y] in
        change G';
        unfolder
   | [ |- parse_of_production _ ?s (Terminal _ :: _) ]
     => apply ParseProductionCons with (n := 1)
   | [ |- parse_of_production _ ?s (_ :: nil) ]
     => apply ParseProductionCons with (n := String.length s)
   | [ |- parse_of_production _ ?s (_ :: nil) ]
     => apply ParseProductionCons with (n := String.length s)
   | [ |- parse_of_production _ ?s (_ :: Terminal _ :: nil) ]
     => apply ParseProductionCons with (n := String.length s - 1)
   | [ |- parse_of_production _ ?s (_ :: Terminal _ :: Terminal _ :: nil) ]
     => apply ParseProductionCons with (n := String.length s - 2)
   | [ |- parse_of_production _ _ nil ]
     => apply ParseProductionNil
   | [ |- parse_of_item _ (String.String ?ch EmptyString) (Terminal _) ]
     => refine (ParseTerminal _ _ ch _ _ _); simpl; reflexivity
   | [ |- parse_of_item _ _ (Terminal _) ]
     => (refine (ParseTerminal _ _ _ _ _ _);
          simpl;
          erewrite ?Equality.ascii_lb by reflexivity;
          reflexivity)
   | [ |- parse_of_item _ _ (NonTerminal _) ]
     => apply ParseNonTerminal
   | [ |- parse_of _ _ (_::nil) ] => apply ParseHead
   | [ |- parse_of _ ?s (nil::_) ]
     => first [ unify s ""%string; apply ParseHead
              | apply ParseTail ]
    | [ |- parse_of _ (String.String ?ch _) (((Terminal (Equality.ascii_beq ?ch')):: _)::_) ]
      => first [ unify ch ch'; fail 1
               | apply ParseTail ]
   | [ |- is_true (is_char (take 1 _) _) ] => apply get_0
   | _ => progress simpl
   | _ => tauto
   end).

Section json.
  Example json_parses_singleline : parse_of_grammar ("[ " ++ CR ++ LF ++ TAB ++ """xy ]z\"""" ]")%string json_grammar.
  Proof.
    hnf; simpl.
    apply ParseTail; repeat safe_step.
    apply ParseHead; repeat safe_step.
    apply ParseProductionCons with (n := 4); repeat safe_step.
    apply ParseProductionCons with (n := 9); simpl; repeat safe_step.
    { apply ParseHead; repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseHead; repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step. }
    { apply ParseProductionCons with (n := 1); simpl; repeat safe_step. }
  Qed.
End json.


(** * Properties about Context Free Grammars *)
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Common Fiat.Common.UIP.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Equality.

Set Implicit Arguments.

Local Open Scope list_scope.

Global Instance item_rect_Proper {Char T}
: Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> eq ==> eq)
         (@item_rect Char (fun _ => T)).
Proof.
  lazy.
  intros ?? H ?? H' ? [?|?] ?; subst; eauto with nocore.
Qed.
Global Instance item_rect_Proper_forall {Char T}
: Proper (forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq))
         (@item_rect Char T).
Proof.
  lazy.
  intros ?? H ?? H' [?|?]; subst; eauto with nocore.
Qed.

Global Instance item_rect_Proper_forall_R {C A} {R : relation A}
  : Proper
      ((pointwise_relation _ R)
         ==> (pointwise_relation _ R)
         ==> forall_relation (fun _ : item C => R))
      (item_rect (fun _ : item C => A)).
Proof.
  lazy; intros ?????? [?|?]; trivial.
Qed.

Hint Extern 1 (Proper _ (@item_rect _ _)) => exact item_rect_Proper : typeclass_instances.
Hint Extern 0 (Proper _ (@item_rect _ _)) => exact item_rect_Proper_forall : typeclass_instances.
Hint Extern 0 (Proper (pointwise_relation _ _ ==> pointwise_relation _ _ ==> forall_relation _) (item_rect _))
=> refine item_rect_Proper_forall_R : typeclass_instances.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char).

  Definition parse_of_item_respectful'
             (parse_of_respectful : forall {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats), parse_of G str2 pats')
             {str1 str2} (H : str1 =s str2) {it it'} (Hit : item_code it it') (p : parse_of_item G str1 it)
  : parse_of_item G str2 it'
    := match p in (parse_of_item _ _ it), it' return item_code it it' -> parse_of_item G str2 it' with
         | ParseTerminal ch P pf0 pf1, Terminal P' => fun Hit => ParseTerminal G str2 ch P' (transitivity (symmetry (Hit _)) pf0) (transitivity (eq_sym (is_char_Proper H eq_refl)) pf1)
         | ParseTerminal _ _ _ _, NonTerminal _ => fun Hit => match Hit with end
         | ParseNonTerminal nt H' p', NonTerminal nt'
           => fun Hit
              => ParseNonTerminal
                   _
                   (match Hit in (_ = nt') return List.In nt' _ with
                      | eq_refl => H'
                    end)
                   (@parse_of_respectful
                      _ _ H (Lookup G nt) (Lookup G nt')
                      (match Hit in (_ = nt') return productions_code (G nt) (G nt') with
                         | eq_refl => reflexivity _
                       end)
                      p')
         | ParseNonTerminal _ _ _, Terminal _ => fun Hit => match Hit with end
       end Hit.

  Global Arguments parse_of_item_respectful' _ _ _ _ _ !_ _ !_ / .

  Section bodies.
    Context (parse_of_respectful : forall {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats), parse_of G str2 pats')
            (parse_of_production_respectful : forall {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat), parse_of_production G str2 pat').

    Definition parse_of_respectful_step {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats) : parse_of G str2 pats'.
    Proof.
      refine (match p in (parse_of _ _ pats), pats' return productions_code pats pats' -> parse_of G str2 pats' with
                | ParseHead pat pats p', pat'::pats' => fun Hpats' => ParseHead pats' (@parse_of_production_respectful _ _ H _ _ _ p')
                | ParseTail pat pats p', pat'::pats' => fun Hpats' => ParseTail pat' (@parse_of_respectful _ _ H _ _ _ p')
                | ParseHead _ _ _, nil => fun Hpats' => match _ : False with end
                | ParseTail _ _ _, nil => fun Hpats' => match _ : False with end
              end Hpats);
      try solve [ clear -Hpats'; abstract inversion Hpats'
                | clear -Hpats'; inversion Hpats'; subst; assumption ].
    Defined.

    Definition parse_of_production_respectful_step {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat) : parse_of_production G str2 pat'.
    Proof.
      refine (match p in (parse_of_production _ _ pat), pat' return production_code pat pat' -> parse_of_production G str2 pat' with
                | ParseProductionNil pf, nil => fun Hpat' => ParseProductionNil G str2 (transitivity (eq_sym (length_Proper H)) pf)
                | ParseProductionCons n pat pats p0 p1, pat'::pats' => fun Hpat' => ParseProductionCons _ n (parse_of_item_respectful' (@parse_of_respectful) (take_Proper eq_refl H) _ p0) (@parse_of_production_respectful _ _ (drop_Proper eq_refl H) _ _ _ p1)
                | ParseProductionNil _, _::_ => fun Hpat' => match _ : False with end
                | ParseProductionCons _ _ _ _ _, nil => fun Hpat' => match _ : False with end
              end Hpat);
      try solve [ clear -Hpat'; abstract inversion Hpat'
                | clear -Hpat'; inversion Hpat'; subst; assumption ].
    Defined.

    Global Arguments parse_of_respectful_step _ _ _ _ _ _ !_ / .
    Global Arguments parse_of_production_respectful_step _ _ _ _ _ _ !_ / .
  End bodies.

  Fixpoint parse_of_respectful {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats) : parse_of G str2 pats'
    := @parse_of_respectful_step (@parse_of_respectful) (@parse_of_production_respectful) _ _ H _ _ Hpats p
  with parse_of_production_respectful {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat) : parse_of_production G str2 pat'
    := @parse_of_production_respectful_step (@parse_of_respectful) (@parse_of_production_respectful) _ _ H _ _ Hpat p.

  Definition parse_of_item_respectful : forall {str1 str2} H {it it'} Hit p, _
    := @parse_of_item_respectful' (@parse_of_respectful).

  Global Arguments parse_of_item_respectful _ _ _ _ !_ _ !_ / .

  Fixpoint parse_of_respectful_refl {str pf pats Hpats} (p : parse_of G str pats) : parse_of_respectful pf Hpats p = p
    := match p return forall Hpats, parse_of_respectful pf Hpats p = p with
         | ParseHead pat pats p' => fun Hpats => f_equal (ParseHead _) (parse_of_production_respectful_refl p')
         | ParseTail pat pats p' => fun Hpats => f_equal (@ParseTail _ _ _ _ _ _ _) (parse_of_respectful_refl p')
       end Hpats
  with parse_of_production_respectful_refl {str pf pat Hpat} (p : parse_of_production G str pat) : parse_of_production_respectful pf Hpat p = p
       := match p return forall Hpat, parse_of_production_respectful pf Hpat p = p with
            | ParseProductionNil pf => fun Hpat => f_equal (ParseProductionNil _ _) (dec_eq_uip (Nat.eq_dec _) _ _)
            | ParseProductionCons n pat pats p0 p1
              => fun Hpat => f_equal2 (@ParseProductionCons _ _ _ _ _ _ _ _)
                                      (parse_of_item_respectful_refl p0)
                                      (parse_of_production_respectful_refl p1)
          end Hpat
  with parse_of_item_respectful_refl {str pf it Hit} (p : parse_of_item G str it) : parse_of_item_respectful pf Hit p = p
       := match p return forall Hit, parse_of_item_respectful pf Hit p = p with
            | ParseTerminal ch P pf1 pf2 => fun Hit => f_equal2 (ParseTerminal _ _ _ _) (dec_eq_uip (Bool.bool_dec _) _ _) (dec_eq_uip (Bool.bool_dec _) _ _)
            | ParseNonTerminal nt H' p'
              => fun Hit'
                 => f_equal2 (ParseNonTerminal nt)
                             match dec_eq_uip (@Equality.string_eq_dec nt) eq_refl Hit' in (_ = Hit') return match Hit' in (_ = nt') return List.In nt' _ with eq_refl => H' end = H' with
                               | eq_refl => eq_refl
                             end
                             (@parse_of_respectful_refl _ _ _ _ p')
          end Hit.

  (*Global Instance parse_of_Proper : Proper (beq ==> eq ==> iff) (parse_of G).
  Proof.
    split; subst; apply parse_of_respectful; [ assumption | symmetry; assumption ].
  Qed.

  Global Instance parse_of_production_Proper : Proper (beq ==> eq ==> iff) (parse_of_production G).
  Proof.
    split; subst; apply parse_of_production_respectful; [ assumption | symmetry; assumption ].
  Qed.

  Global Instance parse_of_item_Proper : Proper (beq ==> eq ==> iff) (parse_of_item G).
  Proof.
    split; subst; apply parse_of_item_respectful; [ assumption | symmetry; assumption ].
  Qed.*)

  Definition ParseProductionSingleton str it (p : parse_of_item G str it) : parse_of_production G str [ it ].
  Proof.
    econstructor.
    { eapply parse_of_item_respectful; [ | reflexivity | eassumption ].
      rewrite take_long; reflexivity. }
    { constructor.
      rewrite drop_length; auto with arith. }
  Defined.

  Section definitions.
    Context (P : String -> String.string -> Type).

    Definition Forall_parse_of_item'
               (Forall_parse_of : forall {str pats} (p : parse_of G str pats), Type)
               {str it} (p : parse_of_item G str it)
      := match p return Type with
           | ParseTerminal ch P pf1 pf2 => unit
           | ParseNonTerminal nt H' p'
             => (P str nt * Forall_parse_of p')%type
         end.

    Fixpoint Forall_parse_of {str pats} (p : parse_of G str pats)
      := match p with
           | ParseHead pat pats p'
             => Forall_parse_of_production p'
           | ParseTail _ _ p'
             => Forall_parse_of p'
         end
    with Forall_parse_of_production {str pat} (p : parse_of_production G str pat)
         := match p return Type with
              | ParseProductionNil pf => unit
              | ParseProductionCons pat strs pats p' p''
                => (Forall_parse_of_item' (@Forall_parse_of) p' * Forall_parse_of_production p'')%type
            end.

    Definition Forall_parse_of_item {str it} (p : parse_of_item G str it)
      := @Forall_parse_of_item' (@Forall_parse_of) str it p.
  End definitions.

  (*Section expand.
    Context {P P' : String -> String.string -> Type}.

    Definition expand_forall_parse_of_item'
               {str str' str''}
               {Forall_parse_of : forall P {str pats} (p : parse_of G str pats), Type}
               (expand : forall {pats pats' pats''} (Hpats : productions_code pats pats') (Hpats' : productions_code pats' pats'') (H : str =s str') (H' : str =s str'') {p}, @Forall_parse_of P str' pats' (parse_of_respectful H Hpats p) -> @Forall_parse_of P' str'' pats'' (parse_of_respectful H' Hpats' p))
               (f : forall n, P str' n -> P' str'' n)
               {it p} (H : str =s str') (H' : str =s str'')
    : @Forall_parse_of_item' P (@Forall_parse_of P) str' it (parse_of_item_respectful H p)
      -> @Forall_parse_of_item' P' (@Forall_parse_of P') str'' it (parse_of_item_respectful H' p).
    Proof.
      destruct p; simpl.
      { exact (fun x => x). }
      { intro ab.
        exact (f _ (fst ab), expand _ H H' _ (snd ab)). }
    Defined.

    Global Arguments expand_forall_parse_of_item' : simpl never.

    Fixpoint expand_forall_parse_of
             str str' str''
             (f : forall str0' str1', str0' ≤s str -> str0' =s str1' -> forall n, P str0' n -> P' str1' n)
             pats (H : str =s str') (H' : str =s str'') (p : parse_of G str pats)
             {struct p}
    : Forall_parse_of P (parse_of_respectful H p) -> Forall_parse_of P' (parse_of_respectful H' p)
    with expand_forall_parse_of_production
           str str' str''
           (f : forall str0' str1', str0' ≤s str -> str0' =s str1' -> forall n, P str0' n -> P' str1' n)
           pat (H : str =s str') (H' : str =s str'') (p : parse_of_production G str pat)
           {struct p}
         : Forall_parse_of_production P (parse_of_production_respectful H p) -> Forall_parse_of_production P' (parse_of_production_respectful H' p).
    Proof.
      { destruct p.
        simpl.
        { apply expand_forall_parse_of_production; exact f. }
        { refine (expand_forall_parse_of _ _ _ _ _ _ _ p); exact f. } }
      { destruct p as [ | n pat pats pit pits ]; simpl.
        { exact (fun x => x). }
        { pose proof (fun f' f'' => @expand_forall_parse_of_item' _ (take n str') (take n str'') (@Forall_parse_of) (@expand_forall_parse_of _ _ _ f') f'' _ pit) as expand_forall_parse_of_item.
          specialize (fun f' H H' => expand_forall_parse_of_production _ (drop n str') (drop n str'') f' _ H H' pits).
          clear expand_forall_parse_of.
          change (Forall_parse_of_item P (parse_of_item_respectful (take_Proper eq_refl H) pit) * Forall_parse_of_production P (parse_of_production_respectful (drop_Proper eq_refl H) pits)
                  -> Forall_parse_of_item P' (parse_of_item_respectful (take_Proper eq_refl H') pit) * Forall_parse_of_production P' (parse_of_production_respectful (drop_Proper eq_refl H') pits))%type.
          intro xy.
          split.
          { eapply expand_forall_parse_of_item; [ .. | exact (fst xy) ].
            { intros ? ? H''; apply f.
              rewrite str_le_take in H''; assumption. }
            { intro; apply f.
              { clear -H HSLP.
                rewrite str_le_take, H; reflexivity. }
              { rewrite <- H, <- H'; reflexivity. } } }
          { eapply expand_forall_parse_of_production; [ .. | exact (snd xy) ].
            intros ? ? H''; apply f.
            etransitivity; [ eassumption | apply str_le_drop ]. } } }
    Defined.

    Global Arguments expand_forall_parse_of : simpl never.
    Global Arguments expand_forall_parse_of_production : simpl never.

    Definition expand_forall_parse_of_item {str str' str''} f {it} {p : parse_of_item G str it} (H : str =s str') (H' : str =s str'')
      := @expand_forall_parse_of_item' str str' str'' _ (@expand_forall_parse_of str str' str'' f) (f _ _ ((_ : Proper (beq ==> beq ==> impl) str_le) _ _ H _ _ (reflexivity _) (reflexivity _)) (transitivity (symmetry H) H')) it p.

    Global Arguments expand_forall_parse_of_item : simpl never.
  End expand.*)
End cfg.

Ltac simpl_parse_of_respectful :=
  repeat match goal with
           | [ |- context[@parse_of_respectful ?Char ?HSLM ?HSL ?HSLP ?G ?str1 ?str2 ?H ?pat ?pat' ?Hpat ?p] ]
             => change (@parse_of_respectful Char HSLM HSL HSLP G str1 str2 H pat pat' Hpat p)
                with (@parse_of_respectful_step Char HSLM HSL G (@parse_of_respectful Char HSLM HSL HSLP G) (@parse_of_production_respectful Char HSLM HSL HSLP G) str1 str2 H pat pat' Hpat p);
               simpl @parse_of_respectful_step
           | [ |- context[@parse_of_production_respectful ?Char ?HSLM ?HSL ?HSLP ?G ?str1 ?str2 ?H ?pat ?pat' ?Hpat ?p] ]
             => change (@parse_of_production_respectful Char HSLM HSL HSLP G str1 str2 H pat pat' Hpat p)
                with (@parse_of_production_respectful_step Char HSLM HSL G (@parse_of_respectful Char HSLM HSL HSLP G) (@parse_of_production_respectful Char HSLM HSL HSLP G) str1 str2 H pat pat' Hpat p);
               simpl @parse_of_production_respectful_step
           | _ => progress simpl @parse_of_item_respectful
           | _ => progress simpl @parse_of_item_respectful'
         end.

Section parse_of_proper.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char} {str : String}.

  Local Ltac t_parse_of_impl lem :=
    repeat intro;
    match goal with
      | [ H : Proper _ _, H' : _ -> _ |- _ ] => eapply H; [ eassumption.. | apply H'; try clear H H' ]
    end;
    eapply lem; [ .. | eassumption ];
    try first [ assumption
              | reflexivity
              | symmetry; assumption ].

  Section fun0.
    Context {P : _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> impl) P}.

    Global Instance parse_of_item_fun0_Proper
    : Proper (item_code ==> production_code ==> impl) (fun it (its : production Char) => parse_of_item G str it -> P it its).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun0_Proper
    : Proper (item_code ==> production_code ==> impl) (fun (it : item Char) (its : production Char) => parse_of_production G str its -> P it its).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun0.
  Section fun0_flip.
    Context {P : _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> flip impl) P}.

    Global Instance parse_of_item_fun0_Proper_flip
    : Proper (item_code ==> production_code ==> flip impl) (fun it (its : production Char) => parse_of_item G str it -> P it its).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun0_Proper_flip
    : Proper (item_code ==> production_code ==> flip impl) (fun (it : item Char) (its : production Char) => parse_of_production G str its -> P it its).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun0_flip.

  Section fun1.
    Context {A} {RA : relation A}
            {P : _ -> _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> RA ==> impl) P}.

    Global Instance parse_of_item_fun1_Proper
    : Proper (item_code ==> production_code ==> RA ==> impl) (fun it (its : production Char) x => parse_of_item G str it -> P it its x).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun1_Proper
    : Proper (item_code ==> production_code ==> RA ==> impl) (fun (it : item Char) (its : production Char) x => parse_of_production G str its -> P it its x).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun1.
  Section fun1_flip.
    Context {A} {RA : relation A}
            {P : _ -> _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> RA ==> flip impl) P}.

    Global Instance parse_of_item_fun1_Proper_flip
    : Proper (item_code ==> production_code ==> RA ==> flip impl) (fun it (its : production Char) x => parse_of_item G str it -> P it its x).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun1_Proper_flip
    : Proper (item_code ==> production_code ==> RA ==> flip impl) (fun (it : item Char) (its : production Char) x => parse_of_production G str its -> P it its x).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun1_flip.
End parse_of_proper.


From aneris.examples.transaction_commit Require Export
    two_phase_runner_code.
From aneris.examples.transaction_commit Require Import
    two_phase_runner_code two_phase_prelude two_phase_tm two_phase_rm.
(** * A simple runner (without aux. clients), proving safety  *)
Section runner.

  Open Scope nat_scope.
  Definition tm_addr := SocketAddressInet "tm" 80.
  Definition rm1_addr := SocketAddressInet "rm.01" 80.
  Definition rm2_addr := SocketAddressInet "rm.02" 80.
  Definition rm3_addr := SocketAddressInet "rm.03" 80.
  Definition rms : gset socket_address :=
    {[ rm1_addr; rm2_addr; rm3_addr ]}.
  Definition addrs : gset socket_address := {[ tm_addr ]} ∪ rms.
  Definition ips : gset string := {[ "tm"; "rm.01"; "rm.02"; "rm.03" ]}.

  Program Instance my_topo : network_topo :=
    {| RMs := rms; tm := tm_addr |}.
  Solve All Obligations with set_solver.

  Context `{!anerisG (TC_model rms) Σ, !tcG Σ}.

  Notation pending_frac := (dfrac_oneshot.pending tc_oneshot_gname).

  Lemma RMs_size :
    size RMs = 3.
  Proof. rewrite /RMs !size_union ?size_singleton //; set_solver. Qed.

  Lemma runner_spec :
    {{{ inv tcN tc_inv ∗
        tm_addr ⤇ tm_si ∗
        tm_addr ⤳ (∅, ∅) ∗
        ([∗ set] rm ∈ rms, rm ⤇ rm_si) ∗
        ([∗ set] rm ∈ rms, rm ↦●{1/2} WORKING) ∗
        ([∗ set] ip ∈ ips, free_ip ip) ∗
        pending_frac 1 }}}
      runner @["system"]
    {{{ v, RET v; True }}}.
  Proof.
    iIntros (Φ) "(#Hinv & #Htm_si & Htm_a & #Hrms_si & Hwork & Hips & Hpend) HΦ".
    rewrite /runner.
    do 4 (wp_makeaddress; wp_let).
    wp_apply (wp_set_empty socket_address); [done|]; iIntros (?) "%H".
    do 3 (wp_apply (wp_set_add (A := socket_address) with "[//]");
          iIntros (?) "%").
    wp_pures.
    rewrite (pending_split_N _ (size RMs + 1)); [|lia].
    iDestruct (big_sepS_delete _ _ "rm.01" with "Hips") as "(Hrm1 & Hips)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ "rm.02" with "Hips") as "(Hrm2 & Hips)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ "rm.03" with "Hips") as "(Hrm3 & Hips)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ "tm" with "Hips") as "(Htm & _)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ rm1_addr with "Hwork") as "(Hw1 & Hwork)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ rm2_addr with "Hwork") as "(Hw2 & Hwork)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ rm3_addr with "Hwork") as "(Hw3 & _)"; [set_solver|].
    rewrite RMs_size.
    iDestruct (big_sepS_delete _ _ 0 with "Hpend") as "(Hp1 & Hpend)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ 1 with "Hpend") as "(Hp2 & Hpend)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ 2 with "Hpend") as "(Hp3 & Hpend)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ 3 with "Hpend") as "(Ht & _)"; [set_solver|].
    rewrite -RMs_size.
    wp_apply (aneris_wp_start {[port_of_address rm1_addr]}); iFrame.
    iSplitR "Hw1 Hp1"; last first.
    { iIntros "!> Hport".
      wp_apply (resource_manager_spec rm1_addr with "[$] [$] [] [$] [$]");
        [set_solver| |done].
      iApply (big_sepS_elem_of with "Hrms_si"); set_solver. }
    iModIntro; wp_seq.
    wp_apply (aneris_wp_start {[port_of_address rm2_addr]}); iFrame.
    iSplitR "Hw2 Hp2"; last first.
    { iIntros "!> Hport".
      wp_apply (resource_manager_spec rm2_addr with "[$] [$] [] [$] [$] ");
        [set_solver| |done].
      iApply (big_sepS_elem_of with "Hrms_si"); set_solver. }
    iModIntro; wp_seq.
    wp_apply (aneris_wp_start {[port_of_address rm3_addr]}); iFrame.
    iSplitR "Hw3 Hp3"; last first.
    { iIntros "!> Hport".
      wp_apply (resource_manager_spec rm3_addr with "[$] [$] [] [$] [$] ");
        [set_solver| |done].
      iApply (big_sepS_elem_of with "Hrms_si"); set_solver. }
    iModIntro; wp_seq.
    wp_apply (aneris_wp_start {[port_of_address tm_addr]}); iFrame.
    iSplitL "HΦ"; [by iApply "HΦ"|].
    iIntros "!> Hport".
    wp_apply aneris_wp_wand_r; iSplitL.
    { wp_apply (transaction_manager_spec
                  with "[$] [$] [$] [$] [$]").
      by rewrite !union_assoc_L union_empty_r_L in H2. }
    by iIntros (?) "?".
  Qed.

End runner.