Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RunAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Fixpoint complete_hvc_exit_loop0 (n: nat) (i: Z) rec_base rec_ofst adt :=
    match n with
    | O => Some (i, adt)
    | S n' =>
        match complete_hvc_exit_loop0 n' i rec_base rec_ofst adt with
        | Some (i, adt) =>
          rely is_int i;
          when' gpr == get_rec_run_gprs_spec i adt;
          rely is_int64 gpr;
          when adt == set_rec_regs_spec (rec_base, rec_ofst) i (VZ64 gpr) adt;
          Some (i + 1, adt)
        | _ => None
        end
    end.

  Definition complete_hvc_exit_spec0 (rec: Pointer) (adt: RData) : option RData :=
    match rec with
    | (rec_base, rec_ofst) =>
      when' esr == get_rec_last_run_info_esr_spec (rec_base, rec_ofst) adt;
      rely is_int64 esr;
      if (Z.land esr ESR_EL2_EC_MASK) =? ESR_EL2_EC_HVC then
        match complete_hvc_exit_loop0 (Z.to_nat REC_RUN_HVC_NR_GPRS) 0 rec_base rec_ofst adt with
        | Some (i, adt) =>
          rely is_int i;
          when adt == reset_last_run_info_spec (rec_base, rec_ofst) adt;
          Some adt
        | _ => None
        end
      else Some adt
    end.

