Require Import compcert.lib.Axioms.
Require Export compcert.common.Errors.
Require Import liblayers.lib.ExtensionalityAxioms.
Require Export liblayers.lib.Functor.
Require Export liblayers.lib.Monad.
Require Import liblayers.lib.Decision.
Require Import liblayers.logic.Structures.
Require Import liblayers.logic.LayerData.

(** * [res] is a monad *)

Global Instance res_functor_ops: FunctorOps res :=
  {
    fmap A B f x := Errors.bind x (fun x => Errors.OK (f x))
  }.

Global Instance res_functor_prf: Functor res.
Proof.
  split.
  * intros A x.
    destruct x; reflexivity.
  * intros A B C f g x.
    destruct x; reflexivity.
Qed.

Global Instance res_monad_ops: MonadOps res :=
  {
    ret := Errors.OK;
    bind A B f x := Errors.bind x f
  }.

Global Instance res_monad_prf: Monad res.
Proof.
  split; try typeclasses eauto.
  * intros A B f.
    extensionality mx.
    destruct mx; reflexivity.
  * intros A B f x.
    reflexivity.
  * intros A mx.
    destruct mx; reflexivity.
  * intros A B C f g mx.
    destruct mx; reflexivity.
Qed.

Global Instance res_monad_inv_ret:
  MonadInvRet res.
Proof.
  intros A x y Hxy.
  inversion Hxy.
  reflexivity.
Qed.

Global Instance res_monad_inv_bind:
  MonadInvBind res.
Proof.
  intros A B f ma b H.
  unfold ret, bind in H; simpl in *.
  destruct ma; try discriminate.
  eauto.
Qed.

Lemma res_bind_error {A B} (f: A -> res B) msg:
  bind f (Error msg) = Error msg.
Proof.
  reflexivity.
Qed.

Hint Rewrite @res_bind_error : monad.

(** * Lifting orders on [res] *)

(** TODO: define [res_rel] as well? *)

(** We need failure on top: <explain>. *)

Inductive res_le {A B} (R: rel A B): rel (res A) (res B) :=
  | res_le_ok_def:
      (R ++> res_le R)%rel (@OK A) (@OK B)
  | res_le_error (msg: errmsg):
      UpperBound (res_le R) (Error msg).

Global Existing Instance res_le_error.

Global Instance res_le_ok:
  Monotonic (@OK) (forallr R, R ++> res_le R).
Proof.
  exact @res_le_ok_def.
Qed.

Global Instance res_le_bind:
  Monotonic
    (@Errors.bind)
    (forallr RA, forallr RB, res_le RA ++> (RA ++> res_le RB) ++> res_le RB).
Proof.
  unfold Errors.bind.
  rauto.
Qed.

Global Instance res_le_monad:
  MonadRel (@res_le).
Proof.
  split; simpl; rauto.
Qed.

Local Instance res_le_op `(Le): Le (res A) :=
  { le := res_le (≤) }.

Global Instance res_le_monotonic {A B}:
  Monotonic (@res_le A B) (subrel ++> subrel).
Proof.
  intros R1 R2 HR x y H.
  destruct H; constructor.
  apply HR; assumption.
Qed.

Global Instance res_le_monotonic_params:
  Params (@res_le) 3.

Lemma res_le_refl `(Reflexive):
  Reflexive (res_le R).
Proof.
  intros [x | msg].
  - constructor; reflexivity.
  - constructor.
Qed.

Hint Extern 1 (Reflexive (res_le _)) =>
  apply res_le_refl : typeclass_instances.

Lemma res_le_trans `(Transitive):
  Transitive (res_le R).
Proof.
  intros x y z Hxy Hyz.
  destruct Hxy as [x y Hxy | x msg].
  - inversion Hyz.
    + constructor.
      transitivity y; trivial.
    + constructor.
  - inversion Hyz.
    constructor.
Qed.

Hint Extern 1 (Transitive (res_le _)) =>
  apply res_le_trans : typeclass_instances.

Global Instance res_le_htrans {A B C} RAB RBC RAC:
  HTransitive (A:=A) (B:=B) (C:=C) RAB RBC RAC ->
  HTransitive (res_le RAB) (res_le RBC) (res_le RAC).
Proof.
  intros HR x y z Hxy Hyz.
  destruct Hyz as [ y z Hyz | ]; try constructor.
  inversion Hxy as [ x' y' Hxy' | ]; subst; try constructor.
  htransitivity y; assumption.
Qed.

Global Instance res_le_rtrans {A B C} RAB RBC RAC:
  RTransitive (A:=A) (B:=B) (C:=C) RAB RBC RAC ->
  RTransitive (res_le RAB) (res_le RBC) (res_le RAC).
Proof.
  intros HR x z Hxz.
  destruct Hxz as [ a c Hac | ].
  * apply rtransitivity in Hac.
    destruct Hac as (b & Hab & Hbc).
    exists (OK b).
    split; constructor; assumption.
  * exists (Error msg).
    split; constructor.
Qed.

Global Instance res_lower_bound {A B} (R: rel A B) (x: A):
  LowerBound R x ->
  LowerBound (res_le R) (OK x).
Proof.
  intros H [y|m]; constructor.
  apply lower_bound.
Qed.

(** ** Data-indexed version *)

Local Instance res_sim_op `(Tsim: Sim): Sim _ (fun D => res (T D)) :=
  { simRR D1 D2 R := res_le (sim R) }.

(** I'm not sure if those are still necessary now that we use the
  generalized [rel]. *)

Global Instance OK_sim_monotonic `(Tsim: Sim):
  Monotonic
    (fun D => @OK (T D))
    (forallr R, sim R ++> sim R).
Proof.
  intros D1 D2 R.
  apply res_le_ok.
Qed.

Global Instance res_sim_bind {V E} {A B: V -> Type}:
  forall (RA: sim_relation E A) (RB: sim_relation E B),
    Monotonic
      (fun (v : V) => bind (A := A v) (B := B v))
      (forallr e @ v1 v2 : E,
         (RA v1 v2 e ++> res_le (RB v1 v2 e)) ++>
         (res_le (RA v1 v2 e) ++> res_le (RB v1 v2 e))).
Proof.
  intros RA RB v1 v2 e.
  intros f g Hfg x y Hxy.
  destruct Hxy as [x y Hxy | y msg].
  * monad_norm.
    apply Hfg.
    assumption.
  * monad_norm.
    constructor.
Qed.

Global Instance res_sim_fmap {V E} {A B: V -> Type}:
  forall (RA: sim_relation E A) (RB: sim_relation E B),
    Monotonic
      (fun (v : V) => fmap (A := A v) (B := B v))
      (forallr e @ v1 v2 : E,
         (RA v1 v2 e ++> RB v1 v2 e) ++>
         (res_le (RA v1 v2 e) ++> res_le (RB v1 v2 e))).
Proof.
  intros RA RB v1 v2 e.
  intros f g Hfg x y Hxy.
  destruct Hxy as [x y Hxy | y msg].
  * monad_norm.
    constructor.
    apply Hfg.
    assumption.
  * monad_norm.
    constructor.
Qed.

(** * Orders for [res ∘ option] *)

Require Import OptionOrders.

Lemma res_option_le_ok_none {A} (R: relation A) (y: res (option A)):
  res_le (option_le R) (OK None) y.
Proof.
  apply lower_bound.
Qed.

Hint Resolve res_option_le_ok_none: liblayers.

(** * Decision-related definitions *)

(** ** The [res] version of [assert]. *)

Definition eassert (e: errmsg) P `{HP: Decision P}: res P :=
  match decide P with
    | left H => ret H
    | right H => Error e
  end.

Lemma eassert_inv `{Pdec: Decision} {A} m (f: P -> res A) (r: A):
  bind f (eassert m P) = ret r <->
  exists H, f H = ret r.
Proof.
  unfold eassert.
  destruct (decide P) as [HP | HP];
  unfold bind; simpl.
  * split; eauto.
    intros [H Hf].
    assert (H = HP) by apply proof_irr; congruence.
  * split; try discriminate.
    intros [H Hf].
    tauto.
Qed.

Instance eassert_le:
  Monotonic eassert (⊤ ++> forallr P Q : flip impl, ⊤ ++> res_le ⊤).
Proof.
  intros msg1 msg2 _ P Q HPQ Pdec Qdec _.
  unfold eassert, flip, impl in *.
  destruct (decide Q) as [HQ | HQ]; try constructor.
  destruct (decide P) as [HP | HP]; try tauto.
  constructor.
  apply I.
Qed.

Hint Rewrite @eassert_inv using typeclasses eauto : monad.

(** These tactics make it easy to reduce subexpressions of the form
  [H <- eassert msg P; M] in the goal by proving or disproving [P]. *)

Lemma eassert_true msg P `{Pdec: Decision P}:
  P -> exists H, eassert msg P = OK H.
Proof.
  intros.
  unfold eassert.
  destruct (decide P); try contradiction.
  eauto.
Defined.

Ltac eassert_true_aux msg P Pdec :=
  let H := fresh "Hasserted" in
  let HH := fresh "Hassert_eq" in
  destruct (eassert_true msg P (Pdec := Pdec)) as [H HH];
    [ idtac (* The user will prove [P] *)
    | rewrite !HH in *;
      clear HH;
      monad_norm;
      try clear H ].

Ltac eassert_true :=
  lazymatch goal with
    | |- context [@eassert ?msg ?P ?Pdec] =>
      eassert_true_aux msg P Pdec
  end.

