+ End CoreToCore.
+
+ Definition coreVarToWeakExprVarOrError cv :=
+ match coreVarToWeakVar cv with
+ | WExprVar wv => wv
+ | _ => Prelude_error "IMPOSSIBLE"
+ end.
+
+ Definition curry {Γ}{Δ}{a}{s}{Σ}{lev} :
+ ND Rule
+ [ Γ > Δ > Σ |- [a ---> s ]@lev ]
+ [ Γ > Δ > [a @@ lev],,Σ |- [ s ]@lev ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply RExch ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RApp ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_id.
+ apply nd_rule.
+ apply RVar.
+ Defined.
+
+ Definition fToC1 {Γ}{Δ}{a}{s}{lev} :
+ ND Rule [] [ Γ > Δ > [ ] |- [a ---> s ]@lev ] ->
+ ND Rule [] [ Γ > Δ > [a @@ lev] |- [ s ]@lev ].
+ intro pf.
+ eapply nd_comp.
+ apply pf.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply RCanR ].
+ apply curry.
+ Defined.
+
+ Definition fToC2 {Γ}{Δ}{a1}{a2}{s}{lev} :
+ ND Rule [] [ Γ > Δ > [] |- [a1 ---> (a2 ---> s) ]@lev ] ->
+ ND Rule [] [ Γ > Δ > [a1 @@ lev],,[a2 @@ lev] |- [ s ]@lev ].
+ intro pf.
+ eapply nd_comp.
+ eapply pf.
+ clear pf.
+ eapply nd_comp.
+ eapply curry.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply RArrange.
+ eapply RCanR.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply RExch ].
+ apply curry.
+ Defined.
+
+ Section coqPassCoreToCore.
+ Context
+ (hetmet_brak : CoreVar)
+ (hetmet_esc : CoreVar)
+ (hetmet_flatten : CoreVar)
+ (hetmet_unflatten : CoreVar)
+ (hetmet_flattened_id : CoreVar)
+ (uniqueSupply : UniqSupply)
+ (lbinds:list (@CoreBind CoreVar))
+ (hetmet_PGArrowTyCon : TyFun)
+ (hetmet_PGArrow_unit_TyCon : TyFun)
+ (hetmet_PGArrow_tensor_TyCon : TyFun)
+ (hetmet_PGArrow_exponent_TyCon : TyFun)
+ (hetmet_pga_id : CoreVar)
+ (hetmet_pga_comp : CoreVar)
+ (hetmet_pga_first : CoreVar)
+ (hetmet_pga_second : CoreVar)
+ (hetmet_pga_cancell : CoreVar)
+ (hetmet_pga_cancelr : CoreVar)
+ (hetmet_pga_uncancell : CoreVar)
+ (hetmet_pga_uncancelr : CoreVar)
+ (hetmet_pga_assoc : CoreVar)
+ (hetmet_pga_unassoc : CoreVar)
+ (hetmet_pga_copy : CoreVar)
+ (hetmet_pga_drop : CoreVar)
+ (hetmet_pga_swap : CoreVar)
+ (hetmet_pga_applyl : CoreVar)
+ (hetmet_pga_applyr : CoreVar)
+ (hetmet_pga_curryl : CoreVar)
+ (hetmet_pga_curryr : CoreVar)
+ .
+
+
+ Definition ga_unit TV (ec:RawHaskType TV ECKind) : RawHaskType TV ★ :=
+ @TyFunApp TV hetmet_PGArrow_unit_TyCon (ECKind::nil) ★ (TyFunApp_cons _ _ ec TyFunApp_nil).
+
+ Definition ga_prod TV (ec:RawHaskType TV ECKind) (a b:RawHaskType TV ★) : RawHaskType TV ★ :=
+ (@TyFunApp TV
+ hetmet_PGArrow_tensor_TyCon
+ (ECKind::★ ::★ ::nil) ★
+ (TyFunApp_cons _ _ ec
+ (TyFunApp_cons _ _ a
+ (TyFunApp_cons _ _ b
+ TyFunApp_nil)))).
+
+ Definition ga_type {TV}(a:RawHaskType TV ECKind)(b c:RawHaskType TV ★) : RawHaskType TV ★ :=
+ TApp (TApp (TApp (@TyFunApp TV
+ hetmet_PGArrowTyCon
+ nil _ TyFunApp_nil) a) b) c.
+
+ Definition ga := @ga_mk ga_unit ga_prod (@ga_type).
+
+ Definition ga_type' {Γ}(a:HaskType Γ ECKind)(b c:HaskType Γ ★) : HaskType Γ ★ :=
+ fun TV ite => TApp (TApp (TApp (@TyFunApp TV
+ hetmet_PGArrowTyCon
+ nil _ TyFunApp_nil) (a TV ite)) (b TV ite)) (c TV ite).
+
+ Definition mkGlob2' {Γ}{κ₁}{κ₂}(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ ★) :
+ IList Kind (fun κ : Kind => HaskType Γ κ) (κ₁::κ₂::nil) -> HaskType Γ ★.
+ intros.
+ inversion X; subst.
+ inversion X1; subst.
+ apply f; auto.
+ Defined.
+
+ Definition mkGlob2 {Γ}{Δ}{l}{κ₁}{κ₂}(cv:CoreVar)(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ ★) x y
+ : ND Rule [] [ Γ > Δ > [] |- [f x y ]@l ].
+ apply nd_rule.
+ refine (@RGlobal Γ Δ l
+ {| glob_wv := coreVarToWeakExprVarOrError cv
+ ; glob_kinds := κ₁ :: κ₂ :: nil
+ ; glob_tf := mkGlob2'(Γ:=Γ) f
+ |} (ICons _ _ x (ICons _ _ y INil))).
+ Defined.
+
+ Definition mkGlob3' {Γ}{κ₁}{κ₂}{κ₃}(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ ★) :
+ IList Kind (fun κ : Kind => HaskType Γ κ) (κ₁::κ₂::κ₃::nil) -> HaskType Γ ★.
+ intros.
+ inversion X; subst.
+ inversion X1; subst.
+ inversion X3; subst.
+ apply f; auto.
+ Defined.
+
+ Definition mkGlob3 {Γ}{Δ}{l}{κ₁}{κ₂}{κ₃}(cv:CoreVar)(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ ★) x y z
+ : ND Rule [] [ Γ > Δ > [] |- [f x y z ]@l ].
+ apply nd_rule.
+ refine (@RGlobal Γ Δ l
+ {| glob_wv := coreVarToWeakExprVarOrError cv
+ ; glob_kinds := κ₁ :: κ₂ :: κ₃ :: nil
+ ; glob_tf := mkGlob3'(Γ:=Γ) f
+ |} (ICons _ _ x (ICons _ _ y (ICons _ _ z INil)))).
+ Defined.
+
+ Definition mkGlob4' {Γ}{κ₁}{κ₂}{κ₃}{κ₄}(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ κ₄ -> HaskType Γ ★) :
+ IList Kind (fun κ : Kind => HaskType Γ κ) (κ₁::κ₂::κ₃::κ₄::nil) -> HaskType Γ ★.
+ intros.
+ inversion X; subst.
+ inversion X1; subst.
+ inversion X3; subst.
+ inversion X5; subst.
+ apply f; auto.
+ Defined.
+
+ Definition mkGlob4 {Γ}{Δ}{l}{κ₁}{κ₂}{κ₃}{κ₄}(cv:CoreVar)(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ κ₄ -> HaskType Γ ★) x y z q
+ : ND Rule [] [ Γ > Δ > [] |- [f x y z q ] @l].
+ apply nd_rule.
+ refine (@RGlobal Γ Δ l
+ {| glob_wv := coreVarToWeakExprVarOrError cv
+ ; glob_kinds := κ₁ :: κ₂ :: κ₃ :: κ₄ :: nil
+ ; glob_tf := mkGlob4'(Γ:=Γ) f
+ |} (ICons _ _ x (ICons _ _ y (ICons _ _ z (ICons _ _ q INil))))).
+ Defined.
+
+ Definition gat {Γ} ec (x:Tree ??(HaskType Γ ★)) := @ga_mk_tree ga_unit ga_prod _ ec x.
+
+ Instance my_ga : garrow ga_unit ga_prod (@ga_type) :=
+ { ga_id := fun Γ Δ ec l a => mkGlob2 hetmet_pga_id (fun ec a => ga_type' ec a a) ec (gat ec a)
+ ; ga_cancelr := fun Γ Δ ec l a => mkGlob2 hetmet_pga_cancelr (fun ec a => ga_type' ec _ a) ec (gat ec a)
+ ; ga_cancell := fun Γ Δ ec l a => mkGlob2 hetmet_pga_cancell (fun ec a => ga_type' ec _ a) ec (gat ec a)
+ ; ga_uncancelr := fun Γ Δ ec l a => mkGlob2 hetmet_pga_uncancelr (fun ec a => ga_type' ec a _) ec (gat ec a)
+ ; ga_uncancell := fun Γ Δ ec l a => mkGlob2 hetmet_pga_uncancell (fun ec a => ga_type' ec a _) ec (gat ec a)
+ ; ga_assoc := fun Γ Δ ec l a b c => mkGlob4 hetmet_pga_assoc (fun ec a b c => ga_type' ec _ _) ec (gat ec a) (gat ec b) (gat ec c)
+ ; ga_unassoc := fun Γ Δ ec l a b c => mkGlob4 hetmet_pga_unassoc (fun ec a b c => ga_type' ec _ _) ec (gat ec a) (gat ec b) (gat ec c)
+ ; ga_swap := fun Γ Δ ec l a b => mkGlob3 hetmet_pga_swap (fun ec a b => ga_type' ec _ _) ec (gat ec a) (gat ec b)
+ ; ga_drop := fun Γ Δ ec l a => mkGlob2 hetmet_pga_drop (fun ec a => ga_type' ec _ _) ec (gat ec a)
+ ; ga_copy := fun Γ Δ ec l a => mkGlob2 hetmet_pga_copy (fun ec a => ga_type' ec _ _) ec (gat ec a)
+ ; ga_first := fun Γ Δ ec l a b x => fToC1 (mkGlob4 hetmet_pga_first (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec x))
+ ; ga_second := fun Γ Δ ec l a b x => fToC1 (mkGlob4 hetmet_pga_second (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec x))
+ ; ga_comp := fun Γ Δ ec l a b c => fToC2 (mkGlob4 hetmet_pga_comp (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec c))
+(* ; ga_lit := fun Γ Δ ec l a => nd_rule (RGlobal _ _ _ _ (coreVarToWeakExprVarOrError hetmet_pga_lit))*)
+(* ; ga_curry := fun Γ Δ ec l a => nd_rule (RGlobal _ _ _ _ (coreVarToWeakExprVarOrError hetmet_pga_curry))*)
+(* ; ga_apply := fun Γ Δ ec l a => nd_rule (RGlobal _ _ _ _ (coreVarToWeakExprVarOrError hetmet_pga_apply))*)
+(* ; ga_kappa := fun Γ Δ ec l a => fToC1 (nd_rule (RGlobal _ _ _ _ (coreVarToWeakExprVarOrError hetmet_pga_kappa)))*)
+ ; ga_lit := fun Γ Δ ec l a => Prelude_error "ga_lit"
+ ; ga_curry := fun Γ Δ ec l a b c => Prelude_error "ga_curry"
+ ; ga_apply := fun Γ Δ ec l a b c => Prelude_error "ga_apply"
+ ; ga_kappa := fun Γ Δ ec l a => Prelude_error "ga_kappa"
+ }.
+
+ Definition hetmet_brak' := coreVarToWeakExprVarOrError hetmet_brak.
+ Definition hetmet_esc' := coreVarToWeakExprVarOrError hetmet_esc.
+ Definition hetmet_flatten' := coreVarToWeakExprVarOrError hetmet_flatten.
+ Definition hetmet_unflatten' := coreVarToWeakExprVarOrError hetmet_unflatten.
+ Definition hetmet_flattened_id' := coreVarToWeakExprVarOrError hetmet_flattened_id.
+
+ Definition coreToCoreExpr' (cex:@CoreExpr CoreVar) : ???(@CoreExpr CoreVar) :=
+ addErrorMessage ("input CoreSyn: " +++ toString cex)
+ (addErrorMessage ("input CoreType: " +++ toString (coreTypeOfCoreExpr cex)) (
+ coreExprToWeakExpr cex >>= fun we =>