End SpecLow.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_addOrdinaryStake (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Definition DePoolContract_Ф_addOrdinaryStake'_tailer (Л_stake Л_fee: XInteger64) : LedgerT True :=
declareLocal Л_participant :>: ξ DePoolLib_ι_Participant := ParticipantBase_Ф_getOrCreateParticipant (! msg_sender () !) ;
declareLocal Л_round :>: RoundsBase_ι_Round := RoundsBase_Ф_getRound0 () ;
declareLocal Л_empty :>: (XMaybe RoundsBase_ι_InvestParams) ;
U0! {( Л_round , Л_participant )} := RoundsBase_Ф__addStakes (! $ Л_round ,
                $ Л_participant ,
                msg_sender () ,
                $ Л_stake ,
                $ Л_empty ,
                $ Л_empty !) ;
RoundsBase_Ф_setRound0 (! $ Л_round !) >>
(ParticipantBase_Ф__setOrDeleteParticipant (! msg_sender () , $ Л_participant !)) >>
(DePoolContract_Ф_sendAcceptAndReturnChange128 (! $ Л_fee !)) .

Definition DePoolContract_Ф_addOrdinaryStake'_header ( Л_stake : XInteger64 )  :  LedgerT ( XErrorValue (XValueValue True) XInteger ) :=
 Require {{ msg_sender () ?!= $ xInt0 , ξ$ Errors_ι_IS_EXT_MSG }} ;
 If!! ( ↑12 D2! DePoolContract_ι_m_poolClosed ) then {
  return!!! ( DePoolContract_Ф__sendError (! $ DePool_ι_STATUS_DEPOOL_CLOSED , $ xInt0 !) ) } ;
 declareLocal Л_msgValue :>: XInteger64 := msg_value () ;
 If!! ( $ Л_msgValue ?< $ Л_stake !+ $ DePool_ι_STAKE_FEE ) then {
  return!!! ( DePoolContract_Ф__sendError (! $ DePool_ι_STATUS_FEE_TOO_SMALL ,
                        $ DePool_ι_STAKE_FEE !) ) } ;
 declareLocal Л_fee :>: XInteger64 := $ Л_msgValue !- $ Л_stake ;
 If! ( $ Л_stake ?< ↑12 D2! DePoolContract_ι_m_minStake ) then {
  return!!! ( DePoolContract_Ф__sendError (! $ DePool_ι_STATUS_STAKE_TOO_SMALL ,
                        ( ↑ε12 DePoolContract_ι_m_minStake ) !) ) } ;
        DePoolContract_Ф_addOrdinaryStake'_tailer Л_stake Л_fee.

Lemma  DePoolContract_Ф_addOrdinaryStake'_header_eq: DePoolContract_Ф_addOrdinaryStake'_header = DePoolContract_Ф_addOrdinaryStake'.
Proof.
  auto.
Qed.

Opaque DePoolContract_Ф_sendAcceptAndReturnChange128 RoundsBase_Ф__addStakes.

Lemma DePoolContract_Ф_addOrdinaryStake'_tailer_exec: forall (Л_stake Л_fee: Z) (l: Ledger),
let sender := eval_state msg_sender l in
let (participant, l_getcreate) := run (↓ ParticipantBase_Ф_getOrCreateParticipant sender) l in

let round := eval_state (↓ RoundsBase_Ф_getRound0 ) l_getcreate in
let (rp' , l_addStakes) := run (↓ RoundsBase_Ф__addStakes round participant sender Л_stake None None) l_getcreate in
let (round', participant') := rp' in
let l_setRound := exec_state (↓ RoundsBase_Ф_setRound0 round') l_addStakes in
let sender' := eval_state msg_sender l_setRound in
let l_setParticipant := exec_state (↓ ParticipantBase_Ф__setOrDeleteParticipant sender' participant') l_setRound in
let l_sendAccept := exec_state (↓ DePoolContract_Ф_sendAcceptAndReturnChange128 Л_fee) l_setParticipant in

exec_state (DePoolContract_Ф_addOrdinaryStake'_tailer Л_stake Л_fee) l = l_sendAccept.

Proof.
  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve. idtac.

  all: destructFunction6 RoundsBase_Ф__addStakes; auto. idtac.
  all: try destruct x; auto. idtac.

  all: time repeat destructIf_solve.

Qed.

Opaque  DePoolContract_Ф_addOrdinaryStake'_tailer.

Lemma DePoolContract_Ф_addOrdinaryStake'_header_exec: forall (Л_stake: Z) (l: Ledger) ,
    let sender := eval_state msg_sender l in
    let isExtMsg : bool := negb (sender =? 0) in
    let isPoolClosed : bool := eval_state (↑12 ε DePoolContract_ι_m_poolClosed) l in
    let minStake := eval_state (↑12 ε DePoolContract_ι_m_minStake) l in
    let STAKE_FEE :=  DePool_ι_STAKE_FEE in
    let msg_value := eval_state msg_value l in
    let feeSmall := msg_value <? Л_stake + STAKE_FEE in
    let fee := msg_value - Л_stake in
    let stakeSmall := Л_stake <? minStake in

    exec_state (DePoolContract_Ф_addOrdinaryStake'_header Л_stake ) l =
    if isExtMsg then
     if isPoolClosed then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_DEPOOL_CLOSED 0 ) l
     else if feeSmall then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_FEE_TOO_SMALL
                                                                    DePool_ι_STAKE_FEE ) l
     else if stakeSmall then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_STAKE_TOO_SMALL
                                                                     (eval_state (↑ε12  DePoolContract_ι_m_minStake) l) ) l
     else exec_state (DePoolContract_Ф_addOrdinaryStake'_tailer Л_stake fee) l
    else l.
Proof.
  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve. idtac.
  destructFunction2  DePoolContract_Ф_addOrdinaryStake'_tailer; auto.

Qed.

Lemma DePoolContract_Ф_addOrdinaryStake'_eval: forall (Л_stake: Z) (l: Ledger),
let sender := eval_state msg_sender l in
let isExtMsg : bool := negb (sender =? 0) in
let isPoolClosed : bool := eval_state (↑12 ε DePoolContract_ι_m_poolClosed) l in
let minStake := eval_state (↑12 ε DePoolContract_ι_m_minStake) l in
let STAKE_FEE := DePool_ι_STAKE_FEE in
let msg_value := eval_state msg_value l in
let feeSmall := msg_value <? Л_stake + STAKE_FEE in
let stakeSmall := Л_stake <? minStake in

eval_state (↓ DePoolContract_Ф_addOrdinaryStake' Л_stake) l =
if isExtMsg then
 if isPoolClosed then Value (Error I)
 else if feeSmall then Value (Error I)
 else if stakeSmall then Value (Error I)
 else Value (Value I)
else Error Errors_ι_IS_EXT_MSG .
Proof.

  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve. idtac.

  all: destructFunction6 RoundsBase_Ф__addStakes; auto. idtac.
  all: try destruct x; auto. idtac.

  all: time repeat destructIf_solve.

Qed.

Lemma DePoolContract_Ф_addOrdinaryStake_eval: forall (Л_stake: Z) (l: Ledger),
let sender := eval_state msg_sender l in
let isExtMsg : bool := negb (sender =? 0) in
let isPoolClosed : bool := eval_state (↑12 ε DePoolContract_ι_m_poolClosed) l in
let minStake := eval_state (↑12 ε DePoolContract_ι_m_minStake) l in
let STAKE_FEE := DePool_ι_STAKE_FEE in
let msg_value := eval_state msg_value l in
let feeSmall := msg_value <? Л_stake + STAKE_FEE in
let stakeSmall := Л_stake <? minStake in

eval_state (↓ DePoolContract_Ф_addOrdinaryStake Л_stake) l =
if isExtMsg then
 if isPoolClosed then Value I
 else if feeSmall then Value I
 else if stakeSmall then Value I
 else Value I
else Error Errors_ι_IS_EXT_MSG .
Proof.

  intros.

  assert (eval_state (↓ DePoolContract_Ф_addOrdinaryStake Л_stake ) l =
  xErrorMapDefaultF (xValue ∘ fromValueValue) (eval_state (↓ DePoolContract_Ф_addOrdinaryStake' Л_stake) l) xError).
  unfold DePoolContract_Ф_addOrdinaryStake.
  unfold callEmbeddedStateAdj.
  remember (DePoolContract_Ф_addOrdinaryStake' Л_stake).
  setoid_rewrite runbind.
  setoid_rewrite eval_bind2.
  rewrite eval_get.
  rewrite exec_get.
  remember (run l0 (injEmbed (T:=LocalState) DePoolFuncs.DePoolSpec.LedgerClass.local0 l)).
  setoid_rewrite <- Heqp.
  destruct p.
  destruct x.
  auto. auto.

  (**********************)
  rewrite H.
  rewrite DePoolContract_Ф_addOrdinaryStake'_eval.
  compute.
  repeat destructIf; auto.

Qed.

Opaque DePoolContract_Ф_addOrdinaryStake'.

Lemma DePoolContract_Ф_addOrdinaryStake_exec: forall (Л_stake: Z) (l: Ledger) ,
    let sender := eval_state msg_sender l in
    let isExtMsg : bool := negb (sender =? 0) in
    let isPoolClosed : bool := eval_state (↑12 ε DePoolContract_ι_m_poolClosed) l in
    let minStake := eval_state (↑12 ε DePoolContract_ι_m_minStake) l in
    let STAKE_FEE :=  DePool_ι_STAKE_FEE in
    let msg_value := eval_state msg_value l in
    let feeSmall := msg_value <? Л_stake + STAKE_FEE in
    let fee := msg_value - Л_stake in
    let stakeSmall := Л_stake <? minStake in

    exec_state (DePoolContract_Ф_addOrdinaryStake Л_stake ) l =
    if isExtMsg then
     if isPoolClosed then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_DEPOOL_CLOSED 0 ) l
     else if feeSmall then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_FEE_TOO_SMALL
                                                                    DePool_ι_STAKE_FEE ) l
     else if stakeSmall then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_STAKE_TOO_SMALL
                                                                     (eval_state (↑ε12  DePoolContract_ι_m_minStake) l) ) l
     else exec_state (DePoolContract_Ф_addOrdinaryStake'_tailer Л_stake fee) l
    else l.
Proof.

  intros.

  assert (exec_state (DePoolContract_Ф_addOrdinaryStake Л_stake ) l =
          exec_state (DePoolContract_Ф_addOrdinaryStake' Л_stake) l).
  unfold DePoolContract_Ф_addOrdinaryStake.
  remember (DePoolContract_Ф_addOrdinaryStake' Л_stake).
  rewrite exec_bind.
  rewrite exec_unit.
  auto.
  (**********************)
  rewrite H.
  rewrite <- DePoolContract_Ф_addOrdinaryStake'_header_eq.
  rewrite DePoolContract_Ф_addOrdinaryStake'_header_exec.
  auto.
Qed.

End DePoolContract_Ф_addOrdinaryStake.


From Coq Require Import String Arith NArith ZArith Eqdep_dec.
From Vyper Require Import Config NaryFun Calldag.
From Vyper.L10 Require Import AST Callset.
From Vyper Require FSet Map UInt256.

Local Open Scope list_scope.
Local Open Scope string_scope.

Section Descend.
Context {C: VyperConfig}.

Definition calldag := generic_calldag decl_callset true.

Lemma call_descend {call_depth_bound new_call_depth_bound current_fun_depth: nat}
                   (DepthOk : current_fun_depth < call_depth_bound)
                   (cd : calldag)
                   (this_fun_name: string)
                   (this_decl: decl)
                   (this_decl_ok: cd_declmap cd this_fun_name = Some this_decl)
                   (current_fun_depth_ok:
                     cd_depthmap cd this_fun_name = Some current_fun_depth)
                   (e: expr)
                   (CallOk: let _ := string_set_impl in
                             FSet.is_subset (expr_callset e) (decl_callset this_decl) = true)
                   (Ebound: call_depth_bound = S new_call_depth_bound)
                   {name: string}
                   {args: list expr}
                   (E: e = PrivateOrBuiltinCall name args)
                   {depth: nat}
                   (Edepth: cd_depthmap cd name = Some depth):
  depth < new_call_depth_bound.
Proof.
subst e. cbn in CallOk.
assert(HasName: let _ := string_set_impl in FSet.has (decl_callset this_decl) name = true).
{
  cbn.
  apply (FSet.is_subset_if CallOk name).
  apply FSet.add_has.
}
clear CallOk. cbn in HasName.
assert (K := cd_depthmap_ok cd this_fun_name).
unfold cd_declmap in this_decl_ok.
rewrite this_decl_ok in K.
rewrite current_fun_depth_ok in K.
cbn in K.
rewrite FSet.for_all_ok in K.
assert (L := K name HasName). clear K.
subst call_depth_bound.
apply lt_n_Sm_le in DepthOk.
rewrite Edepth in L.
destruct current_fun_depth. { discriminate. }
rewrite Nat.leb_le in L.
rewrite Nat.le_succ_l in DepthOk.
apply (Nat.le_lt_trans _ _ _ L DepthOk).
Qed.

Local Lemma fun_ctx_descend_helper {cd: calldag}
                                   {name: string}
                                   {d: decl}
                                   (Edecl : cd_declmap cd name = Some d):
  cd_depthmap cd name <> None.
Proof.
assert (D := cd_depthmap_ok cd name).
unfold cd_declmap in Edecl.
rewrite Edecl in D.
intro H.
rewrite H in D.
exact D.
Qed.

Local Lemma call_descend' {call_depth_bound new_call_depth_bound}
                          {cd: calldag}
                          {e: expr}
                          {name: string}
                          {args: list expr}
                          (fc: fun_ctx cd call_depth_bound)
                          (CallOk: let _ := string_set_impl in
                                      FSet.is_subset (expr_callset e)
                                                     (decl_callset (fun_decl fc))
                                       = true)
                          (Ebound: call_depth_bound = S new_call_depth_bound)
                          (E: e = PrivateOrBuiltinCall name args)
                          {d: decl}
                          (Edecl: cd_declmap cd name = Some d)
                          {depth: nat}
                          (Edepth: cd_depthmap cd name = Some depth):
  (depth <? new_call_depth_bound) = true.
Proof.
exact (proj2 (Nat.ltb_lt _ _)
         (call_descend (proj1 (Nat.ltb_lt _ _) (fun_bound_ok fc))
                       cd (fun_name fc)
                       (fun_decl fc) (fun_decl_ok fc)
                       (fun_depth_ok fc) e CallOk Ebound
                       E Edepth)).
Qed.

(* The inner part of fun_ctx_descend is here separately because
   it's too difficult to destruct [cd_depthmap cd name] otherwise.
 *)
Local Definition fun_ctx_descend_inner {call_depth_bound new_call_depth_bound}
                           {cd: calldag}
                           {e: expr}
                           {name: string}
                           {args: list expr}
                           (fc: fun_ctx cd call_depth_bound)
                           (CallOk: let _ := string_set_impl in
                                       FSet.is_subset (expr_callset e)
                                                      (decl_callset (fun_decl fc))
                                        = true)
                           (Ebound: call_depth_bound = S new_call_depth_bound)
                           (E: e = PrivateOrBuiltinCall name args)
                           {d: decl}
                           (Edecl: cd_declmap cd name = Some d)
:= match cd_depthmap cd name as maybe_depth return _ = maybe_depth -> _ with
   | None => fun Edepth => False_rect _ (fun_ctx_descend_helper Edecl Edepth)
   | Some depth => fun Edepth =>
       Some {| fun_name := name
             ; fun_depth := depth
             ; fun_depth_ok := Edepth
             ; fun_decl := d
             ; fun_decl_ok := Edecl
             ; fun_bound_ok := call_descend' fc CallOk Ebound E Edecl Edepth
            |}
   end eq_refl.

(** Make a callee context from a caller context and a call expression,
  The None result means that no declaration with the given name is found.
  No check is made that the callee context is indeed a function.
  The max stack depth bound is reduced by 1.
 *)
Definition fun_ctx_descend {call_depth_bound new_call_depth_bound}
                           {cd: calldag}
                           {e: expr}
                           {name: string}
                           {args: list expr}
                           (fc: fun_ctx cd call_depth_bound)
                           (CallOk: let _ := string_set_impl in
                                       FSet.is_subset (expr_callset e)
                                                      (decl_callset (fun_decl fc))
                                        = true)
                           (Ebound: call_depth_bound = S new_call_depth_bound)
                           (E: e = PrivateOrBuiltinCall name args)
: option (fun_ctx cd new_call_depth_bound)
:= match cd_declmap cd name as maybe_decl return _ = maybe_decl -> _ with
   | None => fun _ =>
       (* no declaration found - could be a builtin *)
       None
   | Some d => fun Edecl => fun_ctx_descend_inner fc CallOk Ebound E Edecl
   end eq_refl.

Lemma fun_ctx_descend_irrel {call_depth_bound new_call_depth_bound}
                            {cd: calldag}
                            {e: expr}
                            {name: string}
                            {args: list expr}
                            (fc1 fc2: fun_ctx cd call_depth_bound)
                            (CallOk1: let _ := string_set_impl in
                                        FSet.is_subset (expr_callset e)
                                                       (decl_callset (fun_decl fc1))
                                         = true)
                            (CallOk2: let _ := string_set_impl in
                                        FSet.is_subset (expr_callset e)
                                                       (decl_callset (fun_decl fc2))
                                         = true)
                            (Ebound: call_depth_bound = S new_call_depth_bound)
                            (E: e = PrivateOrBuiltinCall name args):
  fun_ctx_descend fc1 CallOk1 Ebound E = fun_ctx_descend fc2 CallOk2 Ebound E.
Proof.
unfold fun_ctx_descend.
assert (InnerOk: forall (d: decl) (Edecl: cd_declmap cd name = Some d),
                   fun_ctx_descend_inner fc1 CallOk1 Ebound E Edecl
                    =
                   fun_ctx_descend_inner fc2 CallOk2 Ebound E Edecl).
{
  intros. unfold fun_ctx_descend_inner.
  remember (fun (depth: nat) (Edepth: cd_depthmap cd name = Some depth) => Some {|
      fun_name := name;
      fun_depth := depth;
      fun_depth_ok := Edepth;
      fun_decl := d;
      fun_decl_ok := Edecl;
      fun_bound_ok := call_descend' fc1 CallOk1 Ebound E Edecl Edepth |}) as some_branch1.
  remember (fun (depth: nat) (Edepth: cd_depthmap cd name = Some depth) => Some {|
      fun_name := name;
      fun_depth := depth;
      fun_depth_ok := Edepth;
      fun_decl := d;
      fun_decl_ok := Edecl;
      fun_bound_ok := call_descend' fc2 CallOk2 Ebound E Edecl Edepth |}) as some_branch2.
  assert(SomeBranchOk: forall (depth: nat) (Edepth: cd_depthmap cd name = Some depth),
                         some_branch1 depth Edepth = some_branch2 depth Edepth).
  {
    intros. subst. f_equal. f_equal.
    apply eq_proofs_unicity. decide equality.
  }
  clear Heqsome_branch1 Heqsome_branch2.
  remember fun_ctx_descend_helper as foo. clear Heqfoo. revert foo.
  revert CallOk1 CallOk2.
  destruct (cd_depthmap cd name).
  { intros. apply SomeBranchOk. }
  trivial.
}
remember fun_ctx_descend_inner as inner. clear Heqinner. revert inner CallOk1 CallOk2 InnerOk.
destruct (cd_declmap cd name). (* this is why fun_ctx_descend_inner exists *)
{ intros. apply InnerOk. }
trivial.
Qed.

Lemma fun_ctx_descend_none {call_depth_bound new_call_depth_bound}
                           {cd: calldag}
                           {e: expr}
                           {name: string}
                           {args: list expr}
                           (fc: fun_ctx cd call_depth_bound)
                           (CallOk: let _ := string_set_impl in
                                       FSet.is_subset (expr_callset e)
                                                      (decl_callset (fun_decl fc))
                                        = true)
                           (Ebound: call_depth_bound = S new_call_depth_bound)
                           (E: e = PrivateOrBuiltinCall name args):
  fun_ctx_descend fc CallOk Ebound E = None
   <->
  cd_declmap cd name = None.
Proof.
unfold fun_ctx_descend.
assert (InnerOk: forall (d: decl) (Edecl: cd_declmap cd name = Some d),
                   fun_ctx_descend_inner fc CallOk Ebound E Edecl = None
                    <->
                   cd_declmap cd name = None).
{
  intros. unfold fun_ctx_descend_inner.
  assert (Ok := cd_depthmap_ok cd name).
  remember (fun (depth: nat) (Edepth: cd_depthmap cd name = Some depth) =>
    Some
      {|
      fun_name := name;
      fun_depth := depth;
      fun_depth_ok := Edepth;
      fun_decl := d;
      fun_decl_ok := Edecl;
      fun_bound_ok := call_descend' fc CallOk Ebound E Edecl Edepth |}) as some_branch.
  remember (fun Edepth : cd_depthmap cd name = None =>
              False_rect (option (fun_ctx cd new_call_depth_bound))
                         (fun_ctx_descend_helper Edecl Edepth))
    as none_branch.
  assert (SomeBranchOk: forall (depth: nat) (Edepth: cd_depthmap cd name = Some depth),
                          some_branch depth Edepth <> None).
  { now subst. }
  assert (NoneBranchOk: forall (Edepth: cd_depthmap cd name = None),
                          none_branch Edepth = None).
  { intro. exfalso. exact (fun_ctx_descend_helper Edecl Edepth). }
  clear Heqsome_branch Heqnone_branch.
  unfold cd_declmap in *.
  rewrite Edecl in *.
  destruct (cd_depthmap cd name). 2:{ contradiction. }
  assert (S := SomeBranchOk n eq_refl).
  split. { contradiction. }
  intro. discriminate.
} (* InnerOk *)
remember fun_ctx_descend_inner as inner. clear Heqinner. revert inner InnerOk.
destruct cd_declmap.
{ intros. apply InnerOk. }
intros. tauto.
Qed.

End Descend.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX DepMaps Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.
From DiSeL
Require Import InductiveInv While.
From DiSeL
Require Import CalculatorProtocol CalculatorInvariant.
From DiSeL
Require Import CalculatorClientLib CalculatorServerLib.

Export CalculatorProtocol.

Section CalculatorServers.

Variable l : Label.
Variable f : input -> option nat.
Variable prec : input -> bool.
Variables (cs cls : seq nid).
Notation nodes := (cs ++ cls).
Hypothesis Huniq : uniq nodes.

Notation cal := (CalculatorProtocol f prec cs cls l).
Notation sts := (snd_trans cal).
Notation rts := (rcv_trans cal).
Notation W := (mkWorld cal).

(* A server node *)
Variable sv : nid.
Hypothesis  Hs : sv \in cs.
Notation loc i := (getLocal sv (getStatelet i l)).

Section CalculatorServerLoop.

(************************************************)
(******    Generic server loop combinator   *****)
(************************************************)

(*
- Actually, this is _higher-order_ programming
- The loop runs infinitely
- It takes an additional generic state argument (useful for memoization),
  which should be constrained appropriately
*)

Variable Sstate : Type.
(* Making sure that the state is okay *)
Variable state_wf : Pred Sstate.

(* Initial well-formed state, which is well-formed *)
Variable state0 : Sstate.
Hypothesis state0_wf : state_wf state0.

(** The server body always cleans up after itself (no outstanding
requests left to be processed) and correctly handles the state, passed
between iterations. *)

Definition server_loop_body_spec (s : Sstate) :=
  DHT [sv, W]
  (fun i => loc i = st :-> ([::]:reqs) /\ state_wf s,
   fun (r : Sstate) m =>
     [/\ loc m = st :-> ([::]:reqs) & state_wf r]).

(* The body to be passed to the loop *)
Variable server_body : forall s, server_loop_body_spec s.

Definition server_loop_cond (res : Sstate) := true.

Definition server_loop_inv :=
  fun (_ r : Sstate) i => loc i = st :-> ([::]:reqs) /\ state_wf r.

Program Definition server_loop :
  DHT [sv, W]
  (fun i => loc i = st :-> ([::]:reqs),
   fun (r : Sstate) m => False) :=
  Do _ (@while sv W _ _ server_loop_cond server_loop_inv _
        (fun r => Do _ (server_body r))) state0.

Next Obligation. by apply: with_spec (x x0). Defined.
Next Obligation.
by move:H; rewrite /server_loop_inv (rely_loc' _ H0).
Qed.
Next Obligation. by apply: with_spec x. Defined.
Next Obligation.
by apply: ghC=>i1 s[H1 H2] C1/=; apply: call_rule.
Qed.
Next Obligation.
move=>i/=E1; apply: call_rule'=>//.
- by move=>C1; exists state0=>//.
by move=>s' m/(_ s')/=; case.
Qed.

End CalculatorServerLoop.
End CalculatorServers.

(*************************************************)
(*      Specific server implementations          *)
(*************************************************)

(***** One-shot (per iteration) server *****)

Module OneShotServer.
Section OneShotServer.

Variable l : Label.
Variable f : input -> option nat.
Variable prec : input -> bool.
Hypothesis prec_valid :
  forall i, prec i -> exists v, f i = Some v.
Variables (cs cls : seq nid).
Notation nodes := (cs ++ cls).
Hypothesis Huniq : uniq nodes.

Notation cal := (CalculatorProtocol f prec cs cls l).
Notation sts := (snd_trans cal).
Notation rts := (rcv_trans cal).
Notation W := (mkWorld cal).

(* A server node *)
Variable sv : nid.
Hypothesis  Hs : sv \in cs.
Notation loc i := (getLocal sv (getStatelet i l)).

(* Server-specific infrastructure *)
Notation Sstate := unit.
Definition state_wf := fun _ : unit => True.
Definition state0 := tt.
Lemma state0_wf : state_wf state0. Proof. done. Qed.

Program Definition one_shot_body : forall _ : unit,
  server_loop_body_spec l f prec cs cls sv _ state_wf state0 :=
  fun _ =>
  Do _ (
    r <-- blocking_receive_req l f prec cs cls _ Hs;
    let: (from, args) := r in
    (* Compute the answer function explicitly *)
    let r := if f args is Some v then v else 0 in
    send_answer l f prec cs cls _ Hs from args r;;
    ret _ _ tt).
Next Obligation.
move=>i1/=[L1]_; apply: step; apply: (gh_ex (g:=[::])).
apply: call_rule=>//[[from args]] i2/=[L2]H1 H2 C2.
case: (prec_valid _ H2)=>ans F.
move: (erefl (f args))=>e.
have X: (match f args as anonymous' return (anonymous' = f args -> nat) with
           | Some v => fun _ : Some v = f args => v
           | None => fun _ : None = f args => 0
         end e) = ans by move: e; rewrite F.
rewrite X=>{X}; apply: step; apply: (gh_ex (g:=[:: (from, sv, args)])).
apply: call_rule=>//; first by move=>_; split=>//; rewrite inE eqxx.
move=>x i3/=; rewrite eqxx=> L3 C3.
apply: ret_rule=>i4 R3 _; split=>//.
by rewrite (rely_loc' _ R3); case: L3.
Qed.

Definition one_shot_server :=
  server_loop _ _ _ _ _ _ _ _ _ state0_wf one_shot_body.

End OneShotServer.
End OneShotServer.

(***** Batching (per iteration) server *****)

Module BatchingServer.
Section BatchingServer.

Variable l : Label.
Variable f : input -> option nat.
Variable prec : input -> bool.
Hypothesis prec_valid :
  forall i, prec i -> exists v, f i = Some v.
Variables (cs cls : seq nid).
Notation nodes := (cs ++ cls).
Hypothesis Huniq : uniq nodes.

Notation cal := (CalculatorProtocol f prec cs cls l).
Notation sts := (snd_trans cal).
Notation rts := (rcv_trans cal).
Notation W := (mkWorld cal).

(* A server node *)
Variable sv : nid.
Hypothesis  Hs : sv \in cs.
Notation loc i := (getLocal sv (getStatelet i l)).

(* Server-specific infrastructure *)
Notation Sstate := unit.
Definition state_wf := fun _ : unit => True.
Definition state0 := tt.
Lemma state0_wf : state_wf state0. Proof. done. Qed.

(* Batch size *)
Variable bsize : nat.

Definition batch_recv_loop_spec := forall (nsa : nat * Sstate * reqs),
  DHT [sv, W]
  (fun i => let: (n, s, acc) := nsa in
            [/\ loc i = st :-> acc,
             size acc + n = bsize,
             (forall e, e \in acc ->
              [/\ e.1.1 \in cls, e.1.2 = sv & prec e.2]) &
             state_wf s],
   fun (r : (reqs * Sstate)) m =>
     [/\ loc m = st :-> r.1,
      size r.1 = bsize,
      (forall e, e \in r.1 ->
              [/\ e.1.1 \in cls, e.1.2 = sv & prec e.2]) &
      state_wf r.2]).

Program Definition receive_req_loop s :
  DHT [sv, W]
  (fun i => loc i = st :-> ([::]:reqs) /\ state_wf s,
   fun (r : (reqs * Sstate)) m =>
     [/\ loc m = st :-> r.1,
      size r.1 = bsize,
      (forall e, e \in r.1 -> [/\ e.1.1 \in cls, e.1.2 = sv & prec e.2]) &
      state_wf r.2]) :=
  Do (ffix (fun (rec : batch_recv_loop_spec) nsa =>
    Do _ (let: (n, s, acc) := nsa in
          if n is n'.+1
          then r <-- blocking_receive_req l f prec cs cls _ Hs;
               let: (from, args) := r in
               let: acc' := (from, sv, args) :: acc in
               rec (n', s, acc')
          else ret _ _ (acc, s))) (bsize, tt, [::])).

Next Obligation.
move=>i1/=[L1]S P _; case: n S=>//[|n]S.
- by apply: ret_rule=>i2 R1/=; rewrite (rely_loc' _ R1) addn0.
apply: step; apply: (gh_ex (g:=r)).
apply: call_rule=>//[[from args]]i2/=[L2]H1 H2 C2.
apply: call_rule=>// _; split=>//; first by rewrite addSnnS.
move=>e; rewrite inE=>/orP; case; last by apply: P.
by move/eqP=>Z; subst e.
Qed.

Next Obligation.
by move=>i1/=[L1]_; apply: call_rule.
Qed.

(* Send batch responses *)

Definition batch_send_loop_spec := forall (acc : reqs),
  DHT [sv, W]
  (fun i => [/\ loc i = st :-> acc &
             (forall e, e \in acc -> [/\ e.1.1 \in cls, e.1.2 = sv & prec e.2])],
   fun (r : Sstate) m =>
     [/\ loc m = st :-> ([::]:reqs) & state_wf r]).

Program Definition send_ans_loop (acc : reqs) :
  DHT [sv, W]
    (fun i => loc i = st :-> acc /\
              (forall e, e \in acc -> [/\ e.1.1 \in cls, e.1.2 = sv & prec e.2]),
   fun (r : Sstate) m =>
     [/\ loc m = st :-> ([::]:reqs) & state_wf r]) :=
  ffix (fun (rec : batch_send_loop_spec) acc =>
    Do _ (if acc is (from, _, args) :: acc'
          then let r := if f args is Some v then v else 0 in
               send_answer l f prec cs cls _ Hs from args r;;
               rec acc'
          else ret _ _ tt)) acc.

Next Obligation.
move=>i1/=[L1]P1; case: acc L1 P1=>[|[[from b]]args acc] L1 P1.
- by apply: ret_rule=>i2 R1[H1]_; rewrite (rely_loc' _ R1).
  apply: step.
move: (P1 (from, b, args)).
rewrite inE eqxx/==>/(_ is_true_true)[X1]Z /prec_valid [v]F; subst b.
move: (erefl (f args))=>e.
have X: (match f args as anonymous' return (anonymous' = f args -> nat) with
           | Some v => fun _ : Some v = f args => v
           | None => fun _ : None = f args => 0
         end e) = v by move: e; rewrite F.
rewrite X=>{X e}.
apply: (gh_ex (g:=((from, sv, args) :: acc))).
apply: call_rule; first by move=>_; split=>//; rewrite inE eqxx.
move=>x i2/= [L2 H2] C2; apply: call_rule=>//_.
rewrite eqxx in L2; split=>//e A; apply: P1.
by rewrite inE A orbC.
Qed.

(* Main batching server *)

Program Definition batched_body : forall _ : unit,
  server_loop_body_spec l f prec cs cls sv _ state_wf state0 :=
  fun _ => Do _ (
     sr <-- receive_req_loop tt;
     send_ans_loop sr.1).
Next Obligation.
move=>i1/=[L1]_; apply: step.
apply: call_rule=>//[[acc _]]/= i2[L2 H2]P2 _ C2.
by apply: call_rule.
Qed.

Definition batched_server :=
  server_loop _ _ _ _ _ _ _ _ _ state0_wf batched_body.

End BatchingServer.
End BatchingServer.

(***** Memoizing Server *****)

Module MemoizingServer.
Section MemoizingServer.

Variable l : Label.
Variable f : input -> option nat.
Variable prec : input -> bool.
Hypothesis prec_valid :
  forall i, prec i -> exists v, f i = Some v.
Variables (cs cls : seq nid).
Notation nodes := (cs ++ cls).
Hypothesis Huniq : uniq nodes.

Notation cal := (CalculatorProtocol f prec cs cls l).
Notation sts := (snd_trans cal).
Notation rts := (rcv_trans cal).
Notation W := (mkWorld cal).
Variable sv : nid.
Hypothesis  Hs : sv \in cs.
Notation loc i := (getLocal sv (getStatelet i l)).

(* Server-specific infrastructure *)
Notation Sstate := (seq ((seq nat) * nat)).
Definition state_wf (s : Sstate) :=
  forall e, e \in s -> f e.1 = Some e.2.
Definition state0 : Sstate := [::].
Lemma state0_wf : state_wf state0. Proof. by []. Qed.

(* Lookup tables *)
Definition update_mem_table (s : Sstate) args v :=
  (args, v) :: s.

Fixpoint lookup_mem_table (s : Sstate) args : option nat :=
  match s with
  | x :: xs => if x.1 == args
               then Some x.2
               else lookup_mem_table xs args
  | [::] => None
  end.

Lemma lookup_valid' s args :
  state_wf s ->
  forall v, lookup_mem_table s args = Some v ->
  f args = Some v.
Proof.
elim:s=>//[[args' v']]s Hi H1 v/=.
case: ifP=>X.
- move/eqP: X=>X;subst args'; case=>Z; subst v'.
  by move:(H1 (args, v)); rewrite inE eqxx/==>/(_ is_true_true).
suff Y: state_wf s by apply: Hi.
by move=>e H; move: (H1 e); rewrite inE H orbC/==>/(_ is_true_true).
Qed.

Lemma lookup_valid s args :
  state_wf s ->
  if lookup_mem_table s args is Some v
  then f args = Some v else True.
Proof.
move/(lookup_valid' s args).
by case: (lookup_mem_table s args)=>//v H; apply: (H v).
Qed.

Program Definition memoized_body : forall s : Sstate,
  server_loop_body_spec l f prec cs cls sv _ state_wf s :=
  fun s =>
  Do _ (
    r <-- blocking_receive_req l f prec cs cls _ Hs;
    let: (from, args) := r in
    (* First, try to look up the result in the memtable *)
    if lookup_mem_table s args is Some v
    then send_answer l f prec cs cls _ Hs from args v;;
         ret _ _ s
    else (* Compute the answer function explicitly *)
      let r := if f args is Some v then v else 0 in
      let s' := update_mem_table s args r in
      send_answer l f prec cs cls _ Hs from args r;;
      ret _ _ s').
Next Obligation.
move=>i1/=[L1]Hw; apply: step; apply: (gh_ex (g:=[::])).
apply: call_rule=>//[[from args]] i2/=[L2]H1 H2 C2.
move: (lookup_valid s args Hw).
- case: (lookup_mem_table s args)=>[v F|_].
  apply: step; apply: (gh_ex (g:=[:: (from, sv, args)])).
  apply: call_rule=>//; first by move=>_; split=>//; rewrite inE eqxx.
  move=>x i3/=; rewrite eqxx=> L3 C3.
  apply: ret_rule=>i4 R3 _; split=>//.
  by rewrite (rely_loc' _ R3); case: L3.
case: (prec_valid _ H2)=>ans F.
move: (erefl (f args))=>e.
have X: (match f args as anonymous' return (anonymous' = f args -> nat) with
           | Some v => fun _ : Some v = f args => v
           | None => fun _ : None = f args => 0
         end e) = ans by move: e; rewrite F.
rewrite X=>{X}; apply: step; apply: (gh_ex (g:=[:: (from, sv, args)])).
apply: call_rule=>//; first by move=>_; split=>//; rewrite inE eqxx.
move=>x i3/=; rewrite eqxx=> L3 C3.
apply: ret_rule=>i4 R3 _; split; first by rewrite (rely_loc' _ R3); case: L3.
move=>z; rewrite/update_mem_table inE/==>/orP.
case; last by move/Hw.
by move/eqP=>->.
Qed.

Definition memoizing_server :=
  server_loop _ _ _ _ _ _ _ _ _ state0_wf memoized_body.

End MemoizingServer.
End MemoizingServer.

(************************************)
(**             Exports             *)
(************************************)

Export OneShotServer.
Export BatchingServer.
Export MemoizingServer.


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.

Set Implicit Arguments.
Set Typeclasses Depth 5.

Section PROOF.
  Let memRA: URA.t := (RA.excl Mem.t).
  Context `{@GRA.inG memRA Σ}.
  Let GURA: URA.t := GRA.to_URA Σ.
  Local Existing Instance GURA.

  Compute (URA.car (t:=memRA)).

  Section BODY.
    Context {Es: Type -> Type}.
    Context `{has_pE: pE -< Es}.
    Context `{has_eventE: eventE -< Es}.
    Definition allocF: (list val) -> itree Es val :=
      fun varg =>
        mp0 <- trigger (PGet);;
        m0 <- mp0↓?;;
        `sz: Z <- (pargs [Tint] varg)?;;
        if (Z_le_gt_dec 0 sz && Z_lt_ge_dec (8 * sz) modulus_64)
        then (delta <- trigger (Choose _);;
              let m0': Mem.t := Mem.mem_pad m0 delta in
              let (blk, m1) := Mem.alloc m0' sz in
              trigger (PPut m1↑);;;
              Ret (Vptr blk 0))
        else triggerUB
    .

    Definition freeF: list val -> itree Es val :=
      fun varg =>
        mp0 <- trigger (PGet);;
        m0 <- mp0↓?;;
        '(b, ofs) <- (pargs [Tptr] varg)?;;
        m1 <- (Mem.free m0 b ofs)?;;
        trigger (PPut m1↑);;;
        Ret (Vint 0)
    .

    Definition loadF: list val -> itree Es val :=
      fun varg =>
        mp0 <- trigger (PGet);;
        m0 <- mp0↓?;;
        '(b, ofs) <- (pargs [Tptr] varg)?;;
        v <- (Mem.load m0 b ofs)?;;
        Ret v
    .

    Definition storeF: list val -> itree Es val :=
      fun varg =>
        mp0 <- trigger (PGet);;
        m0 <- mp0↓?;;
        '(b, ofs, v) <- (pargs [Tptr; Tuntyped] varg)?;;
        m1 <- (Mem.store m0 b ofs v)?;;
        trigger (PPut m1↑);;;
        Ret (Vint 0)
    .

    Definition cmpF: list val -> itree Es val :=
      fun varg =>
        mp0 <- trigger (PGet);;
        m0 <- mp0↓?;;
        '(v0, v1) <- (pargs [Tuntyped; Tuntyped] varg)?;;
        b <- (vcmp m0 v0 v1)?;;
        if b: bool
        then Ret (Vint 1%Z)
        else Ret (Vint 0%Z)
    .

  End BODY.

  Variable csl: gname -> bool.
  Definition MemSem (sk: Sk.t): ModSem.t :=
    {|
      ModSem.fnsems := [("alloc", cfunU allocF) ; ("free", cfunU freeF) ; ("load", cfunU loadF) ; ("store", cfunU storeF) ; ("cmp", cfunU cmpF)];
      ModSem.mn := "Mem";
      ModSem.initial_st := (Mem.load_mem csl sk)↑;
    |}
  .

  Definition Mem: Mod.t := {|
    Mod.get_modsem := MemSem;
    Mod.sk := Sk.unit;
  |}
  .
End PROOF.


(*********************************************************************************************************************************)
(* HaskStrongTypes: representation of types and coercions for HaskStrong                                                         *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import General.
Require Import HaskKinds.
Require Import HaskLiterals.
Require Import HaskTyCons.
Require Import HaskCoreTypes.
Require Import HaskCoreVars.
Require Import HaskWeakTypes.
Require Import HaskWeakVars.
Require Import HaskWeak.
Require Import HaskCoreToWeak.

Variable dataConTyCon      : CoreDataCon -> TyCon.         Extract Inlined Constant dataConTyCon      => "DataCon.dataConTyCon".
Variable dataConExVars_    : CoreDataCon -> list CoreVar.  Extract Inlined Constant dataConExVars_    => "DataCon.dataConExTyVars".
Variable dataConEqTheta_   : CoreDataCon -> list PredType. Extract Inlined Constant dataConEqTheta_   => "DataCon.dataConTheta".
Variable dataConOrigArgTys_: CoreDataCon -> list CoreType. Extract Inlined Constant dataConOrigArgTys_=>"DataCon.dataConOrigArgTys".

Definition dataConExTyVars cdc :=
  filter (map (fun x => match coreVarToWeakVar' x with OK (WTypeVar v) => Some v | _ => None end) (dataConExVars_ cdc)).
  Opaque dataConExTyVars.
Definition dataConCoerKinds cdc :=
  filter (map (fun x => match x with EqPred t1 t2 =>
                          match (
                            coreTypeToWeakType t1 >>= fun t1' =>
                              coreTypeToWeakType t2 >>= fun t2' =>
                                OK (t1',t2'))
                          with OK z => Some z
                            | _ => None
                          end
                          | _ => None
                        end) (dataConEqTheta_ cdc)).
  Opaque dataConCoerKinds.
Definition dataConFieldTypes cdc :=
  filter (map (fun x => match coreTypeToWeakType x with
                          | OK z => Some z
                          | _ => None
                        end) (dataConOrigArgTys_ cdc)).

Definition tyConNumKinds (tc:TyCon) := length (tyConTyVars tc).
  Coercion tyConNumKinds : TyCon >-> nat.

Inductive DataCon : TyCon -> Type :=
  mkDataCon : forall cdc:CoreDataCon, DataCon (dataConTyCon cdc).
  Definition dataConToCoreDataCon `(dc:DataCon tc) : CoreDataCon := match dc with mkDataCon cdc => cdc end.
  Coercion mkDataCon : CoreDataCon >-> DataCon.
  Coercion dataConToCoreDataCon : DataCon >-> CoreDataCon.
  (*Opaque DataCon.*)

Definition tyConKind' tc := fold_right KindArrow ★ (tyConKind tc).

(* types prefixed with "Raw" are NOT binder-polymorphic; they have had their PHOAS parameter instantiated already *)
Section Raw.

  (* TV is the PHOAS type which stands for type variables of System FC *)
  Context {TV:Kind -> Type}.

  (* Figure 7: ρ, σ, τ, ν *)
  Inductive RawHaskType : Kind -> Type :=
  | TVar           : ∀ κ, TV κ                                              -> RawHaskType κ                     (* a        *)
  | TCon           : ∀ tc,                                                     RawHaskType (tyConKind' tc)       (* T        *)
  | TArrow         :                                                           RawHaskType (★ ⇛★ ⇛★ )            (* (->)     *)
  (*
  | TKappa         :                                                           RawHaskType (★ ⇛★ ⇛★ )            (* (~~>)    *)
  *)
  | TCoerc         : ∀ κ, RawHaskType κ -> RawHaskType κ -> RawHaskType ★   -> RawHaskType ★                     (* (+>)     *)
  | TApp           : ∀ κ₁ κ₂, RawHaskType (κ₂⇛κ₁)        -> RawHaskType κ₂  -> RawHaskType κ₁                    (* φ φ      *)
  | TAll           : ∀ κ,                          (TV κ -> RawHaskType ★)  -> RawHaskType ★                     (* ∀a:κ.φ   *)
  | TCode          : RawHaskType ECKind                  -> RawHaskType ★   -> RawHaskType ★                     (* from λ^α *)
  | TyFunApp       : forall (tf:TyFun) kl k, RawHaskTypeList kl             -> RawHaskType k                     (* S_n      *)
  with RawHaskTypeList : list Kind -> Type :=
  | TyFunApp_nil   : RawHaskTypeList nil
  | TyFunApp_cons  : ∀ κ kl, RawHaskType κ -> RawHaskTypeList kl -> RawHaskTypeList (κ::kl).

  (* the "kind" of a coercion is a pair of types *)
  Inductive RawCoercionKind : Type :=
    mkRawCoercionKind : ∀ κ, RawHaskType κ -> RawHaskType κ -> RawCoercionKind.

  (* Figure 7: γ, δ; CV is the PHOAS type which stands for coercion variables of System FC *)
  Inductive RawHaskCoer {CV:Type} : RawCoercionKind -> Prop := .
  (*
   *  This has been disabled until we manage to reconcile SystemFC's
   *  coercions with what GHC actually implements (they are not the
   *  same!)
   *
  | CoVar          : CV                                           -> RawHaskCoer (* g      *)
  | CoType         : RawHaskType                                  -> RawHaskCoer (* τ      *)
  | CoApp          : RawHaskCoer -> RawHaskCoer                   -> RawHaskCoer (* γ γ    *)
  | CoAppT         : RawHaskCoer -> RawHaskType                   -> RawHaskCoer (* γ@v    *)
  | CoCFApp        : ∀ n, CoFunConst n -> vec RawHaskCoer n       -> RawHaskCoer (* C   γⁿ *)
  | CoTFApp        : ∀ n, TyFunConst n -> vec RawHaskCoer n       -> RawHaskCoer (* S_n γⁿ *)
  | CoAll          : Kind  -> (TV -> RawHaskCoer)                 -> RawHaskCoer (* ∀a:κ.γ *)
  | CoSym          : RawHaskCoer                                  -> RawHaskCoer (* sym    *)
  | CoComp         : RawHaskCoer -> RawHaskCoer                   -> RawHaskCoer (* ◯      *)
  | CoLeft         : RawHaskCoer                                  -> RawHaskCoer (* left   *)
  | CoRight        : RawHaskCoer                                  -> RawHaskCoer (* right  *).
  *)
End Raw.

Implicit Arguments TCon   [ [TV] ].
Implicit Arguments TyFunApp [ [TV] ].
Implicit Arguments RawHaskType  [ ].
Implicit Arguments RawHaskCoer  [ ].
Implicit Arguments RawCoercionKind [ ].
Implicit Arguments TVar [ [TV] [κ] ].
Implicit Arguments TCoerc [ [TV] [κ] ].
Implicit Arguments TApp   [ [TV] [κ₁] [κ₂] ].
Implicit Arguments TAll   [ [TV] ].

Notation "t1 ---> t2"        := (fun TV env => (TApp (TApp TArrow (t1 TV env)) (t2 TV env))).
(*Notation "t1 ~~~> t2"        := (fun TV env => (TApp (TApp TKappa (t1 TV env)) (t2 TV env))).*)
Notation "φ₁ ∼∼ φ₂ ⇒ φ₃"     := (fun TV env => TCoerc (φ₁ TV env) (φ₂ TV env) (φ₃ TV env)).

(* Kind and Coercion Environments *)
(*
 *  In System FC, the environment consists of three components, each of
 *  whose well-formedness depends on all of those prior to it:
 *
 *    1. (TypeEnv)        The list of free type     variables and their kinds
 *    2. (CoercionEnv)    The list of free coercion variables and the pair of types between which it witnesses coercibility
 *    3. (Tree ??CoreVar) The list of free value    variables and the type of each one
 *)

Definition TypeEnv                                                         := list Kind.
Definition InstantiatedTypeEnv     (TV:Kind->Type)         (Γ:TypeEnv)     := IList _ TV Γ.
Definition HaskCoercionKind                    (Γ:TypeEnv)                 := ∀ TV, InstantiatedTypeEnv TV Γ -> @RawCoercionKind TV.
Definition CoercionEnv             (Γ:TypeEnv)                             := list (HaskCoercionKind Γ).
Definition InstantiatedCoercionEnv (TV:Kind->Type) CV       (Γ:TypeEnv)(Δ:CoercionEnv Γ):= vec CV (length Δ).

(* A (HaskXX Γ) is an XX which is valid in environments of shape Γ; they are always PHOAS-uninstantiated *)
Definition HaskTyVar (Γ:TypeEnv) κ :=  forall TV    (env:@InstantiatedTypeEnv TV Γ), TV κ.
Definition HaskCoVar Γ Δ           :=  forall TV CV (env:@InstantiatedTypeEnv TV Γ)(cenv:@InstantiatedCoercionEnv TV CV Γ Δ), CV.
Definition HaskLevel (Γ:TypeEnv)   :=  list (HaskTyVar Γ ECKind).
Definition HaskType  (Γ:TypeEnv) κ := ∀ TV, @InstantiatedTypeEnv TV Γ -> RawHaskType TV κ.
Definition haskTyVarToType {Γ}{κ}(htv:HaskTyVar Γ κ) : HaskType Γ κ := fun TV ite => TVar (htv TV ite).

Inductive HaskTypeOfSomeKind (Γ:TypeEnv) :=
  haskTypeOfSomeKind : ∀ κ, HaskType Γ κ -> HaskTypeOfSomeKind Γ.
  Implicit Arguments haskTypeOfSomeKind [ [Γ] [κ] ].
  Definition kindOfHaskTypeOfSomeKind {Γ}(htosk:HaskTypeOfSomeKind Γ) :=
    match htosk with
      haskTypeOfSomeKind κ _ => κ
    end.
  Coercion kindOfHaskTypeOfSomeKind : HaskTypeOfSomeKind >-> Kind.
  Definition haskTypeOfSomeKindToHaskType {Γ}(htosk:HaskTypeOfSomeKind Γ) : HaskType Γ htosk :=
    match htosk as H return HaskType Γ H with
      haskTypeOfSomeKind _ ht => ht
      end.
  Coercion haskTypeOfSomeKindToHaskType : HaskTypeOfSomeKind >-> HaskType.

Definition HaskCoercion Γ Δ (hk:HaskCoercionKind Γ) := forall TV CV (ite:@InstantiatedTypeEnv TV Γ),
    @InstantiatedCoercionEnv TV CV Γ Δ -> @RawHaskCoer TV CV (hk TV ite).
Inductive  LeveledHaskType (Γ:TypeEnv) κ := mkLeveledHaskType : HaskType Γ κ -> HaskLevel Γ -> LeveledHaskType Γ κ.

Definition FreshHaskTyVar {Γ}(κ:Kind) : HaskTyVar (κ::Γ) κ := fun TV env => ilist_head env.

Definition HaskTAll {Γ}(κ:Kind)(σ:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV ★) : HaskType Γ ★
  := fun TV env => TAll κ (σ TV env).
Definition HaskTApp {Γ}{κ}(σ:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV ★)
  (cv:HaskTyVar Γ κ) : HaskType Γ ★
  := fun TV env => σ TV env (cv TV env).
Definition HaskBrak {Γ}(v:HaskTyVar Γ ECKind)(t:HaskType Γ ★) : HaskType Γ ★:=
  fun TV env => @TCode TV (TVar (v TV env)) (t TV env).
Definition HaskTCon {Γ}(tc:TyCon) : HaskType Γ (fold_right KindArrow ★ (tyConKind tc))
  := fun TV ite => TCon tc.
Definition HaskAppT {Γ}{κ₁}{κ₂}(t1:HaskType Γ (κ₂⇛κ₁))(t2:HaskType Γ κ₂) : HaskType Γ κ₁ :=
  fun TV ite => TApp (t1 TV ite) (t2 TV ite).
Definition mkHaskCoercionKind {Γ}{κ}(t1:HaskType Γ κ)(t2:HaskType Γ κ) : HaskCoercionKind Γ :=
 fun TV ite => mkRawCoercionKind _ (t1 TV ite) (t2 TV ite).

Section Flatten.
  Context {TV:Kind -> Type }.
Fixpoint flattenT {κ} (exp: RawHaskType (fun k => RawHaskType TV k) κ) : RawHaskType TV κ :=
     match exp with
    | TVar    _  x        => x
    | TAll     _ y        => TAll   _  (fun v => flattenT  (y (TVar v)))
    | TApp   _ _ x y      => TApp      (flattenT  x) (flattenT  y)
    | TCon       tc       => TCon      tc
    | TCoerc _ t1 t2 t    => TCoerc    (flattenT  t1) (flattenT  t2)   (flattenT  t)
    | TArrow              => TArrow
    | TCode      v e      => TCode     (flattenT  v) (flattenT  e)
    | TyFunApp  tfc kl k lt => TyFunApp tfc kl k (flattenTyFunApp _ lt)
    end
    with flattenTyFunApp (lk:list Kind)(exp:@RawHaskTypeList (fun k => RawHaskType TV k) lk) : @RawHaskTypeList TV lk :=
    match exp in @RawHaskTypeList _ LK return @RawHaskTypeList TV LK with
    | TyFunApp_nil               => TyFunApp_nil
    | TyFunApp_cons  κ kl t rest => TyFunApp_cons _ _ (flattenT  t) (flattenTyFunApp _ rest)
    end.
End Flatten.

(* PHOAS substitution on types *)
Definition substT {Γ}{κ₁}{κ₂}(exp:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ₁ -> RawHaskType TV κ₂)(v:@HaskType Γ κ₁)
  : @HaskType Γ κ₂ :=
  fun TV env =>
    flattenT (exp (fun k => RawHaskType TV k) (ilmap (fun κ tv => TVar tv) env) (v TV env)).

Notation "t @@  l" := (@mkLeveledHaskType _ _ t l) (at level 20).
Notation "t @@@ l" := (mapOptionTree (fun t' => t' @@ l) t) (at level 20).
Notation "'<[' a '|-' t ']>'" := (@HaskBrak _ a t).

Definition getlev {Γ}(lt:LeveledHaskType Γ ★) := match lt with _ @@ l => l end.

Definition unlev {Γ}{κ}(lht:LeveledHaskType Γ κ) :=
  match lht with t@@l => t end.

Structure Global Γ :=
{ glob_wv    : WeakExprVar
; glob_kinds : list Kind
; glob_tf    : IList _ (fun κ => HaskType Γ κ) glob_kinds -> HaskType Γ ★
}.
Coercion glob_tf : Global >-> Funclass.
Coercion glob_wv : Global >-> WeakExprVar.

(* From (t1->(t2->(t3-> ... t))), return t1::t2::t3::...nil *)
(* this is a billion times uglier than it needs to be as a result of how primitive Coq's termiation checker is *)
Fixpoint take_arg_types {TV}{κ}(exp: RawHaskType TV κ) {struct exp} : list (RawHaskType TV κ) :=
  match exp as E in RawHaskType _ K return list (RawHaskType _ K) with
    | TApp   κ₁ κ₂ x y      =>
      (match κ₁ as K1 return RawHaskType TV (κ₂ ⇛ K1) -> list (RawHaskType TV κ₂) -> list (RawHaskType _ K1) with
         | KindStar =>
           match κ₂ as K2 return RawHaskType TV (K2 ⇛ KindStar) -> list (RawHaskType TV K2) -> list (RawHaskType _ KindStar) with
             | KindStar => fun x' =>
               match x' return list (RawHaskType TV KindStar) -> list (RawHaskType _ KindStar) with
                 | TApp κ₁'' κ₂'' w'' x'' =>
                   match κ₂'' as K2'' return RawHaskType TV K2'' -> list (RawHaskType TV KindStar) ->
                                                                    list (RawHaskType _ KindStar) with
                     | KindStar     =>
                       match w'' with
                         | TArrow => fun a b => a::b
                         | _      => fun _ _ => nil
                       end
                     | _ => fun _ _ => nil
                   end x''
                 | _                      => fun _  => nil
               end
             | _        => fun _ _ => nil
           end
         | _ => fun _ _ => nil
       end) x (take_arg_types y)
    | _                     => nil
  end.

Fixpoint count_arg_types {TV}{κ}(exp: RawHaskType TV κ) {struct exp} : nat :=
  match exp as E in RawHaskType _ K return nat with
    | TApp   κ₁ κ₂ x y      =>
      (match κ₁ as K1 return RawHaskType TV (κ₂ ⇛ K1) -> nat -> nat with
         | KindStar =>
           match κ₂ as K2 return RawHaskType TV (K2 ⇛ KindStar) -> nat -> nat with
             | KindStar => fun x' =>
               match x' return nat -> nat with
                 | TApp κ₁'' κ₂'' w'' x'' =>
                   match κ₂'' as K2'' return RawHaskType TV K2'' -> nat -> nat with
                     | KindStar     =>
                       match w'' with
                         | TArrow => fun a b => S b
                         | _      => fun _ _ => 0
                       end
                     | _ => fun _ _ => 0
                   end x''
                 | _                      => fun _  => 0
               end
             | _        => fun _ _ => 0
           end
         | _ => fun _ _ => 0
       end) x (count_arg_types y)
    | _                     => 0
  end.

  Definition ite_unit : ∀ Γ, InstantiatedTypeEnv (fun _ => unit) Γ.
    intros.
    induction Γ.
    apply INil.
    apply ICons; auto.
    apply tt.
    Defined.

Definition take_arg_type {Γ}{κ}(ht:HaskType Γ κ) : (gt (count_arg_types (ht _ (ite_unit _))) 0) -> HaskType Γ κ :=
  fun pf =>
  fun TV ite =>
    match take_arg_types (ht TV ite) with
    | nil => Prelude_error "impossible"
    | x::y => x
    end.

(* From (t1->(t2->(t3-> ... t))), return t *)
(* this is a billion times uglier than it needs to be as a result of how primitive Coq's termiation checker is *)
Fixpoint drop_arg_types {TV}{κ}(exp: RawHaskType TV κ) : RawHaskType TV κ :=
  match exp as E in RawHaskType _ K return RawHaskType _ K with
    | TApp   κ₁ κ₂ x y      =>
      let q :=
      (match κ₁ as K1 return RawHaskType TV (κ₂ ⇛ K1) -> (RawHaskType TV κ₂) -> ??(RawHaskType _ K1) with
         | KindStar =>
           match κ₂ as K2 return RawHaskType TV (K2 ⇛ KindStar) -> (RawHaskType TV K2) -> ??(RawHaskType _ KindStar) with
             | KindStar => fun x' =>
               match x' return  (RawHaskType TV KindStar) -> ??(RawHaskType _ KindStar) with
                 | TApp κ₁'' κ₂'' w'' x'' =>
                   match κ₂'' as K2'' return RawHaskType TV K2'' ->  (RawHaskType TV KindStar) -> ??(RawHaskType _ KindStar) with
                     | KindStar     =>
                       match w'' with
                         | TArrow => fun _ b => Some b
                         | _      => fun _ b => None
                       end
                     | _ => fun _ b => None
                   end x''
                 | _       => fun _ => None
               end
             | _        => fun _ _ => None
           end
         | _ => fun _ _ => None
       end) x (drop_arg_types y)
      in match q with
           | None   => TApp x y
           | Some y => y
         end
    | b                     => b
  end.

(* yeah, things are kind of messy below this point *)

Definition unAddKindFromInstantiatedTypeEnv {Γ:TypeEnv}{κ:Kind}{TV:Kind->Type}(ite:InstantiatedTypeEnv TV (κ::Γ))
  := ilist_tail ite.
Definition addKindToCoercionEnv (Γ:TypeEnv)(Δ:CoercionEnv Γ)(κ:Kind) : CoercionEnv (κ::Γ) :=
  map (fun f => (fun TV ite => f TV (unAddKindFromInstantiatedTypeEnv ite))) Δ.
Definition addKindToInstantiatedTypeEnv {Γ:TypeEnv}{TV:Kind->Type}(env:InstantiatedTypeEnv TV Γ)(κ:Kind)(tv:TV κ)
  : InstantiatedTypeEnv TV (κ::Γ) := tv::::env.
Definition addKindToInstantiatedCoercionEnv {Γ:TypeEnv}{Δ}{TV:Kind->Type}{CV:Type}
  (env:InstantiatedCoercionEnv TV CV Γ Δ)(κ:Kind)(tv:TV κ)
  : InstantiatedCoercionEnv TV CV (κ::Γ) (addKindToCoercionEnv Γ Δ κ).
    simpl.
    unfold InstantiatedCoercionEnv.
    unfold addKindToCoercionEnv.
    simpl.
    rewrite <- map_preserves_length.
    apply env.
    Defined.
Definition coercionEnvContainsCoercion {Γ}{Δ}{TV:Kind->Type}{CV:Type}(ite:InstantiatedTypeEnv TV Γ)
  (ice:InstantiatedCoercionEnv TV CV Γ Δ)(cv:CV)(ck:RawCoercionKind TV)
  := @vec_In _ _ (cv,ck) (vec_zip ice (vec_map (fun f => f TV ite) (list2vec Δ))).
Definition addCoercionToCoercionEnv {Γ}(Δ:CoercionEnv Γ)(κ:HaskCoercionKind Γ) : CoercionEnv Γ :=
  κ::Δ.
Definition addCoercionToInstantiatedCoercionEnv {Γ}{Δ}{κ}{TV CV}(ice:InstantiatedCoercionEnv TV CV Γ Δ)(cv:CV)
  : InstantiatedCoercionEnv TV CV Γ (addCoercionToCoercionEnv Δ κ).
  simpl.
  unfold addCoercionToCoercionEnv; simpl.
  unfold InstantiatedCoercionEnv; simpl.
  apply vec_cons; auto.
  Defined.

(* the various "weak" functions turn a HaskXX-in-Γ into a HaskXX-in-(κ::Γ) *)
Definition weakITE  {Γ:TypeEnv}{κ}{TV}(ite:InstantiatedTypeEnv TV (κ::Γ)) : InstantiatedTypeEnv TV Γ := ilist_tail ite.
Definition weakCE   {Γ:TypeEnv}{κ}(Δ:CoercionEnv Γ) : CoercionEnv (κ::Γ) := map (fun x => (fun tv ite => x tv (weakITE ite))) Δ.
Definition weakV  {Γ:TypeEnv}{κ}{κv}(cv':HaskTyVar Γ κv) : HaskTyVar (κ::Γ) κv := fun TV ite => (cv' TV (weakITE ite)).
Definition weakT {Γ:TypeEnv}{κ}{κ₂}(lt:HaskType Γ κ₂) : HaskType (κ::Γ) κ₂ := fun TV ite => lt TV (weakITE ite).
Definition weakL  {Γ}{κ}(lt:HaskLevel Γ) : HaskLevel (κ::Γ) := map weakV lt.
Definition weakLT {Γ}{κ}{κ₂}(lt:LeveledHaskType Γ κ₂) : LeveledHaskType (κ::Γ) κ₂ := match lt with t @@ l => weakT t @@ weakL l end.
Definition weakICE  {Γ:TypeEnv}{κ}{Δ:CoercionEnv Γ}{TV}{CV}(ice:InstantiatedCoercionEnv TV CV (κ::Γ) (weakCE Δ))
  : InstantiatedCoercionEnv TV CV Γ Δ.
  intros.
  unfold InstantiatedCoercionEnv; intros.
  unfold InstantiatedCoercionEnv in ice.
  unfold weakCE in ice.
  simpl in ice.
  rewrite <- map_preserves_length in ice.
  apply ice.
  Defined.
Definition weakCK {Γ}{κ}(hck:HaskCoercionKind Γ) : HaskCoercionKind (κ::Γ).
  unfold HaskCoercionKind in *.
  intros.
  apply hck; clear hck.
  inversion X; subst; auto.
  Defined.
Definition weakCV {Γ}{Δ}{κ}(cv':HaskCoVar Γ Δ) : HaskCoVar (κ::Γ) (weakCE Δ) :=
  fun TV CV ite ice => (cv' TV CV (weakITE ite) (weakICE ice)).
Definition weakF {Γ:TypeEnv}{κ}{κ₂}(f:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV κ₂) :
  forall TV (env:@InstantiatedTypeEnv TV (κ::Γ)), TV κ -> RawHaskType TV κ₂
  := fun TV ite tv => (f TV (weakITE ite) tv).

Definition weakITE' {Γ:TypeEnv}{κ}{TV}(ite:InstantiatedTypeEnv TV (app κ Γ)) : InstantiatedTypeEnv TV Γ.
  induction κ; auto. apply IHκ. inversion ite; subst. apply X0. Defined.
Definition weakV' {Γ:TypeEnv}{κ}{κv}(cv':HaskTyVar Γ κv) : HaskTyVar (app κ Γ) κv.
  induction κ; auto. apply weakV; auto. Defined.
Definition weakT' {Γ}{κ}{κ₂}(lt:HaskType Γ κ₂) : HaskType (app κ Γ) κ₂.
  induction κ; auto. apply weakT; auto. Defined.
Definition weakT'' {Γ}{κ}{κ₂}(lt:HaskType Γ κ₂) : HaskType (app Γ κ) κ₂.
  unfold HaskType in *.
  unfold InstantiatedTypeEnv in *.
  intros.
  apply ilist_chop in X.
  apply lt.
  apply X.
  Defined.
Definition weakL' {Γ}{κ}(lev:HaskLevel Γ) : HaskLevel (app κ Γ).
  induction κ; auto. apply weakL; auto. Defined.
Definition weakLT' {Γ}{κ}{κ₂}(lt:LeveledHaskType Γ κ₂) : LeveledHaskType (app κ Γ) κ₂
  := match lt with t @@ l => weakT' t @@ weakL' l end.
Definition weakCE' {Γ:TypeEnv}{κ}(Δ:CoercionEnv Γ) : CoercionEnv (app κ Γ).
  induction κ; auto. apply weakCE; auto. Defined.
Definition weakCK' {Γ}{κ}(hck:HaskCoercionKind Γ) : HaskCoercionKind (app κ Γ).
  induction κ; auto.
  apply weakCK.
  apply IHκ.
  Defined.
Definition weakCK'' {Γ}{κ}(hck:list (HaskCoercionKind Γ)) : list (HaskCoercionKind (app κ Γ)) :=
  map weakCK' hck.

Definition weakITE_ {Γ:TypeEnv}{κ}{n}{TV}(ite:InstantiatedTypeEnv TV (list_ins n κ Γ)) : InstantiatedTypeEnv TV Γ.
  rewrite list_ins_app in ite.
  set (weakITE' ite) as ite'.
  set (ilist_chop ite) as a.
  rewrite <- (list_take_drop _ Γ n).
  apply ilist_app; auto.
  inversion ite'; auto.
  Defined.

Definition weakV_ {Γ:TypeEnv}{κ}{n}{κv}(cv':HaskTyVar Γ κv) : HaskTyVar (list_ins n κ Γ) κv.
  unfold HaskTyVar; intros.
  unfold HaskTyVar in cv'.
  apply (cv' TV).
  apply weakITE_ in env.
  apply env.
  Defined.

Definition weakT_ {Γ}{κ}{n}{κ₂}(lt:HaskType Γ κ₂) : HaskType (list_ins n κ Γ) κ₂.
  unfold HaskType; intros.
  apply lt.
  apply weakITE_ in X.
  apply X.
  Defined.
Definition weakL_ {Γ}{κ}{n}(lev:HaskLevel Γ) : HaskLevel (list_ins n κ Γ).
  unfold HaskLevel; intros.
  unfold HaskLevel in lev.
  eapply map.
  apply weakV_.
  apply lev.
  Defined.
Definition weakLT_ {Γ}{κ}{n}{κ₂}(lt:LeveledHaskType Γ κ₂) : LeveledHaskType (list_ins n κ Γ) κ₂ :=
  match lt with t@@l => weakT_ t @@ weakL_ l end.
Definition weakCK_ {Γ}{κ}{n}(hck:HaskCoercionKind Γ) : HaskCoercionKind (list_ins n κ Γ).
  unfold HaskCoercionKind; intros.
  unfold HaskCoercionKind in hck.
  apply hck.
  apply weakITE_ in X.
  apply X.
  Defined.
Definition weakCE_ {Γ:TypeEnv}{κ}{n}(Δ:CoercionEnv Γ) : CoercionEnv (list_ins n κ Γ) := map weakCK_ Δ.
Definition weakF_ {Γ:TypeEnv}{n}{κ}{κ₂}(f:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV κ₂) :
  forall TV (env:@InstantiatedTypeEnv TV (list_ins n κ Γ)), TV κ -> RawHaskType TV κ₂.
  intros.
  apply f.
  apply weakITE_ in env.
  apply env.
  apply X.
  Defined.
Definition weakCV_ {Γ}{Δ}{κ}{n}(cv':HaskCoVar Γ Δ) : HaskCoVar (list_ins n κ Γ) (weakCE_ Δ).
  unfold HaskCoVar; intros.
  unfold HaskCoVar in cv'.
  apply (cv' TV).
  apply weakITE_ in env.
  apply env.
  unfold InstantiatedCoercionEnv.
  unfold InstantiatedCoercionEnv in cenv.
  replace (length (@weakCE_ _ κ n Δ)) with (length Δ) in cenv.
  apply cenv.
  unfold weakCE_.
  rewrite <- map_preserves_length.
  reflexivity.
  Defined.

Definition FreshHaskTyVar_ {Γ}(κ:Kind) : forall {n}, HaskTyVar (list_ins n κ Γ) κ.
  intros.
  unfold HaskTyVar.
  intros.
  rewrite list_ins_app in env.
  apply weakITE' in env.
  inversion env; subst; auto.
  Defined.

Fixpoint caseType0 {Γ}(lk:list Kind) :
  IList _ (HaskType Γ) lk ->
  HaskType Γ (fold_right KindArrow ★ lk) ->
  HaskType Γ ★ :=
  match lk as LK return
    IList _ (HaskType Γ) LK ->
    HaskType Γ (fold_right KindArrow ★ LK) ->
    HaskType Γ ★
  with
  | nil    => fun _     ht => ht
  | k::lk' => fun tlist ht => caseType0 lk' (ilist_tail tlist) (fun TV env => TApp (ht TV env) (ilist_head tlist TV env))
  end.

Definition caseType {Γ}(tc:TyCon)(atypes:IList _ (HaskType Γ) (tyConKind tc)) : HaskType Γ ★ :=
  caseType0 (tyConKind tc) atypes (fun TV env => TCon tc).

(* like a GHC DataCon, but using PHOAS representation for types and coercions *)
Record StrongAltCon {tc:TyCon} :=
{ sac_tc          := tc
; sac_altcon      :  WeakAltCon
; sac_numExTyVars :  nat
; sac_numCoerVars :  nat
; sac_numExprVars :  nat
; sac_ekinds      :  vec Kind sac_numExTyVars
; sac_kinds       := app (tyConKind tc) (vec2list sac_ekinds)
; sac_gamma          := fun Γ => app (vec2list sac_ekinds) Γ
; sac_coercions   :  forall Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)), vec (HaskCoercionKind (sac_gamma Γ)) sac_numCoerVars
; sac_types       :  forall Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)), vec (HaskType (sac_gamma Γ) ★) sac_numExprVars
; sac_delta          := fun    Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)) Δ => app (vec2list (sac_coercions Γ atypes)) Δ
}.
Coercion sac_tc     : StrongAltCon >-> TyCon.
Coercion sac_altcon : StrongAltCon >-> WeakAltCon.

Definition kindOfType {Γ}{κ}(ht:@HaskType Γ κ) : ???Kind := OK κ.

Axiom literal_tycons_are_of_ordinary_kind : forall lit, tyConKind (haskLiteralToTyCon lit) = nil.

Definition literalType (lit:HaskLiteral){Γ} : HaskType Γ ★.
  set (fun TV (ite:InstantiatedTypeEnv TV Γ) => @TCon TV (haskLiteralToTyCon lit)) as z.
  unfold tyConKind' in z.
  rewrite literal_tycons_are_of_ordinary_kind in z.
  unfold HaskType.
  apply z.
  Defined.

Notation "a ∼∼∼ b" := (@mkHaskCoercionKind _ _ a b) (at level 18).

Fixpoint update_xi
  `{EQD_VV:EqDecidable VV}{Γ}
   (ξ:VV -> LeveledHaskType Γ ★)
   (lev:HaskLevel Γ)
   (vt:list (VV * HaskType Γ ★))
   : VV -> LeveledHaskType Γ ★ :=
  match vt with
    | nil => ξ
    | (v,τ)::tl => fun v' => if eqd_dec v v' then τ @@ lev else (update_xi ξ lev tl) v'
  end.

Lemma update_xi_lemma0 `{EQD_VV:EqDecidable VV} : forall Γ ξ (lev:HaskLevel Γ)(varstypes:list (VV*_)) v,
  not (In v (map (@fst _ _) varstypes)) ->
  (update_xi ξ lev varstypes) v = ξ v.
  intros.
  induction varstypes.
  reflexivity.
  simpl.
  destruct a.
  destruct (eqd_dec v0 v).
  subst.
  simpl in  H.
  assert False.
  apply H.
  auto.
  inversion H0.
  apply IHvarstypes.
  unfold not; intros.
  apply H.
  simpl.
  auto.
  Defined.

(***************************************************************************************************)
(* Well-Formedness of Types and Coercions                                                          *)
(* also represents production "S_n:κ" of Γ because these can only wind up in Γ via rule (Type) *)
Inductive TypeFunctionDecl (tfc:TyCon)(vk:vec Kind tfc) : Type :=
  mkTFD : Kind -> TypeFunctionDecl tfc vk.

(*
Section WFCo.
  Context {TV:Kind->Type}.
  Context {CV:Type}.

  (* local notations *)
  Notation "ienv '⊢ᴛy' σ : κ"              := (@WellKinded_RawHaskType TV _ ienv σ κ).
  Notation "env  ∋  cv : t1 ∼ t2 : Γ : t"  := (@coercionEnvContainsCoercion Γ _ TV CV t env cv (@mkRawCoercionKind _ t1 t2))
                 (at level 20, t1 at level 99, t2 at level 99, t at level 99).
  Reserved Notation "ice '⊢ᴄᴏ' γ : a '∼' b : Δ : Γ : ite"
        (at level 20, γ at level 99, b at level 99, Δ at level 99, ite at level 99, Γ at level 99).

  (* Figure 8, lower half *)
  Inductive WFCoercion:forall Γ (Δ:CoercionEnv Γ),
    @InstantiatedTypeEnv TV Γ ->
    @InstantiatedCoercionEnv TV CV Γ Δ ->
    @RawHaskCoer TV CV -> @RawCoercionKind TV -> Prop :=
  | CoTVar':∀ Γ Δ t e c σ τ,
    (@coercionEnvContainsCoercion Γ _ TV CV t e c (@mkRawCoercionKind _ σ τ)) -> e⊢ᴄᴏ CoVar c : σ ∼ τ  : Δ : Γ : t
  | CoRefl :∀ Γ Δ t e   τ κ,                                         t ⊢ᴛy τ :κ    -> e⊢ᴄᴏ CoType τ    :         τ ∼ τ  : Δ :Γ: t
  | Sym    :∀ Γ Δ t e γ σ τ,                            (e⊢ᴄᴏ γ : σ ∼ τ : Δ : Γ:t)  -> e⊢ᴄᴏ CoSym  γ    :         τ ∼ σ  : Δ :Γ: t
  | Trans  :∀ Γ Δ t e γ₁ γ₂ σ₁ σ₂ σ₃,(e⊢ᴄᴏ γ₁:σ₁∼σ₂:Δ:Γ:t) -> (e⊢ᴄᴏ γ₂:σ₂∼σ₃:Δ:Γ:t) -> e⊢ᴄᴏ CoComp γ₁ γ₂:        σ₁ ∼ σ₃ : Δ :Γ: t
  | Left   :∀ Γ Δ t e γ σ₁ σ₂ τ₁ τ₂,(e⊢ᴄᴏ γ : TApp σ₁ σ₂ ∼ TApp τ₁ τ₂ :Δ:Γ:t    )  -> e⊢ᴄᴏ CoLeft  γ   :        σ₁ ∼ τ₁ : Δ :Γ: t
  | Right  :∀ Γ Δ t e γ σ₁ σ₂ τ₁ τ₂,(e⊢ᴄᴏ γ : TApp σ₁ σ₂ ∼ TApp τ₁ τ₂ :Δ:Γ:t   )   -> e⊢ᴄᴏ CoRight γ   :        σ₂ ∼ τ₂ : Δ :Γ: t
  (*
  | SComp  :∀ Γ Δ t e γ n S σ τ κ,
            ListWFCo Γ Δ t e γ σ τ -> t ⊢ᴛy TyFunApp(n:=n) S σ : κ  -> e⊢ᴄᴏ CoTFApp S γ : TyFunApp S σ∼TyFunApp S τ : Δ : Γ : t
  | CoAx   :∀ Γ Δ t e n C κ γ, forall (σ₁:vec TV n) (σ₂:vec TV n), forall (ax:@AxiomDecl n C κ TV),
    ListWFCo                              Γ Δ t e γ (map TVar (vec2list σ₁)) (map TVar (vec2list σ₂)) ->
    ListWellKinded_RawHaskType TV Γ t   (map TVar (vec2list σ₁))            (vec2list κ)  ->
    ListWellKinded_RawHaskType TV Γ t   (map TVar (vec2list σ₂))            (vec2list κ)  ->
    e⊢ᴄᴏ CoCFApp C γ : axd_σ _ _ _ ax σ₁ ∼ axd_τ _ _ _ ax σ₂ : Δ : Γ : t
  *)
  | WFCoAll  : forall Γ Δ κ (t:InstantiatedTypeEnv TV Γ) (e:InstantiatedCoercionEnv TV CV (κ::Γ) (weakCE Δ)) γ σ τ    ,
      (∀ a,           e ⊢ᴄᴏ (        γ a) : (       σ a) ∼ (       τ a) : _ : _ : (t + a : κ))
      ->    weakICE e ⊢ᴄᴏ (CoAll κ γ  ) : (TAll κ σ  ) ∼ (TAll κ τ  ) : Δ : Γ :  t
  | Comp   :forall Γ Δ t e γ₁ γ₂ σ₁ σ₂ τ₁ τ₂ κ,
            (t ⊢ᴛy TApp σ₁ σ₂:κ)->
            (e⊢ᴄᴏ γ₁:σ₁∼τ₁:Δ:Γ:t)->
            (e⊢ᴄᴏ γ₂:σ₂∼τ₂:Δ:Γ:t) ->
            e⊢ᴄᴏ (CoApp γ₁ γ₂) : (TApp σ₁ σ₂) ∼ (TApp τ₁ τ₂) : Δ:Γ:t
  | CoInst :forall Γ Δ t e σ τ κ γ (v:∀ TV, InstantiatedTypeEnv TV Γ -> RawHaskType TV),
          t ⊢ᴛy v TV t : κ  ->
            (e⊢ᴄᴏ γ:HaskTAll κ σ _ t ∼ HaskTAll κ τ _ t:Δ:Γ:t) ->
            e⊢ᴄᴏ CoAppT γ (v TV t) : substT σ v TV t ∼substT τ v TV t : Δ : Γ : t
  with ListWFCo  : forall Γ (Δ:CoercionEnv Γ),
     @InstantiatedTypeEnv TV Γ ->
     InstantiatedCoercionEnv TV CV Γ Δ ->
     list (RawHaskCoer TV CV) -> list (RawHaskType TV) -> list (RawHaskType TV) -> Prop :=
  | LWFCo_nil  : ∀ Γ Δ t e ,                                                            ListWFCo Γ Δ t e nil     nil     nil
  | LWFCo_cons : ∀ Γ Δ t e a b c la lb lc, (e⊢ᴄᴏ a : b∼c : Δ : Γ : t )->
    ListWFCo Γ Δ t e la lb lc -> ListWFCo Γ Δ t e (a::la) (b::lb) (c::lc)
  where "ice '⊢ᴄᴏ' γ : a '∼' b : Δ : Γ : ite" := (@WFCoercion Γ Δ ite ice γ (@mkRawCoercionKind _ a b)).
End WFCo.

Definition WFCCo (Γ:TypeEnv)(Δ:CoercionEnv Γ)(γ:HaskCoercion Γ Δ)(a b:HaskType Γ) :=
  forall {TV CV:Type}(env:@InstantiatedTypeEnv TV Γ)(cenv:InstantiatedCoercionEnv TV CV Γ Δ),
    @WFCoercion _ _ Γ Δ env cenv (γ TV CV env cenv) (@mkRawCoercionKind _ (a TV env) (b TV env)).
    Notation "Δ '⊢ᴄᴏ' γ : a '∼' b" := (@WFCCo _ Δ γ a b).
*)

(* Decidable equality on PHOAS types *)
Fixpoint compareT (n:nat){κ₁}(t1:@RawHaskType (fun _ => nat) κ₁){κ₂}(t2:@RawHaskType (fun _ => nat) κ₂) : bool :=
match t1 with
| TVar    _  x     => match t2 with TVar _ x' => if eqd_dec x x' then true else false | _ => false end
| TAll     _ y     => match t2 with TAll _ y' => compareT (S n) (y n) (y' n)          | _ => false end
| TApp   _ _ x y   => match t2 with TApp _ _ x' y' => if compareT n x x' then compareT n y y' else false | _ => false end
| TCon       tc    => match t2 with TCon tc' => if eqd_dec tc tc' then true else false | _ => false end
| TArrow           => match t2 with TArrow => true | _ => false end
| TCode      ec t  => match t2 with TCode ec' t' => if compareT n ec ec' then compareT n t t' else false | _ => false end
| TCoerc _ t1 t2 t => match t2 with TCoerc _ t1' t2' t' => compareT n t1 t1' && compareT n t2 t2' && compareT n t t' | _ =>false end
| TyFunApp tfc kl k lt  => match t2 with TyFunApp tfc' kl' k' lt' => eqd_dec tfc tfc' && compareTL n lt lt' | _ => false end
end
with compareTL (n:nat){κ₁}(t1:@RawHaskTypeList (fun _ => nat) κ₁){κ₂}(t2:@RawHaskTypeList (fun _ => nat) κ₂) : bool :=
match t1 with
| TyFunApp_nil              => match t2 with TyFunApp_nil => true | _ => false end
| TyFunApp_cons κ kl t r => match t2 with | TyFunApp_cons κ' kl' t' r' => compareT n t t' && compareTL n r r' | _ => false end
end.

Fixpoint count' (lk:list Kind)(n:nat) : IList _ (fun _ => nat) lk :=
match lk as LK return IList _ _ LK with
  | nil    => INil
  | h::t   => n::::(count' t (S n))
end.

Definition compareHT Γ κ (ht1 ht2:HaskType Γ κ) :=
  compareT (length Γ) (ht1 (fun _ => nat) (count' Γ O)) (ht2 (fun _ => nat) (count' Γ O)).

(* The PHOAS axioms
 *
 * This is not provable in Coq's logic because the Coq function space
 * is "too big" - although its only definable inhabitants are Coq
 * functions, it is not provable in Coq that all function space
 * inhabitants are definable (i.e. there are no "exotic" inhabitants).
 * This is actually an important feature of Coq: it lets us reason
 * about properties of non-computable (non-recursive) functions since
 * any property proven to hold for the entire function space will hold
 * even for those functions.  However when representing binding
 * structure using functions we would actually prefer the smaller
 * function-space of *definable* functions only.  These two axioms
 * assert that. *)
Axiom compareHT_decides : forall Γ κ (ht1 ht2:HaskType Γ κ),
  if compareHT Γ κ ht1 ht2
  then ht1=ht2
  else ht1≠ht2.
Axiom compareVars : forall Γ κ (htv1 htv2:HaskTyVar Γ κ),
  if compareHT _ _ (haskTyVarToType htv1) (haskTyVarToType htv2)
  then htv1=htv2
  else htv1≠htv2.

(* using the axioms, we can now create an EqDecidable instance for HaskType, HaskTyVar, and HaskLevel *)
Instance haskTypeEqDecidable Γ κ : EqDecidable (HaskType Γ κ).
  apply Build_EqDecidable.
  intros.
  set (compareHT_decides _ _ v1 v2) as z.
  set (compareHT Γ κ v1 v2) as q.
  destruct q as [ ] _eqn; unfold q in *; rewrite Heqb in *.
    left; auto.
    right; auto.
    Defined.

Instance haskTyVarEqDecidable Γ κ : EqDecidable (HaskTyVar Γ κ).
  apply Build_EqDecidable.
  intros.
  set (compareVars _ _ v1 v2) as z.
  set (compareHT Γ κ (haskTyVarToType v1) (haskTyVarToType v2)) as q.
  destruct q as [ ] _eqn; unfold q in *; rewrite Heqb in *.
    left; auto.
    right; auto.
    Defined.

Instance haskLevelEqDecidable Γ : EqDecidable (HaskLevel Γ).
  apply Build_EqDecidable.
  intros.
  unfold HaskLevel in *.
  apply (eqd_dec v1 v2).
  Defined.

(* ToString instance for PHOAS types *)
Fixpoint typeToString' (needparens:bool)(n:nat){κ}(t:RawHaskType (fun _ => nat) κ) {struct t} : string :=
    match t with
    | TVar    _ v          => "tv" +++ toString v
    | TCon    tc           => toString tc
    | TCoerc _ t1 t2   t   => "("+++typeToString' false n t1+++"~"
                                  +++typeToString' false n t2+++")=>"
                                  +++typeToString' needparens n t
    | TApp  _ _  t1 t2     =>
      match t1 with
        | TApp _ _ TArrow t1 =>
                     if needparens
                     then "("+++(typeToString' true n t1)+++"->"+++(typeToString' true n t2)+++")"
                     else (typeToString' true n t1)+++"->"+++(typeToString' true n t2)
        | _ =>
                     if needparens
                     then "("+++(typeToString' true n t1)+++" "+++(typeToString' false n t2)+++")"
                     else (typeToString' true n t1)+++" "+++(typeToString' false n t2)
      end
    | TArrow => "(->)"
    | TAll   k f           => let alpha := "tv"+++ toString n
                              in "(forall "+++ alpha +++ ":"+++ toString k +++")"+++
                                   typeToString' false (S n) (f n)
    | TCode  ec t          => "<["+++(typeToString' true n t)+++"]>@"+++(typeToString' false n ec)
    | TyFunApp   tfc kl k lt    => toString tfc+++ "_" +++ toString n+++" ["+++
      (fold_left (fun x y => " \  "+++x+++y) (typeList2string false n lt) "")+++"]"
  end
  with typeList2string (needparens:bool)(n:nat){κ}(t:RawHaskTypeList κ) {struct t} : list string :=
  match t with
  | TyFunApp_nil                 => nil
  | TyFunApp_cons  κ kl rhk rhkl => (typeToString' needparens n rhk)::(typeList2string needparens n rhkl)
  end.

Definition typeToString {Γ}{κ}(ht:HaskType Γ κ) : string :=
  typeToString' false (length Γ) (ht (fun _ => nat) (count' Γ O)).

Instance TypeToStringInstance {Γ} {κ} : ToString (HaskType Γ κ) :=
  { toString := typeToString }.

Definition TBool {Γ} : HaskType Γ ★ := fun TV ite => TyFunApp BoolTyCon _ _ TyFunApp_nil.
Definition TInt  {Γ} : HaskType Γ ★ := fun TV ite => TyFunApp IntTyCon  _ _ TyFunApp_nil.


From Coq Require Import Bool List Arith Lia.
From MetaCoq.Template Require Import config utils monad_utils.
From MetaCoq.PCUIC Require Import PCUICGlobalEnv PCUICAst PCUICAstUtils PCUICTactics PCUICInduction PCUICLiftSubst PCUICTyping PCUICEquality PCUICArities PCUICInversion PCUICReduction PCUICSubstitution PCUICConversion PCUICCumulativity PCUICGeneration PCUICWfUniverses PCUICContextConversion PCUICContextSubst PCUICContexts PCUICSpine PCUICWfUniverses PCUICUnivSubst PCUICClosed PCUICInductives PCUICValidity PCUICInductiveInversion PCUICConfluence PCUICWellScopedCumulativity PCUICSR PCUICOnFreeVars PCUICClosedTyp.
From MetaCoq.PCUIC Require Import BDTyping BDToPCUIC BDFromPCUIC.

Require Import ssreflect ssrbool.
From Equations Require Import Equations.
Require Import Equations.Type.Relation Equations.Type.Relation_Properties.
Require Import Equations.Prop.DepElim.

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

Section BDUnique.

Context `{cf : checker_flags}.
Context (Σ : global_env_ext).
Context (wfΣ : wf Σ).

Let Pinfer Γ t T :=
  wf_local Σ Γ ->
  forall T', Σ ;;; Γ |- t ▹ T' ->
  ∑ T'', Σ ;;; Γ ⊢ T ⇝ T'' × Σ ;;; Γ ⊢ T' ⇝ T''.

Let Psort Γ t u :=
  wf_local Σ Γ ->
  forall u', Σ ;;; Γ |- t ▹□ u' ->
  u = u'.

Let Pprod Γ t (na : aname) A B :=
  wf_local Σ Γ ->
  forall na' A' B', Σ ;;; Γ |- t ▹Π (na',A',B') ->
  ∑ A'' B'',
  [× na = na', Σ ;;; Γ ⊢ A ⇝ A'', Σ ;;; Γ ⊢ A' ⇝ A'',
      Σ ;;; Γ,, vass na A ⊢ B ⇝ B'' & Σ ;;; Γ,, vass na A' ⊢ B' ⇝ B''].

Let Pind Γ ind t u args :=
  wf_local Σ Γ ->
  forall ind' u' args', Σ ;;; Γ |- t ▹{ind'} (u',args') ->
  ∑ args'',
  [× ind = ind',
      u = u',
      red_terms Σ Γ args args'' &
      red_terms Σ Γ args' args''].

Let Pcheck (Γ : context) (t T : term) := True.

Let PΓ (Γ : context) := True.

Let PΓ_rel (Γ Γ' : context) := True.

Theorem bidirectional_unique : env_prop_bd Σ Pcheck Pinfer Psort Pprod Pind PΓ PΓ_rel.
Proof using wfΣ.

  apply bidir_ind_env.

  all: intros ; red ; auto.
  1-9,11-13: intros ? T' ty_T' ; inversion_clear ty_T'.
  14-17: intros.

  - rewrite H in H0.
    inversion H0. subst. clear H0.
    eexists ; split.
    all: eapply closed_red_refl.
    2,4: eapply PCUICInversion.nth_error_closed_context.
    all: fvs.

  - eexists ; split.
    all: eapply closed_red_refl ; fvs.

  - apply H in X2 => //.
    apply H0 in X3.
    2:{ constructor ; auto. now eapply infering_sort_isType. }
    subst.
    eexists ; split.
    all: eapply closed_red_refl ; fvs.

  - apply X1 in X4 as [bty' []].
    2:{ constructor ; auto. now eapply infering_sort_isType. }
    exists (tProd n t bty') ; split.
    all: now eapply closed_red_prod_codom.

  - apply X2 in X6 as [A' []].
    2:{ constructor ; auto. 2: eapply checking_typing ; tea. all: now eapply infering_sort_isType. }
    exists (tLetIn n b B A').
    assert (Σ ;;; Γ |- b : B)
      by (eapply checking_typing ; tea ; now eapply infering_sort_isType).
    split.
    all: eapply closed_red_letin ; tea.
    all: apply closed_red_refl.
    all: try now apply wf_local_closed_context.
    1,3: now eapply subject_is_open_term.
    all: now eapply type_is_open_term.

  - unshelve epose proof (X0 _ _ _ _ X3) as (A''&B''&[]) ; tea.
    subst.
    exists (B''{0 := u}).
    split.
    all: eapply (closed_red_subst (Δ := [_]) (Γ' := [])) ; tea.
    + constructor.
      1: constructor.
      rewrite subst_empty.
      eapply checking_typing ; tea.
      now eapply isType_tProd, validity, infering_prod_typing.
    + constructor.
      1: constructor.
      rewrite subst_empty.
      eapply checking_typing ; tea.
      now eapply isType_tProd, validity, infering_prod_typing.

  - replace decl0 with decl by (eapply declared_constant_inj ; eassumption).
    eexists ; split.
    all: eapply closed_red_refl.
    1,3: fvs.
    all: rewrite on_free_vars_subst_instance.
    all: now eapply closed_on_free_vars, declared_constant_closed_type.

  - replace idecl0 with idecl by (eapply declared_inductive_inj ; eassumption).
    eexists ; split.
    all: eapply closed_red_refl.
    1,3: fvs.
    all: rewrite on_free_vars_subst_instance.
    all: now eapply closed_on_free_vars, declared_inductive_closed_type.

  - replace cdecl0 with cdecl by (eapply declared_constructor_inj ; eassumption).
    replace mdecl0 with mdecl by (eapply declared_constructor_inj ; eassumption).
    eexists ; split.
    all: eapply closed_red_refl.
    1,3: fvs.
    all: now eapply closed_on_free_vars, declared_constructor_closed_type.

  - eapply declared_projection_inj in H as (?&?&?&?); tea.
    subst.
    move: (X2) => tyc'.
    eapply X0 in X2 as [args'' []] ; tea.
    eapply infering_ind_typing in X ; tea.
    eapply infering_ind_typing in tyc' ; tea.
    subst.
    exists (subst0 (c :: List.rev args'') (proj_type pdecl)@[u0]).
    split.
    + eapply closed_red_red_subst0 ; tea.
      3: eapply subslet_untyped_subslet, projection_subslet ; tea.
      * eapply is_closed_context_weaken.
        1: fvs.
        eapply wf_local_closed_context, wf_projection_context ; tea.
        now eapply validity, isType_mkApps_Ind_proj_inv in X as [].
      * constructor.
        2: now apply All2_rev.
        apply closed_red_refl.
        1: fvs.
        now eapply subject_is_open_term.
      * now eapply validity.
      * rewrite on_free_vars_subst_instance.
        move: (H1) => H.
        eapply declared_projection_closed in H; eauto.
        rewrite (declared_minductive_ind_npars H1) in H.
        cbn in H. len.
        rewrite closedn_on_free_vars //.
        eapply closed_upwards; tea. cbn. lia.
    + eapply closed_red_red_subst0 ; tea.
      3: eapply subslet_untyped_subslet, projection_subslet ; tea.
      * eapply is_closed_context_weaken.
        1: fvs.
        eapply wf_local_closed_context, wf_projection_context ; tea.
        now eapply validity, isType_mkApps_Ind_proj_inv in X as [].
      * constructor.
        2: now apply All2_rev.
        apply closed_red_refl.
        1: fvs.
        now eapply subject_is_open_term.
      * now eapply validity.
      * rewrite on_free_vars_subst_instance.
        move: (H1) => H.
        eapply declared_projection_closed in H; eauto.
        rewrite (declared_minductive_ind_npars H1) in H.
        cbn in H. len.
        rewrite closedn_on_free_vars //.
        eapply closed_upwards; tea. cbn. lia.

  - rewrite H3 in H0 ; injection H0 as ->.
    eapply nth_error_all in X as (?&[]); tea.
    eexists ; split.
    all: eapply closed_red_refl.
    1,3:fvs.
    all: now eapply subject_is_open_term, infering_sort_typing.

  - rewrite H3 in H0 ; injection H0 as ->.
    eapply nth_error_all in X as (?&[]); tea.
    eexists ; split.
    all: eapply closed_red_refl.
    1,3:fvs.
    all: now eapply subject_is_open_term, infering_sort_typing.

  - intros ? T' ty_T'.
    inversion ty_T' ; subst.
    move: (H) => /declared_inductive_inj /(_ H13) [? ?].
    subst.
    assert (op' : is_open_term Γ (mkApps ptm0 (skipn (ci_npar ci) args0 ++ [c]))).
      by now eapply type_is_open_term, infering_typing.
    move: op'.
    rewrite on_free_vars_mkApps => /andP [optm' oargs'].
    eapply X0 in X9 as [args'' []] ; tea.
    subst.
    eexists (mkApps ptm ((skipn (ci_npar ci) args'') ++ [c])).
    split.
    + eapply into_closed_red.
      * eapply red_mkApps.
        1: reflexivity.
        eapply All2_app.
        2: now constructor.
        eapply All2_skipn, All2_impl ; tea.
        intros ? ? r.
        now apply r.
      * fvs.
      * eapply type_is_open_term, infering_typing ; tea.
        now econstructor.
    + eapply into_closed_red.
      * eapply red_mkApps.
        1: reflexivity.
        eapply All2_app.
        2: now constructor.
        eapply All2_skipn, All2_impl ; tea.
        intros ? ? r.
        now apply r.
      * fvs.
      * now eapply type_is_open_term, infering_typing.

  - inversion X1; subst.
    rewrite H in H2; noconf H2.
    have eq := (declared_constant_inj _ _ H0 H3); subst cdecl0.
    exists (tConst prim_ty []).
    split; eapply closed_red_refl; fvs.

  - inversion X3 ; subst.
    eapply X0 in X4 as [T'' []]; subst ; tea.
    eapply into_closed_red in X1 ; fvs.
    eapply into_closed_red in X5 ; fvs.
    eapply closed_red_confluence in X5 as [? [? ru']]; tea.
    eapply invert_red_sort in ru' ; subst.
    eapply closed_red_confluence in X1 as [? [ru' ru]].
    2: now etransitivity.
    eapply invert_red_sort in ru ; subst.
    eapply invert_red_sort in ru'.
    now congruence.

  - inversion X3 ; subst.
    eapply X0 in X4 as [T'' []]; subst ; tea.
    eapply into_closed_red in X1 ; fvs.
    eapply into_closed_red in X5 ; fvs.
    eapply closed_red_confluence in X5 as [? [? rA']]; tea.
    eapply invert_red_prod in rA' as (?&B0&[]); subst.
    eapply closed_red_confluence in X1 as [? [rA' rA]].
    2: now etransitivity.
    eapply invert_red_prod in rA as (?&?&[]); subst.
    eapply invert_red_prod in rA' as (A''&B''&[]) ; subst.
    injection e as -> -> ->.
    exists A'', B'' ; split ; tea.
    1: reflexivity.
    1: now etransitivity.
    etransitivity ; tea.
    eapply red_red_ctx_inv' ; tea.
    constructor.
    1: eapply closed_red_ctx_refl ; fvs.
    now constructor.

  - inversion X3 ; subst.
    eapply X0 in X4 as [T'' []]; subst ; tea.
    eapply into_closed_red in X1 ; fvs.
    eapply into_closed_red in X5 ; fvs.
    eapply closed_red_confluence in X5 as [? [? rind']]; tea.
    eapply invert_red_mkApps_tInd in rind' as [? []]; subst.
    eapply closed_red_confluence in X1 as [? [rind' rind]].
    2: now etransitivity.
    eapply invert_red_mkApps_tInd in rind as [? []]; subst.
    eapply invert_red_mkApps_tInd in rind' as [args'' [e ]]; subst.
    eapply mkApps_notApp_inj in e as [e ->].
    2-3: easy.
    injection e as <- <-.
    exists args'' ; split ; auto.
    eapply All2_trans ; tea.
    eapply closed_red_trans.
Qed.

End BDUnique.

Theorem infering_unique `{checker_flags} {Σ} (wfΣ : wf Σ) {Γ} (wfΓ : wf_local Σ Γ) {t T T'} :
  Σ ;;; Γ |- t ▹ T -> Σ ;;; Γ |- t ▹ T' ->
  ∑ T'', Σ ;;; Γ ⊢ T ⇝ T'' × Σ ;;; Γ ⊢ T' ⇝ T''.
Proof.
  intros ty ty'.
  now eapply bidirectional_unique in ty'.
Qed.

Theorem infering_unique' `{checker_flags} {Σ} (wfΣ : wf Σ) {Γ} (wfΓ : wf_local Σ Γ) {t T T'} :
  Σ ;;; Γ |- t ▹ T -> Σ ;;; Γ |- t ▹ T' ->
  Σ ;;; Γ ⊢ T = T'.
Proof.
  intros ty ty'.
  eapply bidirectional_unique in ty as [? []]; tea.
  etransitivity.
  2: symmetry.
  all: now eapply red_ws_cumul_pb.
Qed.

Theorem infering_checking `{checker_flags} {Σ} (wfΣ : wf Σ) {Γ} (wfΓ : wf_local Σ Γ) {t T T'} :
  is_open_term Γ T' -> Σ ;;; Γ |- t ▹ T -> Σ ;;; Γ |- t ◃ T' -> Σ ;;; Γ ⊢ T ≤ T'.
Proof.
  intros ? ty ty'.
  depelim ty'.
  eapply infering_unique' in ty ; tea.
  etransitivity ; last first.
  - apply into_ws_cumul_pb ; tea.
    1: fvs.
    now eapply type_is_open_term, infering_typing.
  - now eapply ws_cumul_pb_eq_le.
Qed.

Theorem infering_sort_sort `{checker_flags} {Σ} (wfΣ : wf Σ) {Γ} (wfΓ : wf_local Σ Γ) {t u u'} :
  Σ ;;; Γ |- t ▹□ u -> Σ ;;; Γ |- t ▹□ u' -> u = u'.
Proof.
  intros ty ty'.
  now eapply bidirectional_unique in ty'.
Qed.

Theorem infering_sort_infering `{checker_flags} {Σ} (wfΣ : wf Σ)
  {Γ} {wfΓ : wf_local Σ Γ} {t u T} :
  Σ ;;; Γ |- t ▹□ u -> Σ ;;; Γ |- t ▹ T ->
  Σ ;;; Γ ⊢ T ⇝ tSort u.
Proof.
  intros ty ty'.
  depelim ty.
  eapply into_closed_red in r.
  2: fvs.
  2: now eapply type_is_open_term, infering_typing.
  eapply bidirectional_unique in i as [T'' []]; tea.
  eapply closed_red_confluence in r as [? [? ru]]; tea.
  eapply invert_red_sort in ru ; subst.
  now etransitivity.
Qed.

Theorem infering_prod_prod `{checker_flags} {Σ} (wfΣ : wf Σ)
  {Γ} (wfΓ : wf_local Σ Γ) {t na na' A A' B B'} :
  Σ ;;; Γ |- t ▹Π (na,A,B) -> Σ ;;; Γ |- t ▹Π (na',A',B') ->
  ∑ A'' B'',
  [× na = na', Σ ;;; Γ ⊢ A ⇝ A'', Σ ;;; Γ ⊢ A' ⇝ A'',
      Σ ;;; Γ,, vass na A ⊢ B ⇝ B'' & Σ ;;; Γ,, vass na A' ⊢ B' ⇝ B''].
Proof.
  intros ty ty'.
  now eapply bidirectional_unique in ty'.
Qed.

Theorem infering_prod_prod' `{checker_flags} {Σ} (wfΣ : wf Σ)
  {Γ} (wfΓ : wf_local Σ Γ) {t na na' A A' B B'} :
  Σ ;;; Γ |- t ▹Π (na,A,B) -> Σ ;;; Γ |- t ▹Π (na',A',B') ->
  [× na = na', Σ ;;; Γ ⊢ A = A' & Σ ;;; Γ,, vass na A ⊢ B = B'].
Proof.
  intros ty ty'.
  eapply infering_prod_prod in ty as (A''&B''&[]); tea.
  subst.
  assert (Σ ;;; Γ ⊢ A = A').
  {
    etransitivity.
    2: symmetry.
    all: now eapply red_ws_cumul_pb.
  }
  split ; auto.
  etransitivity.
  1: now eapply red_ws_cumul_pb.
  symmetry.
  eapply ws_cumul_pb_ws_cumul_ctx.
  2: now eapply red_ws_cumul_pb.
  constructor.
  1: eapply ws_cumul_ctx_pb_refl ; fvs.
  now constructor.
Qed.

Theorem infering_prod_infering `{checker_flags} {Σ} (wfΣ : wf Σ)
  {Γ} (wfΓ : wf_local Σ Γ) {t na A B T} :
  Σ ;;; Γ |- t ▹Π(na,A,B) ->
  Σ ;;; Γ |- t ▹ T ->
  ∑ A' B', [× Σ ;;; Γ ⊢ T ⇝ tProd na A' B',
    Σ ;;; Γ ⊢ A ⇝ A' &
    Σ ;;; Γ,, vass na A ⊢ B ⇝ B'].
Proof.
  intros ty ty'.
  depelim ty.
  eapply into_closed_red in r.
  2: fvs.
  2: now eapply type_is_open_term, infering_typing.
  eapply bidirectional_unique in i as [? []]; tea.
  eapply closed_red_confluence in r as [? [? rA']]; tea.
  eapply invert_red_prod in rA' as (A'&B'&[]); subst.
  exists A', B' ; split ; tea.
  now etransitivity.
Qed.

Theorem infering_ind_ind `{checker_flags} {Σ} (wfΣ : wf Σ)
  {Γ} (wfΓ : wf_local Σ Γ) {t ind ind' u u' args args'} :
  Σ ;;; Γ |- t ▹{ind} (u,args) -> Σ ;;; Γ |- t ▹{ind'} (u',args') ->
  ∑ args'',
    [× ind = ind', u = u',
      red_terms Σ Γ args args'' &
      red_terms Σ Γ args' args''].
Proof.
  intros ty ty'.
  now eapply bidirectional_unique in ty'.
Qed.

Theorem infering_ind_ind' `{checker_flags} {Σ} (wfΣ : wf Σ)
  {Γ} (wfΓ : wf_local Σ Γ) {t ind ind' u u' args args'} :
  Σ ;;; Γ |- t ▹{ind} (u,args) -> Σ ;;; Γ |- t ▹{ind'} (u',args') ->
    [× ind = ind', u = u' &
      ws_cumul_pb_terms Σ Γ args args'].
Proof.
  intros ty ty'.
  eapply bidirectional_unique in ty as [args'' []] ; tea.
  subst.
  split ; auto.
  etransitivity.
  2: symmetry.
  all: now eapply red_terms_ws_cumul_pb_terms.
Qed.

Theorem infering_ind_infering `{checker_flags} {Σ} (wfΣ : wf Σ)
  {Γ} (wfΓ : wf_local Σ Γ) {t ind u args T} :
  Σ ;;; Γ |- t ▹{ind} (u,args) ->
  Σ ;;; Γ |- t ▹ T ->
  ∑ args',
    Σ ;;; Γ ⊢ T ⇝ mkApps (tInd ind u) args' ×
      red_terms Σ Γ args args'.
Proof.
  intros ty ty'.
  depelim ty.
  eapply into_closed_red in r.
  2: fvs.
  2: now eapply type_is_open_term, infering_typing.
  eapply bidirectional_unique in i as [? []]; tea.
  eapply closed_red_confluence in r as [? [? rind]]; tea.
  eapply invert_red_mkApps_tInd in rind as [args' []]; subst.
  exists args' ; split ; tea.
  now etransitivity.
Qed.

Corollary principal_type `{checker_flags} {Σ} (wfΣ : wf Σ) {Γ t T} :
  Σ ;;; Γ |- t : T ->
  ∑ T',
    (forall T'', Σ ;;; Γ |- t : T'' -> Σ ;;; Γ ⊢ T' ≤ T'') × Σ ;;; Γ |- t : T'.
Proof.
  intros ty.
  assert (wf_local Σ Γ) by (pcuic; eapply typing_wf_local; eauto).
  apply typing_infering in ty as (S & infS & _); auto.
  exists S.
  repeat split.
  2: by apply infering_typing.
  intros T' ty.
  eapply typing_infering in ty as (S' & infS' & cum'); auto.
  etransitivity ; eauto.
  now eapply ws_cumul_pb_eq_le, infering_unique'.
Qed.