(*******************************************************************************)
- Context (hetmet_flatten : WeakExprVar).
- Context (hetmet_unflatten : WeakExprVar).
- Context (hetmet_id : WeakExprVar).
Context {unitTy : forall TV, RawHaskType TV ECKind -> RawHaskType TV ★ }.
Context {prodTy : forall TV, RawHaskType TV ECKind -> RawHaskType TV ★ -> RawHaskType TV ★ -> RawHaskType TV ★ }.
Context {gaTy : forall TV, RawHaskType TV ECKind -> RawHaskType TV ★ -> RawHaskType TV ★ -> RawHaskType TV ★ }.
; ga_second : ∀ Γ Δ ec l a b x, ND Rule [] [Γ > Δ > [@ga_mk Γ ec a b @@l] |- [@ga_mk Γ ec (x,,a) (x,,b) ]@l ]
; ga_lit : ∀ Γ Δ ec l lit , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec [] [literalType lit] ]@l ]
; ga_curry : ∀ Γ Δ ec l a b c, ND Rule [] [Γ > Δ > [@ga_mk Γ ec (a,,[b]) [c] @@ l] |- [@ga_mk Γ ec a [b ---> c] ]@ l ]
+ ; ga_loopl : ∀ Γ Δ ec l x y z, ND Rule [] [Γ > Δ > [@ga_mk Γ ec (z,,x) (z,,y) @@ l] |- [@ga_mk Γ ec x y ]@ l ]
+ ; ga_loopr : ∀ Γ Δ ec l x y z, ND Rule [] [Γ > Δ > [@ga_mk Γ ec (x,,z) (y,,z) @@ l] |- [@ga_mk Γ ec x y ]@ l ]
; ga_comp : ∀ Γ Δ ec l a b c, ND Rule [] [Γ > Δ > [@ga_mk Γ ec a b @@ l],,[@ga_mk Γ ec b c @@ l] |- [@ga_mk Γ ec a c ]@l ]
; ga_apply : ∀ Γ Δ ec l a a' b c,
ND Rule [] [Γ > Δ > [@ga_mk Γ ec a [b ---> c] @@ l],,[@ga_mk Γ ec a' [b] @@ l] |- [@ga_mk Γ ec (a,,a') [c] ]@l ]
(fun TV : Kind → Type => take_arg_types ○ t TV))))).
reflexivity.
unfold flatten_type.
- clear hetmet_flatten.
- clear hetmet_unflatten.
- clear hetmet_id.
clear gar.
set (t tv ite) as x.
admit.
rename l into g.
rename σ into l.
destruct l as [|ec lev]; simpl.
+ (*
destruct (eqd_dec (g:CoreVar) (hetmet_flatten:CoreVar)).
set (flatten_type (g wev)) as t.
set (RGlobal _ Δ nil (mkGlobal Γ t hetmet_id)) as q.
apply nd_rule.
apply q.
apply INil.
+ *)
unfold flatten_leveled_type. simpl.
apply nd_rule; rewrite globals_do_not_have_code_types.
apply RGlobal.
unfold x1.
rewrite drop_to_nothing.
apply arrangeCancelEmptyTree with (q:=(mapTree (fun _ : ??(HaskType Γ ★) => tt) Σ₁₂)).
- admit. (* OK *)
+ induction Σ₁₂; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ₁₂1 at 2.
+ rewrite <- IHΣ₁₂2 at 2.
+ reflexivity.
eapply nd_comp; [ eapply nd_rule; eapply RArrange; eapply ALeft; eapply ACanL | idtac ].
set (mapOptionTree flatten_type Σ₁₂) as a.
set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) Σ₁)) as b.
eapply RArrange.
eapply ARight.
apply arrangeUnCancelEmptyTree with (q:=(mapTree (fun _ : ??(HaskType Γ ★) => tt) Σ)).
- admit (* FIXME *).
+ induction Σ; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ1 at 2.
+ rewrite <- IHΣ2 at 2.
+ reflexivity.
idtac.
eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanL ].
apply boost.
eapply RArrange.
eapply ALeft.
apply arrangeUnCancelEmptyTree with (q:=(mapTree (fun _ : ??(HaskType Γ ★) => tt) Σ)).
- admit (* FIXME *).
+ induction Σ; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ1 at 2.
+ rewrite <- IHΣ2 at 2.
+ reflexivity.
idtac.
eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanR ].
apply boost.
destruct case_RVoid.
simpl.
- apply nd_rule.
destruct l.
+ apply nd_rule.
apply RVoid.
- apply (Prelude_error "RVoid at level >0").
+ drop_simplify.
+ take_simplify.
+ simpl.
+ apply ga_id.
destruct case_RAppT.
simpl. destruct lev; simpl.
rewrite IHy1.
rewrite IHy2.
reflexivity.
- apply (Prelude_error "LetRec not supported inside brackets yet (FIXME)").
+ repeat drop_simplify.
+ repeat take_simplify.
+ simpl.
+ rewrite drop_to_nothing.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply RArrange.
+ eapply AComp.
+ eapply ARight.
+ apply arrangeCancelEmptyTree with (q:=y).
+ induction y; try destruct a; auto.
+ simpl.
+ rewrite <- IHy1.
+ rewrite <- IHy2.
+ reflexivity.
+ apply ACanL.
+ rewrite take_lemma'.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (h :: lev) lri)) as lri'.
+ set (mapOptionTree flatten_leveled_type (drop_lev (h :: lev) lri)) as lri''.
+ replace (mapOptionTree (flatten_type ○ unlev) (y @@@ (h :: lev))) with (mapOptionTree flatten_type y).
+ apply boost.
+ apply ga_loopl.
+ rewrite <- mapOptionTree_compose.
+ simpl.
+ reflexivity.
destruct case_RCase.
- simpl.
- apply (Prelude_error "Case not supported (BIG FIXME)").
+ destruct lev; [ idtac | apply (Prelude_error "case at depth >0") ]; simpl.
+ apply nd_rule.
+ rewrite <- mapOptionTree_compose.
+ replace (mapOptionTree
+ (fun x => flatten_judgment (pcb_judg (snd x)))
+ alts,, [Γ > Δ > mapOptionTree flatten_leveled_type Σ |- [flatten_type (caseType tc avars)] @ nil])
+ with
+ (mapOptionTree
+ (fun x => @pcb_judg tc Γ Δ nil (flatten_type tbranches) avars (fst x) (snd x))
+ alts,,
+ [Γ > Δ > mapOptionTree flatten_leveled_type Σ |- [caseType tc avars] @ nil]).
+ replace (mapOptionTree flatten_leveled_type
+ (mapOptionTreeAndFlatten
+ (fun x => (snd x)) alts))
+ with (mapOptionTreeAndFlatten
+ (fun x =>
+ (snd x)) alts).
+ apply RCase.
+ admit.
+ admit.
destruct case_SBrak.
simpl.