Lemma eassert_false msg P `{Pdec: Decision P}:
  ~P -> eassert msg P = Error msg.
Proof.
  intros.
  unfold eassert.
  destruct (decide P); try contradiction.
  eauto.
Defined.

Ltac eassert_false_aux msg P Pdec :=
  let H := fresh in
  assert (H: ~P);
    [ idtac (* The user will prove [~P] *)
    | rewrite !(eassert_false msg P (Pdec:=Pdec) H);
      monad_norm;
      clear H ].

Ltac eassert_false :=
  lazymatch goal with
    | |- context [@eassert ?msg ?P ?Pdec] =>
      eassert_false_aux msg P Pdec
  end.

(** ** Whether a [res A] is [OK] or [Error] *)

Definition isOK {A} (x: res A): Prop :=
  exists (a: A), x = OK a.

Definition isError {A} (x: res A): Prop :=
  exists (m: errmsg), x = Error m.

Definition isOKNone {A} (x: res (option A)) :=
  x = OK None.

Global Instance isOK_dec {A} (x: res A): Decision (isOK x) :=
  match x with
    | OK _ => left _
    | Error _ => right _
  end.
Proof.
  abstract (red; eauto).
  abstract (intros [a Ha]; discriminate).
Defined.

Global Instance isError_dec {A} (x: res A): Decision (isError x) :=
  match x with
    | OK _ => right _
    | Error _ => left _
  end.
Proof.
  abstract (intros [msg Hmsg]; discriminate).
  abstract (red; eauto).
Defined.

Global Instance isOKNone_dec {A} (x: res (option A)):
  Decision (isOKNone x) :=
  match x with
    | OK None => left _
    | _ => right _
  end.
Proof.
  abstract (unfold isOKNone; simpl; congruence).
  abstract reflexivity.
  abstract (unfold isOKNone; simpl; congruence).
Defined.

Global Instance isOK_le:
  Monotonic (@isOK) (forallr R, res_le R --> impl).
Proof.
  intros B A R x y Hxy [x' Hx].
  subst.
  inversion Hxy.
  exists x.
  reflexivity.
Qed.

Global Instance isError_le:
  Monotonic (@isError) (forallr R, res_le R ++> impl).
Proof.
  intros A B R x y Hxy Hx.
  destruct Hx as [err Hx]; subst.
  inversion Hxy as [| err' x]; subst.
  eexists.
  reflexivity.
Qed.

Instance isOKNone_le:
  Monotonic (@isOKNone) (forallr R, res_le (option_le R) --> impl).
Proof.
  unfold isOKNone.
  intros A1 A2 RA x y Hxy Hx.
  destruct Hxy as [x y Hxy | ]; try discriminate.
  destruct Hxy as [x y Hxy | ]; try discriminate.
  reflexivity.
Qed.

(** *** Some lemmas and [eauto] hints. *)

Lemma isOK_OK {A} (a: A):
  isOK (OK a).
Proof.
  eexists.
  reflexivity.
Qed.

Lemma isOK_Error {A} msg:
  ~ isOK (@Error A msg).
Proof.
  intros [a Ha].
  discriminate.
Qed.

Hint Resolve isOK_OK.

Lemma isOKNone_OKNone {A}:
  isOKNone (OK (@None A)).
Proof.
  reflexivity.
Qed.

Hint Resolve isOKNone_OKNone.

Lemma isError_Error {A} msg:
  isError (@Error A msg).
Proof.
  eexists.
  reflexivity.
Qed.

Hint Resolve isError_Error.

(** * Miscellaneous helpers *)

Definition fallback {A} (x: A) (y: res A): A :=
  match y with
    | OK a => a
    | Error _ => x
  end.

(** ** Flip [option (res -)] <-> [res (option -)] *)

(** Overall, [res ∘ option] is more convenient to manipulate and
  that's what we have in most places. However, it is more
  straightforward to store into [PTree]s as [option ∘ res].
  Fortunately these wrappers can be used to flip between the two
  representations. *)

Definition res_option_flip {A} (roa: res (option A)): option (res A) :=
  match roa with
    | OK None => None
    | OK (Some a) => Some (OK a)
    | Error msg => Some (Error msg)
  end.

Global Instance res_option_flip_le:
  Monotonic
    (@res_option_flip)
    (forallr R, res_le (option_le R) ++> option_le (res_le R)).
Proof.
  intros A1 A2 RA _ _ [_ _ [y | x y Hxy] | msg [[|]|]];
  simpl;
  rauto.
Qed.

Definition option_res_flip {A} (ora: option (res A)): res (option A) :=
  match ora with
    | None => OK None
    | Some (OK a) => OK (Some a)
    | Some (Error msg) => Error msg
  end.

Lemma option_res_le_flip {A B} (R: rel A B) x y:
  res_le (option_le R) (option_res_flip x) (option_res_flip y) <->
  option_le (res_le R) x y.
Proof.
  destruct x as [[|]|];
  destruct y as [[|]|];
  split; intro H;
  inversion H; subst;
  try (inversion H2; subst);
  repeat (constructor || assumption).
Qed.

Global Instance option_res_flip_le:
  Monotonic
    (@option_res_flip)
    (forallr R, option_le (res_le R) ++> res_le (option_le R)).
Proof.
  intros A1 A2 RA x y Hxy.
  apply option_res_le_flip.
  assumption.
Qed.

Lemma res_option_flip_inv {A} (x: res (option A)):
  option_res_flip (res_option_flip x) = x.
Proof.
  destruct x as [[x|] | msg]; reflexivity.
Qed.

Lemma option_res_flip_inv {A} (x: option (res A)):
  res_option_flip (option_res_flip x) = x.
Proof.
  destruct x as [[x|msg] | ]; reflexivity.
Qed.

Lemma res_option_le_flip {A B} (R: rel A B) x y:
  option_le (res_le R) (res_option_flip x) (res_option_flip y) <->
  res_le (option_le R) x y.
Proof.
  rewrite <- option_res_le_flip.
  repeat rewrite res_option_flip_inv.
  tauto.
Qed.

(** * [PseudoJoin] structure for [res (option -)] *)

Require Import PseudoJoin.

Section RES_OPTION_PSEUDO_JOIN.
  Global Instance res_option_oplus_op (A: Type): Oplus (res (option A)) | 10 :=
    { oplus rox roy :=
    ox <- rox;
    oy <- roy;
    match ox, oy with
      | None, None => ret None
      | Some x, None => ret (Some x)
      | None, Some y => ret (Some y)
      | Some x, Some y => Error nil
    end }.

  Global Instance res_option_oplus_monotonic {A} (R: relation A):
    Monotonic
      (⊕)
      (res_le (option_le R) ++> res_le (option_le R) ++> res_le (option_le R)).
  Proof.
    simpl.
    unfold Errors.bind.
    repeat rstep.
    destruct H3 as [[y1|] | x1 y1 H1];
    destruct H4 as [[y2|] | x2 y2 H2];
    repeat rstep.
  Qed.

  Existing Instance res_le_op.
  Existing Instance option_le_op.

  Local Hint Extern 4 => reflexivity.

  Global Instance res_option_oplus_prf (A: Type) `{Ale: Le A}:
    @PreOrder A (≤) ->
    PseudoJoin (res (option A)) (OK None).
  Proof with simpl; monad_norm; repeat constructor; reflexivity.
    intros Hpre.
    split; try typeclasses eauto.
    * simpl (≤).
      split; typeclasses eauto.
    * red; rauto.
    * intros [[y|]|err]...
    * intros [[x|]|xerr] [[y|]|yerr] [[z|]|zerr]...
    * intros [[x|]|xerr] [[y|]|yerr]...
    * intros [[x|]|xerr] [[y|]|yerr]...
  Qed.

  (** In addition, we have stronger versions of those. *)

  Global Instance res_option_oplus_id_left A:
    @LeftIdentity (res (option A)) eq (⊕) (OK None).
  Proof.
    intros [[|]|]; reflexivity.
  Qed.

  Global Instance res_option_oplus_comm A:
    @RightIdentity (res (option A)) eq (⊕) (OK None).
  Proof.
    intros [[|]|]; reflexivity.
  Qed.
End RES_OPTION_PSEUDO_JOIN.

Section OPTION_RES_PSEUDO_JOIN.
  Global Instance option_res_oplus_op (A: Type): Oplus (option (res A)) | 10 :=
    {
      oplus orx ory :=
        match orx, ory with
          | None, None => None
          | Some x, None => Some x
          | None, Some y => Some y
          | Some (Error e), Some y => Some (Error e)
          | Some (OK x), Some (Error e) => Some (Error e)
          | Some (OK x), Some (OK y) => Some (Error nil)
        end
    }.

  Existing Instance option_le_op.
  Existing Instance res_le_op.

  Global Instance option_res_oplus_prf (A: Type) `{Ale: Le A} `{Hle: PreOrder A (≤)}:
    PseudoJoin (option (res A)) None.
  Proof with simpl; eauto with liblayers; intros; try solve_monotonic.
    split; try typeclasses eauto.
    * simpl (≤); split; typeclasses eauto.
    * intros x1 x2 Hx y1 y2 Hy; simpl.
      destruct Hx as [ [[x2|xerr]|] | _ _ [x1 x2 Hx | xerr [x|xe]]];
      destruct Hy as [ [[y2|yerr]|] | _ _ [y1 y2 Hy | yerr [y|ye]]]...
    * intros [[?|?]|]...
    * intros [[?|?]|] [[?|?]|] [[?|?]|]...
    * intros [[?|?]|] [[?|?]|]...
    * intros [[?|?]|] [[?|?]|]...
  Qed.

  (** In addition, we have a top element. *)
  Global Instance option_res_top {A B} (R: rel A B) errmsg:
    UpperBound (option_le (res_le R)) (Some (Error errmsg)).
  Proof.
    intro x.
    destruct x as [|]; repeat constructor.
  Qed.
End OPTION_RES_PSEUDO_JOIN.

(* Decidable equality *)

