(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Relational specification of expression simplification. *)

Require Import Coqlib (* Maps  *)Errors Integers Floats.
Require Import AST Linking Memory.
Require Import Ctypes Cop Csyntax Clight SimplExpr.
Require Import SepBasicCore SepSet SimplMonad Locally.
Import Maps.PTree.

Section SPEC.

Variable ce: composite_env.

Local Open Scope free_monad_scope.

(** * Relational specification of the translation. *)

  (** ** Translation of expressions *)

  (** This specification covers:
- all cases of [transl_lvalue] and [transl_rvalue];
- two additional cases for [Csyntax.Eparen], so that reductions of [Csyntax.Econdition]
  expressions are properly tracked;
- three additional cases allowing [Csyntax.Eval v] C expressions to match
  any Clight expression [a] that evaluates to [v] in any environment
  matching the given temporary environment [le].
   *)

  Definition dest_below (dst: destination) : iProp :=
    match dst with
    | For_set sd => & (sd_temp sd)
    | _ => emp
    end.

  Definition final (dst: destination) (a: expr) : list statement :=
    match dst with
    | For_val => nil
    | For_effects => nil
    | For_set sd => do_set sd a
    end.

  (** Iris version *)

  Definition tr_is_bitfield_access (l: expr) (bf: bitfield) : Prop :=
  match l with
  | Efield r f _ =>
      exists co ofs,
      match typeof r with
      | Tstruct id _ =>
          ce!id = Some co /\ field_offset ce f (co_members co) = OK (ofs, bf)
      | Tunion id _ =>
          ce!id = Some co /\ union_field_offset ce f (co_members co) = OK (ofs, bf)
      | _ => False%type
      end
  | _ => bf = Full
  end.

  Definition tr_rvalof (ty : type) (e1 : expr) (ls : list statement) (e : expr) : iProp :=
    if type_is_volatile ty
    then
      (∃ t bf, ⌜ ls = make_set bf t e1 :: nil /\ tr_is_bitfield_access e1 bf /\ e = Etempvar t ty⌝ ∗ & t)%I
    else
      ⌜ls =nil /\ e = e1⌝%I.

  Fixpoint tr_expr (le : temp_env) (dst : destination) (e : Csyntax.expr)
           (sl : list statement ) (a : expr) : iProp :=
    (<absorb>
       match e with
       | Csyntax.Evar id ty =>
           dest_below dst ∗ ⌜ sl = final dst (Evar id ty) /\  a = Evar id ty ⌝
       | Csyntax.Ederef e1 ty =>
           dest_below dst ∗
             ∃ sl2 a2, tr_expr le For_val e1 sl2 a2 ∗
                         ⌜sl = sl2 ++ final dst (Ederef' a2 ty) /\ a = Ederef' a2 ty⌝
       | Csyntax.Efield e1 f ty =>
           dest_below dst ∗
             ∃ sl2 a2, tr_expr le For_val e1 sl2 a2 ∗
                         ⌜ sl = sl2 ++ final dst (Efield a2 f ty) /\ a = Efield a2 f ty ⌝
       | Csyntax.Eval v ty =>
           match dst with
           | For_effects => ⌜sl = nil⌝
           | For_val =>
               (∀ tge e m, locally le (fun le' => ⌜eval_expr tge e le' m a v⌝))
                 ∗ ⌜ typeof a = ty /\ sl = nil ⌝
           | For_set sd =>
               (<absorb> dest_below dst) ∧
                 ∃ a,
                   (∀ tge e m, locally le (fun le' => ⌜eval_expr tge e le' m a v⌝))
                     ∗ ⌜ typeof a = ty /\ sl = do_set sd a ⌝

           end
       | Csyntax.Esizeof ty' ty =>
           dest_below dst ∗ ⌜ sl = final dst (Esizeof ty' ty) /\ a = Esizeof ty' ty⌝
       | Csyntax.Ealignof ty' ty =>
           dest_below dst ∗ ⌜ sl = final dst (Ealignof ty' ty) /\ a = Ealignof ty' ty ⌝
       | Csyntax.Evalof e1 ty =>
           dest_below dst ∗
             ∃ sl2 a2 sl3,
               tr_expr le For_val e1 sl2 a2  ∗
                 tr_rvalof (Csyntax.typeof e1) a2 sl3 a  ∗
                 ⌜ sl = (sl2 ++ sl3 ++ final dst a) ⌝
       | Csyntax.Eaddrof e1 ty =>
           dest_below dst ∗
             ∃ sl2 a2, tr_expr le For_val e1 sl2 a2  ∗
                         ⌜ sl = sl2 ++ final dst (Eaddrof' a2 ty) /\ a = Eaddrof' a2 ty ⌝
       | Csyntax.Eunop ope e1 ty =>
           dest_below dst ∗
             ∃ sl2 a2, tr_expr le For_val e1 sl2 a2  ∗
                         ⌜ sl = sl2 ++ final dst (Eunop ope a2 ty) /\ a = Eunop ope a2 ty ⌝
       | Csyntax.Ebinop ope e1 e2 ty =>
           dest_below dst ∗
             ∃ sl2 a2 sl3 a3, tr_expr le For_val e1 sl2 a2  ∗
                                tr_expr le For_val e2 sl3 a3  ∗
                                ⌜ sl = sl2 ++ sl3 ++ final dst (Ebinop ope a2 a3 ty) /\ a = Ebinop ope a2 a3 ty ⌝
       | Csyntax.Ecast e1 ty =>
           match dst with
           | For_val | For_set _ =>
                         dest_below dst ∗
                           ∃ sl2 a2, tr_expr le For_val e1 sl2 a2  ∗
                                       ⌜ sl = sl2 ++ final dst (Ecast a2 ty) /\ a = Ecast a2 ty ⌝
           | For_effects =>
               tr_expr le For_effects e1 sl a
           end
       | Csyntax.Eseqand e1 e2 ty =>
           match dst with
           | For_val =>
               ∃ sl2 a2 sl3 a3 t,
       tr_expr le For_val e1 sl2 a2 ∗
         tr_expr le (For_set (sd_seqbool_val t ty)) e2 sl3 a3 ∗
         ⌜ sl = sl2 ++ makeif a2 (makeseq sl3) (Sset t (Econst_int Int.zero ty)) :: nil /\
         a = Etempvar t ty ⌝
    | For_effects =>
        ∃ sl2 a2 sl3 a3,
       tr_expr le For_val e1 sl2 a2 ∗
         tr_expr le For_effects e2 sl3 a3  ∗
         ⌜  sl = sl2 ++ makeif a2 (makeseq sl3) Sskip :: nil ⌝
    | For_set sd =>
        ∃ sl2 a2 sl3 a3,
       tr_expr le For_val e1 sl2 a2 ∗
         tr_expr le (For_set (sd_seqbool_set ty sd)) e2 sl3 a3 ∗
         ⌜ sl = sl2 ++ makeif a2 (makeseq sl3) (makeseq (do_set sd (Econst_int Int.zero ty))) :: nil ⌝
     end
    | Csyntax.Eseqor e1 e2 ty =>
        match dst with
        | For_val =>
            ∃ sl2 a2 sl3 a3 t,
       tr_expr le For_val e1 sl2 a2  ∗
         tr_expr le (For_set (sd_seqbool_val t ty)) e2 sl3 a3 ∗
         ⌜ sl = sl2 ++ makeif a2 (Sset t (Econst_int Int.one ty)) (makeseq sl3) :: nil /\
         a = Etempvar t ty ⌝
    | For_effects =>
        ∃ sl2 a2 sl3 a3,
       tr_expr le For_val e1 sl2 a2  ∗
         tr_expr le For_effects e2 sl3 a3  ∗
         ⌜ sl = sl2 ++ makeif a2 Sskip (makeseq sl3) :: nil ⌝
    | For_set sd =>
        ∃ sl2 a2 sl3 a3,
       tr_expr le For_val e1 sl2 a2 ∗
       tr_expr le (For_set (sd_seqbool_set ty sd)) e2 sl3 a3 ∗
       ⌜ sl = sl2 ++ makeif a2 (makeseq (do_set sd (Econst_int Int.one ty))) (makeseq sl3) :: nil ⌝
     end

    | Csyntax.Econdition e1 e2 e3 ty =>
      match dst with
      | For_val =>
        ∃ sl2 a2 sl3 a3 sl4 a4 t,
       tr_expr le For_val e1 sl2 a2 ∗
       (tr_expr le (For_set (SDbase ty ty t)) e2 sl3 a3 ∧
       tr_expr le (For_set (SDbase ty ty t)) e3 sl4 a4) ∗
       ⌜ sl = sl2 ++ makeif a2 (makeseq sl3) (makeseq sl4) :: nil /\ a = Etempvar t ty⌝
    | For_effects =>
      ∃ sl2 a2 sl3 a3 sl4 a4,
       tr_expr le For_val e1 sl2 a2  ∗
       tr_expr le For_effects e2 sl3 a3 ∗
       tr_expr le For_effects e3 sl4 a4 ∗
       ⌜ sl = sl2 ++ makeif a2 (makeseq sl3) (makeseq sl4) :: nil ⌝
    | For_set sd =>
      dest_below dst ∗
      ∃ sl2 a2 sl3 a3 sl4 a4 t,
      tr_expr le For_val e1 sl2 a2  ∗
      (tr_expr le (For_set (SDcons ty ty t sd)) e2 sl3 a3 ∧
      tr_expr le (For_set (SDcons ty ty t sd)) e3 sl4 a4) ∗
      ⌜ sl = sl2 ++ makeif a2 (makeseq sl3) (makeseq sl4) :: nil ⌝
     end
    | Csyntax.Eassign e1 e2 ty =>
      match dst with
      | For_val | For_set _ =>
          ∃ sl2 a2 sl3 a3 t bf,
       tr_expr le For_val e1 sl2 a2  ∗
       tr_expr le For_val e2 sl3 a3  ∗
       & t ∗
       dest_below dst ∗
       ⌜ tr_is_bitfield_access a2 bf /\
         sl = sl2 ++ sl3 ++ Sset t (Ecast a3 (Csyntax.typeof e1)) ::
                make_assign bf a2 (Etempvar t (Csyntax.typeof e1)) ::
                final dst (make_assign_value bf (Etempvar t (Csyntax.typeof e1))) /\
         a = make_assign_value bf (Etempvar t (Csyntax.typeof e1))⌝
       | For_effects =>
       ∃ sl2 a2 sl3 a3 bf,
       tr_expr le For_val e1 sl2 a2  ∗
       tr_expr le For_val e2 sl3 a3  ∗
       ⌜ tr_is_bitfield_access a2 bf /\ sl = sl2 ++ sl3 ++ make_assign bf a2 a3 :: nil ⌝
     end

    | Csyntax.Eassignop ope e1 e2 tyres ty =>
      match dst with
      | For_effects =>
        ∃ sl2 a2 sl3 a3 sl4 a4 bf,
       tr_expr le For_val e1 sl2 a2  ∗
       tr_expr le For_val e2 sl3 a3  ∗
       tr_rvalof (Csyntax.typeof e1) a2 sl4 a4  ∗
       ⌜tr_is_bitfield_access a2 bf /\ sl = sl2 ++ sl3 ++ sl4 ++ make_assign bf a2 (Ebinop ope a4 a3 tyres) :: nil ⌝
    | _ =>
      dest_below dst ∗ ∃ sl2 a2 sl3 a3 sl4 a4 bf t,
       tr_expr le For_val e1 sl2 a2  ∗
       tr_expr le For_val e2 sl3 a3  ∗
       tr_rvalof (Csyntax.typeof e1) a2 sl4 a4  ∗
       & t ∗
       ⌜ tr_is_bitfield_access a2 bf /\
         sl = sl2 ++ sl3 ++ sl4 ++ Sset t (Ecast (Ebinop ope a4 a3 tyres) (Csyntax.typeof e1)) ::
                make_assign bf a2 (Etempvar t (Csyntax.typeof e1)) ::
                final dst (make_assign_value bf (Etempvar t (Csyntax.typeof e1)))
       /\ a = make_assign_value bf (Etempvar t (Csyntax.typeof e1)) ⌝
     end
    | Csyntax.Epostincr id e1 ty =>
      ∃ sl2 a2 bf,
       tr_expr le For_val e1 sl2 a2  ∗
       match dst with
       | For_effects =>
         ∃ sl3 a3,
       tr_rvalof (Csyntax.typeof e1) a2 sl3 a3  ∗
       ⌜ tr_is_bitfield_access a2 bf /\
        sl = sl2 ++ sl3 ++ make_assign bf a2 (transl_incrdecr id a3 (Csyntax.typeof e1)) :: nil ⌝
    | _ =>
      dest_below dst ∗
      ∃ t, & t  ∗
      ⌜ tr_is_bitfield_access a2 bf /\
        sl = sl2 ++ make_set bf t a2 :: make_assign bf a2 (transl_incrdecr id (Etempvar t (Csyntax.typeof e1)) (Csyntax.typeof e1)) :: final dst (Etempvar t (Csyntax.typeof e1))
           /\ a = Etempvar t (Csyntax.typeof e1)⌝
     end

    | Csyntax.Ecomma e1 e2 ty =>
      ∃ sl2 a2 sl3,
       tr_expr le For_effects e1 sl2 a2  ∗
       tr_expr le dst e2 sl3 a ∗
       ⌜ sl = sl2 ++ sl3 ⌝

    | Csyntax.Ecall e1 el2 ty =>
      match dst with
      | For_effects =>
        ∃ sl2 a2 sl3 al3,
       tr_expr le For_val e1 sl2 a2  ∗
       tr_exprlist le el2 sl3 al3  ∗
       ⌜  sl = sl2 ++ sl3 ++ Scall None a2 al3 :: nil ⌝
    | _ =>
      dest_below dst ∗ ∃ sl2 a2 sl3 al3 t,
       & t ∗
        tr_expr le For_val e1 sl2 a2  ∗
        tr_exprlist le el2 sl3 al3  ∗
        ⌜ sl = sl2 ++ sl3 ++ Scall (Some t) a2 al3 :: final dst (Etempvar t ty) /\
       a = Etempvar t ty⌝
     end

    | Csyntax.Ebuiltin ef tyargs el ty =>
      match dst with
      | For_effects =>
        ∃ sl2 al2,
       tr_exprlist le el sl2 al2 ∗
       ⌜ sl = sl2 ++ Sbuiltin None ef tyargs al2 :: nil ⌝
    | _ =>
      dest_below dst ∗ ∃ sl2 al2 t,
       tr_exprlist le el sl2 al2  ∗
       & t  ∗
       ⌜ sl = sl2 ++ Sbuiltin (Some t) ef tyargs al2 :: final dst (Etempvar t ty) /\
       a = Etempvar t ty⌝
     end
    | Csyntax.Eparen e1 tycast ty =>
      match dst with
      | For_val =>
        ∃ a2 t, tr_expr le (For_set (SDbase tycast ty t)) e1 sl a2 ∗ ⌜ a = Etempvar t ty ⌝
    | For_effects =>
      ∃ a2, tr_expr le For_effects e1 sl a2
    | For_set sd =>
      ∃ a2 t0, if Pos.eq_dec t0 (sd_temp sd)
               then
                 tr_expr le (For_set (SDcons tycast ty t0 sd)) e1 sl a2
               else
                 tr_expr le (For_set (SDcons tycast ty t0 sd)) e1 sl a2 ∗ dest_below dst
     end

| _ => False
  end)
  with tr_exprlist (le : temp_env) (e : Csyntax.exprlist) (sl : list statement) (a : list expr) : iProp :=
         match e with
         | Csyntax.Enil => ⌜ sl = nil /\ a = nil⌝
         | Csyntax.Econs e1 el2 =>
           ∃ sl2 a2 sl3 al3,
    tr_expr le For_val e1 sl2 a2  ∗
    tr_exprlist le el2 sl3 al3  ∗
    ⌜ sl = sl2 ++ sl3 /\ a = a2 :: al3⌝
  end.

(** Useful invariance properties. *)

  Ltac tac :=
    match goal with
    | |- {{ _ }} bind2 _ (fun _ _ => _) {{ _; _ }} =>
      eapply bind_spec; intros; tac
    | |- {{ _ }} bind _ (fun _ => _) {{ _; _ }} =>
      eapply bind_spec; [> tac | intro; tac]
    | |- {{ _ }} ret _ {{ _; ∃ _, _ }} => eapply exists_spec; tac
    | |- {{ _ }} error _ {{ _; _ }} => apply rule_error
    | |- {{ _ }} gensym _ {{ _; _ }} => Frame; apply rule_gensym
    | H : (forall _ _, {{ emp }} transl_valof _ _ _ {{ _; _}})
      |- {{ _ }} transl_valof _ _ _ {{ _; _ }} =>
        Frame; apply H; tac
    | H : (forall _, {{ emp }} is_bitfield_access _ _ {{ _; _}})
      |- {{ _ }} is_bitfield_access _ _ {{ _; _ }} =>
        Frame; apply H; tac
    | H : (forall _, {{ emp }} transl_expr _ _ ?l {{ __; _}})
      |- {{ _ }} transl_expr _ _ ?l {{ _; _ }} =>
        Frame; apply H; tac
    | H : (forall _ _, {{ emp }} transl_expr _ _ _ {{ _; _}})
      |- {{ _ }} transl_expr _ _ _ {{ _; _ }} =>
      Frame; apply H; tac
    | H :(forall _, {{ emp }} transl_exprlist _ _ {{ _; _}})
      |- {{ _ }} transl_exprlist _ _ {{ _; _ }} =>
      Frame; apply H; tac
    | H : {{ emp }} transl_exprlist _ ?l {{ _; _}}
      |- {{ _ }} transl_exprlist _ ?l {{ _; _ }} =>
      Frame; apply H; tac
    | |- {{ _ }} match ?a with
          | _ => _
          end  {{ _; _ }} =>
      destruct a eqn:?; tac
    | _ => idtac
    end.

  Ltac tac2 :=
    match goal with
    | |- {{ _ }} ret _  {{ _; _ }} => iApply ret_spec
    | _ => (progress tac); tac2
    | _ => idtac
    end.

  Lemma is_bitfield_access_meets_spec: forall l,
      {{ emp }} is_bitfield_access ce l {{ bf ; ⌜ tr_is_bitfield_access l bf ⌝ }}.
  Proof.
    intro l. unfold is_bitfield_access. tac; simpl; auto.
    all : unfold is_bitfield_access_aux; destruct (ce!i0) as [co|] eqn:P; auto.
    all : tac2; iIntros; iPureIntro; destruct (typeof e); try discriminate;
      injection Heqt1; intros; subst; do 2 eexists; split; eauto.
  Qed.

  Lemma transl_valof_meets_spec ty a :
    {{ emp }} transl_valof ce ty a {{ r; tr_rvalof ty a r.1 r.2 }}.
  Proof.
    unfold transl_valof. unfold tr_rvalof.
    destruct (type_is_volatile ty).
    - tac2. Frame. eapply is_bitfield_access_meets_spec.
      iIntros "[HA [$ _]]". norm_all.
    - auto.
  Qed.

  Lemma tr_expr_abs : forall r le dst sl a, <absorb> tr_expr le dst r sl a ⊢ tr_expr le dst r sl a.
  Proof. induction r; iIntros "* >$". Qed.

  (** ** Top-level translation *)

  (** The "top-level" translation is equivalent to [tr_expr] above
  for source terms.  It brings additional flexibility in the matching
  between Csyntax values and Cminor expressions: in the case of
  [tr_expr], the Cminor expression must not depend on memory,
  while in the case of [tr_top] it can depend on the current memory
  state. *)

  Scheme expr_ind2 := Induction for Csyntax.expr Sort Prop
    with exprlist_ind2 := Induction for Csyntax.exprlist Sort Prop.
  Combined Scheme tr_expr_exprlist from expr_ind2, exprlist_ind2.

  Lemma transl_meets_spec :
    (forall r dst,
        {{ emp }}
          transl_expr ce dst r {{ res; dest_below dst -∗ ∀ le, tr_expr le dst r res.1 res.2 }})
    /\
    (forall rl,
        {{ emp }} transl_exprlist ce rl {{ res; ∀ le, tr_exprlist le rl res.1 res.2 }}).
  Proof.

    pose transl_valof_meets_spec.
    pose is_bitfield_access_meets_spec.
    apply tr_expr_exprlist; unfold transl_exprlist; unfold transl_expr;
      fold (transl_expr ce); fold (transl_exprlist ce); intros; tac; iApply ret_spec;
      simpl; iIntros; iNorm; try iModIntro.

    Ltac EvalTac dst :=
        destruct dst; auto; iSplitL; auto; try iExists _;
        try iSplitL; iIntros; [ iApply locally_simpl | iApply locally_simpl | idtac ];
        intros; iPureIntro; [econstructor | econstructor | simpl; eauto].
    1-4 : EvalTac dst.

    - iFrame. repeat iExists _; destruct dst; simpl; simpl_list; eauto.
    - iFrame. repeat iExists _. destruct dst; simpl; iFrame; simpl_list; eauto.
    - iFrame; repeat iExists _; destruct dst; simpl; iFrame;
        iSplitL "HE"; auto; simpl_list; eauto.
      rewrite <- app_assoc. eauto.
    - iFrame; repeat iExists _; destruct dst; simpl; simpl_list; eauto.
    - iFrame; repeat iExists _; destruct dst; simpl; simpl_list; eauto.
    - iFrame. repeat iExists _. iSplitL "HC"; eauto.
      destruct dst; simpl; simpl_list; auto.
    - iFrame. repeat iExists _. iSplitL "HF"; eauto. iSplitL "HC"; eauto.
      destruct dst; simpl; simpl_list; auto. rewrite <- app_assoc. eauto.
    - iFrame; repeat iExists _; destruct dst; simpl; simpl_list; eauto.
    - iApply wp_consequence. iApply H; auto. iIntros; norm_all.
    - iFrame. repeat iExists _. iSplitL "HC"; eauto.
    -repeat iExists _. iSplitL "HG"; auto. iDestruct ("HC" with "[HE]") as "HA"; auto.
    - repeat iExists _. iSplitL "HF"; eauto.
    - repeat iExists _. iSplitL "HE"; eauto. iSplitL; eauto. iApply ("HC" with "[HH]"); auto.
    - repeat iExists _. iSplitL "HG"; auto. iSplitL; eauto. iApply ("HC" with "[HE]"); auto.
    - repeat iExists _. iSplitL "HF"; eauto.
    - repeat iExists _. iSplitL "HE"; eauto. iSplitL; eauto. iApply ("HC" with "[HH]"); auto.
    - repeat iExists _. iSplitL "HI"; auto. iSplitL; eauto. iSplit; iApply tr_expr_abs.
      iApply ("HE" with "[HG]"); auto. iApply ("HC" with "[HG]"); auto.
    - repeat iExists _. iSplitL "HI"; eauto. iSplitL "HF"; auto.
    - iSplitL "HL"; auto. repeat iExists _. iSplitL "HI"; auto. iSplitL; eauto.
      iSplit; iApply tr_expr_abs. iApply ("HE" with "[HG]"); auto. iApply ("HC" with "[HG]"); auto.
    - iFrame; repeat iExists _; destruct dst; simpl; simpl_list; eauto.
    - iFrame; repeat iExists _; destruct dst; simpl; simpl_list; eauto.
    - repeat iExists _. iSplitL "HJ"; eauto. iSplitL "HG"; auto.
    - repeat iExists _. iSplitL "HH"; eauto.
    - repeat iExists _. iSplitL "HJ"; eauto. iSplitL "HG"; auto. iSplitL "HC"; eauto.
      iSplitL; eauto. iPureIntro. repeat split; eauto. do 2 (rewrite <- app_assoc; f_equal).
    - iSplitR; auto. repeat iExists _. iFrame. iSplitL "HL"; eauto.
    - repeat iExists _. iFrame. iSplitL "HJ"; eauto.
    - iSplitL "HO"; auto. repeat iExists _. iSplitL "HL"; auto. iSplitL "HI"; eauto.
      iSplitL "HG"; auto. iSplitL "HC"; eauto. iPureIntro. repeat split; eauto.
      do 3 (rewrite <- app_assoc; f_equal).
    - repeat iExists _. iSplitL "HG"; eauto.
    - repeat iExists _. iSplitL "HG"; eauto.
    - repeat iExists _. iSplitL "HG"; eauto. iSplitL "HJ"; auto. iExists v1.
      iSplitL "HC"; auto. iPureIntro. repeat split; eauto. rewrite <- app_assoc; f_equal.
    - repeat iExists _. iSplitL "HE"; eauto. iSplitL; auto. iApply ("HC" with "HH").
    - iSplitR; auto. repeat iExists _. iSplitL "HC"; auto. iSplitL "HG"; auto.
    - repeat iExists _. iSplitL "HE"; eauto.
    - iSplitL "HJ"; auto. repeat iExists _. iSplitL "HC"; auto. iSplitL "HG"; auto.
      iSplitL "HE"; eauto. iPureIntro. repeat split; eauto.
      do 2 (rewrite <- app_assoc; f_equal).
    - iSplitR; auto. repeat iExists _. iSplitL "HE"; auto.
    - iSplitL "HG"; auto. repeat iExists _. iSplitL "HE"; auto. iSplitL "HC"; auto.
      iPureIntro. repeat split; eauto. rewrite <- app_assoc; f_equal.
    - repeat iExists _. iSplitL "HD"; auto.
  Qed.

  Section TR_TOP.

    Variable ge: genv.
    Variable e: Clight.env.
    Variable le: temp_env.
    Variable m: mem.

    Inductive tr_top: destination -> Csyntax.expr -> list statement -> expr ->  Prop :=
  | tr_top_val_val: forall v ty a,
      typeof a = ty -> eval_expr ge e le m a v ->
      tr_top For_val (Csyntax.Eval v ty) nil a
  | tr_top_base: forall dst r sl a tmp,
      tr_expr le dst r sl a () tmp ->
      tr_top dst r sl a.

  End TR_TOP.

(** Translation of statements *)

  Lemma tr_top_spec : forall r dst sl a,
      ⊢(∀ le, tr_expr le dst r sl a)
        -∗ ⌜∀ ge e le m, tr_top ge e le m dst r sl a⌝.
  Proof.
    iIntros "* HA". iStopProof. apply instance_heap. intros. econstructor.
    apply soundness. apply completeness in H. iIntros "HA". iApply (H with "HA").
  Qed.

  Lemma transl_expr_meets_spec:
    forall r dst,
      {{ emp }} transl_expr ce dst r
      {{ res;  dest_below dst -∗ ⌜ ∀ ge e le m, tr_top ge e le m dst r res.1 res.2 ⌝ }}.
  Proof.
    intros. iApply (consequence _ _ _ _ _ (proj1 transl_meets_spec _ _)); eauto.
    iIntros "* HA HB". iDestruct ("HA" with "HB") as "HA". iApply (tr_top_spec with "HA").
  Qed.

  Inductive tr_expression: Csyntax.expr -> statement -> expr -> Prop :=
  | tr_expression_intro: forall r sl a,
      (forall ge e le m, tr_top ge e le m For_val r sl a) ->
      tr_expression r (makeseq sl) a.

  Lemma transl_expression_meets_spec: forall r,
      {{ emp }} transl_expression ce r {{ res; ⌜ tr_expression r res.1 res.2 ⌝ }}.
  Proof.
    intro. unfold transl_expression. epose transl_expr_meets_spec. tac2.
    iIntros; norm_all.
  Qed.

  Inductive tr_expr_stmt: Csyntax.expr -> statement -> Prop :=
  | tr_expr_stmt_intro: forall r sl a,
      (forall ge e le m, tr_top ge e le m For_effects r sl a) ->
      tr_expr_stmt r (makeseq sl).

  Lemma transl_expr_stmt_meets_spec: forall r,
      {{ emp }} transl_expr_stmt ce r {{ res; ⌜ tr_expr_stmt r res ⌝}}.
  Proof.
    intro. unfold transl_expr_stmt. epose transl_expr_meets_spec. tac2.
    iIntros; norm_all. iPureIntro. econstructor. auto.
  Qed.

  Inductive tr_if: Csyntax.expr -> statement -> statement -> statement -> Prop :=
  | tr_if_intro: forall r s1 s2 sl a,
      (forall ge e le m, tr_top ge e le m For_val r sl a) ->
      tr_if r s1 s2 (makeseq (sl ++ makeif a s1 s2 :: nil)).

  Lemma transl_if_meets_spec: forall r s1 s2,
      {{ emp }} transl_if ce r s1 s2 {{ res; ⌜ tr_if r s1 s2 res ⌝ }}.
  Proof.
    intros. unfold transl_if. epose transl_expr_meets_spec. tac2.
    iIntros; norm_all.
  Qed.

  Inductive tr_stmt: Csyntax.statement -> statement -> Prop :=
  | tr_skip:
      tr_stmt Csyntax.Sskip Sskip
  | tr_do: forall r s,
      tr_expr_stmt r s ->
      tr_stmt (Csyntax.Sdo r) s
  | tr_seq: forall s1 s2 ts1 ts2,
      tr_stmt s1 ts1 -> tr_stmt s2 ts2 ->
      tr_stmt (Csyntax.Ssequence s1 s2) (Ssequence ts1 ts2)
  | tr_ifthenelse_empty: forall r s' a,
      tr_expression r s' a ->
      tr_stmt (Csyntax.Sifthenelse r Csyntax.Sskip Csyntax.Sskip) (Ssequence s' Sskip)
  | tr_ifthenelse: forall r s1 s2 s' a ts1 ts2,
      tr_expression r s' a ->
      tr_stmt s1 ts1 -> tr_stmt s2 ts2 ->
      tr_stmt (Csyntax.Sifthenelse r s1 s2) (Ssequence s' (Sifthenelse a ts1 ts2))
  | tr_while: forall r s1 s' ts1,
      tr_if r Sskip Sbreak s' ->
      tr_stmt s1 ts1 ->
      tr_stmt (Csyntax.Swhile r s1)
              (Sloop (Ssequence s' ts1) Sskip)
  | tr_dowhile: forall r s1 s' ts1,
      tr_if r Sskip Sbreak s' ->
      tr_stmt s1 ts1 ->
      tr_stmt (Csyntax.Sdowhile r s1)
              (Sloop ts1 s')
  | tr_for_1: forall r s3 s4 s' ts3 ts4,
      tr_if r Sskip Sbreak s' ->
      tr_stmt s3 ts3 ->
      tr_stmt s4 ts4 ->
      tr_stmt (Csyntax.Sfor Csyntax.Sskip r s3 s4)
              (Sloop (Ssequence s' ts4) ts3)
  | tr_for_2: forall s1 r s3 s4 s' ts1 ts3 ts4,
      tr_if r Sskip Sbreak s' ->
      s1 <> Csyntax.Sskip ->
      tr_stmt s1 ts1 ->
      tr_stmt s3 ts3 ->
      tr_stmt s4 ts4 ->
      tr_stmt (Csyntax.Sfor s1 r s3 s4)
              (Ssequence ts1 (Sloop (Ssequence s' ts4) ts3))
  | tr_break:
      tr_stmt Csyntax.Sbreak Sbreak
  | tr_continue:
      tr_stmt Csyntax.Scontinue Scontinue
  | tr_return_none:
      tr_stmt (Csyntax.Sreturn None) (Sreturn None)
  | tr_return_some: forall r s' a,
      tr_expression r s' a ->
      tr_stmt (Csyntax.Sreturn (Some r)) (Ssequence s' (Sreturn (Some a)))
  | tr_switch: forall r ls s' a tls,
      tr_expression r s' a ->
      tr_lblstmts ls tls ->
      tr_stmt (Csyntax.Sswitch r ls) (Ssequence s' (Sswitch a tls))
  | tr_label: forall lbl s ts,
      tr_stmt s ts ->
      tr_stmt (Csyntax.Slabel lbl s) (Slabel lbl ts)
  | tr_goto: forall lbl,
      tr_stmt (Csyntax.Sgoto lbl) (Sgoto lbl)

with tr_lblstmts: Csyntax.labeled_statements -> labeled_statements -> Prop :=
  | tr_ls_nil:
      tr_lblstmts Csyntax.LSnil LSnil
  | tr_ls_cons: forall c s ls ts tls,
      tr_stmt s ts ->
      tr_lblstmts ls tls ->
      tr_lblstmts (Csyntax.LScons c s ls) (LScons c ts tls).

  Ltac tac3 :=
    match goal with
    | H : forall _, {{ emp }} transl_expression _ _ {{ _; _ }}
      |- {{ _ }} transl_expression _ _ {{ _; _ }} =>
      Frame; apply H; tac3
    | H : forall _, {{ emp }} transl_expr_stmt _ _ {{ _; _}}
      |- {{ _ }} transl_expr_stmt _ _ {{ _; _}} =>
      Frame; apply H; tac3
    | H: forall _ _ _, {{ emp }} transl_if _ _ _ _ {{ _; _ }}
      |- {{ _ }} transl_if _ _ _ _ {{ _; _ }} =>
      Frame; apply H; tac3
    | H: {{ emp }} transl_stmt _ ?s {{ _; _ }}
      |- {{ _ }} transl_stmt _ ?s {{ _; _ }} =>
      Frame; apply H; tac3
    | H:(forall _, {{ emp }} transl_stmt _ _ {{ _; _ }})
      |- {{ _ }} transl_stmt _ ?s {{ _; _ }} =>
      Frame; apply H; tac3
    | H: {{ emp }} transl_lblstmt _ ?l {{ _; _ }}
      |- {{ _ }} transl_lblstmt _ ?l {{ _; _ }} =>
      Frame; apply H; tac3
    | H: (forall _, {{ emp }} transl_lblstmt _  _ {{ _; _ }})
      |- {{ _ }} transl_lblstmt _  _ {{ _; _ }} =>
      Frame; apply H; tac3
    | _ => (progress tac); tac3
    | _ => (progress tac2); tac3
    | _ => idtac
    end.

  Lemma transl_stmt_meets_spec : forall s,
      {{ emp }} transl_stmt ce s {{ res; ⌜ tr_stmt s res ⌝}}
  with transl_lblstmt_meets_spec:
         forall s,
           {{ emp }} transl_lblstmt ce s {{ res; ⌜ tr_lblstmts s res ⌝ }}.
  Proof.
    pose transl_expression_meets_spec.
    pose transl_if_meets_spec.
    pose transl_expr_stmt_meets_spec.
    clear transl_stmt_meets_spec. intro.
    induction s; rewrite /transl_stmt; fold (transl_stmt ce); fold (transl_lblstmt ce); tac3.
    - iIntros. iPureIntro. constructor.
    - apply (consequence _ _ _ _ _ (b1 e)); eauto. iIntros (v tr). iPureIntro. apply (tr_do _ _ tr).
    - iIntros "[% [% _]]". iPureIntro. constructor; auto.
    - iIntros "[% [% [% _]]]". iPureIntro. pose Heqb2. apply Is_true_eq_left in e0.
      apply andb_prop_elim in e0 as (P0&P1).
      destruct (is_Sskip s1); destruct (is_Sskip s2) eqn:?; try contradiction. subst.
      eapply tr_ifthenelse_empty; eauto.
    - iIntros"[% [% [% _]]]". iPureIntro. apply (tr_ifthenelse _ _ _ _ _ _ _ H H1 H0).
    - iIntros "[% [% _]]". iPureIntro. apply (tr_while _ _ _ _ H0 H).
    - iIntros "[% [% _]]". iPureIntro. apply (tr_dowhile _ _ _ _ H0 H).
    - iIntros "[% [% [% [% _]]]]"; iPureIntro; subst. apply (tr_for_1 _ _ _ _ _ _ H1 H0 H).
    - iIntros "[% [% [% [% _]]]]"; iPureIntro; subst. apply (tr_for_2 _ _ _ _ _ _ _ _ H1 n H2 H0 H).
    - iIntros "_". iPureIntro. constructor.
    - iIntros "_". iPureIntro. constructor.
    - iIntros "[% _]". iPureIntro. apply (tr_return_some _ _ _ H).
    - iIntros "_". iPureIntro. constructor.
    - iIntros "[% [% _]]". iPureIntro. constructor; auto.
    - iIntros "[% _]". iPureIntro. constructor; auto.
    - iIntros "_". iPureIntro. constructor.
    - induction s; rewrite /transl_lblstmt; fold (transl_lblstmt ce); fold (transl_stmt ce); tac3.
      + iIntros "_". iPureIntro. constructor.
      + iIntros "[% [% _]]". iPureIntro. constructor; auto.
  Qed.

  Inductive tr_fun : Csyntax.statement -> (statement * list (ident * type)) -> Prop :=
  | tr_fun_intro : forall s ts l,
      tr_stmt s ts ->
      tr_fun s (ts, l).

  Lemma transl_fun_meets_spec : forall s,
      {{ emp }} transl_fun ce s {{ res; ⌜ tr_fun s res ⌝}}.
  Proof.
    intro. unfold transl_fun. tac3. apply transl_stmt_meets_spec. Frame. eapply rule_trail.
    iIntros "[_ %]". eauto.
    Qed.

  (** Relational presentation for the transformation of functions, fundefs, and variables. *)

  Inductive tr_function: Csyntax.function -> Clight.function -> Prop :=
  | tr_function_intro: forall f tf l,
      tr_fun f.(Csyntax.fn_body) (tf.(fn_body),l) ->
      fn_return tf = Csyntax.fn_return f ->
      fn_callconv tf = Csyntax.fn_callconv f ->
      fn_params tf = Csyntax.fn_params f ->
      fn_vars tf = Csyntax.fn_vars f ->
      tr_function f tf.

  Lemma transl_function_spec:
    forall f tf,
      transl_function ce f = OK tf ->
      tr_function f tf.
  Proof.
    unfold transl_function; intros.
    destruct (run (transl_fun ce (Csyntax.fn_body f))) eqn:?; inversion H.
    destruct p. simpl in *.
    eapply tr_function_intro; auto; simpl.
    eapply adequacy.
    2 : apply Heqr. apply transl_fun_meets_spec.
  Qed.

End SPEC.

  Inductive tr_fundef (p: Csyntax.program): Csyntax.fundef -> Clight.fundef -> Prop :=
  | tr_internal: forall f tf,
      tr_function p.(prog_comp_env) f tf ->
      tr_fundef p (Internal f) (Internal tf)
  | tr_external: forall ef targs tres cconv,
      tr_fundef p (External ef targs tres cconv) (External ef targs tres cconv).

  Lemma transl_fundef_spec:
    forall p fd tfd,
      transl_fundef p.(prog_comp_env) fd = OK tfd ->
      tr_fundef p fd tfd.
  Proof.
    unfold transl_fundef; intros.
    destruct fd; Errors.monadInv H.
    + constructor. eapply transl_function_spec; eauto.
    + constructor.
  Qed.


From Coq Require Import String NArith ZArith DecimalString HexString.

From Vyper Require Import Config FSet.
From Vyper.L10 Require AST Base ToString.

Section AST.

Context {C: VyperConfig}.

Inductive small_stmt
:= Pass
 | Const (dst: N) (val: uint256)
 | Copy (dst src: N)
 | StorageGet (dst: N) (name: string)
 | StoragePut (name: string) (src: N)
 | UnOp (op: L10.AST.unop) (dst src: N)
 | PowConstBase (dst: N) (base: uint256) (exp: N)
 | PowConstExp (dst base: N) (exp: uint256)
 | BinOp (op: L10.AST.binop) (dst src1 src2: N) (Ok: op <> L10.AST.Pow)
 | PrivateCall (dst: N) (name: string) (args_offset args_count: N)
 | BuiltinCall (dst: N) (name: string) (args_offset args_count: N)
 | Abort (ab: L10.Base.abort)
 | Return (src: N)
 | Raise (src: N).

Inductive stmt
:= SmallStmt (s: small_stmt)
 | IfElseStmt (cond_src: N) (yes: stmt) (no: stmt)
 | Loop (var: N) (count: uint256) (body: stmt)
 | Semicolon (a b: stmt).

Inductive decl
:= StorageVarDecl (name: string)
 | FunDecl (name: string) (args_count: N) (body: stmt).

(****************************   format   ******************************)

Local Open Scope string_scope.

Definition string_of_small_stmt (ss: small_stmt)
:= match ss with
   | Pass => "pass"
   | Const dst val => "var" ++ NilZero.string_of_uint (N.to_uint dst)
                      ++ " = "
                      ++ HexString.of_Z (Z_of_uint256 val)
   | Copy dst src => "var" ++ NilZero.string_of_uint (N.to_uint dst)
                     ++ " = var"
                     ++ NilZero.string_of_uint (N.to_uint src)
   | StorageGet dst name => "var" ++ NilZero.string_of_uint (N.to_uint dst)
                            ++ " = storage_get(" ++ name ++ ")"
   | StoragePut name src => "storage_put(" ++ name
                            ++ ", var" ++ NilZero.string_of_uint (N.to_uint src) ++ ")"
   | UnOp op dst src => "var" ++ NilZero.string_of_uint (N.to_uint dst)
                        ++ " = "
                        ++ L10.ToString.string_of_unop op
                        ++ " var" ++ NilZero.string_of_uint (N.to_uint src)
   | PowConstBase dst base exp =>
      "var" ++ NilZero.string_of_uint (N.to_uint dst) ++ " = "
       ++ NilZero.string_of_int (Z.to_int (Z_of_uint256 base))
       ++ " ** var" ++ NilZero.string_of_uint (N.to_uint exp)
   | PowConstExp dst base exp =>
      "var" ++ NilZero.string_of_uint (N.to_uint dst)
       ++ " = var" ++ NilZero.string_of_uint (N.to_uint base)
       ++ " ** " ++ NilZero.string_of_int (Z.to_int (Z_of_uint256 exp))
   | BinOp op dst src1 src2 _ => "var" ++ NilZero.string_of_uint (N.to_uint dst)
                                 ++ " = var" ++ NilZero.string_of_uint (N.to_uint src1) ++ " "
                                 ++ L10.ToString.string_of_binop op
                                 ++ " var" ++ NilZero.string_of_uint (N.to_uint src2)
   | PrivateCall dst name args_offset args_count =>
       "var" ++ NilZero.string_of_uint (N.to_uint dst)
        ++ " = " ++ name ++ "/"
        ++ NilZero.string_of_uint (N.to_uint args_count)
        ++ "(var" ++ NilZero.string_of_uint (N.to_uint args_offset) ++ ", ...)"
   | BuiltinCall dst name args_offset args_count =>
       "var" ++ NilZero.string_of_uint (N.to_uint dst)
        ++ " = $" ++ name ++ "/"
        ++ NilZero.string_of_uint (N.to_uint args_count)
        ++ "(var" ++ NilZero.string_of_uint (N.to_uint args_offset) ++ ", ...)"
   | Abort a => "abort " ++ L10.Base.string_of_abort a
   | Return n => "return var" ++ NilZero.string_of_uint (N.to_uint n)
   | Raise n => "raise var" ++ NilZero.string_of_uint (N.to_uint n)
   end.

Fixpoint lines_of_stmt (s: stmt)
: list string
:=  match s with
    | SmallStmt ss => string_of_small_stmt ss :: nil
    | IfElseStmt cond yes no => ("if var" ++ NilZero.string_of_uint (N.to_uint cond) ++ ":")
                                :: L10.ToString.add_indent (lines_of_stmt yes)
                                ++ "else:" :: L10.ToString.add_indent (lines_of_stmt no)
    | Loop var count body =>  ("for var" ++ NilZero.string_of_uint (N.to_uint var) ++ " in count("
                                       ++ HexString.of_Z (Z_of_uint256 count) ++ "):")
                                       :: L10.ToString.add_indent (lines_of_stmt body)
    | Semicolon a b => lines_of_stmt a ++ lines_of_stmt b
    end.

Definition lines_of_decl (d: decl)
: list string
:= (match d with
    | StorageVarDecl name => ("var " ++ name)%string :: nil
    | FunDecl name args body =>
        ("def " ++ name ++ "/" ++ NilZero.string_of_uint (N.to_uint args) ++ ":")%string
        :: L10.ToString.add_indent (lines_of_stmt body)
    end)%list.

Definition string_of_decl (d: decl)
:= let newline := "
" in newline ++ List.fold_right (fun x tail => x ++ newline ++ tail) "" (lines_of_decl d).

Definition string_of_decls {C: VyperConfig} (l: list decl)
:= List.fold_right append "" (List.map string_of_decl l).

End AST.


Require Import Raft.
Require Import RaftRefinementInterface.

Section AppendEntriesLeader.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition appendEntries_leader net :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit h e,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                              entries leaderCommit ->
      In e entries ->
      currentTerm (snd (nwState net h)) = t ->
      type (snd (nwState net h)) = Leader ->
      In e (log (snd (nwState net h))).

  Class append_entries_leader_interface : Prop :=
    {
      append_entries_leader_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          appendEntries_leader net
    }.
End AppendEntriesLeader.


(*********************************************************************************************************************************)
(* HaskWeakToStrong: convert HaskWeak to HaskStrong                                                                              *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import NaturalDeduction.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Init.Specif.
Require Import HaskKinds.
Require Import HaskLiterals.
Require Import HaskTyCons.
Require Import HaskWeakTypes.
Require Import HaskWeakVars.
Require Import HaskWeak.
Require Import HaskWeakToCore.
Require Import HaskStrongTypes.
Require Import HaskStrong.
Require Import HaskCoreVars.
Require Import HaskCoreToWeak.
Require Import HaskCoreTypes.

Open Scope string_scope.
Definition TyVarResolver Γ   := forall wt:WeakTypeVar, ???(HaskTyVar Γ wt).
Definition CoVarResolver Γ Δ := forall wt:WeakCoerVar, ???(HaskCoVar Γ Δ).

Definition lamer {a}{b}{c}{κ}(lt:HaskType (app (app a  b) c) κ) : HaskType (app a (app b c)) κ.
  rewrite <- ass_app in lt.
  exact lt.
  Defined.

Definition upPhi {Γ}(tv:WeakTypeVar)(φ:TyVarResolver Γ) : TyVarResolver ((tv:Kind)::Γ).
  unfold TyVarResolver.
  refine (fun tv' =>
    if eqd_dec tv tv'
    then let fresh := @FreshHaskTyVar Γ tv in OK _
    else φ tv' >>= fun tv'' => OK (fun TV ite => tv'' TV (weakITE ite))).
  rewrite <- _H; apply fresh.
  Defined.

Definition upPhi2 {Γ}(tvs:list WeakTypeVar)(φ:TyVarResolver Γ)
  : (TyVarResolver (app (map (fun tv:WeakTypeVar => tv:Kind) tvs) Γ)).
  induction tvs.
  apply φ.
  simpl.
  apply upPhi.
  apply IHtvs.
  Defined.

Definition substPhi {Γ:TypeEnv}(κ κ':Kind)(θ:HaskType Γ κ) : HaskType (κ::Γ) κ' -> HaskType Γ κ'.
  intro ht.
  refine (substT _ θ).
  clear θ.
  unfold HaskType in ht.
  intros.
  apply ht.
  apply ICons; [ idtac | apply env ].
  apply X.
  Defined.

Definition substphi {Γ:TypeEnv}(lk:list Kind)(θ:IList _ (fun κ => HaskType Γ κ) lk){κ} : HaskType (app lk Γ) κ -> HaskType Γ κ.
  induction lk.
  intro q; apply q.
  simpl.
  intro q.
  apply IHlk.
  inversion θ; subst; auto.
  inversion θ; subst.
  eapply substPhi.
  eapply weakT'.
  apply X.
  apply q.
  Defined.

(* this is a StrongAltCon plus some stuff we know about StrongAltCons which we've built ourselves *)
Record StrongAltConPlusJunk {tc:TyCon} :=
{ sacpj_sac : @StrongAltCon tc
; sacpj_phi   : forall Γ          (φ:TyVarResolver Γ  ),  (TyVarResolver (sac_gamma sacpj_sac Γ))
; sacpj_psi   : forall Γ Δ atypes (ψ:CoVarResolver Γ Δ), CoVarResolver _ (sac_delta sacpj_sac Γ atypes (weakCK'' Δ))
}.
Implicit Arguments StrongAltConPlusJunk [ ].
Coercion sacpj_sac : StrongAltConPlusJunk >-> StrongAltCon.

(* yes, I know, this is really clumsy *)
Variable emptyφ : TyVarResolver nil.
  Extract Inlined Constant emptyφ => "(\x -> Prelude.error ""encountered unbound tyvar!"")".

Definition mkPhi (lv:list WeakTypeVar)
  : (TyVarResolver (map (fun x:WeakTypeVar => x:Kind) lv)).
  set (upPhi2(Γ:=nil) lv emptyφ) as φ2.
  rewrite <- app_nil_end in φ2.
  apply φ2.
  Defined.

Definition dataConExKinds dc := vec_map (fun x:WeakTypeVar => (x:Kind)) (list2vec (dataConExTyVars dc)).
Definition tyConKinds     tc := vec_map (fun x:WeakTypeVar => (x:Kind)) (list2vec (tyConTyVars tc)).

Definition fixkind {κ}(tv:WeakTypeVar) := weakTypeVar tv κ.
Notation " ` x " := (@fixkind _ x) (at level 100).

Ltac matchThings T1 T2 S :=
  destruct (eqd_dec T1 T2) as [matchTypeVars_pf|];
   [ idtac | apply (Error (S +++ toString T1 +++ " " +++ toString T2)) ].

Definition mkTAll' {κ}{Γ} : HaskType (κ :: Γ) ★ -> (forall TV (ite:InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV ★).
  intros.
  unfold InstantiatedTypeEnv in ite.
  apply X.
  apply (X0::::ite).
  Defined.

Definition mkTAll {κ}{Γ} : HaskType (κ :: Γ) ★ -> HaskType Γ ★.
  intro.
  unfold HaskType.
  intros.
  apply (TAll κ).
  eapply mkTAll'.
  apply X.
  apply X0.
  Defined.

Definition weakTypeToType : forall {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType), ???(HaskTypeOfSomeKind Γ).
  refine (fix weakTypeToType {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType) {struct t} : ???(HaskTypeOfSomeKind Γ) :=
  addErrorMessage ("weakTypeToType " +++ toString t)
  match t with
    | WFunTyCon         => let case_WFunTyCon := tt in OK (haskTypeOfSomeKind (fun TV ite => TArrow))
    | WTyCon      tc    => let case_WTyCon := tt    in _
    | WClassP   c lt    => let case_WClassP := tt   in Error "weakTypeToType: WClassP not implemented"
    | WIParam _ ty      => let case_WIParam := tt   in Error "weakTypeToType: WIParam not implemented"
    | WAppTy  t1 t2     => let case_WAppTy := tt    in weakTypeToType _ φ t1 >>= fun t1' => weakTypeToType _ φ t2 >>= fun t2' => _
    | WTyVarTy  v       => let case_WTyVarTy := tt  in φ v >>= fun v' => _
    | WForAllTy wtv t   => let case_WForAllTy := tt in weakTypeToType _ (upPhi wtv φ) t >>= fun t => _
    | WCodeTy ec tbody  => let case_WCodeTy := tt   in weakTypeToType _ φ tbody
                                 >>= fun tbody' => φ (@fixkind ECKind ec) >>= fun ec' => _
    | WCoFunTy t1 t2 t3 => let case_WCoFunTy := tt  in
      weakTypeToType _ φ t1 >>= fun t1' =>
      weakTypeToType _ φ t2 >>= fun t2' =>
      weakTypeToType _ φ t3 >>= fun t3' => _
    | WTyFunApp   tc lt =>
      ((fix weakTypeListToTypeList (lk:list Kind) (lt:list WeakType)
        { struct lt } : ???(forall TV (ite:InstantiatedTypeEnv TV Γ), @RawHaskTypeList TV lk) :=
        match lt with
          | nil    => match lk as LK return ???(forall TV (ite:InstantiatedTypeEnv TV Γ), @RawHaskTypeList TV LK) with
                        | nil => OK (fun TV _ => TyFunApp_nil)
                        | _   => Error "WTyFunApp not applied to enough types"
                      end
          | tx::lt' => weakTypeToType Γ φ tx >>= fun t' =>
                        match lk as LK return ???(forall TV (ite:InstantiatedTypeEnv TV Γ), @RawHaskTypeList TV LK) with
                          | nil    => Error ("WTyFunApp applied to too many types"(* +++ eol +++
                                             "  tyCon= "           +++ toString tc +++ eol +++
                                             "  tyConKindArgs= "   +++ toString (fst (tyFunKind tc)) +++ eol +++
                                             "  tyConKindResult= " +++ toString (snd (tyFunKind tc)) +++ eol +++
                                             "  types= "           +++ toString lt +++ eol*))
                          | k::lk' => weakTypeListToTypeList lk' lt' >>= fun rhtl' =>
                                        let case_weakTypeListToTypeList := tt in _
                        end
        end
      ) (fst (tyFunKind tc)) lt) >>= fun lt' => let case_WTyFunApp := tt in  _
  end ); clear weakTypeToType.
  apply ConcatenableString.

  destruct case_WTyVarTy.
    apply (addErrorMessage "case_WTyVarTy").
    apply OK.
    exact (haskTypeOfSomeKind (fun TV env => TVar (v' TV env))).

  destruct case_WAppTy.
    apply (addErrorMessage "case_WAppTy").
    destruct t1' as  [k1' t1'].
    destruct t2' as [k2' t2'].
    set ("tried to apply type "+++toString t1'+++" of kind "+++toString k1'+++" to type "+++
      toString t2'+++" of kind "+++toString k2') as err.
    destruct k1';
      try (matchThings k1'1 k2' "Kind mismatch in WAppTy: ";
        subst; apply OK; apply (haskTypeOfSomeKind (fun TV env => TApp (t1' TV env) (t2' TV env))));
      apply (Error ("Kind mismatch in WAppTy: "+++err)).

  destruct case_weakTypeListToTypeList.
    apply (addErrorMessage "case_weakTypeListToTypeList").
    destruct t' as [ k' t' ].
    matchThings k k' "Kind mismatch in weakTypeListToTypeList".
    subst.
    apply (OK (fun TV ite => TyFunApp_cons _ _ (t' TV ite) (rhtl' TV ite))).

  destruct case_WTyFunApp.
    apply (addErrorMessage "case_WTyFunApp").
    apply OK.
    eapply haskTypeOfSomeKind.
    unfold HaskType; intros.
    apply (TyFunApp tc (fst (tyFunKind tc)) (snd (tyFunKind tc))).
    apply lt'.
    apply X.

  destruct case_WTyCon.
    apply (addErrorMessage "case_WTyCon").
    apply OK.
    eapply haskTypeOfSomeKind.
    unfold HaskType; intros.
    apply (TCon tc).

  destruct case_WCodeTy.
    apply (addErrorMessage "case_WCodeTy").
    destruct tbody'.
    matchThings κ ★ "Kind mismatch in WCodeTy: ".
    apply OK.
    eapply haskTypeOfSomeKind.
    unfold HaskType; intros.
    apply TCode.
    apply (TVar (ec' TV X)).
    subst.
    apply h.
    apply X.

  destruct case_WCoFunTy.
    apply (addErrorMessage "case_WCoFunTy").
    destruct t1' as [ k1' t1' ].
    destruct t2' as [ k2' t2' ].
    destruct t3' as [ k3' t3' ].
    matchThings k1' k2' "Kind mismatch in arguments of WCoFunTy".
    subst.
    matchThings k3' ★ "Kind mismatch in result of WCoFunTy".
    subst.
    apply OK.
    apply (haskTypeOfSomeKind (t1' ∼∼ t2' ⇒ t3')).

  destruct case_WForAllTy.
    apply (addErrorMessage "case_WForAllTy").
    destruct t1.
    matchThings ★  κ "Kind mismatch in WForAllTy: ".
    subst.
    apply OK.
    apply (@haskTypeOfSomeKind _ ★).
    apply (@mkTAll wtv).
    apply h.
    Defined.

(* information about a datacon/literal/default which is common to all instances of a branch with that tag *)
Section StrongAltCon.
  Context (tc : TyCon)(dc:DataCon tc).

Definition weakTypeToType' {Γ} : IList Kind (HaskType Γ) (vec2list (tyConKinds tc))
 -> WeakType → ???(HaskType (app (vec2list (dataConExKinds dc)) Γ) ★).
  intro avars.
  intro ct.
  apply (addErrorMessage "weakTypeToType'").
  set (ilmap (@weakT' _ (vec2list (dataConExKinds dc))) avars) as avars'.
  set (@substphi _ _ avars') as q.
  set (upPhi2 (tyConTyVars tc)  (mkPhi (dataConExTyVars dc))) as φ2.
  set (@weakTypeToType _ φ2 ct) as t.
  destruct t as [|t]; try apply (Error error_message).
  destruct t as [tk t].
  matchThings tk ★ "weakTypeToType'".
  subst.
  apply OK.
  set (@weakT'' _ Γ _ t) as t'.
  set (@lamer _ _ _ _ t') as t''.
  fold (tyConKinds tc) in t''.
  fold (dataConExKinds dc) in t''.
  apply q.
  clear q.
  unfold tyConKinds.
  unfold dataConExKinds.
  rewrite <- vec2list_map_list2vec.
  rewrite <- vec2list_map_list2vec.
  rewrite vec2list_list2vec.
  rewrite vec2list_list2vec.
  apply t''.
  Defined.

Definition mkStrongAltCon : @StrongAltCon tc.
  refine
   {| sac_altcon      := WeakDataAlt dc
    ; sac_numCoerVars := length (dataConCoerKinds dc)
    ; sac_numExprVars := length (dataConFieldTypes dc)
    ; sac_ekinds      := dataConExKinds dc
    ; sac_coercions   := fun Γ avars => let case_sac_coercions := tt in _
    ; sac_types       := fun Γ avars => let case_sac_types := tt in _
    |}.

  destruct case_sac_coercions.
    refine (vec_map _ (list2vec (dataConCoerKinds dc))).
    intro.
    destruct X.
    unfold tyConKind in avars.
    set (@weakTypeToType' Γ) as q.
    unfold tyConKinds in q.
    rewrite <- vec2list_map_list2vec in q.
    rewrite vec2list_list2vec in q.
    apply (
      match
        q avars w >>= fun t1 =>
        q avars w0 >>= fun t2 =>
          OK (mkHaskCoercionKind t1 t2)
      with
        | Error s => Prelude_error s
        | OK y => y
      end).

  destruct case_sac_types.
    refine (vec_map _ (list2vec (dataConFieldTypes dc))).
    intro X.
    unfold tyConKind in avars.
    set (@weakTypeToType' Γ) as q.
    unfold tyConKinds in q.
    rewrite <- vec2list_map_list2vec in q.
    rewrite vec2list_list2vec in q.
    set (q avars X) as y.
    apply (match y with
             | Error s =>Prelude_error s
             | OK y' => y'
           end).
    Defined.

Lemma weakCV' : forall {Γ}{Δ} Γ',
   HaskCoVar Γ Δ
   -> HaskCoVar (app Γ' Γ) (weakCK'' Δ).
  intros.
  unfold HaskCoVar in *.
  intros; apply (X TV CV).
  apply ilist_chop' in env; auto.
  unfold InstantiatedCoercionEnv in *.
  unfold weakCK'' in cenv.
  destruct Γ'.
  rewrite <- map_preserves_length in cenv.
  apply cenv.
  rewrite <- map_preserves_length in cenv.
  apply cenv.
  Defined.

Definition mkStrongAltConPlusJunk : StrongAltConPlusJunk tc.
    refine
     {| sacpj_sac     := mkStrongAltCon
      ; sacpj_phi       := fun Γ φ => (fun htv => φ htv >>= fun htv' => OK (weakV' htv'))
      ; sacpj_psi       :=
      fun Γ Δ avars ψ => (fun htv => ψ htv >>= fun htv' => OK (_ (weakCV' (vec2list (sac_ekinds mkStrongAltCon)) htv')))
      |}.
    intro.
    unfold sac_gamma.
    unfold HaskCoVar in *.
    intros.
    apply (x TV CV env).
    simpl in cenv.
    unfold sac_delta in *.
    unfold InstantiatedCoercionEnv in *.
    apply vec_chop' in cenv.
    apply cenv.
    Defined.

  Lemma weakCK'_nil_inert : forall Γ Δ, (@weakCK'' Γ (@nil Kind)) Δ = Δ.
    intros.
    induction Δ.
    reflexivity.
    simpl.
    rewrite IHΔ.
    reflexivity.
    Qed.

End StrongAltCon.

Definition mkStrongAltConPlusJunk' (tc : TyCon)(alt:WeakAltCon) : ???(@StrongAltConPlusJunk tc).
  destruct alt.
  set (c:DataCon _) as dc.
  set ((dataConTyCon c):TyCon) as tc' in *.
  set (eqd_dec tc tc') as eqpf; destruct eqpf;
    [ idtac
      | apply (Error ("in a case of tycon "+++toString tc+++", found a branch with datacon "+++toString (dc:CoreDataCon))) ]; subst.
  apply OK.
  eapply mkStrongAltConPlusJunk.
  simpl in *.
  apply dc.

  apply OK; refine {| sacpj_sac := {|
                     sac_ekinds  := vec_nil ; sac_coercions := fun _ _ => vec_nil ; sac_types := fun _ _ => vec_nil
                    ; sac_altcon := WeakLitAlt h
                    |} |}.
            intro; intro φ; apply φ.
            intro; intro; intro; intro ψ. simpl. unfold sac_gamma; simpl. unfold sac_delta; simpl.
            rewrite weakCK'_nil_inert. apply ψ.
  apply OK; refine {| sacpj_sac := {|
                     sac_ekinds := vec_nil ; sac_coercions := fun _ _ => vec_nil ; sac_types := fun _ _ => vec_nil
                      ; sac_altcon := WeakDEFAULT |} |}.
            intro; intro φ; apply φ.
            intro; intro; intro; intro ψ. simpl. unfold sac_gamma; simpl. unfold sac_delta; simpl.
            rewrite weakCK'_nil_inert. apply ψ.
Defined.

Definition weakExprVarToWeakType : WeakExprVar -> WeakType :=
  fun wev => match wev with weakExprVar _ t => t end.
  Coercion weakExprVarToWeakType : WeakExprVar >-> WeakType.

Variable weakCoercionToHaskCoercion : forall Γ Δ κ, WeakCoercion -> HaskCoercion Γ Δ κ.

Definition weakPsi {Γ}{Δ:CoercionEnv Γ} {κ}(ψ:WeakCoerVar -> ???(HaskCoVar Γ Δ)) :
  WeakCoerVar -> ???(HaskCoVar Γ (κ::Δ)).
  intros.
  refine (ψ X >>= _).
  unfold HaskCoVar.
  intros.
  apply OK.
  intros.
  inversion cenv; auto.
  Defined.

(* attempt to "cast" an expression by simply checking if it already had the desired type, and failing otherwise *)
Definition castExpr (we:WeakExpr)(err_msg:string) {Γ} {Δ} {ξ} {τ} {l} τ' l' (e:@Expr _ CoreVarEqDecidable Γ Δ ξ τ l)
  : ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ' l').
  apply (addErrorMessage ("castExpr " +++ err_msg)).
  intros.
  destruct (eqd_dec l l'); [ idtac
    | apply (Error ("level mismatch in castExpr, invoked by "+++err_msg+++eol+++
                    "  got: " +++(fold_left (fun x y => y+++","+++y) (map (toString ○ haskTyVarToType) l) "")+++eol+++
                    "  wanted: "+++(fold_left (fun x y => x+++","+++y) (map (toString ○ haskTyVarToType) l') "")
    )) ].
  destruct (eqd_dec τ τ'); [ idtac
    | apply (Error ("type mismatch in castExpr, invoked by "+++err_msg+++eol+++
                    "  got: " +++toString τ+++eol+++
                    "  wanted: "+++toString τ'
    )) ].
  subst.
  apply OK.
  apply e.
  Defined.

Definition coVarKind (wcv:WeakCoerVar) : Kind :=
  match wcv with weakCoerVar _ t _ => (kindOfCoreType (weakTypeToCoreType t)) end.
  Coercion coVarKind : WeakCoerVar >-> Kind.

Definition weakTypeToTypeOfKind : forall {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType)(κ:Kind), ???(HaskType Γ κ).
  intros.
  set (weakTypeToType φ t) as wt.
  destruct wt; try apply (Error error_message).
  destruct h.
  matchThings κ κ0 ("Kind mismatch in weakTypeToTypeOfKind in ").
  subst.
  apply OK.
  apply h.
  Defined.

Fixpoint varsTypes {Γ}(t:Tree ??(WeakExprVar * WeakExpr))(φ:TyVarResolver Γ) : Tree ??(CoreVar * HaskType Γ ★) :=
  match t with
    | T_Leaf None            => []
    | T_Leaf (Some (wev,e))  => match weakTypeToTypeOfKind φ wev ★ with
                                  | OK    t' => [((wev:CoreVar),t')]
                                  | _        => []
                                end
    | T_Branch b1 b2         => (varsTypes b1 φ),,(varsTypes b2 φ)
  end.

Fixpoint mkAvars {Γ}(wtl:list WeakType)(lk:list Kind)(φ:TyVarResolver Γ) : ???(IList Kind (HaskType Γ) lk) :=
match lk as LK return ???(IList Kind (HaskType Γ) LK) with
  | nil => match wtl with
             | nil => OK INil
             | _   => Error "length mismatch in mkAvars"
           end
  | k::lk' => match wtl with
                | nil => Error "length mismatch in mkAvars"
                | wt::wtl' =>
                  weakTypeToTypeOfKind φ wt k >>= fun t =>
                    mkAvars wtl' lk' φ >>= fun rest =>
                    OK (ICons _ _ t rest)
              end
end.

Fixpoint update_ig (ig:CoreVar -> bool) (vars:list CoreVar) : CoreVar -> bool :=
  match vars with
    | nil => ig
    | v::vars' =>
      fun v' =>
        if eqd_dec v v'
          then false
            else update_ig ig vars' v'
  end.

(* does the specified variable occur free in the expression? *)
Fixpoint doesWeakVarOccur (wev:WeakExprVar)(me:WeakExpr) : bool :=
  match me with
    | WELit    _        => false
    | WEVar    cv       => if eqd_dec (wev:CoreVar) (cv:CoreVar) then true else false
    | WECast   e co     =>                            doesWeakVarOccur wev e
    | WENote   n e      =>                            doesWeakVarOccur wev e
    | WETyApp  e t      =>                            doesWeakVarOccur wev e
    | WECoApp  e co     =>                            doesWeakVarOccur wev e
    | WEBrak _ ec e _   =>                            doesWeakVarOccur wev e
    | WEEsc  _ ec e _   =>                            doesWeakVarOccur wev e
    | WECSP  _ ec e _   =>                            doesWeakVarOccur wev e
    | WELet    cv e1 e2 => doesWeakVarOccur wev e1 || (if eqd_dec (wev:CoreVar) (cv:CoreVar)then false else doesWeakVarOccur wev e2)
    | WEApp    e1 e2    => doesWeakVarOccur wev e1 || doesWeakVarOccur wev e2
    | WELam    cv e     => if eqd_dec (wev:CoreVar) (cv:CoreVar) then false else doesWeakVarOccur wev e
(*
    | WEKappaApp  e1 e2 => doesWeakVarOccur wev e1 || doesWeakVarOccur wev e2
    | WEKappa  cv e     => if eqd_dec (wev:CoreVar) (cv:CoreVar) then false else doesWeakVarOccur wev e
*)
    | WETyLam  cv e     => doesWeakVarOccur wev e
    | WECoLam  cv e     => doesWeakVarOccur wev e
    | WECase vscrut escrut tbranches tc avars alts =>
      doesWeakVarOccur wev escrut ||
      if eqd_dec (wev:CoreVar) (vscrut:CoreVar) then false else
        ((fix doesWeakVarOccurAlts alts {struct alts} : bool :=
          match alts with
            | T_Leaf  None                                         => false
            | T_Leaf (Some (WeakDEFAULT,_,_,_,e))                      => doesWeakVarOccur wev e
            | T_Leaf (Some (WeakLitAlt lit,_,_,_,e))                   => doesWeakVarOccur wev e
            | T_Leaf (Some ((WeakDataAlt dc), tvars, cvars, evars,e))  => doesWeakVarOccur wev e  (* FIXME!!! *)
            | T_Branch b1 b2                                       => doesWeakVarOccurAlts b1 || doesWeakVarOccurAlts b2
          end) alts)
    | WELetRec mlr e =>
      doesWeakVarOccur wev e ||
      (fix doesWeakVarOccurLetRec (mlr:Tree ??(WeakExprVar * WeakExpr)) : bool :=
      match mlr with
        | T_Leaf None          => false
        | T_Leaf (Some (cv,e)) => if eqd_dec (wev:CoreVar) (cv:CoreVar) then false else doesWeakVarOccur wev e
        | T_Branch b1 b2       => doesWeakVarOccurLetRec b1 || doesWeakVarOccurLetRec b2
      end) mlr
  end.
Fixpoint doesWeakVarOccurAlts (wev:WeakExprVar)
  (alts:Tree ??(WeakAltCon * list WeakTypeVar * list WeakCoerVar * list WeakExprVar * WeakExpr)) : bool :=
  match alts with
    | T_Leaf  None                                             => false
    | T_Leaf (Some (WeakDEFAULT,_,_,_,e))                      => doesWeakVarOccur wev e
    | T_Leaf (Some (WeakLitAlt lit,_,_,_,e))                   => doesWeakVarOccur wev e
    | T_Leaf (Some ((WeakDataAlt dc), tvars, cvars, evars,e))  => doesWeakVarOccur wev e  (* FIXME!!! *)
    | T_Branch b1 b2                                           => doesWeakVarOccurAlts wev b1 || doesWeakVarOccurAlts wev b2
  end.

Definition checkDistinct :
  forall {V}(EQ:EqDecidable V)(lv:list V), ???(distinct lv).
  intros.
  set (distinct_decidable lv) as q.
  destruct q.
  exact (OK d).
  exact (Error "checkDistinct failed").
  Defined.

(* FIXME: check the kind of the type of the weakexprvar to support >0 *)
Definition mkGlobal Γ (τ:HaskType Γ ★) (wev:WeakExprVar) : Global Γ.
  refine {| glob_kinds := nil |}.
  apply wev.
  intros.
  apply τ.
  Defined.

Definition weakExprToStrongExpr : forall
    (Γ:TypeEnv)
    (Δ:CoercionEnv Γ)
    (φ:TyVarResolver Γ)
    (ψ:CoVarResolver Γ Δ)
    (ξ:CoreVar -> LeveledHaskType Γ ★)
    (ig:CoreVar -> bool)
    (τ:HaskType Γ ★)
    (lev:HaskLevel Γ),
    WeakExpr -> ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ lev ).
  refine ((
    fix weakExprToStrongExpr
    (Γ:TypeEnv)
    (Δ:CoercionEnv Γ)
    (φ:TyVarResolver Γ)
    (ψ:CoVarResolver Γ Δ)
    (ξ:CoreVar -> LeveledHaskType Γ ★)
    (ig:CoreVar -> bool)
    (τ:HaskType Γ ★)
    (lev:HaskLevel Γ)
    (we:WeakExpr) : ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ lev )  :=
    addErrorMessage ("in weakExprToStrongExpr " +++ toString we)
    match we with

    | WEVar   v                         => if ig v
                                              then OK ((EGlobal Γ Δ ξ (mkGlobal Γ τ v) INil lev) : Expr Γ Δ ξ τ lev)
                                              else castExpr we ("WEVar "+++toString (v:CoreVar)) τ lev (EVar Γ Δ ξ v)

    | WELit   lit                       => castExpr we ("WELit "+++toString lit) τ lev (ELit Γ Δ ξ lit lev)

    | WELam   ev ebody                  => weakTypeToTypeOfKind φ ev ★ >>= fun tv =>
                                             weakTypeOfWeakExpr ebody >>= fun tbody =>
                                               weakTypeToTypeOfKind φ tbody ★ >>= fun tbody' =>
                                                 let ξ' := update_xi ξ lev (((ev:CoreVar),tv)::nil) in
                                                 let ig' := update_ig ig ((ev:CoreVar)::nil) in
                                                   weakExprToStrongExpr Γ Δ φ ψ ξ' ig' tbody' lev ebody >>= fun ebody' =>
                                                     castExpr we "WELam" τ lev (ELam Γ Δ ξ tv tbody' lev ev ebody')

    | WEBrak  _ ec e tbody              => φ (`ec) >>= fun ec' =>
                                             weakTypeToTypeOfKind φ tbody ★ >>= fun tbody' =>
                                               weakExprToStrongExpr Γ Δ φ ψ ξ ig tbody' ((ec')::lev) e >>= fun e' =>
                                                 castExpr we "WEBrak" τ lev (EBrak Γ Δ ξ ec' tbody' lev e')

    | WEEsc   _ ec e tbody              => φ ec >>= fun ec'' =>
                                           weakTypeToTypeOfKind φ tbody ★ >>= fun tbody' =>
                                           match lev with
                                             | nil       => Error "ill-leveled escapification"
                                             | ec'::lev' => weakExprToStrongExpr Γ Δ φ ψ ξ ig (<[ ec' |- tbody' ]>) lev' e
                                               >>= fun e' => castExpr we "WEEsc" τ lev (EEsc Γ Δ ξ ec' tbody' lev' e')
                                           end

    | WECSP   _ ec e tbody              => Error "FIXME: CSP not supported beyond HaskWeak stage"

    | WENote  n e                       => weakExprToStrongExpr Γ Δ φ ψ ξ ig τ lev e >>= fun e' => OK (ENote _ _ _ _ _ n e')

    | WELet   v ve  ebody               => weakTypeToTypeOfKind φ v ★  >>= fun tv =>
                                             weakExprToStrongExpr Γ Δ φ ψ ξ ig tv lev ve >>= fun ve' =>
                                               weakExprToStrongExpr Γ Δ φ ψ (update_xi ξ lev (((v:CoreVar),tv)::nil))
                                                    (update_ig ig ((v:CoreVar)::nil)) τ lev ebody
                                               >>= fun ebody' =>
                                                 OK (ELet _ _ _ tv _ lev (v:CoreVar) ve' ebody')

    | WEApp   e1 e2                     => weakTypeOfWeakExpr e2 >>= fun t2 =>
                                             weakTypeToTypeOfKind φ t2 ★ >>= fun t2' =>
                                               weakExprToStrongExpr Γ Δ φ ψ ξ ig t2' lev e2 >>= fun e2' =>
                                                 weakExprToStrongExpr Γ Δ φ ψ ξ ig (t2'--->τ) lev e1 >>= fun e1' =>
                                                   OK (EApp _ _ _ _ _ _ e1' e2')

    | WETyLam tv e                      => let φ2 := upPhi tv φ in
                                             weakTypeOfWeakExpr e >>= fun te =>
                                               weakTypeToTypeOfKind φ2 te ★ >>= fun τ' =>
                                                 weakExprToStrongExpr _ (weakCE_(n:=O) Δ) φ2
                                                   (fun x => (ψ x) >>= fun y =>
                                                     OK (weakCV_ y)) (weakLT_○ξ) ig _ (weakL_ lev) e
                                                   >>= fun e' => castExpr we "WETyLam2" _ _
                                                     (ETyLam Γ Δ ξ tv (mkTAll' τ') lev 0 e')

    | WETyApp e t                       => weakTypeOfWeakExpr e >>= fun te =>
                                           match te with
                                             | WForAllTy wtv te' =>
                                               let φ2 := upPhi wtv φ in
                                                 weakTypeToTypeOfKind φ2 te' ★ >>= fun te'' =>
                                                   weakExprToStrongExpr Γ Δ φ ψ ξ ig (mkTAll te'') lev e >>= fun e' =>
                                                     weakTypeToTypeOfKind φ t (wtv:Kind) >>= fun t' =>
                                                       castExpr we "WETyApp" _ _ (ETyApp Γ Δ wtv (mkTAll' te'') t' ξ lev e')
                                             | _                 => Error ("weakTypeToType: WETyApp body with type "+++toString te)
                                           end

    | WECoApp e co                     => weakTypeOfWeakExpr e >>= fun te =>
                                           match te with
                                             | WCoFunTy t1 t2 t3 =>
                                               weakTypeToType φ t1 >>= fun t1' =>
                                                 match t1' with
                                                   haskTypeOfSomeKind κ t1'' =>
                                                   weakTypeToTypeOfKind φ t2 κ >>= fun t2'' =>
                                                     weakTypeToTypeOfKind φ t3 ★ >>= fun t3'' =>
                                                       weakExprToStrongExpr Γ Δ φ ψ ξ ig (t1'' ∼∼ t2'' ⇒ τ) lev e >>= fun e' =>
                                                         castExpr we "WECoApp" _ _ e' >>= fun e'' =>
                                                           OK (ECoApp Γ Δ κ t1'' t2''
                                                             (weakCoercionToHaskCoercion _ _ _ co) τ ξ lev e'')
                                                 end
                                             | _                 => Error ("weakTypeToType: WECoApp body with type "+++toString te)
                                           end

    | WECoLam cv e                      => let (_,t1,t2) := cv in
                                           weakTypeOfWeakExpr e >>= fun te =>
                                             weakTypeToTypeOfKind φ te ★ >>= fun te' =>
                                               weakTypeToTypeOfKind φ t1 cv >>= fun t1' =>
                                                 weakTypeToTypeOfKind φ t2 cv >>= fun t2' =>
                                                   weakExprToStrongExpr Γ (_ :: Δ) φ (weakPsi ψ) ξ ig te' lev e >>= fun e' =>
                                                     castExpr we "WECoLam" _ _ (ECoLam Γ Δ cv te' t1' t2' ξ lev e')

    | WECast  e co                      => let (t1,t2) := weakCoercionTypes co in
                                             weakTypeToTypeOfKind φ t1 ★ >>= fun t1' =>
                                               weakTypeToTypeOfKind φ t2 ★ >>= fun t2' =>
                                                   weakExprToStrongExpr Γ Δ φ ψ ξ ig t1' lev e >>= fun e' =>
                                                     castExpr we "WECast" _ _
                                                       (ECast Γ Δ ξ t1' t2' (weakCoercionToHaskCoercion _ _ _ co) lev e')

    | WELetRec rb   e                   =>
      let ξ' := update_xi ξ lev _ in
      let ig' := update_ig ig (map (fun x:(WeakExprVar*_) => (fst x):CoreVar) (leaves rb)) in
      let binds :=
        (fix binds (t:Tree ??(WeakExprVar * WeakExpr))
          : ???(ELetRecBindings Γ Δ ξ' lev (varsTypes t φ)) :=
        match t with
          | T_Leaf None           => let case_nil := tt in OK (ELR_nil _ _ _ _)
          | T_Leaf (Some (wev,e)) => let case_some := tt in (fun e' => _) (fun τ => weakExprToStrongExpr Γ Δ φ ψ ξ' ig' τ lev e)
          | T_Branch b1 b2        =>
            binds b1 >>= fun b1' =>
              binds b2 >>= fun b2' =>
                OK (ELR_branch Γ Δ ξ' lev _ _ b1' b2')
        end) rb
      in binds >>= fun binds' =>
         checkDistinct CoreVarEqDecidable (map (@fst _ _) (leaves (varsTypes rb φ))) >>= fun rb_distinct =>
           weakExprToStrongExpr Γ Δ φ ψ ξ' ig' τ lev e >>= fun e' =>
             OK (ELetRec Γ Δ ξ lev τ _ _ binds' e')

    | WECase vscrut escrut tbranches tc avars alts =>
        weakTypeOfWeakExpr escrut >>= fun tscrut =>
          weakTypeToTypeOfKind φ tscrut ★ >>= fun tscrut' =>
            if doesWeakVarOccurAlts vscrut alts
            then Error "encountered a Case which actually used its binder - these should have been desugared away!!"
            else mkAvars avars (tyConKind tc) φ >>= fun avars' =>
                weakTypeToTypeOfKind φ tbranches ★  >>= fun tbranches' =>
                  (fix mkTree (t:Tree ??(WeakAltCon*list WeakTypeVar*list WeakCoerVar*list WeakExprVar*WeakExpr)) : ???(Tree
                      ??{ sac : _ & {scb : StrongCaseBranchWithVVs CoreVar CoreVarEqDecidable tc avars' sac &
                        Expr (sac_gamma sac Γ) (sac_delta sac Γ avars' (weakCK'' Δ))(scbwv_xi scb ξ lev)(weakT' tbranches')(weakL' lev)}}) :=
                    match t with
                      | T_Leaf None           => OK []
                      | T_Leaf (Some (ac,extyvars,coervars,exprvars,ebranch)) =>
                        mkStrongAltConPlusJunk' tc ac >>= fun sac =>
                          list2vecOrFail (map (fun ev:WeakExprVar => ev:CoreVar) exprvars) _ (fun _ _ => "WECase")
                          >>= fun exprvars' =>
                            (let case_pf := tt in _) >>= fun pf =>
                            let scb := @Build_StrongCaseBranchWithVVs CoreVar CoreVarEqDecidable tc Γ avars' sac exprvars' pf in
                              weakExprToStrongExpr (sac_gamma sac Γ) (sac_delta sac Γ avars' (weakCK'' Δ)) (sacpj_phi sac _ φ)
                              (sacpj_psi sac _ _ avars' ψ)
                              (scbwv_xi scb ξ lev)
                              (update_ig ig (map (@fst _ _) (vec2list (scbwv_varstypes scb))))
                              (weakT' tbranches') (weakL' lev) ebranch >>= fun ebranch' =>
                                let case_case := tt in OK [ _ ]
                      | T_Branch b1 b2        =>
                        mkTree b1 >>= fun b1' =>
                          mkTree b2 >>= fun b2' =>
                            OK (b1',,b2')
                    end) alts >>= fun tree =>

                    weakExprToStrongExpr Γ Δ φ ψ ξ ig (caseType tc avars') lev escrut >>= fun escrut' =>
                      castExpr we "ECase" τ lev (ECase Γ Δ ξ lev tc tbranches' avars' escrut' tree)
    end)); try clear binds; try apply ConcatenableString.

    destruct case_some.
    apply (addErrorMessage "case_some").
      simpl.
      destruct (weakTypeToTypeOfKind φ wev ★); try apply (Error error_message).
      matchThings h (unlev (ξ' wev)) "LetRec".
      destruct wev.
      rewrite matchTypeVars_pf.
      clear matchTypeVars_pf.
      set (e' (unlev (ξ' (weakExprVar c w)))) as e''.
      destruct e''; try apply (Error error_message).
      apply OK.
      apply ELR_leaf.
      unfold ξ'.
      simpl.
      induction (leaves (varsTypes rb φ)).
        simpl; auto.
        destruct (ξ c).
        simpl.
      apply e1.
      rewrite mapleaves.
      apply rb_distinct.

    destruct case_pf.
      set (distinct_decidable (vec2list exprvars')) as dec.
      destruct dec; [ idtac | apply (Error "malformed HaskWeak: case branch with variables repeated") ].
      apply OK; auto.

    destruct case_case.
      exists sac.
      exists scb.
      apply ebranch'.

    Defined.


Require Import VST.floyd.proofauto.
Require Import ASI_mmap0.
Require Import malloc.
Require Import ASI_malloc.
Require Import malloc_lemmas.
Require Import malloc_sep.

Definition Tok_APD := Build_MallocTokenAPD malloc_token' malloc_token'_valid_pointer
                    malloc_token'_local_facts.

Definition R_APD := Build_MallocFree_R_APD Tok_APD mem_mgr_R.

(*+ specs of private functions *)

Definition bin2size_spec :=
 DECLARE _bin2size
  WITH b: Z
  PRE [ tint ]
     PROP( 0 <= b < BINS )
     PARAMS ((Vint (Int.repr b))) GLOBALS () SEP ()
  POST [ tuint ]
     PROP() LOCAL(temp ret_temp (Vptrofs (Ptrofs.repr (bin2sizeZ b)))) SEP ().

Definition size2bin_spec :=
 DECLARE _size2bin
  WITH s: Z
  PRE [ tuint ]
     PROP( 0 <= s <= Ptrofs.max_unsigned )
     PARAMS ((Vptrofs (Ptrofs.repr s))) GLOBALS () SEP ()
  POST [ tint ]
     PROP() LOCAL(temp ret_temp (Vint (Int.repr (size2binZ s)))) SEP ().

Definition list_from_block_spec :=
 DECLARE _list_from_block
  WITH s: Z, p: val, tl: val, tlen: nat, b: Z
  PRE [ tuint, tptr tschar, tptr tvoid ]
     PROP( 0 <= b < BINS /\ s = bin2sizeZ b /\ malloc_compatible BIGBLOCK p )
     PARAMS ((Vptrofs (Ptrofs.repr s)); p; tl) GLOBALS ()
     SEP ( memory_block Tsh BIGBLOCK p; mmlist s tlen tl nullval )
  POST [ tptr tvoid ] EX res:_,
     PROP()
     LOCAL(temp ret_temp res)
     SEP ( mmlist s (Z.to_nat(chunks_from_block (size2binZ s)) + tlen) res nullval * TT ).

(* The postcondition describes the list returned, together with
   TT for the wasted space at the beginning and end of the big block from mmap. *)

Definition fill_bin_spec :=
 DECLARE _fill_bin
  WITH b: _
  PRE [ tint ]
     PROP(0 <= b < BINS) PARAMS ((Vint (Int.repr b))) GLOBALS () SEP ()
  POST [ (tptr tvoid) ] EX p:_, EX len:Z,
     PROP( if eq_dec p nullval then True else len > 0 )
     LOCAL(temp ret_temp p)
     SEP ( if eq_dec p nullval then emp
           else mmlist (bin2sizeZ b) (Z.to_nat len) p nullval * TT).

Definition malloc_small_spec :=
   DECLARE _malloc_small
   WITH n:Z, gv:globals, rvec:resvec
   PRE [ size_t ]
       PROP (0 <= n <= bin2sizeZ(BINS-1))
       PARAMS ((Vptrofs (Ptrofs.repr n))) GLOBALS (gv)
       SEP ( mem_mgr_R rvec gv)
   POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( if guaranteed rvec n
             then mem_mgr_R (add_resvec rvec (size2binZ n) (-1)) gv *
                  malloc_token' Ews n p * memory_block Ews n p
             else if eq_dec p nullval
                  then mem_mgr_R rvec gv
                  else (EX rvec':_, !!(eq_except rvec' rvec (size2binZ n))
                                 && mem_mgr_R rvec' gv *
                                    malloc_token' Ews n p * memory_block Ews n p) ).

Definition malloc_large_spec :=
   DECLARE _malloc_large
   WITH n:Z, gv:globals, rvec:resvec
   PRE [ size_t ]
       PROP (bin2sizeZ(BINS-1) < n <= Ptrofs.max_unsigned - (WA+WORD))
       PARAMS ((Vptrofs (Ptrofs.repr n))) GLOBALS (gv)
       SEP ( mem_mgr_R rvec gv)
   POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr_R rvec gv;
            if eq_dec p nullval then emp
            else malloc_token' Ews n p * memory_block Ews n p).

(* s is the stored chunk size and n is the original request amount. *)
(* Note: the role of n in free_small_spec is merely to facilitate proof for free itself *)
Definition free_small_spec :=
   DECLARE _free_small
   WITH p:_, s:_, n:_, gv:globals, rvec:resvec
   PRE [ tptr tvoid, tuint ]
       PROP (0 <= n <= bin2sizeZ(BINS-1) /\ s = bin2sizeZ(size2binZ n) /\
             malloc_compatible s p)
       PARAMS (p; (Vptrofs (Ptrofs.repr s))) GLOBALS (gv)
       SEP ( data_at Tsh tuint (Vptrofs (Ptrofs.repr s)) (offset_val (- WORD) p);
            data_at_ Tsh (tptr tvoid) p;
            memory_block Tsh (s - WORD) (offset_val WORD p);
            mem_mgr_R rvec gv)
   POST [ tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr_R (add_resvec rvec (size2binZ n) 1) gv).

Definition free_large_spec :=
   DECLARE _free_large
   WITH p:_, s:_, gv:globals, rvec:resvec
   PRE [ tptr tvoid, tuint ]
       PROP (malloc_compatible s p /\ maxSmallChunk < s <= Ptrofs.max_unsigned - (WA+WORD))
       PARAMS (p; (Vptrofs (Ptrofs.repr s))) GLOBALS (gv)
       SEP ( data_at Tsh tuint (Vptrofs (Ptrofs.repr s)) (offset_val (- WORD) p);
            data_at_ Tsh (tptr tvoid) p;
            memory_block Tsh (s - WORD) (offset_val WORD p);
            memory_block Tsh WA (offset_val (- (WA+WORD)) p);
            mem_mgr_R rvec gv)
   POST [ tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr_R rvec gv).

Definition MF_Vprog : varspecs. mk_varspecs prog. Defined.

Definition MF_internal_specs: funspecs :=
    [malloc_large_spec; malloc_small_spec; free_large_spec; free_small_spec;
     bin2size_spec; size2bin_spec; list_from_block_spec; fill_bin_spec]
   ++ Malloc_R_ASI R_APD _pre_fill _try_pre_fill _malloc _free.

Definition MF_Imports:funspecs := Mmap0_ASI _mmap0 _munmap.

Definition MF_Gprog:funspecs := MF_Imports ++ MF_internal_specs.

Ltac start_function_hint ::= idtac. (* no hint reminder *)