Global Instance decide_res_eq `{EqDec}:
  EqDec (res A).
Proof.
  repeat red.
  repeat decide equality.
  apply (decide _).
Defined.


Require Import Coq.ZArith.BinInt.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Import ListNotations.

Require Import Util.

(*TODO: where do we need this? See. Also should we use Interval package?*)
Record int_range := mk_intrng { ir_lower : Z; ir_upper: Z}.

(* TODO: should really be machine-length integers *)
Record float_format := mk_floatfmt {
    fp_exponent_digits : Z;
    fp_significand_digits : Z
}.

(*TODO: do we need attributes or tag?*)
(* Need tag for comparison (use as key in map) *)
Record ident : Type := mk_ident {
    id_string : string;
    id_tag : Z (*We just use the concrete type, not hashtable tag*)
}.

Definition ident_eq_dec: forall (i1 i2: ident), {i1 = i2} + {i1 <> i2}.
Proof.
    solve_eq_dec.
Defined.

(*In the real implementation, there is a mutable counter for the tags of
    each ident that is registered (in id_register in ident.ml). Instead,
    we assume the existence of an injective string -> Z function (which
    does exist and we may write it later), and just use the fact that the
    string names are unique.*)
Section MakeTag.

Axiom string_to_Z : string -> Z.
Axiom string_to_Z_inj: forall s1 s2, string_to_Z s1 = string_to_Z s2 -> s1 = s2.

End MakeTag.

Definition mk_id (s: string) : ident := mk_ident s (string_to_Z s).

(*Types*)

Record tvsymbol : Type :=
    mk_tvsym { tv_name : ident }.

Definition tvsymbol_eq_dec: forall (t1 t2: tvsymbol), {t1 = t2} + {t1 <> t2}.
Proof.
    solve_eq_dec.
Defined.

(*Simplified version of types with no mutual recursion.
  We do not include Range/Float because they are not used
  in the frama-C translation.
  Frama-C does ues Alias, which we represent with an option type.*)

Inductive ty : Type :=
    | Tyvar : (ident * list tvsymbol * option ty) -> ty
    | Tyapp : (ident * list tvsymbol * option ty) -> list ty -> ty
    | Alias : ty -> ty.

Notation tysymbol := (ident * list tvsymbol * option ty)%type.

(*A more faithful (but annoying to use) version would be:

Inductive type_def (A: Type) : Type :=
    | NoDef : type_def A
    | Alias : A -> type_def A
    | Range : int_range -> type_def A
    | Float : float_format -> type_def A.

Inductive tysymbol : Type :=
    | mk_tysym : ident -> list tvsymbol -> type_def ty -> tysymbol
(*simplified version - ignore tags, combine ty and ty_node into 1*)
with ty : Type := (*ignoring tag*)
    | mk_ty : ty_node -> ty
with ty_node : Type :=
    | Tyvar : tvsymbol -> ty_node
    | Tyapp : tysymbol -> list ty -> ty_node.
*)

(*The default induction principle is useless, we need a better one:*)

Definition p_opt {A: Type} (P: A -> Prop) (o: option A) : Prop :=
    match o with
    | None => True
    | Some x => P x
    end.

Section TyInd.

Variable P: ty -> Prop.
Variable Hvar: forall (i: ident) (l: list tvsymbol) (o: option ty),
    p_opt P o -> P (Tyvar (i, l, o)).
Variable Happ: forall (i: ident) (l: list tvsymbol) (o: option ty) (lty: list ty),
    p_opt P o -> Forall P lty ->P (Tyapp (i, l, o) lty).
Variable Halias: forall (t: ty), P t -> P (Alias t).

Fixpoint ty_ind' (t: ty): P t :=
let f := (fix list_ty_ind (ls: list ty) : Forall P ls :=
    match ls with
    | nil => (@Forall_nil ty P)
    | (x :: tl) => @Forall_cons ty P _ _ (ty_ind' x) (list_ty_ind tl)
    end) in
match t with
| Tyvar (i, l, (Some t)) => Hvar i l (Some t) (ty_ind' t)
| Tyvar (i, l, None) => Hvar i l None I
| Tyapp (i, l, Some t) lty => Happ i l (Some t) lty (ty_ind' t) (f lty)
| Tyapp (i, l, None) lty => Happ i l None lty I (f lty)
| Alias t' => Halias t' (ty_ind' t')
end.

End TyInd.

(* Decidable Equality on Types *)

(*Writing functions over this type is quite annoying, due to the nested
  options/lists*)
Fixpoint ty_eqb (t1 t2: ty) : bool :=
    match t1, t2 with
    | Tyvar (i1, l1, o1), Tyvar (i2, l2, o2) =>
        (ident_eq_dec i1 i2) &&
        (list_eq_dec tvsymbol_eq_dec l1 l2) &&
        match o1, o2 with
        | Some t1', Some t2' => ty_eqb t1' t2'
        | None, None => true
        | _, _ => false
        end
    | Tyapp (i1, l1, o1) tyl1, Tyapp (i2, l2, o2) tyl2 =>
        (ident_eq_dec i1 i2) &&
        (list_eq_dec tvsymbol_eq_dec l1 l2) &&
        match o1, o2 with
        | Some t1', Some t2' => ty_eqb t1' t2'
        | None, None => true
        | _, _ => false
        end &&
        ((fix eqb_ty_list (l1: list ty) (l2: list ty) : bool :=
            match l1, l2 with
            | nil, nil => true
            | t1 :: tl1, t2 :: tl2 => (ty_eqb t1 t2) && (eqb_ty_list tl1 tl2)
            | _, _ => false
            end) tyl1 tyl2)
    | Alias t1', Alias t2' => ty_eqb t1' t2'
    | _, _ => false
    end.

Ltac contra :=
    let C := fresh in
    intro C; inversion C; subst; contradiction.

Ltac destruct_eq x :=
    destruct x; simpl; [|contra].

Lemma eqb_ty_list_simpl: forall l l',
(fix eqb_ty_list (l1 l2 : list ty) {struct l1} : bool :=
match l1 with
| [] => match l2 with
        | [] => true
        | _ :: _ => false
        end
| t1 :: tl1 =>
    match l2 with
    | [] => false
    | t2 :: tl2 => ty_eqb t1 t2 && eqb_ty_list tl1 tl2
    end
end) l l' = (Nat.eqb (length l) (length l')) && forallb id (map2 l l' (fun x y => ty_eqb x y)).
Proof.
    intros l. induction l as [|h t IH]; intros l'; simpl.
    - destruct l'; reflexivity.
    - destruct l' as [|h1 t1]; simpl; auto.
      rewrite IH; simpl. rewrite andb_comm, andb_assoc.
      unfold id at 2. rewrite <- andb_assoc.
      rewrite (andb_comm _ (ty_eqb _ _)), andb_assoc.
      reflexivity.
Qed.

Lemma ty_eqb_eq: forall (t1 t2: ty),
    ty_eqb t1 t2 = true ->
    t1 = t2.
Proof.
    intros t1. induction t1 using ty_ind'.
    - intros t2. destruct t2; simpl; try contra.
      destruct p as [[i2 l2] o2]; simpl.
      destruct_eq (ident_eq_dec i i2).
      destruct_eq (list_eq_dec tvsymbol_eq_dec l l2).
      subst.
      destruct o as [t1|]; destruct o2 as [t2|]; try contra;[|reflexivity].
      simpl in H. intro Heq. subst. rewrite (H t2); auto.
    - intros t2. destruct t2; simpl; try contra.
      destruct p as [[i2 l2] o2]; simpl.
      destruct_eq (ident_eq_dec i i2).
      destruct_eq (list_eq_dec tvsymbol_eq_dec l l2).
      subst. intros Heq; apply andb_prop in Heq; destruct Heq.
      assert (lty = l0). {
          rewrite eqb_ty_list_simpl in H2.
          apply andb_prop in H2; destruct H2.
          apply EqNat.beq_nat_true in H2.
          rewrite map2_combine, forallb_forall in H3.
          apply list_combine_eq; auto.
          intros x y Hinxy. assert(Hmap:=Hinxy).
          eapply in_map in Hmap. apply H3 in Hmap.
          simpl in Hmap. unfold id in Hmap.
          apply in_combine_l in Hinxy.
          rewrite Forall_forall in H0. apply H0; assumption.
      } subst; clear H2.
      destruct o as [t1|]; destruct o2 as [t2|]; try solve[inversion H1].
      rewrite (H t2) by assumption. all: reflexivity.
    - simpl. intros t2; destruct t2; try contra; intros Heq.
      rewrite (IHt1 t2); auto.
Qed.

Lemma ty_eqb_refl: forall (t: ty),
    ty_eqb t t = true.
Proof.
    intros t; induction t using ty_ind'; simpl.
    - destruct (ident_eq_dec i i); auto.
      destruct (list_eq_dec tvsymbol_eq_dec l l); auto.
      simpl. destruct o; simpl in *; auto.
    - destruct (ident_eq_dec i i); auto.
      destruct (list_eq_dec tvsymbol_eq_dec l l); auto.
      simpl.
      (*Need nested lemma for fixpoint here:*)
      assert (
      (fix eqb_ty_list (l1 l2 : list ty) {struct l1} : bool :=
      match l1 with
      | [] => match l2 with
              | [] => true
              | _ :: _ => false
              end
      | t1 :: tl1 =>
          match l2 with
          | [] => false
          | t2 :: tl2 => ty_eqb t1 t2 && eqb_ty_list tl1 tl2
          end
      end) lty lty = true). {
        rewrite eqb_ty_list_simpl. apply andb_true_intro.
        split.
        - apply PeanoNat.Nat.eqb_refl.
        - rewrite map2_combine; apply forallb_forall. intros x Hin.
          rewrite in_map_iff in Hin. destruct Hin as [[t1 t2] [Heq Hin]].
          simpl in *; subst. assert (Heq:=Hin).
          apply in_combine_same in Heq; subst. apply in_combine_l in Hin.
          rewrite Forall_forall in H0. apply H0. assumption.
      }
      rewrite H1; clear H1.
      destruct o; simpl in *; auto.
      rewrite H. reflexivity.
    - assumption.
Qed.

Lemma ty_eqb_eq_iff: forall (t1 t2: ty),
  Bool.reflect (t1 = t2) (ty_eqb t1 t2).
Proof.
    intros t1 t2. destruct (ty_eqb t1 t2) eqn : Heq.
    - apply ReflectT. apply ty_eqb_eq. assumption.
    - apply ReflectF. intro C; subst.
      rewrite ty_eqb_refl in Heq. inversion Heq.
Qed.

Definition ty_eq_dec: forall (t1 t2: ty), {t1 = t2} + {t1 <> t2} :=
    fun t1 t2 => reflect_dec _ _ (ty_eqb_eq_iff t1 t2).

Definition tysymbol_eq_dec: forall (t1 t2: tysymbol), {t1 = t2} + {t1 <> t2}.
Proof.
    intros t1 t2. decide equality.
    - apply option_eq_dec. intros a1 a2. apply ty_eq_dec.
    - solve_eq_dec.
Qed.

(* Type constructors *)
Definition mk_ts (name: string) (args: list tvsymbol) (def: option ty) : tysymbol :=
    ((mk_id name), args, def).

(* Built in type symbols *)
Definition ts_int : tysymbol :=
    mk_ts "int" nil None.

Definition ts_real : tysymbol :=
    mk_ts "real" nil None.

Definition ts_bool : tysymbol :=
    mk_ts "bool" nil None.

Definition ts_str : tysymbol :=
    mk_ts "string" nil None.

(*Their implementation uses mutable hashtables and lots of exceptions.
    This is a simpler version for the types we need*)
Definition ty_app (s: tysymbol) (tl : list ty) : ty :=
    (*TODO: ignoring alias for now, may need*)
    Tyapp s tl.

Definition ty_int : ty := ty_app ts_int nil.
Definition ty_real : ty := ty_app ts_real nil.
Definition ty_bool : ty := ty_app ts_bool nil.
Definition ty_str : ty := ty_app ts_str nil.

Definition ts_func : tysymbol :=
    let tv_a := mk_tvsym (mk_id "a") in
    let tv_b := mk_tvsym (mk_id "b") in
    mk_ts "->" [tv_a; tv_b] None.

Definition ty_func (ty_a ty_b : ty) : ty :=
    ty_app ts_func [ty_a; ty_b].

(*a -> bool function*)
Definition ty_pred (ty_a : ty) : ty :=
    ty_app ts_func [ty_a; ty_bool].

(*Tuples*)

Definition nat_to_string (n: nat) : string :=
    (String (Ascii.ascii_of_nat n) EmptyString).

(*In the OCaml impl, each element gets a different id. We model
  that by giving each a different name (technically, this means that
  tuples cannot have more than 256 elements)
  Do these have to be globally unique?*)
Definition ts_tuple (n: nat) : tysymbol :=
    let vl := fold_left (fun acc m => mk_tvsym (mk_id (nat_to_string m)) :: acc)
        (seq 0 n) nil in
    mk_ts ("tuple" ++ nat_to_string n) vl None.

Definition ty_tuple (tyl: list ty) : ty :=
    ty_app (ts_tuple (length tyl)) tyl.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.
Require Import apile.
Require Import spec_stdlib.
Require Import spec_pile.
Require Import spec_pile_private.
Require Import spec_apile.

#[export] Instance APileCompSpecs : compspecs. make_compspecs prog. Defined.

Section Apile_VSU.
Variable M: MallocFreeAPD.
Variable PILEPRIV: PilePrivateAPD M. (*apile is parametric in a PRIVATE pile predicate structure*)

Definition apile (sigma: list Z) (gv: globals): mpred :=
  !!(headptr (gv _a_pile)) && pilerep PILEPRIV sigma (gv _a_pile).
(*We define apile in terms of pilerep and then,
  in the proof of make_apile below, use the axiom
  spec_pile_private.pile_rep_exposed
  to exploit the representation exposure*)

Lemma make_apile: forall gv,
  globals_ok gv ->
  data_at Ews size_t nullval (gv apile._a_pile) |-- apile nil gv.
Proof.
intros. unfold apile. rewrite pile_rep_exposed. (*HERE*)
unfold prep.
assert_PROP (headptr (gv _a_pile)) by entailer!.
Exists nullval.
unfold listrep. entailer!.
unfold_data_at (data_at _ spec_pile.tpile _ _).
rewrite field_at_data_at. simpl.
rewrite field_compatible_field_address
   by auto with field_compatible.
simpl. normalize.
rewrite <- data_at_nullptr.
cancel.
Qed.

Lemma apile_Init: VSU_initializer prog (apile nil).
  Proof.
    InitGPred_tac.  rewrite sepcon_emp.
    apply make_apile; auto.
Qed.

Definition APILE: APileAPD := Build_APileAPD apile (*APileCompSpecs make_apile*) (*_ apile_Init*).

  Definition Apile_ASI: funspecs := ApileASI M APILE.

  Definition apile_imported_specs:funspecs :=
     [ Pile_add_spec M PILEPRIV; Pile_count_spec PILEPRIV].

  Definition apile_internal_specs: funspecs := Apile_ASI.

  Definition ApileVprog: varspecs. mk_varspecs prog. Defined.
  Definition ApileGprog: funspecs := apile_imported_specs ++ apile_internal_specs.

Lemma body_Apile_add: semax_body ApileVprog ApileGprog f_Apile_add (Apile_add_spec M APILE).
Proof.
start_function.
simpl spec_apile.apile. unfold apile; Intros.
forward_call (gv _a_pile, n,sigma,gv).
entailer!. simpl. unfold apile. entailer!.
Qed.

Lemma body_Apile_count: semax_body ApileVprog ApileGprog f_Apile_count (Apile_count_spec M APILE).
Proof.
start_function.
simpl spec_apile.apile. unfold apile in *; Intros.
forward_call (gv _a_pile, sigma).
forward.
entailer!. simpl. unfold apile. entailer!.
Qed.

Definition ApileVSU: @VSU NullExtension.Espec
      nil apile_imported_specs ltac:(QPprog prog) Apile_ASI (apile nil).
Proof.
 mkVSU prog apile_internal_specs.
    + solve_SF_internal body_Apile_add.
    + solve_SF_internal body_Apile_count.
    + apply apile_Init.
  Qed.

End Apile_VSU.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.

Inductive insn :=
| Nop
| Arg
| Self
| Deref (off : nat)
| Call
| MkConstr (tag : nat) (nargs : nat)
| Switch (cases : list (list insn))
| MkClose (f : function_name) (nfree : nat)
| OpaqueOp (op : opaque_oper_name) (nargs : nat)
.

Definition env := list (list insn).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    stack : list value
}.

Definition push f v :=
    Frame (arg f) (self f) (v :: stack f).

Definition pop f n :=
    Frame (arg f) (self f) (skipn n (stack f)).

Definition pop_push f n v :=
    push (pop f n) v.

Definition top f :=
    match stack f with
    | [] => Constr 0 []
    | v :: _ => v
    end.

Inductive cont :=
| Kret (code : list insn) (f : frame) (k : cont)
(* keeping the original `stk` lets us enforce that each branch pushes
 * exactly one value before running SContSwitch *)
| Kswitch (code : list insn) (stk : list value) (k : cont)
| Kstop.

Inductive state :=
| Run (i : list insn) (f : frame) (k : cont)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SNop : forall is f k,
        sstep E (Run (Nop :: is) f k)
                (Run is f k)

| SArg : forall is f k,
        sstep E (Run (Arg :: is) f k)
                (Run is (push f (arg f)) k)
| SSelf : forall is f k,
        sstep E (Run (Self :: is) f k)
                (Run is (push f (self f)) k)

| SDerefinateConstr : forall off is f k  tag args v,
        length (stack f) >= 1 ->
        top f = Constr tag args ->
        nth_error args off = Some v ->
        sstep E (Run (Deref off :: is) f k)
                (Run is (pop_push f 1 v) k)
| SDerefinateClose : forall off is f k  fname free v,
        length (stack f) >= 1 ->
        top f = Close fname free ->
        nth_error free off = Some v ->
        sstep E (Run (Deref off :: is) f k)
                (Run is (pop_push f 1 v) k)

| SConstrDone : forall tag nargs is f k,
        length (stack f) >= nargs ->
        sstep E (Run (MkConstr tag nargs :: is) f k)
                (Run is (pop_push f nargs (Constr tag (rev (firstn nargs (stack f))))) k)
| SCloseDone : forall fname nfree is f k,
        length (stack f) >= nfree ->
        sstep E (Run (MkClose fname nfree :: is) f k)
                (Run is (pop_push f nfree (Close fname (rev (firstn nfree (stack f))))) k)
| SOpaqueOpDone : forall op nargs is f k v,
        length (stack f) >= nargs ->
        opaque_oper_denote_higher op (rev (firstn nargs (stack f))) = Some v ->
        sstep E (Run (OpaqueOp op nargs :: is) f k)
                (Run is (pop_push f nargs v) k)

| SMakeCall : forall is f k  fname free body,
        length (stack f) >= 2 ->
        nth_error (stack f) 1 = Some (Close fname free) ->
        nth_error E fname = Some body ->
        sstep E (Run (Call :: is) f k)
                (Run body (Frame (top f) (Close fname free) [])
                    (Kret is (pop f 2) k))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall cases is f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run (Switch cases :: is) f k)
                (Run case f (Kswitch is (stack f) k))

| SContRet : forall code f f' k,
        length (stack f) = 1 ->
        sstep E (Run [] f (Kret code f' k))
                (Run code (push f' (top f)) k)
| SContSwitch : forall code f stk k v,
        stack f = v :: stk ->
        sstep E (Run [] f (Kswitch code stk k))
                (Run code f k)
| SContStop : forall f,
        length (stack f) = 1 ->
        sstep E (Run [] f Kstop)
                (Stop (top f))
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 Kstop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HNop :     P Nop)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Nop => HNop
        | Arg => HArg
        | Self => HSelf
        | Deref off => HDeref off
        | Call => HCall
        | MkConstr tag nargs => HConstr tag nargs
        | Switch cases => HSwitch cases (go_list_list cases)
        | MkClose fname nfree => HClose fname nfree
        | OpaqueOp op nargs => HOpaqueOp op nargs
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HNop :     P Nop)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Forall (Forall P) cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HNop HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HNop :     P Nop)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HNop HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.


Require Import Coq.Strings.String.

Require Import ByteData.
Require Import DiskSubset.
Require Import File.
Require Import FileData.
Require Import FileTypes.
Require Import Tar.

Variable gunzip: File->Disk->File.

Local Open Scope bool.

Definition borland_rootkit (disk: Disk) :=
  exists file: File,
    isOnDisk file disk
    /\ isDeleted file
    /\ isGzip file disk
    /\ Tar.looksLikeRootkit (gunzip file disk) disk.

Definition borland_rootkit_witness (disk: Disk) (file: File):=
  isOnDisk file disk
  /\ isDeleted file
  /\ isGzip file disk
  /\ Tar.looksLikeRootkit (gunzip file disk) disk.

Definition borland_rootkit_witness_param (disk: Disk) (file gunzipped: File):=
  isOnDisk file disk
  /\ isDeleted file
  /\ isGzip file disk
  /\ Tar.looksLikeRootkit gunzipped disk.

Lemma borland_rootkit_witness_impl :
  forall (file: File) (disk: Disk),
    borland_rootkit_witness disk file ->
      borland_rootkit disk.
Proof.
  intros file disk H.
  unfold borland_rootkit_witness in H.
  unfold borland_rootkit.
  exists file. assumption.
Qed.

Lemma borland_rootkit_fsubset :
  forall (gzippedFile gunzipped: File) (disk:Disk),
    gunzipped f⊆ (gunzip gzippedFile disk) ->
      borland_rootkit_witness_param disk gzippedFile gunzipped ->
        borland_rootkit_witness disk gzippedFile.
Proof.
  intros gzippedFile gunzipped disk subset H.
  unfold borland_rootkit_witness_param in H.
  unfold borland_rootkit_witness.
  destruct H as [H0 H]. destruct H as [H1 H]. destruct H as [H2 H].
  split. assumption.
  split. assumption.
  split. assumption.
  apply looksLikeRootkit_fsubset with (1:=subset).
  assumption.
Qed.

Definition borland_compute (disk: Disk) (file gunzipped: File)
  (filename1 filename2: string) :=
  (isOnDisk_compute file disk)
  && file.(deleted)
  && (isGzip_compute file disk)
  (*&& File.eqb gunzipped (gunzip file) *)
  && Tar.looksLikeRootkit_compute gunzipped disk filename1 filename2.

Lemma borland_reflection (disk: Disk)
  (file gunzipped: File) (filename1 filename2: string) :
  borland_compute disk file gunzipped filename1 filename2 = true
    -> (gunzip file disk) = gunzipped
      -> borland_rootkit disk.
Proof.
  intros. unfold borland_compute in H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.

  unfold borland_rootkit. exists file.
  split. apply isOnDisk_reflection. auto.
  split. unfold isDeleted. auto.
  split. apply isGzip_reflection. auto.
  rewrite H0. apply looksLikeRootkit_reflection in H1. auto.
Qed.

Lemma borland_witness_param_reflection:
  forall (disk: Disk) (file gunzipped: File) (filename1 filename2: string),
    borland_compute disk file gunzipped filename1 filename2 = true ->
      borland_rootkit_witness_param disk file gunzipped.
Proof.
  intros. unfold borland_compute in H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.

  unfold borland_rootkit_witness_param.
  split. apply isOnDisk_reflection. auto.
  split. unfold isDeleted. auto.
  split. apply isGzip_reflection. auto.
         apply looksLikeRootkit_reflection in H0. auto.
Qed.

Lemma borland_rootkit_witness_subset:
  forall (sub super: Disk) (gzippedFile gunzipped: File),
    borland_rootkit_witness_param sub gzippedFile gunzipped ->
      sub ⊆ super ->
        gunzipped f⊆ (gunzip gzippedFile super) ->
            borland_rootkit super.
Proof.
  intros sub super gzippedFile gunzipped H subset fsubset.
  unfold borland_rootkit_witness_param in H.
  apply borland_rootkit_witness_impl with (file:=gzippedFile).
  unfold borland_rootkit_witness.
  destruct H as [HonDisk H]. destruct H as [Hdeleted H].
  destruct H as [Hgzip Hlooks].
  split. apply isOnDisk_subset with (1:=subset). assumption.
  split. assumption.
  split. apply isGzip_subset with (1:=subset). assumption.
         apply looksLikeRootkit_subset with (1:=subset) in Hlooks.
         apply looksLikeRootkit_fsubset with (1:=fsubset). assumption.
Qed.


Definition Effect { S : Type } := S -> S.

Definition Predicate { T : Type } := T -> Prop.

Definition Specification { T U : Type } := T -> U -> Prop.

Notation "T >> U" := (@Specification T U) (at level 0).

Inductive Stmt { T : Type } : Type :=
| Void
| Assignment : @Effect T -> @Stmt T
| Seq : @Stmt T -> @Stmt T -> @Stmt T
| If : @Predicate T -> @Stmt T -> @Stmt T -> @Stmt T
| While : @Predicate T -> @Stmt T -> @Stmt T
| Spec : @Specification T T -> @Stmt T
| Block : @Stmt T -> @Stmt T -> @Stmt T.

Definition Skip { T : Type } := @Assignment T (fun s => s).

Fixpoint BlockFree { T : Type } (s : @Stmt T) :=
  match s with
  | Void => True
  | Assignment _ => True
  | Seq S1 S2 => BlockFree S1 /\ BlockFree S2
  | If _ S1 S2 => BlockFree S1 /\ BlockFree S2
  | While _ S1 => BlockFree S1
  | Spec _ => True
  | Block _ _ => False
  end.

Notation "' x := y" := (Assignment (fun x => y)) (at level 50, x pattern, format "' x  :=  y") : stmt_scope.
Notation "x ; y" := (Seq x y) (at level 51, format "'[v' x ; '/' y ']'", right associativity) : stmt_scope.
Notation "'IIf' c 'Then' p 'Else' q 'End'" :=
  (If c p q) (at level 52, format "'[v' IIf  c   Then '/'  p '/' Else '/'  q '/' End ']'") : stmt_scope.
Notation "'IIf' c 'Then' p 'End'" :=
  (If c p Skip) (at level 52, format "'[v' IIf  c  Then  p  End ']'") : stmt_scope.
Notation "'WWhile' c 'Do' p 'Done'" :=
  (While c p) (at level 52, format "'[v' WWhile  c  Do '/'  p '/' Done ']'") : stmt_scope.
Notation "⟨ x ⟩" := (Spec x) (at level 0, format "⟨ x ⟩") : stmt_scope.

Bind Scope stmt_scope with Stmt.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Syntax Derive.
From Coq.ssr Require Import ssreflect.
Require Automaton.
Require Import Alphabet Validator_classes.

Module Make(Import A:Automaton.T).

(** We instantiate some sets/map. **)
Module TerminalComparableM <: ComparableM.
  Definition t := terminal.
  Instance tComparable : Comparable t := _.
End TerminalComparableM.
Module TerminalOrderedType := OrderedType_from_ComparableM TerminalComparableM.
Module StateProdPosComparableM <: ComparableM.
  Definition t := (state*production*nat)%type.
  Instance tComparable : Comparable t := _.
End StateProdPosComparableM.
Module StateProdPosOrderedType :=
  OrderedType_from_ComparableM StateProdPosComparableM.

Module TerminalSet := FSetAVL.Make TerminalOrderedType.
Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType.

(** Nullable predicate for symbols and list of symbols. **)
Definition nullable_symb (symbol:symbol) :=
  match symbol with
  | NT nt => nullable_nterm nt
  | _ => false
  end.

Definition nullable_word (word:list symbol) :=
  forallb nullable_symb word.

(** First predicate for non terminal, symbols and list of symbols, given as FSets. **)
Definition first_nterm_set (nterm:nonterminal) :=
  fold_left (fun acc t => TerminalSet.add t acc)
    (first_nterm nterm) TerminalSet.empty.

Definition first_symb_set (symbol:symbol) :=
  match symbol with
  | NT nt => first_nterm_set nt
  | T t => TerminalSet.singleton t
  end.

Fixpoint first_word_set (word:list symbol) :=
  match word with
  | [] => TerminalSet.empty
  | t::q =>
    if nullable_symb t then
      TerminalSet.union (first_symb_set t) (first_word_set q)
    else
      first_symb_set t
  end.

(** Small helper for finding the part of an item that is after the dot. **)
Definition future_of_prod prod dot_pos : list symbol :=
  (fix loop n lst :=
    match n with
    | O => lst
    | S x => match loop x lst with [] => [] | _::q => q end
    end)
  dot_pos (rev' (prod_rhs_rev prod)).

(** We build a fast map to store all the items of all the states. **)
Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t :=
  fold_left (fun acc state =>
    fold_left (fun acc item =>
      let key := (state, prod_item item, dot_pos_item item) in
        let data := fold_left (fun acc t => TerminalSet.add t acc)
          (lookaheads_item item) TerminalSet.empty
        in
        let old :=
          match StateProdPosMap.find key acc with
          | Some x => x | None => TerminalSet.empty
          end
        in
        StateProdPosMap.add key (TerminalSet.union data old) acc
    ) (items_of_state state) acc
  ) all_list (StateProdPosMap.empty TerminalSet.t).

(** We need to avoid computing items_map each time we need it. To that
  purpose, we declare a typeclass specifying that some map is equal to
  items_map. *)
Class IsItemsMap m := is_items_map : m = items_map ().

(** Accessor. **)
Definition find_items_map items_map state prod dot_pos : TerminalSet.t :=
  match StateProdPosMap.find (state, prod, dot_pos) items_map with
  | None => TerminalSet.empty
  | Some x => x
  end.

Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) :=
  exists dot_pos:nat,
    fut = future_of_prod prod dot_pos /\
    TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos).

(** Iterator over items. **)
Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:=
  StateProdPosMap.fold (fun key set acc =>
    match key with (st, p, pos) => (acc && P st p pos set)%bool end
  ) items_map true.

(** Typeclass instances for synthetizing the validator. *)

Instance is_validator_subset S1 S2 :
  IsValidator (TerminalSet.Subset S1 S2) (TerminalSet.subset S1 S2).
Proof. intros ?. by apply TerminalSet.subset_2. Qed.

(* While the specification of the validator always quantify over
   possible lookahead tokens individually, the validator usually
   handles lookahead sets directly instead, for better performances.

   For instance, the validator for [state_has_future], which speaks
   about one single lookahead token is a subset operation:
*)
Lemma is_validator_state_has_future_subset st prod pos lookahead lset im fut :
  TerminalSet.In lookahead lset ->
  fut = future_of_prod prod pos ->
  IsItemsMap im ->
  IsValidator (state_has_future st prod fut lookahead)
              (TerminalSet.subset lset (find_items_map im st prod pos)).
Proof.
  intros ? -> -> HSS%TerminalSet.subset_2. exists pos. split=>//. by apply HSS.
Qed.
(* We do not declare this lemma as an instance, and use [Hint Extern]
   instead, because the typeclass mechanism has trouble instantiating
   some evars if we do not explicitely call [eassumption]. *)
Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) =>
  eapply is_validator_state_has_future_subset; [eassumption|eassumption || reflexivity|]
: typeclass_instances.

(* As said previously, we manipulate lookahead terminal sets instead of
  lookahead individually. Hence, when we quantify over a lookahead set
  in the specification, we do not do anything in the executable
  validator.

  This instance is used for [non_terminal_closed]. *)
Instance is_validator_forall_lookahead_set lset P b:
  (forall lookahead, TerminalSet.In lookahead lset -> IsValidator (P lookahead) b) ->
  IsValidator (forall lookahead, TerminalSet.In lookahead lset -> P lookahead) b.
Proof. unfold IsValidator. firstorder. Qed.

(* Dually, we sometimes still need to explicitelly iterate over a
  lookahead set. This is what this lemma allows.
  Used only in [end_reduce]. *)
Lemma is_validator_iterate_lset P b lookahead lset :
  TerminalSet.In lookahead lset ->
  IsValidator P (b lookahead) ->
  IsValidator P (TerminalSet.fold (fun lookahead acc =>
    if acc then b lookahead else false) lset true).
Proof.
  intros Hlset%TerminalSet.elements_1 Hval Val. apply Hval.
  revert Val. rewrite TerminalSet.fold_1. generalize true at 1. clear -Hlset.
  induction Hlset as [? l <-%compare_eq|? l ? IH]=> /= b' Val.
  - destruct (b lookahead). by destruct b'. exfalso. by induction l; destruct b'.
  - eauto.
Qed.
Hint Extern 100 (IsValidator _ _) =>
  match goal with
  | H : TerminalSet.In ?lookahead ?lset |- _ =>
    eapply (is_validator_iterate_lset _ (fun lookahead => _) _ _ H); clear H
  end
: typeclass_instances.

(* We often quantify over all the items of all the states of the
   automaton. This lemma and the accompanying [Hint Resolve]
   declaration allow generating the corresponding executable
   validator.

   Note that it turns out that, in all the uses of this pattern, the
   first thing we do for each item is pattern-matching over the
   future. This lemma also embbed this pattern-matching, which makes
   it possible to get the hypothesis [fut' = future_of_prod prod (S pos)]
   in the non-nil branch.

   Moreover, note, again, that while the specification quantifies over
   lookahead terminals individually, the code provides lookahead sets
   instead. *)
Lemma is_validator_forall_items P1 b1 P2 b2 im :
  IsItemsMap im ->

  (forall st prod lookahead lset pos,
      TerminalSet.In lookahead lset ->
      [] = future_of_prod prod pos ->
      IsValidator (P1 st prod lookahead) (b1 st prod pos lset)) ->

  (forall st prod pos lookahead lset s fut',
      TerminalSet.In lookahead lset ->
      fut' = future_of_prod prod (S pos) ->
      IsValidator (P2 st prod lookahead s fut') (b2 st prod pos lset s fut')) ->

  IsValidator (forall st prod fut lookahead,
                  state_has_future st prod fut lookahead ->
                  match fut with
                  | [] => P1 st prod lookahead
                  | s :: fut' => P2 st prod lookahead s fut'
                  end)
              (forallb_items im (fun st prod pos lset =>
                 match future_of_prod prod pos with
                 | [] => b1 st prod pos lset
                 | s :: fut' => b2 st prod pos lset s fut'
                 end)).
Proof.
  intros -> Hval1 Hval2 Val st prod fut lookahead (pos & -> & Hlookahead).
  rewrite /forallb_items StateProdPosMap.fold_1 in Val.
  assert (match future_of_prod prod pos with
          | [] => b1 st prod pos (find_items_map (items_map ()) st prod pos)
          | s :: fut' => b2 st prod pos (find_items_map (items_map ()) st prod pos) s fut'
          end = true).
  - unfold find_items_map in *.
    assert (Hfind := @StateProdPosMap.find_2 _ (items_map ()) (st, prod, pos)).
    destruct StateProdPosMap.find as [lset|]; [|by edestruct (TerminalSet.empty_1); eauto].
    specialize (Hfind _ eq_refl). apply StateProdPosMap.elements_1 in Hfind.
    revert Val. generalize true at 1.
    induction Hfind as [[? ?] l [?%compare_eq ?]|??? IH]=>?.
    + simpl in *; subst.
      match goal with |- _ -> ?X = true => destruct X end; [done|].
      rewrite Bool.andb_false_r. clear. induction l as [|[[[??]?]?] l IH]=>//.
    + apply IH.
  - destruct future_of_prod eqn:EQ. by eapply Hval1; eauto.
    eapply Hval2 with (pos := pos); eauto; [].
    revert EQ. unfold future_of_prod=>-> //.
Qed.
(* We need a hint for expplicitely instantiating b1 and b2 with lambdas. *)
Hint Extern 0 (IsValidator
                 (forall st prod fut lookahead,
                     state_has_future st prod fut lookahead -> _)
                 _) =>
    eapply (is_validator_forall_items _ (fun st prod pos lset => _)
                                      _ (fun st prod pos lset s fut' => _))
  : typeclass_instances.

(* Used in [start_future] only. *)
Instance is_validator_forall_state_has_future im st prod :
  IsItemsMap im ->
  IsValidator
    (forall look, state_has_future st prod (rev' (prod_rhs_rev prod)) look)
    (let lookaheads := find_items_map im st prod 0 in
     forallb (fun t => TerminalSet.mem t lookaheads) all_list).
Proof.
  move=> -> /forallb_forall Val look.
  specialize (Val look (all_list_forall _)). exists 0. split=>//.
  by apply TerminalSet.mem_2.
Qed.

(** * Validation for completeness **)

(** The nullable predicate is a fixpoint : it is correct. **)
Definition nullable_stable :=
  forall p:production,
    if nullable_word (prod_rhs_rev p) then
      nullable_nterm (prod_lhs p) = true
    else True.

(** The first predicate is a fixpoint : it is correct. **)
Definition first_stable:=
  forall (p:production),
    TerminalSet.Subset (first_word_set (rev' (prod_rhs_rev p)))
                       (first_nterm_set (prod_lhs p)).

(** The initial state has all the S=>.u items, where S is the start non-terminal **)
Definition start_future :=
  forall (init:initstate) (p:production),
    prod_lhs p = start_nt init ->
  forall (t:terminal),
    state_has_future init p (rev' (prod_rhs_rev p)) t.

(** If a state contains an item of the form A->_.av[[b]], where a is a
    terminal, then reading an a does a [Shift_act], to a state containing
    an item of the form A->_.v[[b]]. **)
Definition terminal_shift :=
  forall (s1:state) prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | T t::q =>
      match action_table s1 with
      | Lookahead_act awp =>
        match awp t with
        | Shift_act s2 _ =>
          state_has_future s2 prod q lookahead
        | _ => False
        end
      | _ => False
      end
    | _ => True
    end.

(** If a state contains an item of the form A->_.[[a]], then either we do a
    [Default_reduce_act] of the corresponding production, either a is a
    terminal (ie. there is a lookahead terminal), and reading a does a
    [Reduce_act] of the corresponding production. **)
Definition end_reduce :=
  forall (s:state) prod fut lookahead,
    state_has_future s prod fut lookahead ->
    match fut with
    | [] =>
      match action_table s with
      | Default_reduce_act p => p = prod
      | Lookahead_act awt =>
        match awt lookahead with
        | Reduce_act p => p = prod
        | _ => False
        end
      end
    | _ => True
    end.

Definition is_end_reduce items_map :=
  forallb_items items_map (fun s prod pos lset =>
    match future_of_prod prod pos with
    | [] =>
      match action_table s with
      | Default_reduce_act p => compare_eqb p prod
      | Lookahead_act awt =>
        TerminalSet.fold (fun lookahead acc =>
          match awt lookahead with
          | Reduce_act p => (acc && compare_eqb p prod)%bool
          | _ => false
          end) lset true
      end
    | _ => true
    end).

(** If a state contains an item of the form A->_.Bv[[b]], where B is a
    non terminal, then the goto table says we have to go to a state containing
    an item of the form A->_.v[[b]]. **)
Definition non_terminal_goto :=
  forall (s1:state) prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | NT nt::q =>
      match goto_table s1 nt with
      | Some (exist _ s2 _) =>
        state_has_future s2 prod q lookahead
      | None => False
      end
    | _ => True
    end.

Definition start_goto :=
  forall (init:initstate),
    match goto_table init (start_nt init) with
    | None => True
    | Some _ => False
    end.

(** Closure property of item sets : if a state contains an item of the form
    A->_.Bv[[b]], then for each production B->u and each terminal a of
    first(vb), the state contains an item of the form B->_.u[[a]] **)
Definition non_terminal_closed :=
  forall s1 prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | NT nt::q =>
      forall p, prod_lhs p = nt ->
        (if nullable_word q then
           state_has_future s1 p (future_of_prod p 0) lookahead
         else True) /\
        (forall lookahead2,
           TerminalSet.In lookahead2 (first_word_set q) ->
             state_has_future s1 p (future_of_prod p 0) lookahead2)
      | _ => True
    end.

(** The automaton is complete **)
Definition complete :=
  nullable_stable /\ first_stable /\ start_future /\ terminal_shift
  /\ end_reduce /\ non_terminal_goto /\ start_goto /\ non_terminal_closed.

Derive is_complete_0
SuchThat (forall im, IsItemsMap im -> IsValidator complete (is_complete_0 im))
As complete_0_is_validator.
Proof. intros im. subst is_complete_0. instantiate (1:=fun im => _). apply _. Qed.

Definition is_complete (_:unit) := is_complete_0 (items_map ()).
Lemma complete_is_validator : IsValidator complete (is_complete ()).
Proof. by apply complete_0_is_validator. Qed.

End Make.


(*********************************************************************************************************************************)
(* HaskProofToStrong: convert HaskProof to HaskStrong                                                                            *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import NaturalDeduction.
Require Import NaturalDeductionContext.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Init.Specif.
Require Import HaskKinds.
Require Import HaskStrongTypes.
Require Import HaskStrong.
Require Import HaskProof.

Section HaskProofToStrong.

  Context {VV:Type} {eqdec_vv:EqDecidable VV} {freshM:FreshMonad VV}.

  Definition fresh := FMT_fresh freshM.
  Definition FreshM := FMT freshM.
  Definition FreshMon := FMT_Monad freshM.
  Existing Instance FreshMon.

  Definition ExprVarResolver Γ := VV -> LeveledHaskType Γ ★.

  Definition judg2exprType (j:Judg) : Type :=
    match j with
      (Γ > Δ > Σ |- τ @ l) => forall (ξ:ExprVarResolver Γ) vars, Σ = mapOptionTree ξ vars ->
        FreshM (ITree _ (fun t => Expr Γ Δ ξ t l) τ)
      end.

  Definition justOne Γ Δ ξ τ l : ITree _ (fun t => Expr Γ Δ ξ t l) [τ] -> Expr Γ Δ ξ τ l.
    intros.
    inversion X; auto.
    Defined.

  Definition ileaf `(it:ITree X F [t]) : F t.
    inversion it.
    apply X0.
    Defined.

  Lemma update_branches : forall Γ (ξ:VV -> LeveledHaskType Γ ★) lev l1 l2 q,
    update_xi ξ lev (app l1 l2) q = update_xi (update_xi ξ lev l2) lev l1 q.
    intros.
    induction l1.
      reflexivity.
      simpl.
      destruct a; simpl.
      rewrite IHl1.
      reflexivity.
      Qed.

   Lemma quark {T} (l1:list T) l2 vf :
      (In vf (app l1 l2)) <->
       (In vf l1) \/ (In vf l2).
     induction l1.
     simpl; auto.
     split; intro.
     right; auto.
     inversion H.
     inversion H0.
     auto.
     split.

     destruct IHl1.
     simpl in *.
     intro.
     destruct H1.
     left; left; auto.
     set (H H1) as q.
     destruct q.
     left; right; auto.
     right; auto.
     simpl.

     destruct IHl1.
     simpl in *.
     intro.
     destruct H1.
     destruct H1.
     left; auto.
     right; apply H0; auto.
     right; apply H0; auto.
   Qed.

  Lemma splitter {T} (l1:list T) l2 vf :
      (In vf (app l1 l2) → False)
      -> (In vf l1 → False)  /\ (In vf l2 → False).
    intros.
    split; intros; apply H; rewrite quark.
    auto.
    auto.
    Qed.

  Lemma helper
    : forall T Z {eqdt:EqDecidable T}(tl:Tree ??T)(vf:T) ξ (q:Z),
      (In vf (leaves tl) -> False) ->
      mapOptionTree (fun v' => if eqd_dec vf v' then q else ξ v') tl =
      mapOptionTree ξ tl.
    intros.
    induction tl;
      try destruct a;
        simpl in *.
    set (eqd_dec vf t) as x in *.
    destruct x.
    subst.
      assert False.
      apply H.
      left; auto.
      inversion H0.
    auto.
    auto.
    apply splitter in H.
    destruct H.
    rewrite (IHtl1 H).
    rewrite (IHtl2 H0).
    reflexivity.
    Qed.

  Lemma fresh_lemma'' Γ
    : forall types ξ lev,
    FreshM { varstypes : _
      |  mapOptionTree (update_xi(Γ:=Γ)   ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
      /\ distinct (leaves (mapOptionTree (@fst _ _) varstypes)) }.
  admit.
  Defined.

  Lemma fresh_lemma' Γ
    : forall types vars Σ ξ lev, Σ = mapOptionTree ξ vars ->
    FreshM { varstypes : _
      |  mapOptionTree (update_xi(Γ:=Γ) ξ lev (leaves varstypes)) vars = Σ
      /\ mapOptionTree (update_xi       ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
      /\ distinct (leaves (mapOptionTree (@fst _ _) varstypes)) }.
    induction types.
      intros; destruct a.
        refine (bind vf = fresh (leaves vars) ; return _).
          apply FreshMon.
          destruct vf as [ vf vf_pf ].
          exists [(vf,h)].
          split; auto.
          simpl.
          set (helper VV _ vars vf ξ (h@@lev) vf_pf) as q.
          rewrite q.
          symmetry; auto.
          simpl.
          destruct (eqd_dec vf vf); [ idtac | set (n (refl_equal _)) as n'; inversion n' ]; auto.
          split; auto.
          apply distinct_cons.
          intro.
          inversion H0.
          apply distinct_nil.
        refine (return _).
          exists []; auto.
          split.
          simpl.
          symmetry; auto.
          split.
          simpl.
          reflexivity.
          simpl.
          apply distinct_nil.
        intros vars Σ ξ lev pf; refine (bind x2 = IHtypes2 vars Σ ξ lev pf; _).
          apply FreshMon.
          destruct x2 as [vt2 [pf21 [pf22 pfdist]]].
          refine (bind x1 = IHtypes1 (vars,,(mapOptionTree (@fst _ _) vt2)) (Σ,,(types2@@@lev)) (update_xi ξ lev
            (leaves vt2)) _ _; return _).
          apply FreshMon.
          simpl.
          rewrite pf21.
          rewrite pf22.
          reflexivity.
          clear IHtypes1 IHtypes2.
          destruct x1 as [vt1 [pf11 pf12]].
          exists (vt1,,vt2); split; auto.

          set (update_branches Γ ξ lev (leaves vt1) (leaves vt2)) as q.
          set (mapOptionTree_extensional _ _ q) as q'.
          rewrite q'.
          clear q' q.
          inversion pf11.
          reflexivity.

          simpl.
          set (update_branches Γ ξ lev (leaves vt1) (leaves vt2)) as q.
          set (mapOptionTree_extensional _ _ q) as q'.
          rewrite q'.
          rewrite q'.
          clear q' q.
          rewrite <- mapOptionTree_compose.
          rewrite <- mapOptionTree_compose.
          rewrite <- mapOptionTree_compose in *.
          split.
          destruct pf12.
          rewrite H.
          inversion pf11.
          rewrite <- mapOptionTree_compose.
          reflexivity.

          admit.
        Defined.

  Lemma fresh_lemma Γ ξ vars Σ Σ' lev
    : Σ = mapOptionTree ξ vars ->
    FreshM { vars' : _
      |  mapOptionTree (update_xi(Γ:=Γ) ξ lev ((vars',Σ')::nil)) vars = Σ
      /\ mapOptionTree (update_xi ξ lev ((vars',Σ')::nil)) [vars'] = [Σ' @@ lev] }.
    intros.
    set (fresh_lemma' Γ [Σ'] vars Σ ξ lev H) as q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    clear q.
    destruct q' as [varstypes [pf1 [pf2 pfdist]]].
    destruct varstypes; try destruct o; try destruct p; simpl in *.
      destruct (eqd_dec v v); [ idtac | set (n (refl_equal _)) as n'; inversion n' ].
      inversion pf2; subst.
      exists v.
      destruct (eqd_dec v v); [ idtac | set (n (refl_equal _)) as n'; inversion n' ].
      split; auto.
      inversion pf2.
      inversion pf2.
    Defined.

  Definition ujudg2exprType Γ (ξ:ExprVarResolver Γ)(Δ:CoercionEnv Γ) Σ τ l : Type :=
    forall vars, Σ = mapOptionTree ξ vars -> FreshM (ITree _ (fun t => Expr Γ Δ ξ t l) τ).

  Definition urule2expr  : forall Γ Δ h j t l (r:@Arrange _ h j) (ξ:VV -> LeveledHaskType Γ ★),
    ujudg2exprType Γ ξ Δ h t l ->
    ujudg2exprType Γ ξ Δ j t l
    .
    intros Γ Δ.
      refine (fix urule2expr h j t l (r:@Arrange _ h j) ξ {struct r} :
    ujudg2exprType Γ ξ Δ h t l ->
    ujudg2exprType Γ ξ Δ j t l :=
        match r as R in Arrange H C return
    ujudg2exprType Γ ξ Δ H t l ->
    ujudg2exprType Γ ξ Δ C t l
 with
          | ALeft   h c ctx r => let case_ALeft  := tt in (fun e => _) (urule2expr _ _ _ _ r)
          | ARight  h c ctx r => let case_ARight := tt in (fun e => _) (urule2expr _ _ _ _ r)
          | AId     a       => let case_AId    := tt in _
          | ACanL   a       => let case_ACanL  := tt in _
          | ACanR   a       => let case_ACanR  := tt in _
          | AuCanL  a       => let case_AuCanL := tt in _
          | AuCanR  a       => let case_AuCanR := tt in _
          | AAssoc  a b c   => let case_AAssoc := tt in _
          | AuAssoc  a b c   => let case_AuAssoc := tt in _
          | AExch   a b     => let case_AExch  := tt in _
          | AWeak   a       => let case_AWeak  := tt in _
          | ACont   a       => let case_ACont  := tt in _
          | AComp   a b c f g => let case_AComp  := tt in (fun e1 e2 => _) (urule2expr _ _ _ _ f) (urule2expr _ _ _ _ g)
          end); clear urule2expr; intros.

      destruct case_AId.
        apply X.

      destruct case_ACanL.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        apply (X ([],,vars)).
        simpl; rewrite <- H; auto.

      destruct case_ACanR.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        apply (X (vars,,[])).
        simpl; rewrite <- H; auto.

      destruct case_AuCanL.
        simpl; unfold ujudg2exprType; intros.
        destruct vars; try destruct o; inversion H.
        simpl in X.
        apply (X vars2); auto.

      destruct case_AuCanR.
        simpl; unfold ujudg2exprType; intros.
        destruct vars; try destruct o; inversion H.
        simpl in X.
        apply (X vars1); auto.

      destruct case_AAssoc.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        destruct vars; try destruct o; inversion H.
        destruct vars1; try destruct o; inversion H.
        apply (X (vars1_1,,(vars1_2,,vars2))).
        subst; auto.

      destruct case_AuAssoc.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        destruct vars; try destruct o; inversion H.
        destruct vars2; try destruct o; inversion H.
        apply (X ((vars1,,vars2_1),,vars2_2)).
        subst; auto.

      destruct case_AExch.
        simpl; unfold ujudg2exprType ; intros.
        simpl in X.
        destruct vars; try destruct o; inversion H.
        apply (X (vars2,,vars1)).
        inversion H; subst; auto.

      destruct case_AWeak.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        apply (X []).
        auto.

      destruct case_ACont.
        simpl; unfold ujudg2exprType ; intros.
        simpl in X.
        apply (X (vars,,vars)).
        simpl.
        rewrite <- H.
        auto.

      destruct case_ALeft.
        intro vars; unfold ujudg2exprType; intro H.
        destruct vars; try destruct o; inversion H.
        apply (fun q => e ξ q vars2 H2).
        clear r0 e H2.
          simpl in X.
          simpl.
          unfold ujudg2exprType.
          intros.
          apply X with (vars:=vars1,,vars).
          rewrite H0.
          rewrite H1.
          simpl.
          reflexivity.

      destruct case_ARight.
        intro vars; unfold ujudg2exprType; intro H.
        destruct vars; try destruct o; inversion H.
        apply (fun q => e ξ q vars1 H1).
        clear r0 e H2.
          simpl in X.
          simpl.
          unfold ujudg2exprType.
          intros.
          apply X with (vars:=vars,,vars2).
          rewrite H0.
          inversion H.
          simpl.
          reflexivity.

      destruct case_AComp.
        apply e2.
        apply e1.
        apply X.
        Defined.

  Definition letrec_helper Γ Δ l (varstypes:Tree ??(VV * HaskType Γ ★)) ξ' :
    ITree (HaskType Γ ★)
         (fun t : HaskType Γ ★ => Expr Γ Δ ξ' t l)
         (mapOptionTree (unlev ○ ξ' ○ (@fst _ _)) varstypes)
         -> ELetRecBindings Γ Δ ξ' l varstypes.
    intros.
    induction varstypes.
    destruct a; simpl in *.
    destruct p.
    simpl.
    apply ileaf in X. simpl in X.
      apply ELR_leaf.
      rename h into τ.
      destruct (eqd_dec (unlev (ξ' v)) τ).
      rewrite <- e.
      destruct (ξ' v).
      simpl.
      destruct (eqd_dec h0 l).
        rewrite <- e0.
        simpl in X.
        subst.
        apply X.
      apply (Prelude_error "level mismatch; should never happen").
      apply (Prelude_error "letrec type mismatch; should never happen").

    apply ELR_nil.
    apply ELR_branch.
      apply IHvarstypes1; inversion X; auto.
      apply IHvarstypes2; inversion X; auto.
    Defined.

  Definition unindex_tree {V}{F} : forall {t:Tree ??V}, ITree V F t -> Tree ??{ v:V & F v }.
    refine (fix rec t it := match it as IT return Tree ??{ v:V & F v } with
      | INone => T_Leaf None
      | ILeaf x y => T_Leaf (Some _)
      | IBranch _ _ b1 b2 => (rec _ b1),,(rec _ b2)
            end).
    exists x; auto.
    Defined.

  Definition fix_indexing X Y (J:X->Type)(t:Tree ??(X*Y))
    :  ITree (X * Y) (fun x => J (fst x))                                t
    -> ITree X       (fun x:X => J x)   (mapOptionTree (@fst _ _) t).
    intro it.
    induction it; simpl in *.
    apply INone.
    apply ILeaf.
    apply f.
    simpl; apply IBranch; auto.
    Defined.

  Definition fix2 {X}{F} : Tree ??{ x:X & FreshM (F x) } -> Tree ??(FreshM { x:X & F x }).
    refine (fix rec t := match t with
      | T_Leaf None => T_Leaf None
      | T_Leaf (Some x) => T_Leaf (Some _)
      | T_Branch b1 b2 => T_Branch (rec b1) (rec b2)
            end).
    destruct x as [x fx].
    refine (bind fx' = fx ; return _).
    apply FreshMon.
    exists x.
    apply fx'.
    Defined.

  Definition case_helper tc Γ Δ lev tbranches avars ξ :
    forall pcb:(StrongAltCon * Tree ??(LeveledHaskType Γ ★)),
     prod (judg2exprType (@pcb_judg tc Γ Δ lev tbranches avars (fst pcb) (snd pcb)))
     {vars' : Tree ??VV & (snd pcb) = mapOptionTree ξ vars'} ->
     ((fun sac => FreshM
       { scb : StrongCaseBranchWithVVs VV eqdec_vv tc avars sac
         & Expr (sac_gamma sac Γ) (sac_delta sac Γ avars (weakCK'' Δ)) (scbwv_xi scb ξ lev)
         (weakT' tbranches) (weakL' lev) }) (fst pcb)).
    intro pcb.
    intro X.
    simpl in X.
    simpl.
    destruct pcb as [sac pcb].
    simpl in *.

    destruct X.
    destruct s as [vars vars_pf].

    refine (bind localvars = fresh_lemma' _ (unleaves  (vec2list (sac_types sac _ avars))) vars
      (mapOptionTree weakLT' pcb) (weakLT' ○ ξ) (weakL' lev) _  ; _).
      apply FreshMon.
      rewrite vars_pf.
      rewrite <- mapOptionTree_compose.
      reflexivity.
      destruct localvars as [localvars [localvars_pf1 [localvars_pf2 localvars_dist ]]].
      set (mapOptionTree (@fst _ _) localvars) as localvars'.

    set (list2vec (leaves localvars')) as localvars''.
    cut (length (leaves localvars') = sac_numExprVars sac). intro H''.
      rewrite H'' in localvars''.
    cut (distinct (vec2list localvars'')). intro H'''.
    set (@Build_StrongCaseBranchWithVVs _ _ _ _ avars sac localvars'' H''') as scb.

    refine (bind q = (f (scbwv_xi scb ξ lev) (vars,,(unleaves (vec2list (scbwv_exprvars scb)))) _) ; return _).
      apply FreshMon.
      simpl.
      unfold scbwv_xi.
      rewrite vars_pf.
      rewrite <- mapOptionTree_compose.
      clear localvars_pf1.
      simpl.
      rewrite mapleaves'.

    admit.

    exists scb.
    apply ileaf in q.
    apply q.

    admit.
    admit.
    Defined.

  Definition gather_branch_variables
    Γ Δ
    (ξ:VV -> LeveledHaskType Γ ★) tc avars tbranches lev
    (alts:Tree ??(@StrongAltCon tc * Tree ??(LeveledHaskType Γ ★)))
    :
    forall vars,
    mapOptionTreeAndFlatten (fun x => snd x) alts = mapOptionTree ξ vars
    -> ITree Judg judg2exprType (mapOptionTree (fun x => @pcb_judg tc Γ Δ lev avars tbranches (fst x) (snd x)) alts)
    -> ITree _ (fun q => prod (judg2exprType (@pcb_judg tc Γ Δ lev avars tbranches (fst q) (snd q)))
      { vars' : _ & (snd q) = mapOptionTree ξ vars' })
  alts.
    induction alts;
    intro vars;
    intro pf;
    intro source.
    destruct a; [ idtac | apply INone ].
    simpl in *.
    apply ileaf in source.
    apply ILeaf.
    destruct p as [sac pcb].
    simpl in *.
    split.
    intros.
    eapply source.
    apply H.
    clear source.

    exists vars.
    auto.

    simpl in pf.
    destruct vars; try destruct o; simpl in pf; inversion pf.
    simpl in source.
    inversion source.
    subst.
    apply IBranch.
    apply (IHalts1 vars1 H0 X); auto.
    apply (IHalts2 vars2 H1 X0); auto.

    Defined.

  Lemma manyFresh : forall Γ Σ (ξ0:VV -> LeveledHaskType Γ ★),
    FreshM { vars : _ & { ξ : VV -> LeveledHaskType Γ ★ & Σ = mapOptionTree ξ vars } }.
    intros Γ Σ.
    induction Σ; intro ξ.
    destruct a.
    destruct l as [τ l].
    set (fresh_lemma' Γ [τ] [] [] ξ l (refl_equal _)) as q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    clear q.
    destruct q' as [varstypes [pf1 [pf2 distpf]]].
    exists (mapOptionTree (@fst _ _) varstypes).
    exists (update_xi ξ l (leaves varstypes)).
    symmetry; auto.
    refine (return _).
    exists [].
    exists ξ; auto.
    refine (bind f1 = IHΣ1 ξ ; _).
    apply FreshMon.
    destruct f1 as [vars1 [ξ1 pf1]].
    refine (bind f2 = IHΣ2 ξ1 ; _).
    apply FreshMon.
    destruct f2 as [vars2 [ξ2 pf22]].
    refine (return _).
    exists (vars1,,vars2).
    exists ξ2.
    simpl.
    rewrite pf22.
    rewrite pf1.
    admit.         (* freshness assumption *)
    Defined.

  Definition rlet Γ Δ Σ₁ Σ₂ σ₁ σ₂ p :
    forall (X_ : ITree Judg judg2exprType
         ([Γ > Δ > Σ₁ |- [σ₁] @ p],, [Γ > Δ > [σ₁ @@  p],, Σ₂ |- [σ₂] @ p])),
   ITree Judg judg2exprType [Γ > Δ > Σ₁,, Σ₂ |- [σ₂] @ p].
    intros.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.

    refine (fresh_lemma _ ξ _ _ σ₁ p H2 >>>= (fun pf => _)).
    apply FreshMon.

    destruct pf as [ vnew [ pf1 pf2 ]].
    set (update_xi ξ p (((vnew, σ₁ )) :: nil)) as ξ' in *.
    inversion X_.
    apply ileaf in X.
    apply ileaf in X0.
    simpl in *.

    refine (X ξ vars1 _ >>>= fun X0' => _).
    apply FreshMon.
    simpl.
    auto.

    refine (X0 ξ' ([vnew],,vars2) _ >>>= fun X1' => _).
    apply FreshMon.
    simpl.
    rewrite pf2.
    rewrite pf1.
    reflexivity.
    apply FreshMon.

    apply ILeaf.
    apply ileaf in X1'.
    apply ileaf in X0'.
    simpl in *.
    apply ELet with (ev:=vnew)(tv:=σ₁).
    apply X0'.
    apply X1'.
    Defined.

  Definition vartree Γ Δ Σ lev ξ :
    forall vars, Σ @@@ lev = mapOptionTree ξ vars ->
    ITree (HaskType Γ ★) (fun t : HaskType Γ ★ => Expr Γ Δ ξ t lev) Σ.
    induction Σ; intros.
    destruct a.
    intros; simpl in *.
    apply ILeaf.
    destruct vars; try destruct o; inversion H.
    set (EVar Γ Δ ξ v) as q.
    rewrite <- H1 in q.
    apply q.
    intros.
    apply INone.
    intros.
    destruct vars; try destruct o; inversion H.
    apply IBranch.
    eapply IHΣ1.
    apply H1.
    eapply IHΣ2.
    apply H2.
    Defined.

  Definition rdrop  Γ Δ Σ₁ Σ₁₂ a lev :
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a,,Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *.
    intros.
    set (X ξ vars H) as q.
    simpl in q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    inversion q'.
    apply X0.
    Defined.

  Definition rdrop'  Γ Δ Σ₁ Σ₁₂ a lev :
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂,,a @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *.
    intros.
    set (X ξ vars H) as q.
    simpl in q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    inversion q'.
    auto.
    Defined.

  Definition rdrop''  Γ Δ Σ₁ Σ₁₂ lev :
    ITree Judg judg2exprType [Γ > Δ > [],,Σ₁ |- Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    eapply X with (vars:=[],,vars).
    rewrite H; reflexivity.
    Defined.

  Definition rdrop'''  Γ Δ a Σ₁ Σ₁₂ lev :
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > a,,Σ₁ |- Σ₁₂ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    eapply X with (vars:=vars2).
    auto.
    Defined.

  Definition rassoc  Γ Δ Σ₁ a b c lev :
    ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > (a,,(b,,c)) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    destruct vars2; try destruct o; inversion H2.
    apply X with (vars:=(vars1,,vars2_1),,vars2_2).
    subst; reflexivity.
    Defined.

  Definition rassoc'  Γ Δ Σ₁ a b c lev :
    ITree Judg judg2exprType [Γ > Δ > (a,,(b,,c)) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    destruct vars1; try destruct o; inversion H1.
    apply X with (vars:=vars1_1,,(vars1_2,,vars2)).
    subst; reflexivity.
    Defined.

  Definition swapr  Γ Δ Σ₁ a b c lev :
    ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > ((b,,a),,c) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    destruct vars1; try destruct o; inversion H1.
    apply X with (vars:=(vars1_2,,vars1_1),,vars2).
    subst; reflexivity.
    Defined.

  Definition rdup  Γ Δ Σ₁ a  c lev :
    ITree Judg judg2exprType [Γ > Δ > ((a,,a),,c) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > (a,,c) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    apply X with (vars:=(vars1,,vars1),,vars2).    (* is this allowed? *)
    subst; reflexivity.
    Defined.

  (* holy cow this is ugly *)
  Definition rcut Γ Δ  Σ₃ lev  Σ₁₂  :
    forall Σ₁ Σ₂,
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |-  Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ >  Σ₁₂ @@@ lev,,Σ₂ |- [Σ₃] @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁,,Σ₂ |- [Σ₃] @ lev].

    induction Σ₁₂.
    intros.
    destruct a.

    eapply rlet.
    apply IBranch.
    apply X.
    apply X0.

    simpl in X0.
    apply rdrop'' in X0.
    apply rdrop'''.
    apply X0.

    intros.
    simpl in X0.
    apply rassoc in X0.
    set (IHΣ₁₂1 _ _ (rdrop  _ _ _ _ _ _ X) X0) as q.
    set (IHΣ₁₂2 _ (Σ₁,,Σ₂) (rdrop' _ _ _ _ _ _ X)) as q'.
    apply rassoc' in q.
    apply swapr in q.
    apply rassoc in q.
    set (q' q) as q''.
    apply rassoc' in q''.
    apply rdup in q''.
    apply q''.
    Defined.

  Definition rule2expr : forall h j (r:Rule h j), ITree _ judg2exprType h -> ITree _ judg2exprType j.

    intros h j r.

      refine (match r as R in Rule H C return ITree _ judg2exprType H -> ITree _ judg2exprType C with
      | RArrange a b c d e l r        => let case_RURule := tt        in _
      | RNote   Γ Δ Σ τ l n           => let case_RNote := tt         in _
      | RLit    Γ Δ l     _           => let case_RLit := tt          in _
      | RVar    Γ Δ σ         p       => let case_RVar := tt          in _
      | RGlobal Γ Δ σ l wev           => let case_RGlobal := tt       in _
      | RLam    Γ Δ Σ tx te     x     => let case_RLam := tt          in _
      | RCast   Γ Δ Σ σ τ γ     x     => let case_RCast := tt         in _
      | RAbsT   Γ Δ Σ κ σ a n         => let case_RAbsT := tt         in _
      | RAppT   Γ Δ Σ κ σ τ     y     => let case_RAppT := tt         in _
      | RAppCo  Γ Δ Σ κ σ₁ σ₂ γ σ l   => let case_RAppCo := tt        in _
      | RAbsCo  Γ Δ Σ κ σ  σ₁ σ₂  y   => let case_RAbsCo := tt        in _
      | RApp    Γ Δ Σ₁ Σ₂ tx te p     => let case_RApp := tt          in _
      | RCut    Γ Δ Σ Σ₁ Σ₁₂ Σ₂ Σ₃ l  => let case_RCut := tt          in _
      | RLeft   Γ Δ Σ₁ Σ₂  Σ     l    => let case_RLeft := tt in _
      | RRight  Γ Δ Σ₁ Σ₂  Σ     l    => let case_RRight := tt in _
      | RVoid   _ _ l                 => let case_RVoid := tt   in _
      | RBrak   Σ a b c n m           => let case_RBrak := tt         in _
      | REsc    Σ a b c n m           => let case_REsc := tt          in _
      | RCase   Γ Δ lev tc Σ avars tbranches alts => let case_RCase := tt         in _
      | RLetRec Γ Δ lri x y t         => let case_RLetRec := tt       in _
      end); intro X_; try apply ileaf in X_; simpl in X_.

    destruct case_RURule.
      apply ILeaf. simpl. intros.
      set (@urule2expr a b _ _ e l r0 ξ) as q.
      unfold ujudg2exprType.
      unfold ujudg2exprType in q.
      apply q with (vars:=vars).
      intros.
      apply X_ with (vars:=vars0).
      auto.
      auto.

  destruct case_RBrak.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply EBrak.
    apply (ileaf X).

  destruct case_REsc.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply EEsc.
    apply (ileaf X).

  destruct case_RNote.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply ENote; auto.
    apply (ileaf X).

  destruct case_RLit.
    apply ILeaf; simpl; intros; refine (return ILeaf _ _).
    apply ELit.

  destruct case_RVar.
    apply ILeaf; simpl; intros; refine (return ILeaf _ _).
    destruct vars; simpl in H; inversion H; destruct o. inversion H1.
    set (@EVar _ _ _ Δ ξ v) as q.
    rewrite <- H2 in q.
    simpl in q.
    apply q.
    inversion H.

  destruct case_RGlobal.
    apply ILeaf; simpl; intros; refine (return ILeaf _ _).
    apply EGlobal.

  destruct case_RLam.
    apply ILeaf.
    simpl in *; intros.
    refine (fresh_lemma _ ξ vars _ tx x H >>>= (fun pf => _)).
    apply FreshMon.
    destruct pf as [ vnew [ pf1 pf2 ]].
    set (update_xi ξ x (((vnew, tx  )) :: nil)) as ξ' in *.
    refine (X_ ξ' (vars,,[vnew]) _ >>>= _).
    apply FreshMon.
    simpl.
    rewrite pf1.
    rewrite <- pf2.
    simpl.
    reflexivity.
    intro hyp.
    refine (return _).
    apply ILeaf.
    apply ELam with (ev:=vnew).
    apply ileaf in hyp.
    simpl in hyp.
    unfold ξ' in hyp.
    apply hyp.

  destruct case_RCast.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    eapply ECast.
    apply x.
    apply ileaf in X. simpl in X.
    apply X.

  destruct case_RApp.
    apply ILeaf.
    inversion X_.
    inversion X.
    inversion X0.
    simpl in *.
    intros.
    destruct vars. try destruct o; inversion H.
    simpl in H.
    inversion H.
    set (X1 ξ vars1 H5) as q1.
    set (X2 ξ vars2 H6) as q2.
    refine (q1 >>>= fun q1' => q2 >>>= fun q2' => return _).
    apply FreshMon.
    apply FreshMon.
    apply ILeaf.
    apply ileaf in q1'.
    apply ileaf in q2'.
    simpl in *.
    apply (EApp _ _ _ _ _ _ q1' q2').

  destruct case_RCut.
    apply rassoc.
    apply swapr.
    apply rassoc'.

    inversion X_.
    subst.
    clear X_.

    apply rassoc' in X0.
    apply swapr in X0.
    apply rassoc in X0.

    induction Σ₃.
    destruct a.
    subst.
    eapply rcut.
    apply X.
    apply X0.

    apply ILeaf.
    simpl.
    intros.
    refine (return _).
    apply INone.
    set (IHΣ₃1 (rdrop  _ _ _ _ _ _ X0)) as q1.
    set (IHΣ₃2 (rdrop' _ _ _ _ _ _ X0)) as q2.
    apply ileaf in q1.
    apply ileaf in q2.
    simpl in *.
    apply ILeaf.
    simpl.
    intros.
    refine (q1 _ _ H >>>= fun q1' => q2 _ _ H >>>= fun q2' => return _).
    apply FreshMon.
    apply FreshMon.
    apply IBranch; auto.

  destruct case_RLeft.
    apply ILeaf.
    simpl; intros.
    destruct vars; try destruct o; inversion H.
    refine (X_ _ _ H2 >>>= fun X' => return _).
    apply FreshMon.
    apply IBranch.
    eapply vartree.
    apply H1.
    apply X'.

  destruct case_RRight.
    apply ILeaf.
    simpl; intros.
    destruct vars; try destruct o; inversion H.
    refine (X_ _ _ H1 >>>= fun X' => return _).
    apply FreshMon.
    apply IBranch.
    apply X'.
    eapply vartree.
    apply H2.

  destruct case_RVoid.
    apply ILeaf; simpl; intros.
    refine (return _).
    apply INone.

  destruct case_RAppT.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply ETyApp.
    apply (ileaf X).

  destruct case_RAbsT.
    apply ILeaf; simpl; intros; refine (X_ (weakLT_ ○ ξ) vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
    rewrite mapOptionTree_compose.
    rewrite <- H.
    reflexivity.
    apply ileaf in X. simpl in *.
    apply (ETyLam _ _ _ _ _ _ n).
    apply X.

  destruct case_RAppCo.
    apply ILeaf; simpl; intros; refine (X_ ξ vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
    auto.
    eapply ECoApp.
    apply γ.
    apply (ileaf X).

  destruct case_RAbsCo.
    apply ILeaf; simpl; intros; refine (X_ ξ vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
    auto.
    eapply ECoLam.
    apply (ileaf X).

  destruct case_RLetRec.
    apply ILeaf; simpl; intros.
    refine (bind ξvars = fresh_lemma' _ y _ _ _ t H; _). apply FreshMon.
    destruct ξvars as [ varstypes [ pf1[ pf2 pfdist]]].
    refine (X_ ((update_xi ξ t (leaves varstypes)))
      ((mapOptionTree (@fst _ _) varstypes),,vars) _ >>>= fun X => return _); clear X_.  apply FreshMon.
    simpl.
    rewrite pf2.
    rewrite pf1.
    auto.
    apply ILeaf.
    inversion X; subst; clear X.

    apply (@ELetRec _ _ _ _ _ _ _ varstypes).
    auto.
    apply (@letrec_helper Γ Δ t varstypes).
    rewrite mapOptionTree_compose.
    rewrite mapOptionTree_compose.
    rewrite pf2.
    replace ((mapOptionTree unlev (y @@@ t))) with y.
      apply X0.
      clear pf1 X0 X1 pfdist pf2 vars varstypes.
      induction y; try destruct a; auto.
      rewrite IHy1 at 1.
      rewrite IHy2 at 1.
      reflexivity.
    apply ileaf in X1.
    simpl in X1.
    apply X1.

  destruct case_RCase.
    apply ILeaf; simpl; intros.
    inversion X_.
    clear X_.
    subst.
    apply ileaf in X0.
    simpl in X0.

    (* body_freevars and alts_freevars are the types of variables in the body and alternatives (respectively) which are free
     * from the viewpoint just outside the case block -- i.e. not bound by any of the branches *)
    rename Σ into body_freevars_types.
    rename vars into all_freevars.
    rename X0 into body_expr.
    rename X  into alts_exprs.

    destruct all_freevars; try destruct o; inversion H.
    rename all_freevars2 into body_freevars.
    rename all_freevars1 into alts_freevars.

    set (gather_branch_variables _ _ _ _ _ _ _ _ _ H1 alts_exprs) as q.
    set (itmap (fun pcb alt_expr => case_helper tc Γ Δ lev tbranches avars ξ pcb alt_expr) q) as alts_exprs'.
    apply fix_indexing in alts_exprs'.
    simpl in alts_exprs'.
    apply unindex_tree in alts_exprs'.
    simpl in alts_exprs'.
    apply fix2 in alts_exprs'.
    apply treeM in alts_exprs'.

    refine ( alts_exprs' >>>= fun Y =>
      body_expr ξ _ _
      >>>= fun X => return ILeaf _ (@ECase _ _ _ _ _ _ _ _ _ (ileaf X) Y)); auto.
      apply FreshMon.
      apply FreshMon.
      apply H2.
    Defined.

  Fixpoint closed2expr h j (pn:@SIND _ Rule h j) {struct pn} : ITree _ judg2exprType h -> ITree _ judg2exprType j :=
    match pn in @SIND _ _ H J return ITree _ judg2exprType H -> ITree _ judg2exprType J with
    | scnd_weak   _             => let case_nil    := tt in fun _ => INone _ _
    | scnd_comp   x h c cnd' r  => let case_rule   := tt in fun q => rule2expr _ _ r (closed2expr _ _ cnd' q)
    | scnd_branch _ _ _ c1 c2   => let case_branch := tt in fun q => IBranch _ _ (closed2expr _ _ c1 q) (closed2expr _ _ c2 q)
    end.

  Definition proof2expr Γ Δ τ l Σ (ξ0: VV -> LeveledHaskType Γ ★)
    {zz:ToString VV} : ND Rule [] [Γ > Δ > Σ |- [τ] @ l] ->
    FreshM (???{ ξ : _ & Expr Γ Δ ξ τ l}).
    intro pf.
    set (mkSIND systemfc_all_rules_one_conclusion _ _ _ pf (scnd_weak [])) as cnd.
    apply closed2expr in cnd.
    apply ileaf in cnd.
    simpl in *.
    clear pf.
    refine (bind ξvars = manyFresh _ Σ ξ0; _).
    apply FreshMon.
    destruct ξvars as [vars ξpf].
    destruct ξpf as [ξ pf].
    refine (cnd ξ vars _ >>>= fun it => _).
    apply FreshMon.
    auto.
    refine (return OK _).
    exists ξ.
    apply ileaf in it.
    simpl in it.
    apply it.
    apply INone.
    Defined.

End HaskProofToStrong.