-- | See <https://www.cs.kent.ac.uk/people/staff/smk/redblack/rb.html here> for
-- the original term-level code by Stefan Kahrs. It is also copied at the end
-- of this file.  Some parts of the type-level code include the correspondign
-- term-level parts in their comments.
{-# LANGUAGE DataKinds,
             TypeOperators,
             ConstraintKinds,
             PolyKinds,
             TypeFamilies,
             GADTs,
             MultiParamTypeClasses,
             FunctionalDependencies,
             FlexibleInstances,
             FlexibleContexts,
             UndecidableInstances,
             UndecidableSuperClasses,
             TypeApplications,
             ScopedTypeVariables,
             AllowAmbiguousTypes,
             ExplicitForAll,
             RankNTypes, 
             DefaultSignatures,
             PartialTypeSignatures,
             LambdaCase,
             EmptyCase,
             StandaloneKindSignatures

#-}
{-#  OPTIONS_GHC -Wno-partial-type-signatures  #-}

module Data.RBR.Internal where

import           Data.Proxy
import           Data.Kind
import           Data.Typeable
import           Data.Coerce
import           Data.Functor.Contravariant (Contravariant(contramap))
import           Data.Bifunctor (first)
import           Data.Monoid (Endo(..))
import           Data.List (intersperse)
import           Data.Foldable (asum)
import           GHC.TypeLits
import           GHC.Generics (D1,C1,S1(..),M1(..),K1(..),Rec0(..), Generically(..))
import qualified GHC.Generics as G

import           Data.SOP (I(..),K(..),unI,unK,NP(..),NS(..),All,SListI,type (-.->)(Fn,apFn),mapKIK,(:.:)(..),Top)
import           Data.SOP.NP (collapse_NP,liftA_NP,liftA2_NP,cliftA_NP,cliftA2_NP,pure_NP,sequence_NP,sequence'_NP)
import           Data.SOP.NS (collapse_NS,ap_NS,injections,Injection)


{- $setup
 
>>> :set -XDataKinds -XTypeApplications -XPartialTypeSignatures -XFlexibleContexts -XTypeFamilies -XDeriveGeneric 
>>> :set -Wno-partial-type-signatures  
>>> import Data.RBR
>>> import Data.SOP
>>> import GHC.Generics

-}


-- | The color of a node.
data Color = R
           | B
    deriving (Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Color -> ShowS
showsPrec :: Int -> Color -> ShowS
$cshow :: Color -> String
show :: Color -> String
$cshowList :: [Color] -> ShowS
showList :: [Color] -> ShowS
Show,Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
/= :: Color -> Color -> Bool
Eq)

-- | A Red-Black tree. It will be used as a kind, to index the 'Record' and 'Variant' types.
data Map symbol q = E 
             | N Color (Map symbol q) symbol q (Map symbol q)
    deriving (Int -> Map symbol q -> ShowS
[Map symbol q] -> ShowS
Map symbol q -> String
(Int -> Map symbol q -> ShowS)
-> (Map symbol q -> String)
-> ([Map symbol q] -> ShowS)
-> Show (Map symbol q)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall symbol q.
(Show symbol, Show q) =>
Int -> Map symbol q -> ShowS
forall symbol q. (Show symbol, Show q) => [Map symbol q] -> ShowS
forall symbol q. (Show symbol, Show q) => Map symbol q -> String
$cshowsPrec :: forall symbol q.
(Show symbol, Show q) =>
Int -> Map symbol q -> ShowS
showsPrec :: Int -> Map symbol q -> ShowS
$cshow :: forall symbol q. (Show symbol, Show q) => Map symbol q -> String
show :: Map symbol q -> String
$cshowList :: forall symbol q. (Show symbol, Show q) => [Map symbol q] -> ShowS
showList :: [Map symbol q] -> ShowS
Show,Map symbol q -> Map symbol q -> Bool
(Map symbol q -> Map symbol q -> Bool)
-> (Map symbol q -> Map symbol q -> Bool) -> Eq (Map symbol q)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall symbol q.
(Eq symbol, Eq q) =>
Map symbol q -> Map symbol q -> Bool
$c== :: forall symbol q.
(Eq symbol, Eq q) =>
Map symbol q -> Map symbol q -> Bool
== :: Map symbol q -> Map symbol q -> Bool
$c/= :: forall symbol q.
(Eq symbol, Eq q) =>
Map symbol q -> Map symbol q -> Bool
/= :: Map symbol q -> Map symbol q -> Bool
Eq)

-- | A map without entries. See also 'unit' and 'impossible'.
type Empty = E

--
--
-- This code has been copied and adapted from the corresponding Data.SOP code (the All constraint).
--

-- Why is this KeysValuesAllF type family needed at all? Why is not KeysValuesAll sufficient by itself?
-- In fact, if I delete KeysValuesAllF and use eclusively KeysValuesAll, functions like demoteKeys seem to still work fine.
--
-- UndecidableSuperClasses and RankNTypes seem to be required by KeysValuesAllF.
type KeysValuesAllF :: (symbol -> q -> Constraint) -> Map symbol q -> Constraint
type family
  KeysValuesAllF c t :: Constraint where
  KeysValuesAllF _ E                        = ()
  KeysValuesAllF c (N color left k v right) = (c k v, KeysValuesAll c left, KeysValuesAll c right)

{- | Require a constraint for every key-value pair in a tree. This is a generalization of 'Data.SOP.All' from "Data.SOP".
-}
type KeysValuesAll :: (symbol -> q -> Constraint) -> Map symbol q -> Constraint
class KeysValuesAllF c t => KeysValuesAll (c :: symbol -> q -> Constraint) (t :: Map symbol q) where

  --  'cpara_Map' constructs a 'Record' by means of a constraint for producing
  --  the nodes of the tree. The constraint is passed as a 'Data.Proxy.Proxy'.
  cpara_Map ::
       proxy c
    -> r E
    -> (forall left k v right color . (c k v, KeysValuesAll c left, KeysValuesAll c right) 
                                   => r left -> r right -> r (N color left k v right))
    -> r t

{- | This typeclass provides generalizations of 'Applicative'-like functions
     which work over 'Record's and 'Variant's.
-}
type Maplike :: Map Symbol Type -> Constraint
class Maplike (t :: Map Symbol Type) where
    {- | 
         See 'cpure_Record' and 'cpure'_Record' for more useful versions of
         this function.

         The naming scheme follows that of 'Data.SOP.NP.pure_NP'.
    -}
    pure_Record :: (forall v. f v) -> Record f t
    {- | 
         Pulls out an 'Applicative' that wraps each field, resulting in an 'Applicative' containing a pure 'Record'.

         The naming scheme follows that of 'Data.SOP.NP.sequence_NP'.
    -}
    sequence_Record :: Applicative f => Record f t -> f (Record I t)
    {- | 
         Like 'sequence_Record', but only pulls out the outer 'Applicative'
         from an 'Applicative' composition that wraps each field. See
         'Data.SOP.:.:'.

         This can be useful for staged computations, where each stage is
         represented by an 'Applicative' layer.

         The naming scheme follows that of 'Data.SOP.NP.sequence'_NP'.
    -}
    sequence'_Record :: Applicative f => Record (f :.: g) t -> f (Record g t)
    {- | Apply a transformation to the type constructor which wraps the fields of a 'Record'.
     
         The naming scheme follows that of 'Data.SOP.NP.liftA_NP'.
    -}
    liftA_Record :: (forall a. f a -> g a) -> Record f t -> Record g t
    {- | 
         The naming scheme follows that of 'Data.SOP.NP.liftA2_NP'.
    -}
    liftA2_Record :: (forall a. f a -> g a -> h a) -> Record f t -> Record g t -> Record h t
    {- | Apply a transformation to the active branch of a 'Variant'.
     
         The naming scheme follows that of 'Data.SOP.NS.liftA_NS'.
    -}
    liftA_Variant :: (forall a. f a -> g a) -> Variant f t -> Variant g t
    {- | Given a 'Record' of transformation, apply the one which matches the active branch of 'Variant'.
     
         The naming scheme follows that of 'Data.SOP.NS.liftA2_NS'.
    -}
    liftA2_Variant :: (forall a. f a -> g a -> h a) -> Record f t -> Variant g t -> Variant h t
    {- | 
         Constructs a 'Record' made of functions which take a value of the
         field's type and inject it in the 'Variant' branch which corresponds
         to the field.

         Compare to 'Data.SOP.NS.injections' from @generics-sop@.
    -}
    injections'_Variant :: Record (Case f (Variant f t)) t
    {- | 
         Constructs a 'Record' made of functions which take a value of the
         field's type and return a record updater function that sets the field.
    -}
    injections_Record :: Record (Case f (Endo (Record f t))) t
    {- | Collapse a 'Record' composed of 'K' monoidal annotations.
        
    >>> collapse'_Record (unit :: Record (K [Bool]) Empty)
    []

    >>> collapse'_Record (insert @"bar" (K [False]) unit)
    [False]

    The naming scheme follows that of 'Data.SOP.NP.collapse_NP'.

    -}
    collapse'_Record :: Monoid a => Record (K a) t -> a
    collapse_Variant :: Variant (K a) t -> a

instance Maplike E where
    pure_Record :: forall (f :: * -> *). (forall v. f v) -> Record f 'E
pure_Record forall v. f v
_ = Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    sequence_Record :: forall (f :: * -> *).
Applicative f =>
Record f 'E -> f (Record I 'E)
sequence_Record Record f 'E
Empty = Record I 'E -> f (Record I 'E)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Record I 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    sequence'_Record :: forall (f :: * -> *) (g :: * -> *).
Applicative f =>
Record (f :.: g) 'E -> f (Record g 'E)
sequence'_Record Record (f :.: g) 'E
Empty = Record g 'E -> f (Record g 'E)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Record g 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    liftA_Record :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f 'E -> Record g 'E
liftA_Record forall a. f a -> g a
_ Record f 'E
Empty = Record g 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    liftA2_Record :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f 'E -> Record g 'E -> Record h 'E
liftA2_Record forall a. f a -> g a -> h a
_ Record f 'E
Empty Record g 'E
Empty = Record h 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    liftA_Variant :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Variant f 'E -> Variant g 'E
liftA_Variant forall a. f a -> g a
_ Variant f 'E
neverHappens = Variant f 'E -> Variant g 'E
forall {q} (f :: q -> *) b. Variant f Empty -> b
impossible Variant f 'E
neverHappens
    liftA2_Variant :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f 'E -> Variant g 'E -> Variant h 'E
liftA2_Variant forall a. f a -> g a -> h a
_ Record f 'E
Empty Variant g 'E
neverHappens = Variant g 'E -> Variant h 'E
forall {q} (f :: q -> *) b. Variant f Empty -> b
impossible Variant g 'E
neverHappens
    injections'_Variant :: forall (f :: * -> *). Record (Case f (Variant f 'E)) 'E
injections'_Variant = Record (Case f (Variant f 'E)) 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    injections_Record :: forall (f :: * -> *). Record (Case f (Endo (Record f 'E))) 'E
injections_Record = Record (Case f (Endo (Record f 'E))) 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    collapse'_Record :: forall a. Monoid a => Record (K a) 'E -> a
collapse'_Record Record (K a) 'E
Empty = a
forall a. Monoid a => a
mempty
    collapse_Variant :: forall a. Variant (K a) 'E -> a
collapse_Variant = Variant (K a) 'E -> a
forall {q} (f :: q -> *) b. Variant f Empty -> b
impossible

instance (Maplike left, Maplike right) => Maplike (N color left k v right) where
    pure_Record :: forall (f :: * -> *).
(forall v. f v) -> Record f ('N color left k v right)
pure_Record forall v. f v
f = Record f left
-> f v -> Record f right -> Record f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node ((forall v. f v) -> Record f left
forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
(forall v. f v) -> Record f t
forall (f :: * -> *). (forall v. f v) -> Record f left
pure_Record f v
forall v. f v
f) f v
forall v. f v
f ((forall v. f v) -> Record f right
forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
(forall v. f v) -> Record f t
forall (f :: * -> *). (forall v. f v) -> Record f right
pure_Record f v
forall v. f v
f)
    sequence_Record :: forall (f :: * -> *).
Applicative f =>
Record f ('N color left k v right)
-> f (Record I ('N color left k v right))
sequence_Record (Node Record f left
left f v
v Record f right
right) = (\Record I left
l v
x Record I right
r -> Record I left
-> I v -> Record I right -> Record I ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record I left
l (v -> I v
forall a. a -> I a
I v
x) Record I right
r) (Record I left
 -> v -> Record I right -> Record I ('N color left k v right))
-> f (Record I left)
-> f (v -> Record I right -> Record I ('N color left k v right))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record f left -> f (Record I left)
forall (t :: Map Symbol (*)) (f :: * -> *).
(Maplike t, Applicative f) =>
Record f t -> f (Record I t)
forall (f :: * -> *).
Applicative f =>
Record f left -> f (Record I left)
sequence_Record Record f left
Record f left
left f (v -> Record I right -> Record I ('N color left k v right))
-> f v -> f (Record I right -> Record I ('N color left k v right))
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f v
f v
v f (Record I right -> Record I ('N color left k v right))
-> f (Record I right) -> f (Record I ('N color left k v right))
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Record f right -> f (Record I right)
forall (t :: Map Symbol (*)) (f :: * -> *).
(Maplike t, Applicative f) =>
Record f t -> f (Record I t)
forall (f :: * -> *).
Applicative f =>
Record f right -> f (Record I right)
sequence_Record Record f right
Record f right
right
    sequence'_Record :: forall (f :: * -> *) (g :: * -> *).
Applicative f =>
Record (f :.: g) ('N color left k v right)
-> f (Record g ('N color left k v right))
sequence'_Record (Node Record (f :.: g) left
left (Comp f (g v)
v) Record (f :.: g) right
right) = (\Record g left
l g v
x Record g right
r -> Record g left
-> g v -> Record g right -> Record g ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record g left
l g v
x Record g right
r) (Record g left
 -> g v -> Record g right -> Record g ('N color left k v right))
-> f (Record g left)
-> f (g v -> Record g right -> Record g ('N color left k v right))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record (f :.: g) left -> f (Record g left)
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
(Maplike t, Applicative f) =>
Record (f :.: g) t -> f (Record g t)
forall (f :: * -> *) (g :: * -> *).
Applicative f =>
Record (f :.: g) left -> f (Record g left)
sequence'_Record Record (f :.: g) left
Record (f :.: g) left
left f (g v -> Record g right -> Record g ('N color left k v right))
-> f (g v)
-> f (Record g right -> Record g ('N color left k v right))
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (g v)
f (g v)
v f (Record g right -> Record g ('N color left k v right))
-> f (Record g right) -> f (Record g ('N color left k v right))
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Record (f :.: g) right -> f (Record g right)
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
(Maplike t, Applicative f) =>
Record (f :.: g) t -> f (Record g t)
forall (f :: * -> *) (g :: * -> *).
Applicative f =>
Record (f :.: g) right -> f (Record g right)
sequence'_Record Record (f :.: g) right
Record (f :.: g) right
right
    liftA_Record :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a)
-> Record f ('N color left k v right)
-> Record g ('N color left k v right)
liftA_Record forall a. f a -> g a
trans (Node Record f left
left1 f v
v1 Record f right
right1) = Record g left
-> g v -> Record g right -> Record g ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node ((forall a. f a -> g a) -> Record f left -> Record g left
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Record f t -> Record g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f left -> Record g left
liftA_Record f a -> g a
forall a. f a -> g a
trans Record f left
Record f left
left1) (f v -> g v
forall a. f a -> g a
trans f v
f v
v1) ((forall a. f a -> g a) -> Record f right -> Record g right
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Record f t -> Record g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f right -> Record g right
liftA_Record f a -> g a
forall a. f a -> g a
trans Record f right
Record f right
right1)
    liftA2_Record :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f ('N color left k v right)
-> Record g ('N color left k v right)
-> Record h ('N color left k v right)
liftA2_Record forall a. f a -> g a -> h a
trans (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record g left
left2 g v
v2 Record g right
right2) = Record h left
-> h v -> Record h right -> Record h ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node ((forall a. f a -> g a -> h a)
-> Record f left -> Record g left -> Record h left
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
Maplike t =>
(forall a. f a -> g a -> h a)
-> Record f t -> Record g t -> Record h t
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f left -> Record g left -> Record h left
liftA2_Record f a -> g a -> h a
forall a. f a -> g a -> h a
trans Record f left
Record f left
left1 Record g left
Record g left
left2) (f v -> g v -> h v
forall a. f a -> g a -> h a
trans f v
f v
v1 g v
g v
v2) ((forall a. f a -> g a -> h a)
-> Record f right -> Record g right -> Record h right
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
Maplike t =>
(forall a. f a -> g a -> h a)
-> Record f t -> Record g t -> Record h t
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f right -> Record g right -> Record h right
liftA2_Record f a -> g a -> h a
forall a. f a -> g a -> h a
trans Record f right
Record f right
right1 Record g right
Record g right
right2)
    liftA_Variant :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a)
-> Variant f ('N color left k v right)
-> Variant g ('N color left k v right)
liftA_Variant forall a. f a -> g a
trans Variant f ('N color left k v right)
vv = case Variant f ('N color left k v right)
vv of
        Here  f v
fv -> g v -> Variant g ('N color left k v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here (f v -> g v
forall a. f a -> g a
trans f v
f v
fv)
        LookLeft Variant f t
leftV -> Variant g left -> Variant g ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft ((forall a. f a -> g a) -> Variant f left -> Variant g left
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Variant f t -> Variant g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Variant f left -> Variant g left
liftA_Variant f a -> g a
forall a. f a -> g a
trans Variant f left
Variant f t
leftV)
        LookRight Variant f t
rightV -> Variant g right -> Variant g ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight ((forall a. f a -> g a) -> Variant f right -> Variant g right
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Variant f t -> Variant g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Variant f right -> Variant g right
liftA_Variant f a -> g a
forall a. f a -> g a
trans Variant f right
Variant f t
rightV)
    liftA2_Variant :: forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f ('N color left k v right)
-> Variant g ('N color left k v right)
-> Variant h ('N color left k v right)
liftA2_Variant forall a. f a -> g a -> h a
trans (Node Record f left
left f v
rv Record f right
right) Variant g ('N color left k v right)
vv = case Variant g ('N color left k v right)
vv of
        Here  g v
fv -> h v -> Variant h ('N color left k v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here (f v -> g v -> h v
forall a. f a -> g a -> h a
trans f v
f v
rv g v
g v
fv)
        LookLeft Variant g t
leftV -> Variant h left -> Variant h ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft ((forall a. f a -> g a -> h a)
-> Record f left -> Variant g left -> Variant h left
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
Maplike t =>
(forall a. f a -> g a -> h a)
-> Record f t -> Variant g t -> Variant h t
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f left -> Variant g left -> Variant h left
liftA2_Variant f a -> g a -> h a
forall a. f a -> g a -> h a
trans Record f left
Record f left
left Variant g left
Variant g t
leftV)
        LookRight Variant g t
rightV -> Variant h right -> Variant h ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight ((forall a. f a -> g a -> h a)
-> Record f right -> Variant g right -> Variant h right
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
Maplike t =>
(forall a. f a -> g a -> h a)
-> Record f t -> Variant g t -> Variant h t
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f right -> Variant g right -> Variant h right
liftA2_Variant f a -> g a -> h a
forall a. f a -> g a -> h a
trans Record f right
Record f right
right Variant g right
Variant g t
rightV)
    injections'_Variant :: forall (f :: * -> *).
Record
  (Case f (Variant f ('N color left k v right)))
  ('N color left k v right)
injections'_Variant = 
        let injections_Left :: Record (Case f (Variant f ('N color left k v right))) left
injections_Left = (forall a.
 Case f (Variant f left) a
 -> Case f (Variant f ('N color left k v right)) a)
-> Record (Case f (Variant f left)) left
-> Record (Case f (Variant f ('N color left k v right))) left
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Record f t -> Record g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f left -> Record g left
liftA_Record (\(Case f a -> Variant f left
j) -> (f a -> Variant f ('N color left k v right))
-> Case f (Variant f ('N color left k v right)) a
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case ((f a -> Variant f ('N color left k v right))
 -> Case f (Variant f ('N color left k v right)) a)
-> (f a -> Variant f ('N color left k v right))
-> Case f (Variant f ('N color left k v right)) a
forall a b. (a -> b) -> a -> b
$ Variant f left -> Variant f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f left -> Variant f ('N color left k v right))
-> (f a -> Variant f left)
-> f a
-> Variant f ('N color left k v right)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Variant f left
j) (forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
Record (Case f (Variant f t)) t
injections'_Variant @left)
            injections_Right :: Record (Case f (Variant f ('N color left k v right))) right
injections_Right = (forall a.
 Case f (Variant f right) a
 -> Case f (Variant f ('N color left k v right)) a)
-> Record (Case f (Variant f right)) right
-> Record (Case f (Variant f ('N color left k v right))) right
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Record f t -> Record g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f right -> Record g right
liftA_Record (\(Case f a -> Variant f right
j) -> (f a -> Variant f ('N color left k v right))
-> Case f (Variant f ('N color left k v right)) a
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case ((f a -> Variant f ('N color left k v right))
 -> Case f (Variant f ('N color left k v right)) a)
-> (f a -> Variant f ('N color left k v right))
-> Case f (Variant f ('N color left k v right)) a
forall a b. (a -> b) -> a -> b
$ Variant f right -> Variant f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f right -> Variant f ('N color left k v right))
-> (f a -> Variant f right)
-> f a
-> Variant f ('N color left k v right)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Variant f right
j) (forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
Record (Case f (Variant f t)) t
injections'_Variant @right)
         in Record (Case f (Variant f ('N color left k v right))) left
-> Case f (Variant f ('N color left k v right)) v
-> Record (Case f (Variant f ('N color left k v right))) right
-> Record
     (Case f (Variant f ('N color left k v right)))
     ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record (Case f (Variant f ('N color left k v right))) left
injections_Left ((f v -> Variant f ('N color left k v right))
-> Case f (Variant f ('N color left k v right)) v
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case ((f v -> Variant f ('N color left k v right))
 -> Case f (Variant f ('N color left k v right)) v)
-> (f v -> Variant f ('N color left k v right))
-> Case f (Variant f ('N color left k v right)) v
forall a b. (a -> b) -> a -> b
$ f v -> Variant f ('N color left k v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here) Record (Case f (Variant f ('N color left k v right))) right
injections_Right
    injections_Record :: forall (f :: * -> *).
Record
  (Case f (Endo (Record f ('N color left k v right))))
  ('N color left k v right)
injections_Record = 
         Record (Case f (Endo (Record f ('N color left k v right)))) left
-> Case f (Endo (Record f ('N color left k v right))) v
-> Record
     (Case f (Endo (Record f ('N color left k v right)))) right
-> Record
     (Case f (Endo (Record f ('N color left k v right))))
     ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node 
             ((forall a.
 Case f (Endo (Record f left)) a
 -> Case f (Endo (Record f ('N color left k v right))) a)
-> Record (Case f (Endo (Record f left))) left
-> Record (Case f (Endo (Record f ('N color left k v right)))) left
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Record f t -> Record g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f left -> Record g left
liftA_Record (\(Case f a -> Endo (Record f left)
cleft) -> 
                                ((f a -> Endo (Record f ('N color left k v right)))
-> Case f (Endo (Record f ('N color left k v right))) a
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case ((f a -> Endo (Record f ('N color left k v right)))
 -> Case f (Endo (Record f ('N color left k v right))) a)
-> (f a -> Endo (Record f ('N color left k v right)))
-> Case f (Endo (Record f ('N color left k v right))) a
forall a b. (a -> b) -> a -> b
$ \f a
x -> 
                                    (Record f ('N color left k v right)
 -> Record f ('N color left k v right))
-> Endo (Record f ('N color left k v right))
forall a. (a -> a) -> Endo a
Endo ((Record f ('N color left k v right)
  -> Record f ('N color left k v right))
 -> Endo (Record f ('N color left k v right)))
-> (Record f ('N color left k v right)
    -> Record f ('N color left k v right))
-> Endo (Record f ('N color left k v right))
forall a b. (a -> b) -> a -> b
$ (\(Node Record f left
left' f v
x' Record f right
right') -> Record f left
-> f v -> Record f right -> Record f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Endo (Record f left) -> Record f left -> Record f left
forall a. Endo a -> a -> a
appEndo (f a -> Endo (Record f left)
cleft f a
x)  Record f left
Record f left
left') f v
f v
x' Record f right
Record f right
right')))

                           (forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
Record (Case f (Endo (Record f t))) t
injections_Record @left))
             ((f v -> Endo (Record f ('N color left k v right)))
-> Case f (Endo (Record f ('N color left k v right))) v
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case ((f v -> Endo (Record f ('N color left k v right)))
 -> Case f (Endo (Record f ('N color left k v right))) v)
-> (f v -> Endo (Record f ('N color left k v right)))
-> Case f (Endo (Record f ('N color left k v right))) v
forall a b. (a -> b) -> a -> b
$ \f v
x -> (Record f ('N color left k v right)
 -> Record f ('N color left k v right))
-> Endo (Record f ('N color left k v right))
forall a. (a -> a) -> Endo a
Endo ((Record f ('N color left k v right)
  -> Record f ('N color left k v right))
 -> Endo (Record f ('N color left k v right)))
-> (Record f ('N color left k v right)
    -> Record f ('N color left k v right))
-> Endo (Record f ('N color left k v right))
forall a b. (a -> b) -> a -> b
$ \(Node Record f left
left f v
v Record f right
right) -> Record f left
-> f v -> Record f right -> Record f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
Record f left
left f v
x Record f right
Record f right
right) 
             ((forall a.
 Case f (Endo (Record f right)) a
 -> Case f (Endo (Record f ('N color left k v right))) a)
-> Record (Case f (Endo (Record f right))) right
-> Record
     (Case f (Endo (Record f ('N color left k v right)))) right
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Record f t -> Record g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f right -> Record g right
liftA_Record (\(Case f a -> Endo (Record f right)
cright) -> 
                                ((f a -> Endo (Record f ('N color left k v right)))
-> Case f (Endo (Record f ('N color left k v right))) a
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case ((f a -> Endo (Record f ('N color left k v right)))
 -> Case f (Endo (Record f ('N color left k v right))) a)
-> (f a -> Endo (Record f ('N color left k v right)))
-> Case f (Endo (Record f ('N color left k v right))) a
forall a b. (a -> b) -> a -> b
$ \f a
x -> 
                                    (Record f ('N color left k v right)
 -> Record f ('N color left k v right))
-> Endo (Record f ('N color left k v right))
forall a. (a -> a) -> Endo a
Endo ((Record f ('N color left k v right)
  -> Record f ('N color left k v right))
 -> Endo (Record f ('N color left k v right)))
-> (Record f ('N color left k v right)
    -> Record f ('N color left k v right))
-> Endo (Record f ('N color left k v right))
forall a b. (a -> b) -> a -> b
$ (\(Node Record f left
left' f v
x' Record f right
right') -> Record f left
-> f v -> Record f right -> Record f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
Record f left
left' f v
f v
x' (Endo (Record f right) -> Record f right -> Record f right
forall a. Endo a -> a -> a
appEndo (f a -> Endo (Record f right)
cright f a
x) Record f right
Record f right
right'))))

                           (forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
Record (Case f (Endo (Record f t))) t
injections_Record @right))  
    collapse'_Record :: forall a. Monoid a => Record (K a) ('N color left k v right) -> a
collapse'_Record (Node Record (K a) left
left (K a
v) Record (K a) right
right) = Record (K a) left -> a
forall a. Monoid a => Record (K a) left -> a
forall (t :: Map Symbol (*)) a.
(Maplike t, Monoid a) =>
Record (K a) t -> a
collapse'_Record Record (K a) left
left a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (a
v a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Record (K a) right -> a
forall a. Monoid a => Record (K a) right -> a
forall (t :: Map Symbol (*)) a.
(Maplike t, Monoid a) =>
Record (K a) t -> a
collapse'_Record Record (K a) right
right) 
    collapse_Variant :: forall a. Variant (K a) ('N color left k v right) -> a
collapse_Variant Variant (K a) ('N color left k v right)
vv = case Variant (K a) ('N color left k v right)
vv of
        Here (K a
a) -> a
a
        LookLeft Variant (K a) t
leftV -> Variant (K a) t -> a
forall a. Variant (K a) t -> a
forall (t :: Map Symbol (*)) a. Maplike t => Variant (K a) t -> a
collapse_Variant Variant (K a) t
leftV
        LookRight Variant (K a) t
rightV -> Variant (K a) t -> a
forall a. Variant (K a) t -> a
forall (t :: Map Symbol (*)) a. Maplike t => Variant (K a) t -> a
collapse_Variant Variant (K a) t
rightV

{-# DEPRECATED injections_Variant "Use injections'_Variant instead" #-}
injections_Variant :: Maplike t => Record (VariantInjection f t) t
injections_Variant :: forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
Record (VariantInjection f t) t
injections_Variant = (forall a. Case f (Variant f t) a -> VariantInjection f t a)
-> Record (Case f (Variant f t)) t
-> Record (VariantInjection f t) t
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *).
Maplike t =>
(forall a. f a -> g a) -> Record f t -> Record g t
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Record f t -> Record g t
liftA_Record (\(Case f a -> Variant f t
f) -> (f a -> Variant f t) -> VariantInjection f t a
forall q (f :: q -> *) (t :: Map Symbol q) (v :: q).
(f v -> Variant f t) -> VariantInjection f t v
VariantInjection f a -> Variant f t
f) Record (Case f (Variant f t)) t
forall (t :: Map Symbol (*)) (f :: * -> *).
Maplike t =>
Record (Case f (Variant f t)) t
forall (f :: * -> *). Record (Case f (Variant f t)) t
injections'_Variant 

{-# DEPRECATED VariantInjection "Use Case instead" #-}
newtype VariantInjection (f :: q -> Type) (t :: Map Symbol q) (v :: q) = VariantInjection { forall q (f :: q -> *) (t :: Map Symbol q) (v :: q).
VariantInjection f t v -> f v -> Variant f t
runVariantInjection :: f v -> Variant f t }

instance KeysValuesAll c E where
  cpara_Map :: forall (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r 'E
cpara_Map proxy c
_p r 'E
nil forall (left :: Map symbol q) (k :: symbol) (v :: q)
       (right :: Map symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
r left -> r right -> r ('N color left k v right)
_step = r 'E
nil

instance (c k v, KeysValuesAll c left, KeysValuesAll c right) => KeysValuesAll c (N color left k v right) where
  cpara_Map :: forall (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r ('N color left k v right)
cpara_Map proxy c
p r 'E
nil forall (left :: Map symbol q) (k :: symbol) (v :: q)
       (right :: Map symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
r left -> r right -> r ('N color left k v right)
cons =
    r left -> r right -> r ('N color left k v right)
forall (left :: Map symbol q) (k :: symbol) (v :: q)
       (right :: Map symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
r left -> r right -> r ('N color left k v right)
cons (proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r left
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r left
cpara_Map proxy c
p r 'E
nil r left -> r right -> r ('N color left k v right)
forall (left :: Map symbol q) (k :: symbol) (v :: q)
       (right :: Map symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
r left -> r right -> r ('N color left k v right)
cons) (proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r right
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r right
cpara_Map proxy c
p r 'E
nil r left -> r right -> r ('N color left k v right)
forall (left :: Map symbol q) (k :: symbol) (v :: q)
       (right :: Map symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
r left -> r right -> r ('N color left k v right)
cons)

{- |
    Create a 'Record', knowing that both keys and values satisfy a 2-place constraint. The constraint is passed as a 'Data.Proxy.Proxy'.

    The naming scheme follows that of 'Data.SOP.NP.cpure_NP'.
 -}
cpure_Record :: forall c t f. KeysValuesAll c t => Proxy c -> (forall k v. c k v => f v) -> Record f t
cpure_Record :: forall {q} (c :: Symbol -> q -> Constraint) (t :: Map Symbol q)
       (f :: q -> *).
KeysValuesAll c t =>
Proxy c
-> (forall (k :: Symbol) (v :: q). c k v => f v) -> Record f t
cpure_Record Proxy c
_ forall (k :: Symbol) (v :: q). c k v => f v
fpure = Proxy c
-> Record f 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    Record f left
    -> Record f right -> Record f ('N color left k v right))
-> Record f t
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy c
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @c) Record f 'E
forall {q} (f :: q -> *). Record f 'E
unit Record f left
-> Record f right -> Record f ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
Record f left
-> Record f right -> Record f ('N color left k v right)
go
    where
    go :: forall left k' v' right color. (c k' v', KeysValuesAll c left, KeysValuesAll c right) 
       => Record f left
       -> Record f right
       -> Record f (N color left k' v' right)
    go :: forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
Record f left
-> Record f right -> Record f ('N color left k v right)
go Record f left
left Record f right
right = Record f left
-> f v' -> Record f right -> Record f ('N color left k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left (forall (k :: Symbol) (v :: q). c k v => f v
fpure @k' @v') Record f right
right 

{- |
    Create a 'Record', knowing that the keys can be demoted to strings and that
    the values satisfy some constraint. The constraint is passed as a
    'Data.Proxy.Proxy'.

    The function that constructs each field receives the name of the field as an
    argument.

    The naming scheme follows that of 'Data.SOP.NP.cpure_NP'.
 -}
cpure'_Record :: forall c t f. KeysValuesAll (KeyValueConstraints KnownSymbol c) t => Proxy c -> (forall v. c v => String -> f v) -> Record f t
cpure'_Record :: forall {q} (c :: q -> Constraint) (t :: Map Symbol q)
       (f :: q -> *).
KeysValuesAll (KeyValueConstraints KnownSymbol c) t =>
Proxy c -> (forall (v :: q). c v => String -> f v) -> Record f t
cpure'_Record Proxy c
_ forall (v :: q). c v => String -> f v
fpure = Proxy (KeyValueConstraints KnownSymbol c)
-> Record f 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (KeyValueConstraints KnownSymbol c k v,
     KeysValuesAll (KeyValueConstraints KnownSymbol c) left,
     KeysValuesAll (KeyValueConstraints KnownSymbol c) right) =>
    Record f left
    -> Record f right -> Record f ('N color left k v right))
-> Record f t
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy (KeyValueConstraints KnownSymbol c)
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (KeyValueConstraints KnownSymbol c k v,
     KeysValuesAll (KeyValueConstraints KnownSymbol c) left,
     KeysValuesAll (KeyValueConstraints KnownSymbol c) right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @(KeyValueConstraints KnownSymbol c)) Record f 'E
forall {q} (f :: q -> *). Record f 'E
unit Record f left
-> Record f right -> Record f ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KeyValueConstraints KnownSymbol c k v,
 KeysValuesAll (KeyValueConstraints KnownSymbol c) left,
 KeysValuesAll (KeyValueConstraints KnownSymbol c) right) =>
Record f left
-> Record f right -> Record f ('N color left k v right)
go
   where
    go :: forall left k' v' right color. (KeyValueConstraints KnownSymbol c k' v', KeysValuesAll (KeyValueConstraints KnownSymbol c) left, KeysValuesAll (KeyValueConstraints KnownSymbol c) right) 
       => Record f left
       -> Record f right
       -> Record f (N color left k' v' right)
    go :: forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KeyValueConstraints KnownSymbol c k v,
 KeysValuesAll (KeyValueConstraints KnownSymbol c) left,
 KeysValuesAll (KeyValueConstraints KnownSymbol c) right) =>
Record f left
-> Record f right -> Record f ('N color left k v right)
go Record f left
left Record f right
right = Record f left
-> f v' -> Record f right -> Record f ('N color left k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left (forall (v :: q). c v => String -> f v
fpure @v' (Proxy k' -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @k'))) Record f right
right 

type F1 :: (q -> Type) -> (q -> Type) -> Map Symbol q -> Type
newtype F1 f g t = F1 { forall q (f :: q -> *) (g :: q -> *) (t :: Map Symbol q).
F1 f g t -> Record f t -> Record g t
unF1 :: Record f t -> Record g t }

{- | Apply a transformation to the type constructor which wraps the fields of a 'Record', with some constraints in scope.
 
     The naming scheme follows that of 'Data.SOP.NP.cliftA_NP'.
-}
cliftA_Record :: forall c t f g. KeysValuesAll c t => Proxy c -> (forall k v. c k v => f v -> g v) -> Record f t -> Record g t
cliftA_Record :: forall {q} (c :: Symbol -> q -> Constraint) (t :: Map Symbol q)
       (f :: q -> *) (g :: q -> *).
KeysValuesAll c t =>
Proxy c
-> (forall (k :: Symbol) (v :: q). c k v => f v -> g v)
-> Record f t
-> Record g t
cliftA_Record Proxy c
_ forall (k :: Symbol) (v :: q). c k v => f v -> g v
func = F1 f g t -> Record f t -> Record g t
forall q (f :: q -> *) (g :: q -> *) (t :: Map Symbol q).
F1 f g t -> Record f t -> Record g t
unF1 (F1 f g t -> Record f t -> Record g t)
-> F1 f g t -> Record f t -> Record g t
forall a b. (a -> b) -> a -> b
$ Proxy c
-> F1 f g 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    F1 f g left -> F1 f g right -> F1 f g ('N color left k v right))
-> F1 f g t
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy c
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @c) ((Record f 'E -> Record g 'E) -> F1 f g 'E
forall q (f :: q -> *) (g :: q -> *) (t :: Map Symbol q).
(Record f t -> Record g t) -> F1 f g t
F1 ((Record f 'E -> Record g 'E) -> F1 f g 'E)
-> (Record f 'E -> Record g 'E) -> F1 f g 'E
forall a b. (a -> b) -> a -> b
$ \Record f 'E
_ -> Record g 'E
forall {q} (f :: q -> *). Record f 'E
unit) F1 f g left -> F1 f g right -> F1 f g ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
F1 f g left -> F1 f g right -> F1 f g ('N color left k v right)
go
    where
    go :: forall left k' v' right color. (c k' v', KeysValuesAll c left, KeysValuesAll c right) 
       => F1 f g left
       -> F1 f g right
       -> F1 f g (N color left k' v' right)
    go :: forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
F1 f g left -> F1 f g right -> F1 f g ('N color left k v right)
go (F1 Record f left -> Record g left
leftf) (F1 Record f right -> Record g right
rightf) = (Record f ('N color left k' v' right)
 -> Record g ('N color left k' v' right))
-> F1 f g ('N color left k' v' right)
forall q (f :: q -> *) (g :: q -> *) (t :: Map Symbol q).
(Record f t -> Record g t) -> F1 f g t
F1 (\(Node Record f left
left f v
v Record f right
right) -> Record g left
-> g v' -> Record g right -> Record g ('N color left k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left -> Record g left
leftf Record f left
Record f left
left) (forall (k :: Symbol) (v :: q). c k v => f v -> g v
func @k' @v' f v'
f v
v) (Record f right -> Record g right
rightf Record f right
Record f right
right))

type F2 :: (q -> Type) -> (q -> Type) -> (q -> Type) -> Map Symbol q -> Type
newtype F2 f g h t = F2 { forall q (f :: q -> *) (g :: q -> *) (h :: q -> *)
       (t :: Map Symbol q).
F2 f g h t -> Record f t -> Record g t -> Record h t
unF2 :: Record f t -> Record g t -> Record h t }

{- | 
     The naming scheme follows that of 'Data.SOP.NP.cliftA2_NP'.
-}
cliftA2_Record :: forall c t f g h. KeysValuesAll c t => Proxy c -> (forall k v. c k v => f v -> g v -> h v) -> Record f t -> Record g t -> Record h t
cliftA2_Record :: forall {q} (c :: Symbol -> q -> Constraint) (t :: Map Symbol q)
       (f :: q -> *) (g :: q -> *) (h :: q -> *).
KeysValuesAll c t =>
Proxy c
-> (forall (k :: Symbol) (v :: q). c k v => f v -> g v -> h v)
-> Record f t
-> Record g t
-> Record h t
cliftA2_Record Proxy c
_ forall (k :: Symbol) (v :: q). c k v => f v -> g v -> h v
func = F2 f g h t -> Record f t -> Record g t -> Record h t
forall q (f :: q -> *) (g :: q -> *) (h :: q -> *)
       (t :: Map Symbol q).
F2 f g h t -> Record f t -> Record g t -> Record h t
unF2 (F2 f g h t -> Record f t -> Record g t -> Record h t)
-> F2 f g h t -> Record f t -> Record g t -> Record h t
forall a b. (a -> b) -> a -> b
$ Proxy c
-> F2 f g h 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    F2 f g h left
    -> F2 f g h right -> F2 f g h ('N color left k v right))
-> F2 f g h t
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy c
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @c) ((Record f 'E -> Record g 'E -> Record h 'E) -> F2 f g h 'E
forall q (f :: q -> *) (g :: q -> *) (h :: q -> *)
       (t :: Map Symbol q).
(Record f t -> Record g t -> Record h t) -> F2 f g h t
F2 ((Record f 'E -> Record g 'E -> Record h 'E) -> F2 f g h 'E)
-> (Record f 'E -> Record g 'E -> Record h 'E) -> F2 f g h 'E
forall a b. (a -> b) -> a -> b
$ \Record f 'E
_ Record g 'E
_ -> Record h 'E
forall {q} (f :: q -> *). Record f 'E
unit) F2 f g h left
-> F2 f g h right -> F2 f g h ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
F2 f g h left
-> F2 f g h right -> F2 f g h ('N color left k v right)
go
    where
    go :: forall left k' v' right color. (c k' v', KeysValuesAll c left, KeysValuesAll c right) 
       => F2 f g h left
       -> F2 f g h right
       -> F2 f g h (N color left k' v' right)
    go :: forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(c k v, KeysValuesAll c left, KeysValuesAll c right) =>
F2 f g h left
-> F2 f g h right -> F2 f g h ('N color left k v right)
go (F2 Record f left -> Record g left -> Record h left
leftf) (F2 Record f right -> Record g right -> Record h right
rightf) = (Record f ('N color left k' v' right)
 -> Record g ('N color left k' v' right)
 -> Record h ('N color left k' v' right))
-> F2 f g h ('N color left k' v' right)
forall q (f :: q -> *) (g :: q -> *) (h :: q -> *)
       (t :: Map Symbol q).
(Record f t -> Record g t -> Record h t) -> F2 f g h t
F2 (\(Node Record f left
left1 f v
v1 Record f right
right1) (Node Record g left
left2 g v
v2 Record g right
right2) -> Record h left
-> h v' -> Record h right -> Record h ('N color left k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left -> Record g left -> Record h left
leftf Record f left
Record f left
left1 Record g left
Record g left
left2) (forall (k :: Symbol) (v :: q). c k v => f v -> g v -> h v
func @k' @v' f v'
f v
v1 g v'
g v
v2) (Record f right -> Record g right -> Record h right
rightf Record f right
Record f right
right1 Record g right
Record g right
right2))

{- | Create a 'Record' containing the names of each field. 
    
     The names are represented by a constant functor 'K' carrying an annotation
     of type 'String'. This means that there aren't actually any values of the
     type that corresponds to each field, only the 'String' annotations.

>>> putStrLn $ prettyShow_Record show $ demoteKeys @(FromList [ '("foo",Char), '("bar",Bool) ])
{bar = K "bar", foo = K "foo"}

     For computations involving field names, sometimes 'cpure'_Record' is a better option.

-} 
demoteKeys :: forall t. KeysValuesAll KnownKey t => Record (K String) t
demoteKeys :: forall {q} (t :: Map Symbol q).
KeysValuesAll KnownKey t =>
Record (K String) t
demoteKeys = Proxy KnownKey
-> Record (K String) 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (KnownKey k v, KeysValuesAll KnownKey left,
     KeysValuesAll KnownKey right) =>
    Record (K String) left
    -> Record (K String) right
    -> Record (K String) ('N color left k v right))
-> Record (K String) t
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy KnownKey
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (KnownKey k v, KeysValuesAll KnownKey left,
     KeysValuesAll KnownKey right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @KnownKey) Record (K String) 'E
forall {q} (f :: q -> *). Record f 'E
unit Record (K String) left
-> Record (K String) right
-> Record (K String) ('N color left k v right)
forall {q} (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KnownKey k v, KeysValuesAll KnownKey left,
 KeysValuesAll KnownKey right) =>
Record (K String) left
-> Record (K String) right
-> Record (K String) ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KnownKey k v, KeysValuesAll KnownKey left,
 KeysValuesAll KnownKey right) =>
Record (K String) left
-> Record (K String) right
-> Record (K String) ('N color left k v right)
go
    where
    go :: forall left k v right color. (KnownKey k v, KeysValuesAll KnownKey left, KeysValuesAll KnownKey right) 
       => Record (K String) left 
       -> Record (K String) right 
       -> Record (K String) (N color left k v right)
    go :: forall {q} (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KnownKey k v, KeysValuesAll KnownKey left,
 KeysValuesAll KnownKey right) =>
Record (K String) left
-> Record (K String) right
-> Record (K String) ('N color left k v right)
go Record (K String) left
left Record (K String) right
right = Record (K String) left
-> K String v
-> Record (K String) right
-> Record (K String) ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record (K String) left
left (String -> K String v
forall k a (b :: k). a -> K a b
K (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @k))) Record (K String) right
right 

{- |
  Two-place constraint saying that a 'Symbol' key can be demoted to 'String'. Nothing is required from the corresponding value.

  Defined using the "class synonym" <https://www.reddit.com/r/haskell/comments/ab8ypl/monthly_hask_anything_january_2019/edk1ot3/ trick>.
-}
type KnownKey :: Symbol -> q -> Constraint
class KnownSymbol k => KnownKey (k :: Symbol) (v :: q)
instance KnownSymbol k => KnownKey k v 


{- | 
  Create a record containing the names of each field along with a term-level
  representation of each type.

>>> putStrLn $ prettyShow_Record show $ demoteEntries @(FromList [ '("foo",Char), '("bar",Bool) ])
{bar = K ("bar",Bool), foo = K ("foo",Char)}

-}
demoteEntries :: forall t. KeysValuesAll KnownKeyTypeableValue t => Record (K (String,TypeRep)) t
demoteEntries :: forall {q} (t :: Map Symbol q).
KeysValuesAll KnownKeyTypeableValue t =>
Record (K (String, TypeRep)) t
demoteEntries = Proxy KnownKeyTypeableValue
-> Record (K (String, TypeRep)) 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (KnownKeyTypeableValue k v,
     KeysValuesAll KnownKeyTypeableValue left,
     KeysValuesAll KnownKeyTypeableValue right) =>
    Record (K (String, TypeRep)) left
    -> Record (K (String, TypeRep)) right
    -> Record (K (String, TypeRep)) ('N color left k v right))
-> Record (K (String, TypeRep)) t
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy KnownKeyTypeableValue
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (KnownKeyTypeableValue k v,
     KeysValuesAll KnownKeyTypeableValue left,
     KeysValuesAll KnownKeyTypeableValue right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @KnownKeyTypeableValue) Record (K (String, TypeRep)) 'E
forall {q} (f :: q -> *). Record f 'E
unit Record (K (String, TypeRep)) left
-> Record (K (String, TypeRep)) right
-> Record (K (String, TypeRep)) ('N color left k v right)
forall {q} (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KnownKeyTypeableValue k v,
 KeysValuesAll KnownKeyTypeableValue left,
 KeysValuesAll KnownKeyTypeableValue right) =>
Record (K (String, TypeRep)) left
-> Record (K (String, TypeRep)) right
-> Record (K (String, TypeRep)) ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KnownKeyTypeableValue k v,
 KeysValuesAll KnownKeyTypeableValue left,
 KeysValuesAll KnownKeyTypeableValue right) =>
Record (K (String, TypeRep)) left
-> Record (K (String, TypeRep)) right
-> Record (K (String, TypeRep)) ('N color left k v right)
go
    where
    go :: forall left k v right color. (KnownKeyTypeableValue k v, KeysValuesAll KnownKeyTypeableValue left, KeysValuesAll KnownKeyTypeableValue right) 
       => Record (K (String,TypeRep)) left 
       -> Record (K (String,TypeRep)) right 
       -> Record (K (String,TypeRep)) (N color left k v right)
    go :: forall {q} (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(KnownKeyTypeableValue k v,
 KeysValuesAll KnownKeyTypeableValue left,
 KeysValuesAll KnownKeyTypeableValue right) =>
Record (K (String, TypeRep)) left
-> Record (K (String, TypeRep)) right
-> Record (K (String, TypeRep)) ('N color left k v right)
go Record (K (String, TypeRep)) left
left Record (K (String, TypeRep)) right
right = Record (K (String, TypeRep)) left
-> K (String, TypeRep) v
-> Record (K (String, TypeRep)) right
-> Record (K (String, TypeRep)) ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record (K (String, TypeRep)) left
left ((String, TypeRep) -> K (String, TypeRep) v
forall k a (b :: k). a -> K a b
K (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @k),Proxy v -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall (t :: q). Proxy t
forall {k} (t :: k). Proxy t
Proxy @v))) Record (K (String, TypeRep)) right
right 

{- |
  Two-place constraint saying that a 'Symbol' key can be demoted to 'String', and that the corresponding value 'Type' has a term-level representation. 

  Defined using the "class synonym" <https://www.reddit.com/r/haskell/comments/ab8ypl/monthly_hask_anything_january_2019/edk1ot3/ trick>.
-}
type KnownKeyTypeableValue :: Symbol -> q -> Constraint
class (KnownSymbol k, Typeable v) => KnownKeyTypeableValue (k :: Symbol) (v :: q)
instance (KnownSymbol k, Typeable v) => KnownKeyTypeableValue k v 

{- |
  Lifts two one-place constraints (one for keys, one for values) to a two-place constraint. Useful with function like 'cpure_Record'.

  Defined using the "class synonym" <https://www.reddit.com/r/haskell/comments/ab8ypl/monthly_hask_anything_january_2019/edk1ot3/ trick>.
-}
type KeyValueConstraints :: (Symbol -> Constraint) -> (q -> Constraint) -> Symbol -> q -> Constraint
class (kc k, vc v) => KeyValueConstraints (kc :: Symbol -> Constraint) (vc :: q -> Constraint) (k :: Symbol) (v :: q)
instance (kc k, vc v) => KeyValueConstraints kc vc k v

{- |
  Lifts a one-place constraint for values to a two-place constraint. Useful with function like 'cpure_Record'.

  Defined using the "class synonym" <https://www.reddit.com/r/haskell/comments/ab8ypl/monthly_hask_anything_january_2019/edk1ot3/ trick>.
-}
type ValueConstraint :: (q -> Constraint) -> Symbol -> q -> Constraint
class (vc v) => ValueConstraint (vc :: q -> Constraint) (k :: Symbol) (v :: q)
instance (vc v) => ValueConstraint vc k v

--
--

{- | An extensible product-like type with named fields.
 
     The values in the 'Record' come wrapped in a type constructor @f@, which
     for pure records will be the identity functor 'I'.

     See also 'insert', 'delete' and 'project'.
-}
type Record :: (q -> Type) -> Map Symbol q -> Type
data Record (f :: q -> Type) (t :: Map Symbol q) where
    Empty :: Record f E 
    Node  :: Record f left -> f v -> Record f right -> Record f (N color left k v right)

instance (Productlike '[] t result, Show (NP f result)) => Show (Record f t) where
    show :: Record f t -> String
show Record f t
x = String
"fromNP (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NP f result -> String
forall a. Show a => a -> String
show (Record f t -> NP f result
forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP Record f t
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

instance ToRecord (Record I (t :: Map Symbol Type)) where
    type RecordCode (Record I t)  = t
    toRecord :: Record I t -> Record I (RecordCode (Record I t))
toRecord = Record I t -> Record I t
Record I t -> Record I (RecordCode (Record I t))
forall a. a -> a
id

instance FromRecord (Record I (t :: Map Symbol Type)) where
    fromRecord :: Record I (RecordCode (Record I t)) -> Record I t
fromRecord = Record I t -> Record I t
Record I (RecordCode (Record I t)) -> Record I t
forall a. a -> a
id

{-# DEPRECATED collapse_Record "Use collapse'_Record" #-}
collapse_Record :: forall t result a. (Productlike '[] t result) => Record (K a) t -> [a]
collapse_Record :: forall {q} (t :: Map Symbol q) (result :: [q]) a.
Productlike '[] t result =>
Record (K a) t -> [a]
collapse_Record = NP (K a) result -> [a]
forall {k} a (xs :: [k]). NP (K a) xs -> [a]
collapse_NP (NP (K a) result -> [a])
-> (Record (K a) t -> NP (K a) result) -> Record (K a) t -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record (K a) t -> NP (K a) result
forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP


{- | Show a 'Record' in a friendlier way than the default 'Show' instance. The
     function argument will usually be 'show', but it can be used to unwrap the
     value of each field before showing it.
-}
prettyShow_Record :: forall t f. (Maplike t, KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) 
                  => (forall x. Show x => f x -> String) 
                  -> Record f t 
                  -> String
prettyShow_Record :: forall (t :: Map Symbol (*)) (f :: * -> *).
(Maplike t,
 KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) =>
(forall x. Show x => f x -> String) -> Record f t -> String
prettyShow_Record forall x. Show x => f x -> String
showf Record f t
r = 
    let showfs :: Record ((,) String :.: Case f String) t
showfs = Proxy Show
-> (forall v.
    Show v =>
    String -> (:.:) ((,) String) (Case f String) v)
-> Record ((,) String :.: Case f String) t
forall {q} (c :: q -> Constraint) (t :: Map Symbol q)
       (f :: q -> *).
KeysValuesAll (KeyValueConstraints KnownSymbol c) t =>
Proxy c -> (forall (v :: q). c v => String -> f v) -> Record f t
cpure'_Record (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Show) ((forall v.
  Show v =>
  String -> (:.:) ((,) String) (Case f String) v)
 -> Record ((,) String :.: Case f String) t)
-> (forall v.
    Show v =>
    String -> (:.:) ((,) String) (Case f String) v)
-> Record ((,) String :.: Case f String) t
forall a b. (a -> b) -> a -> b
$ \String
fieldName -> (String, Case f String v) -> (:.:) ((,) String) (Case f String) v
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (String
fieldName, (f v -> String) -> Case f String v
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case  f v -> String
forall x. Show x => f x -> String
showf)
        entries :: Record (K [String]) t
entries = (forall a.
 (:.:) ((,) String) (Case f String) a -> f a -> K [String] a)
-> Record ((,) String :.: Case f String) t
-> Record f t
-> Record (K [String]) t
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
Maplike t =>
(forall a. f a -> g a -> h a)
-> Record f t -> Record g t -> Record h t
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f t -> Record g t -> Record h t
liftA2_Record (\(Comp (String
fieldName,Case f a -> String
f)) f a
fv -> [String] -> K [String] a
forall k a (b :: k). a -> K a b
K [ String
fieldName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ f a -> String
f f a
fv ]) Record ((,) String :.: Case f String) t
showfs Record f t
r
     in String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Monoid a => [a] -> a
mconcat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " (Record (K [String]) t -> [String]
forall a. Monoid a => Record (K a) t -> a
forall (t :: Map Symbol (*)) a.
(Maplike t, Monoid a) =>
Record (K a) t -> a
collapse'_Record Record (K [String]) t
entries)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"


{- | Like 'prettyShow_Record' but specialized to pure records.
-}
prettyShow_RecordI :: forall t. (Maplike t, KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) => Record I t -> String
prettyShow_RecordI :: forall (t :: Map Symbol (*)).
(Maplike t,
 KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) =>
Record I t -> String
prettyShow_RecordI Record I t
r = (forall x. Show x => I x -> String) -> Record I t -> String
forall (t :: Map Symbol (*)) (f :: * -> *).
(Maplike t,
 KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) =>
(forall x. Show x => f x -> String) -> Record f t -> String
prettyShow_Record (x -> String
forall a. Show a => a -> String
show (x -> String) -> (I x -> x) -> I x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> x
forall a. I a -> a
unI) Record I t
r 


{-# DEPRECATED prettyShowRecord "Use prettyShow_Record" #-}
prettyShowRecord :: forall t flat f. (KeysValuesAll KnownKey t,Productlike '[] t flat, All Show flat, SListI flat) 
                 => (forall x. Show x => f x -> String) 
                 -> Record f t 
                 -> String
prettyShowRecord :: forall (t :: Map Symbol (*)) (flat :: [*]) (f :: * -> *).
(KeysValuesAll KnownKey t, Productlike '[] t flat, All Show flat,
 SListI flat) =>
(forall x. Show x => f x -> String) -> Record f t -> String
prettyShowRecord forall x. Show x => f x -> String
showf Record f t
r = 
    let keysflat :: NP (K String) flat
keysflat = forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
forall (t :: Map Symbol (*)) (result :: [*]) (f :: * -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP @t (forall {q} (t :: Map Symbol q).
KeysValuesAll KnownKey t =>
Record (K String) t
forall (t :: Map Symbol (*)).
KeysValuesAll KnownKey t =>
Record (K String) t
demoteKeys @t)
        valuesflat :: NP f flat
valuesflat = forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
forall (t :: Map Symbol (*)) (result :: [*]) (f :: * -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP @t Record f t
r
        entries :: NP (K String) flat
entries = Proxy Show
-> (forall a. Show a => K String a -> f a -> K String a)
-> NP (K String) flat
-> NP f flat
-> NP (K String) flat
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *) (g :: k -> *)
       (h :: k -> *).
All c xs =>
proxy c
-> (forall (a :: k). c a => f a -> g a -> h a)
-> NP f xs
-> NP g xs
-> NP h xs
cliftA2_NP (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Show) (\(K String
key) f a
fv -> String -> K String a
forall k a (b :: k). a -> K a b
K (String
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ f a -> String
forall x. Show x => f x -> String
showf f a
fv))
                                           NP (K String) flat
keysflat 
                                           NP f flat
valuesflat
     in String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Monoid a => [a] -> a
mconcat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " (NP (K String) flat -> [String]
forall {k} a (xs :: [k]). NP (K a) xs -> [a]
collapse_NP NP (K String) flat
entries)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"


{-# DEPRECATED prettyShowRecordI "Use prettyShow_RecordI" #-}
prettyShowRecordI :: forall t flat. (KeysValuesAll KnownKey t,Productlike '[] t flat, All Show flat, SListI flat) => Record I t -> String
prettyShowRecordI :: forall (t :: Map Symbol (*)) (flat :: [*]).
(KeysValuesAll KnownKey t, Productlike '[] t flat, All Show flat,
 SListI flat) =>
Record I t -> String
prettyShowRecordI Record I t
r = (forall x. Show x => I x -> String) -> Record I t -> String
forall (t :: Map Symbol (*)) (flat :: [*]) (f :: * -> *).
(KeysValuesAll KnownKey t, Productlike '[] t flat, All Show flat,
 SListI flat) =>
(forall x. Show x => f x -> String) -> Record f t -> String
prettyShowRecord (x -> String
forall a. Show a => a -> String
show (x -> String) -> (I x -> x) -> I x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> x
forall a. I a -> a
unI) Record I t
r 

{-| A Record without components is a boring, uninformative type whose single value can be conjured out of thin air.
-}
unit :: Record f Empty
unit :: forall {q} (f :: q -> *). Record f 'E
unit = Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty

{- | An extensible sum-like type with named branches.
 
     The values in the 'Variant' come wrapped in a type constructor @f@, which
     por pure variants will be the identity functor 'I'.

     See also 'widen', 'winnow' and 'inject'.
-}
type Variant :: (q -> Type) -> Map Symbol q -> Type
data Variant (f :: q -> Type) (t :: Map Symbol q)  where
    Here       :: f v -> Variant f (N color left k v right)
    LookRight  :: Variant f t -> Variant f (N color' left' k' v' t)
    LookLeft   :: Variant f t -> Variant f (N color' t k' v' right')

instance (Sumlike '[] t result, Show (NS f result)) => Show (Variant f t) where
    show :: Variant f t -> String
show Variant f t
x = String
"fromNS (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NS f result -> String
forall a. Show a => a -> String
show (Variant f t -> NS f result
forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Sumlike '[] t result =>
Variant f t -> NS f result
toNS Variant f t
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

{-| A Variant without branches doesn't have any values. From an impossible thing, anything can come out. 
-}
impossible :: Variant f Empty -> b
impossible :: forall {q} (f :: q -> *) b. Variant f Empty -> b
impossible Variant f Empty
v = case Variant f Empty
v of


{- | Show a 'Variant' in a friendlier way than the default 'Show' instance. The
     function argument will usually be 'show', but it can be used to unwrap the
     value of the branch before showing it.
-}
prettyShow_Variant :: forall t flat f. (Maplike t, KeysValuesAll (KeyValueConstraints KnownSymbol Show) t)
                   => (forall x. Show x => f x -> String) 
                   -> Variant f t 
                   -> String
prettyShow_Variant :: forall {k} (t :: Map Symbol (*)) (flat :: k) (f :: * -> *).
(Maplike t,
 KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) =>
(forall x. Show x => f x -> String) -> Variant f t -> String
prettyShow_Variant forall x. Show x => f x -> String
showf Variant f t
v = 
    let showfs :: Record ((,) String :.: Case f String) t
showfs = Proxy Show
-> (forall v.
    Show v =>
    String -> (:.:) ((,) String) (Case f String) v)
-> Record ((,) String :.: Case f String) t
forall {q} (c :: q -> Constraint) (t :: Map Symbol q)
       (f :: q -> *).
KeysValuesAll (KeyValueConstraints KnownSymbol c) t =>
Proxy c -> (forall (v :: q). c v => String -> f v) -> Record f t
cpure'_Record (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Show) ((forall v.
  Show v =>
  String -> (:.:) ((,) String) (Case f String) v)
 -> Record ((,) String :.: Case f String) t)
-> (forall v.
    Show v =>
    String -> (:.:) ((,) String) (Case f String) v)
-> Record ((,) String :.: Case f String) t
forall a b. (a -> b) -> a -> b
$ \String
fieldName -> (String, Case f String v) -> (:.:) ((,) String) (Case f String) v
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (String
fieldName, (f v -> String) -> Case f String v
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case f v -> String
forall x. Show x => f x -> String
showf)
        entries :: Variant (K String) t
entries = (forall a.
 (:.:) ((,) String) (Case f String) a -> f a -> K String a)
-> Record ((,) String :.: Case f String) t
-> Variant f t
-> Variant (K String) t
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
Maplike t =>
(forall a. f a -> g a -> h a)
-> Record f t -> Variant g t -> Variant h t
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f t -> Variant g t -> Variant h t
liftA2_Variant (\(Comp (String
fieldName,Case f a -> String
f)) f a
fv -> String -> K String a
forall k a (b :: k). a -> K a b
K (String
fieldName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ f a -> String
f f a
fv String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")) Record ((,) String :.: Case f String) t
showfs Variant f t
v
     in Variant (K String) t -> String
forall a. Variant (K a) t -> a
forall (t :: Map Symbol (*)) a. Maplike t => Variant (K a) t -> a
collapse_Variant Variant (K String) t
entries

{- | Like 'prettyShow_Variant' but specialized to pure variants.
-}
prettyShow_VariantI :: forall t flat. (Maplike t, KeysValuesAll (KeyValueConstraints KnownSymbol Show) t)
                    => Variant I t -> String
prettyShow_VariantI :: forall {k} (t :: Map Symbol (*)) (flat :: k).
(Maplike t,
 KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) =>
Variant I t -> String
prettyShow_VariantI Variant I t
v = (forall x. Show x => I x -> String) -> Variant I t -> String
forall {k} (t :: Map Symbol (*)) (flat :: k) (f :: * -> *).
(Maplike t,
 KeysValuesAll (KeyValueConstraints KnownSymbol Show) t) =>
(forall x. Show x => f x -> String) -> Variant f t -> String
prettyShow_Variant (x -> String
forall a. Show a => a -> String
show (x -> String) -> (I x -> x) -> I x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> x
forall a. I a -> a
unI) Variant I t
v 


{-# DEPRECATED prettyShowVariant "Use prettyShow_Variant" #-}
prettyShowVariant :: forall t flat f. (KeysValuesAll KnownKey t,Productlike '[] t flat, Sumlike '[] t flat, All Show flat, SListI flat)
                  => (forall x. Show x => f x -> String) 
                  -> Variant f t 
                  -> String
prettyShowVariant :: forall (t :: Map Symbol (*)) (flat :: [*]) (f :: * -> *).
(KeysValuesAll KnownKey t, Productlike '[] t flat,
 Sumlike '[] t flat, All Show flat, SListI flat) =>
(forall x. Show x => f x -> String) -> Variant f t -> String
prettyShowVariant forall x. Show x => f x -> String
showf Variant f t
v = 
    let keysflat :: NP (K String) flat
keysflat = forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
forall (t :: Map Symbol (*)) (result :: [*]) (f :: * -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP @t (forall {q} (t :: Map Symbol q).
KeysValuesAll KnownKey t =>
Record (K String) t
forall (t :: Map Symbol (*)).
KeysValuesAll KnownKey t =>
Record (K String) t
demoteKeys @t)
        eliminators :: NP (f -.-> K String) flat
eliminators = Proxy Show
-> (forall a. Show a => K String a -> (-.->) f (K String) a)
-> NP (K String) flat
-> NP (f -.-> K String) flat
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *) (g :: k -> *).
All c xs =>
proxy c
-> (forall (a :: k). c a => f a -> g a) -> NP f xs -> NP g xs
cliftA_NP (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Show) (\(K String
k) -> (f a -> K String a) -> (-.->) f (K String) a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
(f a -> g a) -> (-.->) f g a
Fn (\f a
fv -> (String -> K String a
forall k a (b :: k). a -> K a b
K (String
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ f a -> String
forall x. Show x => f x -> String
showf f a
fv String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")))) NP (K String) flat
keysflat
        valuesflat :: NS f flat
valuesflat = forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Sumlike '[] t result =>
Variant f t -> NS f result
forall (t :: Map Symbol (*)) (result :: [*]) (f :: * -> *).
Sumlike '[] t result =>
Variant f t -> NS f result
toNS @t Variant f t
v
     in NS (K String) flat -> String
forall {k} a (xs :: [k]). NS (K a) xs -> a
collapse_NS (NP (f -.-> K String) flat -> NS f flat -> NS (K String) flat
forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]).
NP (f -.-> g) xs -> NS f xs -> NS g xs
ap_NS NP (f -.-> K String) flat
eliminators NS f flat
valuesflat)

{-# DEPRECATED prettyShowVariantI "Use prettyShow_VariantI" #-}
prettyShowVariantI :: forall t flat. (KeysValuesAll KnownKey t,Productlike '[] t flat, Sumlike '[] t flat, All Show flat, SListI flat) 
                   => Variant I t -> String
prettyShowVariantI :: forall (t :: Map Symbol (*)) (flat :: [*]).
(KeysValuesAll KnownKey t, Productlike '[] t flat,
 Sumlike '[] t flat, All Show flat, SListI flat) =>
Variant I t -> String
prettyShowVariantI Variant I t
v = (forall x. Show x => I x -> String) -> Variant I t -> String
forall (t :: Map Symbol (*)) (flat :: [*]) (f :: * -> *).
(KeysValuesAll KnownKey t, Productlike '[] t flat,
 Sumlike '[] t flat, All Show flat, SListI flat) =>
(forall x. Show x => f x -> String) -> Variant f t -> String
prettyShowVariant (x -> String
forall a. Show a => a -> String
show (x -> String) -> (I x -> x) -> I x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> x
forall a. I a -> a
unI) Variant I t
v 

--
--
-- Insertion

{- | Insert a list of type level key / value pairs into a type-level map. 
-}
type InsertAll :: [(Symbol,q)] -> Map Symbol q -> Map Symbol q
type family InsertAll (es :: [(Symbol,q)]) (t :: Map Symbol q) :: Map Symbol q where
    InsertAll '[] t = t
    InsertAll ( '(name,fieldType) ': es ) t = Insert name fieldType (InsertAll es t)

{- | Build a type-level map out of a list of type level key / value pairs. 
-}
type FromList (es :: [(Symbol,q)]) = InsertAll es Empty


{- |
     Adds a new field to a 'Record'.

>>> project @"foo" (insert @"foo" (I 'a') unit)
I 'a'

>>> project @"foo" (insert @"foo" @Char Nothing unit)
Nothing

 -}
insert :: forall k v t f. Insertable k v t => f v -> Record f t -> Record f (Insert k v t)
insert :: forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
insert = forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
_insert @_ @k @v @t @f

{- |
     Lets you use a 'Variant' in a bigger context
     than the one in which is was defined. 
 -}
widen :: forall k v t f. Insertable k v t => Variant f t -> Variant f (Insert k v t)
widen :: forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Insertable k v t =>
Variant f t -> Variant f (Insert k v t)
widen = forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Insertable k v t =>
Variant f t -> Variant f (Insert k v t)
_widen @_ @k @v @t @f

{- | Alias for 'insert'. 
-}
addField :: forall k v t f. Insertable k v t => f v -> Record f t -> Record f (Insert k v t)
addField :: forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
addField = forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
forall (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
insert @k @v @t @f

{- | Like 'insert' but specialized to pure 'Record's.
 
>>> projectI @"foo" (insertI @"foo" 'a' unit)
'a'

-}
insertI :: forall k v t . Insertable k v t => v -> Record I t -> Record I (Insert k v t)
insertI :: forall (k :: Symbol) v (t :: Map Symbol (*)).
Insertable k v t =>
v -> Record I t -> Record I (Insert k v t)
insertI = forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
forall (k :: Symbol) v (t :: Map Symbol (*)) (f :: * -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
insert @k @v @t (I v -> Record I t -> Record I (MakeBlack (Insert1 k v t)))
-> (v -> I v)
-> v
-> Record I t
-> Record I (MakeBlack (Insert1 k v t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> I v
forall a. a -> I a
I

{- | Like 'addField' but specialized to pure 'Record's.
-}
addFieldI :: forall k v t . Insertable k v t => v -> Record I t -> Record I (Insert k v t)
addFieldI :: forall (k :: Symbol) v (t :: Map Symbol (*)).
Insertable k v t =>
v -> Record I t -> Record I (Insert k v t)
addFieldI = forall (k :: Symbol) v (t :: Map Symbol (*)).
Insertable k v t =>
v -> Record I t -> Record I (Insert k v t)
insertI @k @v @t

{- | Class that determines if the pair of a 'Symbol' key and a type can
     be inserted into a type-level map.
 
     The associated type family 'Insert' produces the resulting map.

     At the term level, this manifests in 'insert', which adds a new field to a
     record, and in 'widen', which lets you use a 'Variant' in a bigger context
     than the one in which is was defined. 'insert' tends to be more useful in
     practice.

     If the map already has the key but with a /different/ type, the
     insertion fails to compile.
 -}
type Insertable :: Symbol -> q -> Map Symbol q -> Constraint
class Insertable (k :: Symbol) (v :: q) (t :: Map Symbol q) where
    type Insert k v t :: Map Symbol q
    _insert :: f v -> Record f t -> Record f (Insert k v t)
    _widen :: Variant f t -> Variant f (Insert k v t)

-- insert x s =
--  T B a z b
--  where
--  T _ a z b = ins s
instance (InsertableHelper1 k v t, Insert1 k v t ~ inserted, CanMakeBlack inserted) => Insertable k v t where
    type Insert k v t = MakeBlack (Insert1 k v t)
    _insert :: forall (f :: q -> *). f v -> Record f t -> Record f (Insert k v t)
_insert f v
fv Record f t
r = forall q (t :: Map Symbol q) (f :: q -> *).
CanMakeBlack t =>
Record f t -> Record f (MakeBlack t)
makeBlackR @_ (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
f v -> Record f t -> Record f (Insert1 k v t)
insert1 @_ @k @v f v
fv Record f t
r) 
    _widen :: forall (f :: q -> *). Variant f t -> Variant f (Insert k v t)
_widen Variant f t
v = forall q (t :: Map Symbol q) (f :: q -> *).
CanMakeBlack t =>
Variant f t -> Variant f (MakeBlack t)
makeBlackV @_ (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
Variant f t -> Variant f (Insert1 k v t)
widen1 @_ @k @v Variant f t
v)

class CanMakeBlack (t :: Map Symbol q) where
    type MakeBlack t :: Map Symbol q
    makeBlackR :: Record f t -> Record f (MakeBlack t)
    makeBlackV :: Variant f t -> Variant f (MakeBlack t)

instance CanMakeBlack (N color left k v right) where
    type MakeBlack (N color left k v right) = N B left k v right
    makeBlackR :: forall (f :: q -> *).
Record f ('N color left k v right)
-> Record f (MakeBlack ('N color left k v right))
makeBlackR (Node Record f left
left f v
fv Record f right
right) = Record f left
-> f v -> Record f right -> Record f ('N 'B left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
fv Record f right
right
    makeBlackV :: forall (f :: q -> *).
Variant f ('N color left k v right)
-> Variant f (MakeBlack ('N color left k v right))
makeBlackV Variant f ('N color left k v right)
v = case Variant f ('N color left k v right)
v of
        LookLeft Variant f t
l -> Variant f t -> Variant f ('N 'B t k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
l
        Here f v
v -> f v -> Variant f ('N 'B left k v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v
        LookRight Variant f t
r -> Variant f t -> Variant f ('N 'B left k v t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
r

instance CanMakeBlack E where
    type MakeBlack E = E
    makeBlackR :: forall (f :: q -> *). Record f 'E -> Record f (MakeBlack 'E)
makeBlackR Record f 'E
Empty = Record f (MakeBlack 'E)
Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    makeBlackV :: forall (f :: q -> *). Variant f 'E -> Variant f (MakeBlack 'E)
makeBlackV = Variant f 'E -> Variant f (MakeBlack 'E)
Variant f 'E -> Variant f 'E
forall {q} (f :: q -> *) b. Variant f Empty -> b
impossible

-- for some reason, removing the "inline" kind signatures causes a compilation error
type InsertableHelper1 :: Symbol -> q -> Map Symbol q -> Constraint
class InsertableHelper1 (k :: Symbol) 
                        (v :: q) 
                        (t :: Map Symbol q) where
    type Insert1 k v t :: Map Symbol q 
    insert1 :: f v -> Record f t -> Record f (Insert1 k v t)
    widen1 :: Variant f t -> Variant f (Insert1 k v t)

instance InsertableHelper1 k v E where
    type Insert1 k v E = N R E k v E
    insert1 :: forall (f :: q -> *).
f v -> Record f 'E -> Record f (Insert1 k v 'E)
insert1 f v
fv Record f 'E
Empty = Record f 'E -> f v -> Record f 'E -> Record f ('N 'R 'E k v 'E)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty f v
fv Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty 
    widen1 :: forall (f :: q -> *). Variant f 'E -> Variant f (Insert1 k v 'E)
widen1 = Variant f 'E -> Variant f (Insert1 k v 'E)
Variant f 'E -> Variant f ('N 'R 'E k v 'E)
forall {q} (f :: q -> *) b. Variant f Empty -> b
impossible 
 
instance (CmpSymbol k k' ~ ordering, 
          InsertableHelper2 ordering k v color left k' v' right
         )
         => InsertableHelper1 k v (N color left k' v' right) where
    -- FIXME possible duplicate work with CmpSymbol: both in constraint and in associated type family. 
    -- Is that bad? How to avoid it?
    type Insert1 k v (N color left k' v' right) = Insert2 (CmpSymbol k k') k v color left k' v' right  
    insert1 :: forall (f :: q -> *).
f v
-> Record f ('N color left k' v' right)
-> Record f (Insert1 k v ('N color left k' v' right))
insert1 = forall q (ordering :: Ordering) (k :: Symbol) (v :: q)
       (color :: Color) (left :: Map Symbol q) (k' :: Symbol) (v' :: q)
       (right :: Map Symbol q) (f :: q -> *).
InsertableHelper2 ordering k v color left k' v' right =>
f v
-> Record f ('N color left k' v' right)
-> Record f (Insert2 ordering k v color left k' v' right)
insert2 @_ @ordering @k @v @color @left @k' @v' @right
    widen1 :: forall (f :: q -> *).
Variant f ('N color left k' v' right)
-> Variant f (Insert1 k v ('N color left k' v' right))
widen1  = forall q (ordering :: Ordering) (k :: Symbol) (v :: q)
       (color :: Color) (left :: Map Symbol q) (k' :: Symbol) (v' :: q)
       (right :: Map Symbol q) (f :: q -> *).
InsertableHelper2 ordering k v color left k' v' right =>
Variant f ('N color left k' v' right)
-> Variant f (Insert2 ordering k v color left k' v' right)
widen2 @_ @ordering @k @v @color @left @k' @v' @right

class InsertableHelper2 (ordering :: Ordering) 
                        (k :: Symbol) 
                        (v :: q) 
                        (color :: Color) 
                        (left :: Map Symbol q) 
                        (k' :: Symbol) 
                        (v' :: q) 
                        (right :: Map Symbol q) where
    type Insert2 ordering k v color left k' v' right :: Map Symbol q 
    insert2 :: f v -> Record f (N color left k' v' right) -> Record f (Insert2 ordering k v color left k' v' right)
    widen2 :: Variant f (N color left k' v' right) -> Variant f (Insert2 ordering k v color left k' v' right)

--  ins s@(T B a y b)
--      | x<y = balance (ins a) y b
instance (InsertableHelper1 k v left, Insert1 k v left ~ inserted,
          Balanceable inserted k' v' right 
         )
         => InsertableHelper2 LT k v B left k' v' right where
    type Insert2              LT k v B left k' v' right = Balance (Insert1 k v left) k' v' right
    insert2 :: forall (f :: q -> *).
f v
-> Record f ('N 'B left k' v' right)
-> Record f (Insert2 'LT k v 'B left k' v' right)
insert2 f v
fv (Node Record f left
left f v
fv' Record f right
right) = forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Record f ('N color left k v right)
-> Record f (Balance left k v right)
balanceR @_ @_ @k' @v' @right (Record f inserted
-> f v' -> Record f right -> Record f ('N Any inserted k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
f v -> Record f t -> Record f (Insert1 k v t)
insert1 @_ @k @v f v
fv Record f left
left) f v'
f v
fv' Record f right
Record f right
right) 
    widen2 :: forall (f :: q -> *).
Variant f ('N 'B left k' v' right)
-> Variant f (Insert2 'LT k v 'B left k' v' right)
widen2 Variant f ('N 'B left k' v' right)
v = forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @(Insert1 k v left) @k' @v' @right (Variant f ('N Any (Insert1 k v left) k' v' right)
 -> Variant f (Balance (Insert1 k v left) k' v' right))
-> Variant f ('N Any (Insert1 k v left) k' v' right)
-> Variant f (Balance (Insert1 k v left) k' v' right)
forall a b. (a -> b) -> a -> b
$ case Variant f ('N 'B left k' v' right)
v of
        Here f v
x -> f v' -> Variant f ('N Any inserted k' v' right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v'
f v
x
        LookLeft Variant f t
x -> Variant f inserted -> Variant f ('N Any inserted k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
Variant f t -> Variant f (Insert1 k v t)
widen1 @_ @k @v Variant f t
x)
        LookRight Variant f t
x -> Variant f right -> Variant f ('N Any inserted k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f right
Variant f t
x

--  ins s@(T B a y b)
--      | x<y = balance (ins a) y b
instance (InsertableHelper1 k v left, Insert1 k v left ~ inserted,
          Balanceable inserted k' v' right
         )
         => InsertableHelper2 LT k v R left k' v' right where
    type Insert2              LT k v R left k' v' right = N R (Insert1 k v left) k' v' right
    insert2 :: forall (f :: q -> *).
f v
-> Record f ('N 'R left k' v' right)
-> Record f (Insert2 'LT k v 'R left k' v' right)
insert2 f v
fv (Node Record f left
left f v
fv' Record f right
right) = Record f inserted
-> f v -> Record f right -> Record f ('N 'R inserted k' v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
f v -> Record f t -> Record f (Insert1 k v t)
insert1 @_ @k @v f v
fv Record f left
left) f v
fv' Record f right
right 
    widen2 :: forall (f :: q -> *).
Variant f ('N 'R left k' v' right)
-> Variant f (Insert2 'LT k v 'R left k' v' right)
widen2 Variant f ('N 'R left k' v' right)
v = case Variant f ('N 'R left k' v' right)
v of
        Here f v
x -> f v -> Variant f ('N 'R inserted k' v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x
        LookLeft Variant f t
x -> Variant f inserted -> Variant f ('N 'R inserted k' v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
Variant f t -> Variant f (Insert1 k v t)
widen1 @_ @k @v Variant f t
x)
        LookRight Variant f t
x -> Variant f t -> Variant f ('N 'R inserted k' v' t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x


-- This instance implies that we can't change the type associated to an
-- existing key. If we did that, we wouldn't be able to widen Variants that
-- happen to match that key!
instance InsertableHelper2 EQ k v color left k v right where
    type Insert2           EQ k v color left k v right = N color left k v right
    insert2 :: forall (f :: q -> *).
f v
-> Record f ('N color left k v right)
-> Record f (Insert2 'EQ k v color left k v right)
insert2 f v
fv (Node Record f left
left f v
_ Record f right
right) = Record f left
-> f v -> Record f right -> Record f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
fv Record f right
right
    widen2 :: forall (f :: q -> *).
Variant f ('N color left k v right)
-> Variant f (Insert2 'EQ k v color left k v right)
widen2 = Variant f ('N color left k v right)
-> Variant f (Insert2 'EQ k v color left k v right)
Variant f ('N color left k v right)
-> Variant f ('N color left k v right)
forall a. a -> a
id

--  ins s@(T B a y b)
--      | ...
--      | x>y = balance a y (ins b)
instance (InsertableHelper1 k v right, Insert1 k v right ~ inserted,
          Balanceable left  k' v' inserted
         )
         => InsertableHelper2 GT k v B left k' v' right where
    type Insert2              GT k v B left k' v' right = Balance left  k' v' (Insert1 k v right)
    insert2 :: forall (f :: q -> *).
f v
-> Record f ('N 'B left k' v' right)
-> Record f (Insert2 'GT k v 'B left k' v' right)
insert2 f v
fv (Node Record f left
left f v
fv' Record f right
right) = forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Record f ('N color left k v right)
-> Record f (Balance left k v right)
balanceR @_ @left @k' @v' @_ (Record f left
-> f v'
-> Record f inserted
-> Record f ('N Any left k' v' inserted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
Record f left
left  f v'
f v
fv' (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
f v -> Record f t -> Record f (Insert1 k v t)
insert1 @_ @k @v f v
fv Record f right
right)) 
    widen2 :: forall (f :: q -> *).
Variant f ('N 'B left k' v' right)
-> Variant f (Insert2 'GT k v 'B left k' v' right)
widen2 Variant f ('N 'B left k' v' right)
v = forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @left @k' @v' @(Insert1 k v right) (Variant f ('N Any left k' v' (Insert1 k v right))
 -> Variant f (Balance left k' v' (Insert1 k v right)))
-> Variant f ('N Any left k' v' (Insert1 k v right))
-> Variant f (Balance left k' v' (Insert1 k v right))
forall a b. (a -> b) -> a -> b
$ case Variant f ('N 'B left k' v' right)
v of
        Here f v
x -> f v' -> Variant f ('N Any left k' v' inserted)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v'
f v
x
        LookLeft Variant f t
x -> Variant f left -> Variant f ('N Any left k' v' inserted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f left
Variant f t
x
        LookRight Variant f t
x -> Variant f inserted -> Variant f ('N Any left k' v' inserted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
Variant f t -> Variant f (Insert1 k v t)
widen1 @_ @k @v Variant f t
x)

--  ins s@(T R a y b)
--      | ...
--      | x>y = T R a y (ins b)
instance (InsertableHelper1 k v right, Insert1 k v right ~ inserted,
          Balanceable left  k' v' inserted
         )
         => InsertableHelper2 GT k v R left k' v' right where
    type Insert2              GT k v R left k' v' right = N R left k' v' (Insert1 k v right)
    insert2 :: forall (f :: q -> *).
f v
-> Record f ('N 'R left k' v' right)
-> Record f (Insert2 'GT k v 'R left k' v' right)
insert2 f v
fv (Node Record f left
left f v
fv' Record f right
right) = Record f left
-> f v -> Record f inserted -> Record f ('N 'R left k' v inserted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
fv' (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
f v -> Record f t -> Record f (Insert1 k v t)
insert1 @_ @k @v f v
fv Record f right
right) 
    widen2 :: forall (f :: q -> *).
Variant f ('N 'R left k' v' right)
-> Variant f (Insert2 'GT k v 'R left k' v' right)
widen2 Variant f ('N 'R left k' v' right)
v = case Variant f ('N 'R left k' v' right)
v of
        Here f v
x -> f v -> Variant f ('N 'R left k' v inserted)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x
        LookLeft Variant f t
x -> Variant f t -> Variant f ('N 'R t k' v' inserted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x
        LookRight Variant f t
x -> Variant f inserted -> Variant f ('N 'R left k' v' inserted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
InsertableHelper1 k v t =>
Variant f t -> Variant f (Insert1 k v t)
widen1 @_ @k @v Variant f t
x)

data BalanceAction = BalanceSpecial
                   | BalanceLL
                   | BalanceLR
                   | BalanceRL
                   | BalanceRR
                   | DoNotBalance
                   deriving Int -> BalanceAction -> ShowS
[BalanceAction] -> ShowS
BalanceAction -> String
(Int -> BalanceAction -> ShowS)
-> (BalanceAction -> String)
-> ([BalanceAction] -> ShowS)
-> Show BalanceAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BalanceAction -> ShowS
showsPrec :: Int -> BalanceAction -> ShowS
$cshow :: BalanceAction -> String
show :: BalanceAction -> String
$cshowList :: [BalanceAction] -> ShowS
showList :: [BalanceAction] -> ShowS
Show

type ShouldBalance :: Map k' v' -> Map k' v' -> BalanceAction
type family ShouldBalance (left :: Map k' v') (right :: Map k' v') :: BalanceAction where
    ShouldBalance (N R _ _ _ _) (N R _ _ _ _) = BalanceSpecial
    ShouldBalance (N R (N R _ _ _ _) _ _ _) _ = BalanceLL
    ShouldBalance (N R _ _ _ (N R _ _ _ _)) _ = BalanceLR
    ShouldBalance _ (N R (N R _ _ _ _) _ _ _) = BalanceRL
    ShouldBalance _ (N R _ _ _ (N R _ _ _ _)) = BalanceRR
    ShouldBalance _ _                         = DoNotBalance

class Balanceable (left :: Map Symbol q) (k :: Symbol) (v :: q) (right :: Map Symbol q) where
    type Balance left k v right :: Map Symbol q
    balanceR :: Record f (N color left k v right) -> Record f (Balance left k v right)
    balanceV :: Variant f (N color left k v right) -> Variant f (Balance left k v right)

instance (ShouldBalance left right ~ action, 
          BalanceableHelper action left k v right
         ) 
         => Balanceable left k v right where
    -- FIXME possible duplicate work with ShouldBalance: both in constraint and in associated type family. 
    -- Is that bad? How to avoid it?
    type Balance left k v right = Balance' (ShouldBalance left right) left k v right
    balanceR :: forall (f :: q -> *) (color :: Color).
Record f ('N color left k v right)
-> Record f (Balance left k v right)
balanceR = forall q (action :: BalanceAction) (left :: Map Symbol q)
       (k :: Symbol) (v :: q) (right :: Map Symbol q) (f :: q -> *)
       (color :: Color).
BalanceableHelper action left k v right =>
Record f ('N color left k v right)
-> Record f (Balance' action left k v right)
balanceR' @_ @action @left @k @v @right
    balanceV :: forall (f :: q -> *) (color :: Color).
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV = forall q (action :: BalanceAction) (left :: Map Symbol q)
       (k :: Symbol) (v :: q) (right :: Map Symbol q) (f :: q -> *)
       (color :: Color).
BalanceableHelper action left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance' action left k v right)
balanceV' @_ @action @left @k @v @right
    
class BalanceableHelper (action :: BalanceAction) 
                        (left :: Map Symbol q) 
                        (k :: Symbol) 
                        (v :: q) 
                        (right :: Map Symbol q) where
    type Balance' action left k v right :: Map Symbol q
    balanceR' :: Record f (N color left k v right) -> Record f (Balance' action left k v right)
    balanceV' :: Variant f (N color left k v right) -> Variant f (Balance' action left k v right)

-- balance (T R a x b) y (T R c z d) = T R (T B a x b) y (T B c z d)
instance BalanceableHelper BalanceSpecial (N R left1 k1 v1 right1) kx vx (N R left2 k2 v2 right2) where
    type Balance'          BalanceSpecial (N R left1 k1 v1 right1) kx vx (N R left2 k2 v2 right2) = 
                                      N R (N B left1 k1 v1 right1) kx vx (N B left2 k2 v2 right2)
    balanceR' :: forall (f :: q -> *) (color :: Color).
Record
  f
  ('N
     color ('N 'R left1 k1 v1 right1) kx vx ('N 'R left2 k2 v2 right2))
-> Record
     f
     (Balance'
        'BalanceSpecial
        ('N 'R left1 k1 v1 right1)
        kx
        vx
        ('N 'R left2 k2 v2 right2))
balanceR' (Node (Node Record f left
left1 f v
v1 Record f right
right1) f v
vx (Node Record f left
left2 f v
v2 Record f right
right2)) = 
              (Record f ('N 'B left k1 v right)
-> f v
-> Record f ('N 'B left k2 v right)
-> Record
     f ('N 'R ('N 'B left k1 v right) kx v ('N 'B left k2 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f right -> Record f ('N 'B left k1 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left1 f v
v1 Record f right
right1) f v
vx (Record f left
-> f v -> Record f right -> Record f ('N 'B left k2 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left2 f v
v2 Record f right
right2))
    balanceV' :: forall (f :: q -> *) (color :: Color).
Variant
  f
  ('N
     color ('N 'R left1 k1 v1 right1) kx vx ('N 'R left2 k2 v2 right2))
-> Variant
     f
     (Balance'
        'BalanceSpecial
        ('N 'R left1 k1 v1 right1)
        kx
        vx
        ('N 'R left2 k2 v2 right2))
balanceV' Variant
  f
  ('N
     color ('N 'R left1 k1 v1 right1) kx vx ('N 'R left2 k2 v2 right2))
v = case Variant
  f
  ('N
     color ('N 'R left1 k1 v1 right1) kx vx ('N 'R left2 k2 v2 right2))
v of
        LookLeft (LookLeft Variant f t
x)   -> Variant f ('N 'B t k1 v1 right1)
-> Variant
     f ('N 'R ('N 'B t k1 v1 right1) kx vx ('N 'B left2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t k1 v1 right1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x)
        LookLeft (Here f v
x)       -> Variant f ('N 'B left1 k1 v right1)
-> Variant
     f
     ('N 'R ('N 'B left1 k1 v right1) kx vx ('N 'B left2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B left1 k1 v right1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x)
        LookLeft (LookRight Variant f t
x)  -> Variant f ('N 'B left1 k1 v1 t)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 t) kx vx ('N 'B left2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B left1 k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x)
        Here f v
x -> f v
-> Variant
     f
     ('N 'R ('N 'B left1 k1 v1 right1) kx v ('N 'B left2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x
        LookRight (LookLeft Variant f t
x)  -> Variant f ('N 'B t k2 v2 right2)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 right1) kx vx ('N 'B t k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B t k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x)
        LookRight (Here f v
x)      -> Variant f ('N 'B left2 k2 v right2)
-> Variant
     f
     ('N 'R ('N 'B left1 k1 v1 right1) kx vx ('N 'B left2 k2 v right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'B left2 k2 v right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x)
        LookRight (LookRight Variant f t
x) -> Variant f ('N 'B left2 k2 v2 t)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 right1) kx vx ('N 'B left2 k2 v2 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B left2 k2 v2 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x)

-- balance (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
instance BalanceableHelper BalanceLL (N R (N R a k1 v1 b) k2 v2 c) k3 v3 d where
    type Balance'          BalanceLL (N R (N R a k1 v1 b) k2 v2 c) k3 v3 d = 
                                 N R (N B a k1 v1 b) k2 v2 (N B c k3 v3 d)
    balanceR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color ('N 'R ('N 'R a k1 v1 b) k2 v2 c) k3 v3 d)
-> Record
     f (Balance' 'BalanceLL ('N 'R ('N 'R a k1 v1 b) k2 v2 c) k3 v3 d)
balanceR' (Node (Node (Node Record f left
a f v
fv1 Record f right
b) f v
fv2 Record f right
c) f v
fv3 Record f right
d) = 
               Record f ('N 'B left k1 v right)
-> f v
-> Record f ('N 'B right k3 v right)
-> Record
     f ('N 'R ('N 'B left k1 v right) k2 v ('N 'B right k3 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f right -> Record f ('N 'B left k1 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
a f v
fv1 Record f right
b) f v
fv2 (Record f right
-> f v -> Record f right -> Record f ('N 'B right k3 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f right
c f v
fv3 Record f right
d)
    balanceV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color ('N 'R ('N 'R a k1 v1 b) k2 v2 c) k3 v3 d)
-> Variant
     f (Balance' 'BalanceLL ('N 'R ('N 'R a k1 v1 b) k2 v2 c) k3 v3 d)
balanceV' Variant f ('N color ('N 'R ('N 'R a k1 v1 b) k2 v2 c) k3 v3 d)
v = case Variant f ('N color ('N 'R ('N 'R a k1 v1 b) k2 v2 c) k3 v3 d)
v of
        LookLeft (LookLeft Variant f t
x)  -> Variant f ('N 'B a k1 v1 b)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (case Variant f t
x of LookLeft Variant f t
y  -> Variant f t -> Variant f ('N 'B t k1 v1 b)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
y
                                                      Here f v
y      -> f v -> Variant f ('N 'B a k1 v b)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
y
                                                      LookRight Variant f t
y -> Variant f t -> Variant f ('N 'B a k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
y)
        LookLeft (Here f v
x)      -> f v -> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x
        LookLeft (LookRight Variant f t
x) -> Variant f ('N 'B t k3 v3 d)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B t k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B t k3 v3 d)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x)
        Here f v
x                 -> Variant f ('N 'B c k3 v d)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'B c k3 v d)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x)
        LookRight Variant f t
x            -> Variant f ('N 'B c k3 v3 t)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v3 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B c k3 v3 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x)

-- balance (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
instance BalanceableHelper BalanceLR (N R a k1 v1 (N R b k2 v2 c)) k3 v3 d where
    type Balance'          BalanceLR (N R a k1 v1 (N R b k2 v2 c)) k3 v3 d = 
                                 N R (N B a k1 v1 b) k2 v2 (N B c k3 v3 d) 
    balanceR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color ('N 'R a k1 v1 ('N 'R b k2 v2 c)) k3 v3 d)
-> Record
     f (Balance' 'BalanceLR ('N 'R a k1 v1 ('N 'R b k2 v2 c)) k3 v3 d)
balanceR' (Node (Node Record f left
a f v
fv1 (Node Record f left
b f v
fv2 Record f right
c)) f v
fv3 Record f right
d) = 
               Record f ('N 'B left k1 v left)
-> f v
-> Record f ('N 'B right k3 v right)
-> Record
     f ('N 'R ('N 'B left k1 v left) k2 v ('N 'B right k3 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f left -> Record f ('N 'B left k1 v left)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
a f v
fv1 Record f left
b) f v
fv2 (Record f right
-> f v -> Record f right -> Record f ('N 'B right k3 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f right
c f v
fv3 Record f right
d)
    balanceV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color ('N 'R a k1 v1 ('N 'R b k2 v2 c)) k3 v3 d)
-> Variant
     f (Balance' 'BalanceLR ('N 'R a k1 v1 ('N 'R b k2 v2 c)) k3 v3 d)
balanceV' Variant f ('N color ('N 'R a k1 v1 ('N 'R b k2 v2 c)) k3 v3 d)
v = case Variant f ('N color ('N 'R a k1 v1 ('N 'R b k2 v2 c)) k3 v3 d)
v of
        LookLeft (LookLeft Variant f t
x)   -> Variant f ('N 'B t k1 v1 b)
-> Variant f ('N 'R ('N 'B t k1 v1 b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t k1 v1 b)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x)
        LookLeft (Here f v
x)       -> Variant f ('N 'B a k1 v b)
-> Variant f ('N 'R ('N 'B a k1 v b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B a k1 v b)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x) 
        LookLeft (LookRight Variant f t
x)  -> case Variant f t
x of LookLeft Variant f t
y  -> Variant f ('N 'B a k1 v1 t)
-> Variant f ('N 'R ('N 'B a k1 v1 t) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B a k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
y)
                                             Here f v
y      -> f v -> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
y
                                             LookRight Variant f t
y -> Variant f ('N 'B t k3 v3 d)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B t k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B t k3 v3 d)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
y)
        Here f v
x                  -> Variant f ('N 'B c k3 v d)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'B c k3 v d)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x)
        LookRight Variant f t
x             -> Variant f ('N 'B c k3 v3 t)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v3 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B c k3 v3 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x)

-- balance a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
instance BalanceableHelper BalanceRL a k1 v1 (N R (N R b k2 v2 c) k3 v3 d) where
    type Balance'          BalanceRL a k1 v1 (N R (N R b k2 v2 c) k3 v3 d) = 
                                 N R (N B a k1 v1 b) k2 v2 (N B c k3 v3 d) 
    balanceR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color a k1 v1 ('N 'R ('N 'R b k2 v2 c) k3 v3 d))
-> Record
     f (Balance' 'BalanceRL a k1 v1 ('N 'R ('N 'R b k2 v2 c) k3 v3 d))
balanceR' (Node Record f left
a f v
fv1 (Node (Node Record f left
b f v
fv2 Record f right
c) f v
fv3 Record f right
d)) = 
               Record f ('N 'B left k1 v left)
-> f v
-> Record f ('N 'B right k3 v right)
-> Record
     f ('N 'R ('N 'B left k1 v left) k2 v ('N 'B right k3 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f left -> Record f ('N 'B left k1 v left)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
a f v
fv1 Record f left
b) f v
fv2 (Record f right
-> f v -> Record f right -> Record f ('N 'B right k3 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f right
c f v
fv3 Record f right
d)
    balanceV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color a k1 v1 ('N 'R ('N 'R b k2 v2 c) k3 v3 d))
-> Variant
     f (Balance' 'BalanceRL a k1 v1 ('N 'R ('N 'R b k2 v2 c) k3 v3 d))
balanceV' Variant f ('N color a k1 v1 ('N 'R ('N 'R b k2 v2 c) k3 v3 d))
v = case Variant f ('N color a k1 v1 ('N 'R ('N 'R b k2 v2 c) k3 v3 d))
v of
        LookLeft Variant f t
x              -> Variant f ('N 'B t k1 v1 b)
-> Variant f ('N 'R ('N 'B t k1 v1 b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t k1 v1 b)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x)
        Here f v
x                  -> Variant f ('N 'B a k1 v b)
-> Variant f ('N 'R ('N 'B a k1 v b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B a k1 v b)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x)
        LookRight (LookLeft Variant f t
x)  -> case Variant f t
x of LookLeft Variant f t
y  -> Variant f ('N 'B a k1 v1 t)
-> Variant f ('N 'R ('N 'B a k1 v1 t) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B a k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
y)
                                             Here f v
y      -> f v -> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
y
                                             LookRight Variant f t
y -> Variant f ('N 'B t k3 v3 d)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B t k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B t k3 v3 d)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
y)
        LookRight (Here f v
x)      -> Variant f ('N 'B c k3 v d)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'B c k3 v d)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x) 
        LookRight (LookRight Variant f t
x) -> Variant f ('N 'B c k3 v3 t)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v3 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B c k3 v3 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x)


-- balance a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
instance BalanceableHelper BalanceRR a k1 v1 (N R b k2 v2 (N R c k3 v3 d)) where
    type Balance'          BalanceRR a k1 v1 (N R b k2 v2 (N R c k3 v3 d)) = 
                                 N R (N B a k1 v1 b) k2 v2 (N B c k3 v3 d) 
    balanceR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color a k1 v1 ('N 'R b k2 v2 ('N 'R c k3 v3 d)))
-> Record
     f (Balance' 'BalanceRR a k1 v1 ('N 'R b k2 v2 ('N 'R c k3 v3 d)))
balanceR' (Node Record f left
a f v
fv1 (Node Record f left
b f v
fv2 (Node Record f left
c f v
fv3 Record f right
d))) = 
               Record f ('N 'B left k1 v left)
-> f v
-> Record f ('N 'B left k3 v right)
-> Record
     f ('N 'R ('N 'B left k1 v left) k2 v ('N 'B left k3 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f left -> Record f ('N 'B left k1 v left)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
a f v
fv1 Record f left
b) f v
fv2 (Record f left
-> f v -> Record f right -> Record f ('N 'B left k3 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
c f v
fv3 Record f right
d)
    balanceV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color a k1 v1 ('N 'R b k2 v2 ('N 'R c k3 v3 d)))
-> Variant
     f (Balance' 'BalanceRR a k1 v1 ('N 'R b k2 v2 ('N 'R c k3 v3 d)))
balanceV' Variant f ('N color a k1 v1 ('N 'R b k2 v2 ('N 'R c k3 v3 d)))
v = case Variant f ('N color a k1 v1 ('N 'R b k2 v2 ('N 'R c k3 v3 d)))
v of
        LookLeft Variant f t
x              -> Variant f ('N 'B t k1 v1 b)
-> Variant f ('N 'R ('N 'B t k1 v1 b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t k1 v1 b)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x)
        Here f v
x                  -> Variant f ('N 'B a k1 v b)
-> Variant f ('N 'R ('N 'B a k1 v b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B a k1 v b)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x)
        LookRight (LookLeft Variant f t
x)  -> Variant f ('N 'B a k1 v1 t)
-> Variant f ('N 'R ('N 'B a k1 v1 t) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B a k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x)    
        LookRight (Here f v
x)      -> f v -> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x
        LookRight (LookRight Variant f t
x) -> Variant f ('N 'B c k3 v3 d)
-> Variant f ('N 'R ('N 'B a k1 v1 b) k2 v2 ('N 'B c k3 v3 d))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (case Variant f t
x of LookLeft Variant f t
y  -> Variant f t -> Variant f ('N 'B t k3 v3 d)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
y
                                                        Here f v
y      -> f v -> Variant f ('N 'B c k3 v d)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
y
                                                        LookRight Variant f t
y -> Variant f t -> Variant f ('N 'B c k3 v3 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
y)

-- balance a x b = T B a x b
instance BalanceableHelper DoNotBalance a k v b where
    type Balance'          DoNotBalance a k v b = N B a k v b 
    balanceR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color a k v b)
-> Record f (Balance' 'DoNotBalance a k v b)
balanceR' (Node Record f left
left f v
v Record f right
right) = (Record f left
-> f v -> Record f right -> Record f ('N 'B left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
v Record f right
right)
    balanceV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color a k v b)
-> Variant f (Balance' 'DoNotBalance a k v b)
balanceV' Variant f ('N color a k v b)
v = case Variant f ('N color a k v b)
v of
        LookLeft Variant f t
l -> Variant f t -> Variant f ('N 'B t k v b)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
l
        Here f v
v -> f v -> Variant f ('N 'B a k v b)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v
        LookRight Variant f t
r -> Variant f t -> Variant f ('N 'B a k v t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
r


--
--
-- Accessing fields

--
-- These two type families exist to avoid duplicating expensive type-level
-- computations, in particular the Value' computations.
--
-- Record accessors are compiled WAY slower without them!
--
{- | Auxiliary type family to avoid repetition and help improve compilation times.
 -}

type family Field (f :: q -> Type) (t :: Map Symbol q) (v :: q) where
    Field f t v = Record f t -> (f v -> Record f t, f v)

{- | Auxiliary type family to avoid repetition and help improve compilation times.
 -}
type family Branch (f :: q -> Type) (t :: Map Symbol q) (v :: q) where
    Branch f t v = (Variant f t -> Maybe (f v), f v -> Variant f t)

--
{- | 
     Class that determines if a given 'Symbol' key is present in a type-level
     map.

     The 'Value' type family gives the 'Type' corresponding to the key.
-} 
class Key (k :: Symbol) (t :: Map Symbol q) where
    type Value k t :: q
    _field  :: Field  f t (Value k t)
    _branch :: Branch f t (Value k t)

{- |
     Takes a field name (given through @TypeApplications@) and a
     'Record', and returns a pair of a setter for the field and the original
     value of the field.
-}
field  :: forall k t f. Key k t => Field f t (Value k t)
field :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
field = forall q (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
_field @_ @k @t

{- |
     Takes a branch name (given through @TypeApplications@) and
     returns a pair of a match function and a constructor.
-}
branch :: forall k t f. Key k t => Branch f t (Value k t)
branch :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
branch = forall q (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
_branch @_ @k @t

-- member :: Ord a => a -> RB a -> Bool
class KeyHelper (ordering :: Ordering) (k :: Symbol) (left :: Map Symbol q) (v :: q) (right :: Map Symbol q) where 
    type Value' ordering k left v right :: q
    field'  :: Field  f (N colorx left kx v right) (Value' ordering k left v right)
    branch' :: Branch f (N colorx left kx v right) (Value' ordering k left v right)

instance (CmpSymbol k' k ~ ordering, KeyHelper ordering k left v' right) => Key k (N color left k' v' right) where
    type Value k (N color left k' v' right) = Value' (CmpSymbol k' k) k left v' right
    _field :: forall (f :: q -> *).
Field
  f ('N color left k' v' right) (Value k ('N color left k' v' right))
_field = forall q (ordering :: Ordering) (k :: Symbol)
       (left :: Map Symbol q) (v :: q) (right :: Map Symbol q)
       (f :: q -> *) (colorx :: Color) (kx :: Symbol).
KeyHelper ordering k left v right =>
Field
  f ('N colorx left kx v right) (Value' ordering k left v right)
field' @_ @ordering @k @left @v' @right
    _branch :: forall (f :: q -> *).
Branch
  f ('N color left k' v' right) (Value k ('N color left k' v' right))
_branch = forall q (ordering :: Ordering) (k :: Symbol)
       (left :: Map Symbol q) (v :: q) (right :: Map Symbol q)
       (f :: q -> *) (colorx :: Color) (kx :: Symbol).
KeyHelper ordering k left v right =>
Branch
  f ('N colorx left kx v right) (Value' ordering k left v right)
branch' @_ @ordering @k @left @v' @right

--  | x<y = member x a
instance (CmpSymbol k2 k ~ ordering, KeyHelper ordering k left2 v2 right2) 
      => KeyHelper LT k left v (N color2 left2 k2 v2 right2) where
    type Value'    LT k left v (N color2 left2 k2 v2 right2) = Value' (CmpSymbol k2 k) k left2 v2 right2
    field' :: forall (f :: q -> *) (colorx :: Color) (kx :: Symbol).
Field
  f
  ('N colorx left kx v ('N color2 left2 k2 v2 right2))
  (Value' 'LT k left v ('N color2 left2 k2 v2 right2))
field' (Node Record f left
left f v
fv Record f right
right) = 
        let (f (Value' ordering k left2 v2 right2)
-> Record f ('N color2 left2 k2 v2 right2)
setter,f (Value' ordering k left2 v2 right2)
x) = forall q (ordering :: Ordering) (k :: Symbol)
       (left :: Map Symbol q) (v :: q) (right :: Map Symbol q)
       (f :: q -> *) (colorx :: Color) (kx :: Symbol).
KeyHelper ordering k left v right =>
Field
  f ('N colorx left kx v right) (Value' ordering k left v right)
field' @_ @ordering @k @left2 @v2 @right2 Record f right
right
         in (\f (Value' ordering k left2 v2 right2)
z -> Record f left
-> f v
-> Record f ('N color2 left2 k2 v2 right2)
-> Record f ('N colorx left kx v ('N color2 left2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
fv (f (Value' ordering k left2 v2 right2)
-> Record f ('N color2 left2 k2 v2 right2)
setter f (Value' ordering k left2 v2 right2)
z),f (Value' ordering k left2 v2 right2)
x)
    branch' :: forall (f :: q -> *) (colorx :: Color) (kx :: Symbol).
Branch
  f
  ('N colorx left kx v ('N color2 left2 k2 v2 right2))
  (Value' 'LT k left v ('N color2 left2 k2 v2 right2))
branch' = 
        let (Variant f ('N color2 left2 k2 v2 right2)
-> Maybe (f (Value' ordering k left2 v2 right2))
match,f (Value' ordering k left2 v2 right2)
-> Variant f ('N color2 left2 k2 v2 right2)
inj) = forall q (ordering :: Ordering) (k :: Symbol)
       (left :: Map Symbol q) (v :: q) (right :: Map Symbol q)
       (f :: q -> *) (colorx :: Color) (kx :: Symbol).
KeyHelper ordering k left v right =>
Branch
  f ('N colorx left kx v right) (Value' ordering k left v right)
branch' @_ @ordering @k @left2 @v2 @right2 
         in (\case LookRight Variant f t
x -> Variant f t -> Maybe (f (Value' ordering k left2 v2 right2))
Variant f ('N color2 left2 k2 v2 right2)
-> Maybe (f (Value' ordering k left2 v2 right2))
match Variant f t
x
                   Variant f ('N colorx left kx v ('N color2 left2 k2 v2 right2))
_ -> Maybe (f (Value' ordering k left2 v2 right2))
forall a. Maybe a
Nothing,
             \f (Value' ordering k left2 v2 right2)
fv -> Variant f ('N color2 left2 k2 v2 right2)
-> Variant f ('N colorx left kx v ('N color2 left2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f (Value' ordering k left2 v2 right2)
-> Variant f ('N color2 left2 k2 v2 right2)
inj f (Value' ordering k left2 v2 right2)
fv))

--  | x>y = member x b
instance (CmpSymbol k2 k ~ ordering, KeyHelper ordering k left2 v2 right2) 
      => KeyHelper GT k (N color2 left2 k2 v2 right2) v' right where
    type    Value' GT k (N color2 left2 k2 v2 right2) v' right = Value' (CmpSymbol k2 k) k left2 v2 right2
    field' :: forall (f :: q -> *) (colorx :: Color) (kx :: Symbol).
Field
  f
  ('N colorx ('N color2 left2 k2 v2 right2) kx v' right)
  (Value' 'GT k ('N color2 left2 k2 v2 right2) v' right)
field' (Node Record f left
left f v
fv Record f right
right) = 
        let (f (Value' ordering k left2 v2 right2)
-> Record f ('N color2 left2 k2 v2 right2)
setter,f (Value' ordering k left2 v2 right2)
x) = forall q (ordering :: Ordering) (k :: Symbol)
       (left :: Map Symbol q) (v :: q) (right :: Map Symbol q)
       (f :: q -> *) (colorx :: Color) (kx :: Symbol).
KeyHelper ordering k left v right =>
Field
  f ('N colorx left kx v right) (Value' ordering k left v right)
field' @_ @ordering @k @left2 @v2 @right2 Record f left
left
         in (\f (Value' ordering k left2 v2 right2)
z -> Record f ('N color2 left2 k2 v2 right2)
-> f v
-> Record f right
-> Record f ('N colorx ('N color2 left2 k2 v2 right2) kx v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (f (Value' ordering k left2 v2 right2)
-> Record f ('N color2 left2 k2 v2 right2)
setter f (Value' ordering k left2 v2 right2)
z) f v
fv Record f right
right,f (Value' ordering k left2 v2 right2)
x)
    branch' :: forall (f :: q -> *) (colorx :: Color) (kx :: Symbol).
Branch
  f
  ('N colorx ('N color2 left2 k2 v2 right2) kx v' right)
  (Value' 'GT k ('N color2 left2 k2 v2 right2) v' right)
branch' =
        let (Variant f ('N color2 left2 k2 v2 right2)
-> Maybe (f (Value' ordering k left2 v2 right2))
match,f (Value' ordering k left2 v2 right2)
-> Variant f ('N color2 left2 k2 v2 right2)
inj) = forall q (ordering :: Ordering) (k :: Symbol)
       (left :: Map Symbol q) (v :: q) (right :: Map Symbol q)
       (f :: q -> *) (colorx :: Color) (kx :: Symbol).
KeyHelper ordering k left v right =>
Branch
  f ('N colorx left kx v right) (Value' ordering k left v right)
branch' @_ @ordering @k @left2 @v2 @right2 
         in (\case LookLeft Variant f t
x -> Variant f t -> Maybe (f (Value' ordering k left2 v2 right2))
Variant f ('N color2 left2 k2 v2 right2)
-> Maybe (f (Value' ordering k left2 v2 right2))
match Variant f t
x
                   Variant f ('N colorx ('N color2 left2 k2 v2 right2) kx v' right)
_ -> Maybe (f (Value' ordering k left2 v2 right2))
forall a. Maybe a
Nothing,
             \f (Value' ordering k left2 v2 right2)
fv -> Variant f ('N color2 left2 k2 v2 right2)
-> Variant f ('N colorx ('N color2 left2 k2 v2 right2) kx v' right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f (Value' ordering k left2 v2 right2)
-> Variant f ('N color2 left2 k2 v2 right2)
inj f (Value' ordering k left2 v2 right2)
fv))

--  | otherwise = True
instance KeyHelper EQ k left v right where
    type Value'    EQ k left v right = v
    field' :: forall (f :: q -> *) (colorx :: Color) (kx :: Symbol).
Field f ('N colorx left kx v right) (Value' 'EQ k left v right)
field' (Node Record f left
left f v
fv Record f right
right) = (\f v
x -> Record f left
-> f v -> Record f right -> Record f ('N colorx left kx v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
x Record f right
right, f v
fv)
    branch' :: forall (f :: q -> *) (colorx :: Color) (kx :: Symbol).
Branch f ('N colorx left kx v right) (Value' 'EQ k left v right)
branch' = (\case Here f v
x -> f v -> Maybe (f v)
forall a. a -> Maybe a
Just f v
x
                     Variant f ('N colorx left kx v right)
_ -> Maybe (f v)
forall a. Maybe a
Nothing,
               f v -> Variant f ('N colorx left kx v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here)

{- | Get the value of a field for a 'Record'. 


-}
project :: forall k t f . Key k t => Record f t -> f (Value k t)
project :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Record f t -> f (Value k t)
project = (f (Value k t) -> Record f t, f (Value k t)) -> f (Value k t)
forall a b. (a, b) -> b
snd ((f (Value k t) -> Record f t, f (Value k t)) -> f (Value k t))
-> (Record f t -> (f (Value k t) -> Record f t, f (Value k t)))
-> Record f t
-> f (Value k t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
field @k @t

{- | Alias for 'project'.
-}
getField :: forall k t f . Key k t => Record f t -> f (Value k t)
getField :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Record f t -> f (Value k t)
getField = forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Record f t -> f (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Record f t -> f (Value k t)
project @k @t @f

{- | Set the value of a field for a 'Record'. 
-}
setField :: forall k t f . Key k t => f (Value k t) -> Record f t -> Record f t
setField :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
f (Value k t) -> Record f t -> Record f t
setField f (Value k t)
fv Record f t
r = (f (Value k t) -> Record f t, f (Value k t))
-> f (Value k t) -> Record f t
forall a b. (a, b) -> a
fst (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
field @k @t @f Record f t
r) f (Value k t)
fv

{- | Modify the value of a field for a 'Record'. 
-}
modifyField :: forall k t f . Key k t => (f (Value k t) -> f (Value k t)) -> Record f t -> Record f t
modifyField :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
(f (Value k t) -> f (Value k t)) -> Record f t -> Record f t
modifyField f (Value k t) -> f (Value k t)
f Record f t
r = ((f (Value k t) -> Record f t) -> f (Value k t) -> Record f t)
-> (f (Value k t) -> Record f t, f (Value k t)) -> Record f t
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (f (Value k t) -> Record f t) -> f (Value k t) -> Record f t
forall a b. (a -> b) -> a -> b
($) ((f (Value k t) -> f (Value k t))
-> (f (Value k t) -> Record f t, f (Value k t))
-> (f (Value k t) -> Record f t, f (Value k t))
forall a b.
(a -> b)
-> (f (Value k t) -> Record f t, a)
-> (f (Value k t) -> Record f t, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Value k t) -> f (Value k t)
f (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
field @k @t @f Record f t
r))

{- | Put a value into the branch of a 'Variant'.

>>> match @"foo" (inject @"foo" (I 'a') :: Variant I (Insert "foo" Char Empty))
Just (I 'a')

-}
inject :: forall k t f. Key k t => f (Value k t) -> Variant f t
inject :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
f (Value k t) -> Variant f t
inject = (Variant f t -> Maybe (f (Value k t)),
 f (Value k t) -> Variant f t)
-> f (Value k t) -> Variant f t
forall a b. (a, b) -> b
snd (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
branch @k @t)

{- | Check if a 'Variant' value is the given branch.
-}
match :: forall k t f. Key k t => Variant f t -> Maybe (f (Value k t))
match :: forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Variant f t -> Maybe (f (Value k t))
match = (Variant f t -> Maybe (f (Value k t)),
 f (Value k t) -> Variant f t)
-> Variant f t -> Maybe (f (Value k t))
forall a b. (a, b) -> a
fst (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
branch @k @t)

{- | Like 'project' but specialized to pure 'Record's.

>>> projectI @"foo" (insertI @"foo" 'a' (insertI @"bar" False unit))
'a'

-}
projectI :: forall k t . Key k t => Record I t -> Value k t
projectI :: forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Record I t -> Value k t
projectI = I (Value k t) -> Value k t
forall a. I a -> a
unI (I (Value k t) -> Value k t)
-> (Record I t -> I (Value k t)) -> Record I t -> Value k t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (I (Value k t) -> Record I t, I (Value k t)) -> I (Value k t)
forall a b. (a, b) -> b
snd ((I (Value k t) -> Record I t, I (Value k t)) -> I (Value k t))
-> (Record I t -> (I (Value k t) -> Record I t, I (Value k t)))
-> Record I t
-> I (Value k t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol (*)) (f :: * -> *).
Key k t =>
Field f t (Value k t)
field @k @t

{- | Like 'getField' but specialized to pure 'Record's.
-}
getFieldI :: forall k t . Key k t => Record I t -> Value k t
getFieldI :: forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Record I t -> Value k t
getFieldI = forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Record I t -> Value k t
projectI @k @t

{- | Like 'setField' but specialized to pure 'Record's.
-}
setFieldI :: forall k t . Key k t => Value k t -> Record I t -> Record I t
setFieldI :: forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Value k t -> Record I t -> Record I t
setFieldI Value k t
v Record I t
r = (I (Value k t) -> Record I t, I (Value k t))
-> I (Value k t) -> Record I t
forall a b. (a, b) -> a
fst (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol (*)) (f :: * -> *).
Key k t =>
Field f t (Value k t)
field @k @t Record I t
r) (Value k t -> I (Value k t)
forall a. a -> I a
I Value k t
v)

{- | Like 'modifyField' but specialized to pure 'Record's.
-}
modifyFieldI :: forall k t . Key k t => (Value k t -> Value k t) -> Record I t -> Record I t
modifyFieldI :: forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
(Value k t -> Value k t) -> Record I t -> Record I t
modifyFieldI Value k t -> Value k t
f = forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
(f (Value k t) -> f (Value k t)) -> Record f t -> Record f t
forall (k :: Symbol) (t :: Map Symbol (*)) (f :: * -> *).
Key k t =>
(f (Value k t) -> f (Value k t)) -> Record f t -> Record f t
modifyField @k @t (Value k t -> I (Value k t)
forall a. a -> I a
I (Value k t -> I (Value k t))
-> (I (Value k t) -> Value k t) -> I (Value k t) -> I (Value k t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value k t -> Value k t
f (Value k t -> Value k t)
-> (I (Value k t) -> Value k t) -> I (Value k t) -> Value k t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I (Value k t) -> Value k t
forall a. I a -> a
unI)

{- | Like 'inject' but specialized to pure 'Variant's.
 
>>> matchI @"foo" (injectI @"foo" 'a' :: Variant I (Insert "foo" Char Empty))
Just 'a'

-}
injectI :: forall k t. Key k t => Value k t -> Variant I t
injectI :: forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Value k t -> Variant I t
injectI = (Variant I t -> Maybe (I (Value k t)),
 I (Value k t) -> Variant I t)
-> I (Value k t) -> Variant I t
forall a b. (a, b) -> b
snd (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol (*)) (f :: * -> *).
Key k t =>
Branch f t (Value k t)
branch @k @t) (I (Value k t) -> Variant I t)
-> (Value k t -> I (Value k t)) -> Value k t -> Variant I t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value k t -> I (Value k t)
forall a. a -> I a
I

{- | Like 'match' but specialized to pure 'Variants's.
-}
matchI :: forall k t . Key k t => Variant I t ->  Maybe (Value k t)
matchI :: forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Variant I t -> Maybe (Value k t)
matchI Variant I t
v = I (Value k t) -> Value k t
forall a. I a -> a
unI (I (Value k t) -> Value k t)
-> Maybe (I (Value k t)) -> Maybe (Value k t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Variant I t -> Maybe (I (Value k t)),
 I (Value k t) -> Variant I t)
-> Variant I t -> Maybe (I (Value k t))
forall a b. (a, b) -> a
fst (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Branch f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol (*)) (f :: * -> *).
Key k t =>
Branch f t (Value k t)
branch @k @t) Variant I t
v

{-# DEPRECATED eliminate "Use eliminate_Variant instead." #-}
eliminate :: (Productlike '[] t result, Sumlike '[] t result, SListI result) => Record (Case f r) t -> Variant f t -> r
eliminate :: forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *) r.
(Productlike '[] t result, Sumlike '[] t result, SListI result) =>
Record (Case f r) t -> Variant f t -> r
eliminate Record (Case f r) t
cases Variant f t
variant = 
    let adapt :: Case f a b -> (-.->) f (K a) b
adapt (Case f b -> a
e) = (f b -> K a b) -> (-.->) f (K a) b
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
(f a -> g a) -> (-.->) f g a
Fn (\f b
fv -> a -> K a b
forall k a (b :: k). a -> K a b
K (f b -> a
e f b
fv))
     in NS (K r) result -> r
forall {k} a (xs :: [k]). NS (K a) xs -> a
collapse_NS (NP (f -.-> K r) result -> NS f result -> NS (K r) result
forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]).
NP (f -.-> g) xs -> NS f xs -> NS g xs
ap_NS ((forall (a :: q). Case f r a -> (-.->) f (K r) a)
-> NP (Case f r) result -> NP (f -.-> K r) result
forall {k} (xs :: [k]) (f :: k -> *) (g :: k -> *).
SListI xs =>
(forall (a :: k). f a -> g a) -> NP f xs -> NP g xs
liftA_NP Case f r a -> (-.->) f (K r) a
forall (a :: q). Case f r a -> (-.->) f (K r) a
forall {k} {f :: k -> *} {a} {b :: k}.
Case f a b -> (-.->) f (K a) b
adapt (Record (Case f r) t -> NP (Case f r) result
forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP Record (Case f r) t
cases)) (Variant f t -> NS f result
forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Sumlike '[] t result =>
Variant f t -> NS f result
toNS Variant f t
variant)) 

{- | Process a 'Variant' using a eliminator 'Record' that carries
     handlers for each possible branch of the 'Variant'.

>>> eliminate_Variant (addCaseI @"foo" @Int succ (addCaseI @"bar" pred unit)) (injectI @"bar" 33)
32

-}
eliminate_Variant :: Maplike t => Record (Case f r) t -> Variant f t -> r
eliminate_Variant :: forall (t :: Map Symbol (*)) (f :: * -> *) r.
Maplike t =>
Record (Case f r) t -> Variant f t -> r
eliminate_Variant Record (Case f r) t
cases Variant f t
variant = 
    let adapt :: Case f a b -> f b -> K a b
adapt (Case f b -> a
f) f b
x = a -> K a b
forall k a (b :: k). a -> K a b
K (f b -> a
f f b
x) 
     in Variant (K r) t -> r
forall a. Variant (K a) t -> a
forall (t :: Map Symbol (*)) a. Maplike t => Variant (K a) t -> a
collapse_Variant (Variant (K r) t -> r) -> Variant (K r) t -> r
forall a b. (a -> b) -> a -> b
$ (forall a. Case f r a -> f a -> K r a)
-> Record (Case f r) t -> Variant f t -> Variant (K r) t
forall (t :: Map Symbol (*)) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
Maplike t =>
(forall a. f a -> g a -> h a)
-> Record f t -> Variant g t -> Variant h t
forall (f :: * -> *) (g :: * -> *) (h :: * -> *).
(forall a. f a -> g a -> h a)
-> Record f t -> Variant g t -> Variant h t
liftA2_Variant Case f r a -> f a -> K r a
forall a. Case f r a -> f a -> K r a
forall {q} {k} {f :: q -> *} {a} {b :: q} {b :: k}.
Case f a b -> f b -> K a b
adapt Record (Case f r) t
cases Variant f t
variant

{- | Represents a handler for a branch of a 'Variant'.  
-}
type Case :: (q -> Type) -> Type -> q -> Type
newtype Case f a b = Case { forall q (f :: q -> *) a (b :: q). Case f a b -> f b -> a
runCase :: f b -> a }

instance Functor f => Contravariant (Case f a) where
    contramap :: forall a' a. (a' -> a) -> Case f a a -> Case f a a'
contramap a' -> a
g (Case f a -> a
c) = (f a' -> a) -> Case f a a'
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case (f a -> a
c (f a -> a) -> (f a' -> f a) -> f a' -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a' -> a) -> f a' -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a' -> a
g)

{- | A form of 'addField' for creating eliminators for 'Variant's.
-}
addCase :: forall k v t f a. Insertable k v t => (f v -> a) -> Record (Case f a) t -> Record (Case f a) (Insert k v t)
addCase :: forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *)
       a.
Insertable k v t =>
(f v -> a)
-> Record (Case f a) t -> Record (Case f a) (Insert k v t)
addCase f v -> a
f = forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
forall (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
addField @k @v @t ((f v -> a) -> Case f a v
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case f v -> a
f)

{- | A pure version of 'addCase'.
-}
addCaseI :: forall k v t a. Insertable k v t => (v -> a) -> Record (Case I a) t -> Record (Case I a) (Insert k v t)
addCaseI :: forall (k :: Symbol) v (t :: Map Symbol (*)) a.
Insertable k v t =>
(v -> a) -> Record (Case I a) t -> Record (Case I a) (Insert k v t)
addCaseI v -> a
f = forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
forall (k :: Symbol) v (t :: Map Symbol (*)) (f :: * -> *).
Insertable k v t =>
f v -> Record f t -> Record f (Insert k v t)
addField @k @v @t ((I v -> a) -> Case I a v
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case (v -> a
f (v -> a) -> (I v -> v) -> I v -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I v -> v
forall a. I a -> a
unI))

--
--
-- Subsetting
type SetField :: (q -> Type) -> Type -> q -> Type
newtype SetField f a b = SetField { forall q (f :: q -> *) a (b :: q). SetField f a b -> f b -> a -> a
getSetField :: f b -> a -> a }
 
{- | For a given 'Map', produces a two-place constraint confirming the presence
     of a entry.
     
     Defined using the "class synonym" <https://www.reddit.com/r/haskell/comments/ab8ypl/monthly_hask_anything_january_2019/edk1ot3/ trick>.
-}
type PresentIn :: Map Symbol q -> Symbol -> q -> Constraint
class (Key k t, Value k t ~ v) => PresentIn (t :: Map Symbol q) (k :: Symbol) (v :: q) 
instance (Key k t, Value k t ~ v) => PresentIn (t :: Map Symbol q) (k :: Symbol) (v :: q)

{-# DEPRECATED ProductlikeSubset "This constraint is obsolete" #-}
type ProductlikeSubset (subset :: Map Symbol q) (whole :: Map Symbol q) (flat :: [q]) = 
                       (KeysValuesAll (PresentIn whole) subset,
                       Productlike '[] subset flat,
                       SListI flat)

{-# DEPRECATED fieldSubset "Use Data.RBR.Subset.fieldSubset" #-}
fieldSubset :: forall subset whole flat f. (ProductlikeSubset subset whole flat) 
            => Record f whole -> (Record f subset -> Record f whole, Record f subset)
fieldSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
fieldSubset Record f whole
r = 
    (,)
    (let goset :: forall left k v right color. (PresentIn whole k v, KeysValuesAll (PresentIn whole) left, 
                                                                     KeysValuesAll (PresentIn whole) right) 
               => Record (SetField f (Record f whole)) left 
               -> Record (SetField f (Record f whole)) right 
               -> Record (SetField f (Record f whole)) (N color left k v right)
         goset :: forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
 KeysValuesAll (PresentIn whole) right) =>
Record (SetField f (Record f whole)) left
-> Record (SetField f (Record f whole)) right
-> Record (SetField f (Record f whole)) ('N color left k v right)
goset Record (SetField f (Record f whole)) left
left Record (SetField f (Record f whole)) right
right = Record (SetField f (Record f whole)) left
-> SetField f (Record f whole) v
-> Record (SetField f (Record f whole)) right
-> Record (SetField f (Record f whole)) ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record (SetField f (Record f whole)) left
left ((f v -> Record f whole -> Record f whole)
-> SetField f (Record f whole) v
forall q (f :: q -> *) a (b :: q).
(f b -> a -> a) -> SetField f a b
SetField (\f v
v Record f whole
w -> (f v -> Record f whole, f v) -> f v -> Record f whole
forall a b. (a, b) -> a
fst (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Field f t (Value k t)
field @k @whole Record f whole
w) f v
v)) Record (SetField f (Record f whole)) right
right
         setters :: NP (SetField f (Record f whole)) flat
setters = forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
forall (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP @subset @_ @(SetField f (Record f whole)) (Proxy (PresentIn whole)
-> Record (SetField f (Record f whole)) 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
     KeysValuesAll (PresentIn whole) right) =>
    Record (SetField f (Record f whole)) left
    -> Record (SetField f (Record f whole)) right
    -> Record (SetField f (Record f whole)) ('N color left k v right))
-> Record (SetField f (Record f whole)) subset
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy (PresentIn whole)
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
     KeysValuesAll (PresentIn whole) right) =>
    r left -> r right -> r ('N color left k v right))
-> r subset
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @(PresentIn whole)) Record (SetField f (Record f whole)) 'E
forall {q} (f :: q -> *). Record f 'E
unit Record (SetField f (Record f whole)) left
-> Record (SetField f (Record f whole)) right
-> Record (SetField f (Record f whole)) ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
 KeysValuesAll (PresentIn whole) right) =>
Record (SetField f (Record f whole)) left
-> Record (SetField f (Record f whole)) right
-> Record (SetField f (Record f whole)) ('N color left k v right)
goset)
         appz :: SetField f a b -> f b -> K (Endo a) b
appz (SetField f b -> a -> a
func) f b
fv = Endo a -> K (Endo a) b
forall k a (b :: k). a -> K a b
K ((a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo (f b -> a -> a
func f b
fv))
      in \Record f subset
toset -> Endo (Record f whole) -> Record f whole -> Record f whole
forall a. Endo a -> a -> a
appEndo ([Endo (Record f whole)] -> Endo (Record f whole)
forall a. Monoid a => [a] -> a
mconcat (NP (K (Endo (Record f whole))) flat -> [Endo (Record f whole)]
forall {k} a (xs :: [k]). NP (K a) xs -> [a]
collapse_NP ((forall (a :: q).
 SetField f (Record f whole) a
 -> f a -> K (Endo (Record f whole)) a)
-> NP (SetField f (Record f whole)) flat
-> NP f flat
-> NP (K (Endo (Record f whole))) flat
forall {k} (xs :: [k]) (f :: k -> *) (g :: k -> *) (h :: k -> *).
SListI xs =>
(forall (a :: k). f a -> g a -> h a)
-> NP f xs -> NP g xs -> NP h xs
liftA2_NP SetField f (Record f whole) a -> f a -> K (Endo (Record f whole)) a
forall (a :: q).
SetField f (Record f whole) a -> f a -> K (Endo (Record f whole)) a
forall {q} {k} {f :: q -> *} {a} {b :: q} {b :: k}.
SetField f a b -> f b -> K (Endo a) b
appz NP (SetField f (Record f whole)) flat
setters (Record f subset -> NP f flat
forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP Record f subset
toset)))) Record f whole
r)
    (let goget :: forall left k v right color. (PresentIn whole k v, KeysValuesAll (PresentIn whole) left, 
                                                                     KeysValuesAll (PresentIn whole) right) 
               => Record f left 
               -> Record f right 
               -> Record f (N color left k v right)
         goget :: forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
 KeysValuesAll (PresentIn whole) right) =>
Record f left
-> Record f right -> Record f ('N color left k v right)
goget Record f left
left Record f right
right = Record f left
-> f v -> Record f right -> Record f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left (forall {q} (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Record f t -> f (Value k t)
forall (k :: Symbol) (t :: Map Symbol q) (f :: q -> *).
Key k t =>
Record f t -> f (Value k t)
project @k @whole Record f whole
r) Record f right
right
      in Proxy (PresentIn whole)
-> Record f 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
     KeysValuesAll (PresentIn whole) right) =>
    Record f left
    -> Record f right -> Record f ('N color left k v right))
-> Record f subset
forall symbol q (c :: symbol -> q -> Constraint)
       (t :: Map symbol q) (proxy :: (symbol -> q -> Constraint) -> *)
       (r :: Map symbol q -> *).
KeysValuesAll c t =>
proxy c
-> r 'E
-> (forall (left :: Map symbol q) (k :: symbol) (v :: q)
           (right :: Map symbol q) (color :: Color).
    (c k v, KeysValuesAll c left, KeysValuesAll c right) =>
    r left -> r right -> r ('N color left k v right))
-> r t
forall (proxy :: (Symbol -> q -> Constraint) -> *)
       (r :: Map Symbol q -> *).
proxy (PresentIn whole)
-> r 'E
-> (forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
           (right :: Map Symbol q) (color :: Color).
    (PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
     KeysValuesAll (PresentIn whole) right) =>
    r left -> r right -> r ('N color left k v right))
-> r subset
cpara_Map (forall {k} (t :: k). Proxy t
forall (t :: Symbol -> q -> Constraint). Proxy t
Proxy @(PresentIn whole)) Record f 'E
forall {q} (f :: q -> *). Record f 'E
unit Record f left
-> Record f right -> Record f ('N color left k v right)
forall (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (color :: Color).
(PresentIn whole k v, KeysValuesAll (PresentIn whole) left,
 KeysValuesAll (PresentIn whole) right) =>
Record f left
-> Record f right -> Record f ('N color left k v right)
goget)

{-# DEPRECATED projectSubset "Use Data.RBR.Subset.projectSubset" #-}
projectSubset :: forall subset whole flat f. (ProductlikeSubset subset whole flat) 
              => Record f whole 
              -> Record f subset
projectSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole -> Record f subset
projectSubset =  (Record f subset -> Record f whole, Record f subset)
-> Record f subset
forall a b. (a, b) -> b
snd ((Record f subset -> Record f whole, Record f subset)
 -> Record f subset)
-> (Record f whole
    -> (Record f subset -> Record f whole, Record f subset))
-> Record f whole
-> Record f subset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record f whole
-> (Record f subset -> Record f whole, Record f subset)
forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
fieldSubset

{-# DEPRECATED getFieldSubset "Use Data.RBR.Subset.getFieldSubset" #-}
getFieldSubset :: forall subset whole flat f. (ProductlikeSubset subset whole flat)  
               => Record f whole 
               -> Record f subset
getFieldSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole -> Record f subset
getFieldSubset = Record f whole -> Record f subset
forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole -> Record f subset
projectSubset

{-# DEPRECATED setFieldSubset "Use Data.RBR.Subset.setFieldSubset" #-}
setFieldSubset :: forall subset whole flat f.  (ProductlikeSubset subset whole flat) 
               => Record f subset
               -> Record f whole 
               -> Record f whole
setFieldSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f subset -> Record f whole -> Record f whole
setFieldSubset Record f subset
subset Record f whole
whole = (Record f subset -> Record f whole, Record f subset)
-> Record f subset -> Record f whole
forall a b. (a, b) -> a
fst (Record f whole
-> (Record f subset -> Record f whole, Record f subset)
forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
fieldSubset Record f whole
whole) Record f subset
subset 

{-# DEPRECATED modifyFieldSubset "Use Data.RBR.Subset.modifyFieldSubset" #-}
modifyFieldSubset :: forall subset whole flat f.  (ProductlikeSubset subset whole flat) 
                  => (Record f subset -> Record f subset)
                  -> Record f whole 
                  -> Record f whole
modifyFieldSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
(Record f subset -> Record f subset)
-> Record f whole -> Record f whole
modifyFieldSubset Record f subset -> Record f subset
f Record f whole
r = ((Record f subset -> Record f whole)
 -> Record f subset -> Record f whole)
-> (Record f subset -> Record f whole, Record f subset)
-> Record f whole
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Record f subset -> Record f whole)
-> Record f subset -> Record f whole
forall a b. (a -> b) -> a -> b
($) ((Record f subset -> Record f subset)
-> (Record f subset -> Record f whole, Record f subset)
-> (Record f subset -> Record f whole, Record f subset)
forall a b.
(a -> b)
-> (Record f subset -> Record f whole, a)
-> (Record f subset -> Record f whole, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Record f subset -> Record f subset
f (forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
forall (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
fieldSubset @subset @whole Record f whole
r))


{-# DEPRECATED SumlikeSubset "This constraint is obsolete" #-}
type SumlikeSubset (subset :: Map Symbol q) (whole :: Map Symbol q) (subflat :: [q]) (wholeflat :: [q]) = 
                   (KeysValuesAll (PresentIn whole) subset,
                    Productlike '[] whole  wholeflat,
                    Sumlike '[] whole  wholeflat,
                    SListI wholeflat,
                    Productlike '[] subset subflat,
                    Sumlike '[] subset subflat,
                    SListI subflat)

{-# DEPRECATED branchSubset "Use Data.RBR.Subset.branchSubset" #-}
branchSubset :: forall subset whole subflat wholeflat f. (SumlikeSubset subset whole subflat wholeflat)
             => (Variant f whole -> Maybe (Variant f subset), Variant f subset -> Variant f whole)
branchSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *).
SumlikeSubset subset whole subflat wholeflat =>
(Variant f whole -> Maybe (Variant f subset),
 Variant f subset -> Variant f whole)
branchSubset = 
    let inj2case :: forall t flat f v. Sumlike '[] t flat => (_ -> _) -> Injection _ flat v -> Case _ _ v
        inj2case :: (Variant f t -> w) -> Injection f flat v -> Case f w v
inj2case = \Variant f t -> w
adapt -> \Injection f flat v
fn -> (f v -> w) -> Case f w v
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case (\f v
fv -> Variant f t -> w
adapt (forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Sumlike '[] t result =>
NS f result -> Variant f t
forall (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Sumlike '[] t result =>
NS f result -> Variant f t
fromNS @t (K (NS f flat) v -> NS f flat
forall {k} a (b :: k). K a b -> a
unK (Injection f flat v -> f v -> K (NS f flat) v
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn Injection f flat v
fn f v
fv))))
        -- The intuition is that getting the setter and the getter together might be faster at compile-time.
        -- The intuition might be wrong.
        subs :: forall f. Record f whole -> (Record f subset -> Record f whole, Record f subset)
        subs :: forall (f :: q -> *).
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
subs = forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
forall (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
fieldSubset @subset @whole
     in
     (,)
     (let injs :: Record (Case f (Maybe (Variant f subset))) subset 
          injs :: Record (Case f (Maybe (Variant f subset))) subset
injs = forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
NP f result -> Record f t
forall (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
NP f result -> Record f t
fromNP @subset ((forall (a :: q).
 Injection f subflat a -> Case f (Maybe (Variant f subset)) a)
-> NP (Injection f subflat) subflat
-> NP (Case f (Maybe (Variant f subset))) subflat
forall {k} (xs :: [k]) (f :: k -> *) (g :: k -> *).
SListI xs =>
(forall (a :: k). f a -> g a) -> NP f xs -> NP g xs
liftA_NP ((Variant f subset -> Maybe (Variant f subset))
-> (-.->) f (K (NS f subflat)) a
-> Case f (Maybe (Variant f subset)) a
forall {k} {k} (t :: Map Symbol k) (flat :: [k]) (f :: k) (v :: k)
       {f :: k -> *} {w}.
Sumlike '[] t flat =>
(Variant f t -> w) -> Injection f flat v -> Case f w v
inj2case Variant f subset -> Maybe (Variant f subset)
forall a. a -> Maybe a
Just) (forall (xs :: [q]) (f :: q -> *).
SListI xs =>
NP (Injection f xs) xs
forall {k} (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections @subflat))
          wholeinjs :: Record (Case f (Maybe (Variant f subset))) whole 
          wholeinjs :: Record (Case f (Maybe (Variant f subset))) whole
wholeinjs = forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
NP f result -> Record f t
forall (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
NP f result -> Record f t
fromNP @whole ((forall (a :: q). Case f (Maybe (Variant f subset)) a)
-> NP (Case f (Maybe (Variant f subset))) wholeflat
forall {k} (f :: k -> *) (xs :: [k]).
SListI xs =>
(forall (a :: k). f a) -> NP f xs
pure_NP ((f a -> Maybe (Variant f subset))
-> Case f (Maybe (Variant f subset)) a
forall q (f :: q -> *) a (b :: q). (f b -> a) -> Case f a b
Case (\f a
_ -> Maybe (Variant f subset)
forall a. Maybe a
Nothing)))
          mixedinjs :: Record (Case f (Maybe (Variant f subset))) whole
mixedinjs = (Record (Case f (Maybe (Variant f subset))) subset
 -> Record (Case f (Maybe (Variant f subset))) whole,
 Record (Case f (Maybe (Variant f subset))) subset)
-> Record (Case f (Maybe (Variant f subset))) subset
-> Record (Case f (Maybe (Variant f subset))) whole
forall a b. (a, b) -> a
fst (Record (Case f (Maybe (Variant f subset))) whole
-> (Record (Case f (Maybe (Variant f subset))) subset
    -> Record (Case f (Maybe (Variant f subset))) whole,
    Record (Case f (Maybe (Variant f subset))) subset)
forall (f :: q -> *).
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
subs Record (Case f (Maybe (Variant f subset))) whole
wholeinjs) Record (Case f (Maybe (Variant f subset))) subset
injs
       in Record (Case f (Maybe (Variant f subset))) whole
-> Variant f whole -> Maybe (Variant f subset)
forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *) r.
(Productlike '[] t result, Sumlike '[] t result, SListI result) =>
Record (Case f r) t -> Variant f t -> r
eliminate Record (Case f (Maybe (Variant f subset))) whole
mixedinjs)
     (let wholeinjs :: Record (Case f (Variant f whole)) whole
          wholeinjs :: Record (Case f (Variant f whole)) whole
wholeinjs = forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
NP f result -> Record f t
forall (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
NP f result -> Record f t
fromNP @whole ((forall (a :: q).
 Injection f wholeflat a -> Case f (Variant f whole) a)
-> NP (Injection f wholeflat) wholeflat
-> NP (Case f (Variant f whole)) wholeflat
forall {k} (xs :: [k]) (f :: k -> *) (g :: k -> *).
SListI xs =>
(forall (a :: k). f a -> g a) -> NP f xs -> NP g xs
liftA_NP ((Variant f whole -> Variant f whole)
-> (-.->) f (K (NS f wholeflat)) a -> Case f (Variant f whole) a
forall {k} {k} (t :: Map Symbol k) (flat :: [k]) (f :: k) (v :: k)
       {f :: k -> *} {w}.
Sumlike '[] t flat =>
(Variant f t -> w) -> Injection f flat v -> Case f w v
inj2case Variant f whole -> Variant f whole
forall a. a -> a
id) (forall (xs :: [q]) (f :: q -> *).
SListI xs =>
NP (Injection f xs) xs
forall {k} (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections @wholeflat))
          injs :: Record (Case f (Variant f whole)) subset
injs = (Record (Case f (Variant f whole)) subset
 -> Record (Case f (Variant f whole)) whole,
 Record (Case f (Variant f whole)) subset)
-> Record (Case f (Variant f whole)) subset
forall a b. (a, b) -> b
snd (Record (Case f (Variant f whole)) whole
-> (Record (Case f (Variant f whole)) subset
    -> Record (Case f (Variant f whole)) whole,
    Record (Case f (Variant f whole)) subset)
forall (f :: q -> *).
Record f whole
-> (Record f subset -> Record f whole, Record f subset)
subs Record (Case f (Variant f whole)) whole
wholeinjs)
       in Record (Case f (Variant f whole)) subset
-> Variant f subset -> Variant f whole
forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *) r.
(Productlike '[] t result, Sumlike '[] t result, SListI result) =>
Record (Case f r) t -> Variant f t -> r
eliminate Record (Case f (Variant f whole)) subset
injs)


{-# DEPRECATED injectSubset  "Use Data.RBR.Subset.injectSubset" #-}
injectSubset :: forall subset whole subflat wholeflat f. (SumlikeSubset subset whole subflat wholeflat)
             => Variant f subset -> Variant f whole
injectSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *).
SumlikeSubset subset whole subflat wholeflat =>
Variant f subset -> Variant f whole
injectSubset = (Variant f whole -> Maybe (Variant f subset),
 Variant f subset -> Variant f whole)
-> Variant f subset -> Variant f whole
forall a b. (a, b) -> b
snd (forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *).
SumlikeSubset subset whole subflat wholeflat =>
(Variant f whole -> Maybe (Variant f subset),
 Variant f subset -> Variant f whole)
forall (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *).
SumlikeSubset subset whole subflat wholeflat =>
(Variant f whole -> Maybe (Variant f subset),
 Variant f subset -> Variant f whole)
branchSubset @subset @whole @subflat @wholeflat)

{-# DEPRECATED matchSubset  "Use Data.RBR.Subset.matchSubset" #-}
matchSubset :: forall subset whole subflat wholeflat f. (SumlikeSubset subset whole subflat wholeflat)
            => Variant f whole -> Maybe (Variant f subset)
matchSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *).
SumlikeSubset subset whole subflat wholeflat =>
Variant f whole -> Maybe (Variant f subset)
matchSubset = (Variant f whole -> Maybe (Variant f subset),
 Variant f subset -> Variant f whole)
-> Variant f whole -> Maybe (Variant f subset)
forall a b. (a, b) -> a
fst (forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *).
SumlikeSubset subset whole subflat wholeflat =>
(Variant f whole -> Maybe (Variant f subset),
 Variant f subset -> Variant f whole)
forall (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *).
SumlikeSubset subset whole subflat wholeflat =>
(Variant f whole -> Maybe (Variant f subset),
 Variant f subset -> Variant f whole)
branchSubset @subset @whole @subflat @wholeflat)

{-# DEPRECATED eliminateSubset  "Use Data.RBR.Subset.eliminateSubset" #-}
eliminateSubset :: forall subset whole subflat wholeflat f r. (SumlikeSubset subset whole subflat wholeflat)
                => Record (Case f r) whole -> Variant f subset -> r
eliminateSubset :: forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (subflat :: [q]) (wholeflat :: [q]) (f :: q -> *) r.
SumlikeSubset subset whole subflat wholeflat =>
Record (Case f r) whole -> Variant f subset -> r
eliminateSubset Record (Case f r) whole
cases = 
    let reducedCases :: Record (Case f r) subset
reducedCases = forall {q} (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole -> Record f subset
forall (subset :: Map Symbol q) (whole :: Map Symbol q)
       (flat :: [q]) (f :: q -> *).
ProductlikeSubset subset whole flat =>
Record f whole -> Record f subset
getFieldSubset @subset @whole Record (Case f r) whole
cases
     in Record (Case f r) subset -> Variant f subset -> r
forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *) r.
(Productlike '[] t result, Sumlike '[] t result, SListI result) =>
Record (Case f r) t -> Variant f t -> r
eliminate Record (Case f r) subset
reducedCases 

--
-- Interaction with Data.SOP

{- | Class from converting 'Record's to and from the n-ary product type 'NP' from "Data.SOP".
    
     'prefixNP' flattens a 'Record' and adds it to the initial part of the product.

     'breakNP' reconstructs a 'Record' from the initial part of the product and returns the unconsumed part.

     The functions 'toNP' and 'fromNP' are usually easier to use. 
-}
type Productlike :: [k] -> Map Symbol k -> [k] -> Constraint
class Productlike (start :: [k])
                  (t :: Map Symbol k) 
                  (result :: [k]) | start t -> result, result t -> start where
    _prefixNP:: Record f t -> NP f start -> NP f result
    _breakNP :: NP f result -> (Record f t, NP f start)

instance Productlike start E start where
    _prefixNP :: forall (f :: k -> *). Record f 'E -> NP f start -> NP f start
_prefixNP Record f 'E
_ NP f start
start = NP f start
start  
    _breakNP :: forall (f :: k -> *). NP f start -> (Record f 'E, NP f start)
_breakNP NP f start
start = (Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty, NP f start
start) 

instance (Productlike start right middle, 
          Productlike (v ': middle) left result)
          => Productlike start (N color left k v right) result where
    _prefixNP :: forall (f :: q -> *).
Record f ('N color left k v right) -> NP f start -> NP f result
_prefixNP (Node Record f left
left f v
fv Record f right
right) NP f start
start = 
        forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
Record f t -> NP f start -> NP f result
_prefixNP @_ @_ @left @result Record f left
Record f left
left (f v
fv f v -> NP f middle -> NP f (v : middle)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall (start :: [q]) (t :: Map Symbol q) (result :: [q])
       (f :: q -> *).
Productlike start t result =>
Record f t -> NP f start -> NP f result
forall {k} (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
Record f t -> NP f start -> NP f result
prefixNP @start @right @middle Record f right
Record f right
right NP f start
start)
    _breakNP :: forall (f :: q -> *).
NP f result -> (Record f ('N color left k v right), NP f start)
_breakNP NP f result
result =
        let (Record f left
left, f v
f x
fv :* NP f middle
NP f xs
middle) = forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
NP f result -> (Record f t, NP f start)
_breakNP @_ @_ @left @result NP f result
result
            (Record f right
right, NP f start
start) = forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
NP f result -> (Record f t, NP f start)
_breakNP @_ @start @right NP f middle
middle
         in (Record f left
-> f v -> Record f right -> Record f ('N color left k v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
fv Record f right
right, NP f start
start)

{- | 
     Flattens a 'Record' and adds it to the initial part of the product.
-}
prefixNP:: forall start t result f. Productlike start t result => Record f t -> NP f start -> NP f result
prefixNP :: forall {k} (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
Record f t -> NP f start -> NP f result
prefixNP = forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
Record f t -> NP f start -> NP f result
_prefixNP @_ @start @t @result

{- | 
     Reconstructs a 'Record' from the initial part of the product and returns the unconsumed part.
-}
breakNP :: forall start t result f. Productlike start t result => NP f result -> (Record f t, NP f start)
breakNP :: forall {k} (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
NP f result -> (Record f t, NP f start)
breakNP = forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
NP f result -> (Record f t, NP f start)
_breakNP @_ @start @t @result

{- | Convert a 'Record' into a n-ary product. The order of the elements in the
     product is not the order of insertion in the record.

>>> toNP (insertI @"foo" 'a' (insertI @"bar" True unit))
I True :* I 'a' :* Nil 

-}
toNP :: forall t result f. Productlike '[] t result => Record f t -> NP f result
toNP :: forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Productlike '[] t result =>
Record f t -> NP f result
toNP Record f t
r = Record f t -> NP f '[] -> NP f result
forall {k} (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
Record f t -> NP f start -> NP f result
prefixNP Record f t
r NP f '[]
forall {k} (a :: k -> *). NP a '[]
Nil

{- | Convert a n-ary product into a compatible 'Record'. Usually follows an invocation of 'toNP'. 


>>> :{ 
    prettyShow_RecordI $ 
    fromNP @(Insert "foo" _ (Insert "bar" _ Empty)) $
    toNP $ 
    insertI @"foo" 'a' $
    insertI @"bar" True $
    unit
:}
"{bar = True, foo = 'a'}"

-}
fromNP :: forall t result f. Productlike '[] t result => NP f result -> Record f t
fromNP :: forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Productlike '[] t result =>
NP f result -> Record f t
fromNP NP f result
np = let (Record f t
r,NP f '[]
Nil) = NP f result -> (Record f t, NP f '[])
forall {k} (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Productlike start t result =>
NP f result -> (Record f t, NP f start)
breakNP NP f result
np in Record f t
r

{- | Class from converting 'Variant's to and from the n-ary sum type 'NS' from "Data.SOP".
    
     'prefixNS' flattens a 'Variant' and adds it to the initial part of the sum.

     'breakNS' reconstructs a 'Variant' from the initial part of the sum and returns the unconsumed part.

     The functions 'toNS' and 'fromNS' are usually easier to use. 
-}
type Sumlike :: [k] -> Map Symbol k -> [k] -> Constraint
class Sumlike (start :: [k]) 
              (t :: Map Symbol k) 
              (result :: [k]) | start t -> result, result t -> start where
    _prefixNS :: Either (NS f start) (Variant f t) -> NS f result
    _breakNS :: NS f result -> Either (NS f start) (Variant f t)

instance Sumlike start 
                  (N color E k v E)
                  (v ': start) where
    _prefixNS :: forall (f :: a -> *).
Either (NS f start) (Variant f ('N color 'E k v 'E))
-> NS f (v : start)
_prefixNS = \case
        Left  NS f start
l -> NS f start -> NS f (v : start)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S NS f start
l
        Right Variant f ('N color 'E k v 'E)
x -> case Variant f ('N color 'E k v 'E)
x of Here f v
fv -> forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
forall (a :: a -> *) (x :: a) (xs :: [a]). a x -> NS a (x : xs)
Z @_ @v @start f v
f v
fv
    _breakNS :: forall (f :: a -> *).
NS f (v : start)
-> Either (NS f start) (Variant f ('N color 'E k v 'E))
_breakNS = \case 
        Z f x
x -> Variant f ('N color 'E k v 'E)
-> Either (NS f start) (Variant f ('N color 'E k v 'E))
forall a b. b -> Either a b
Right (f v -> Variant f ('N color 'E k v 'E)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
f x
x)
        S NS f xs
x -> NS f start -> Either (NS f start) (Variant f ('N color 'E k v 'E))
forall a b. a -> Either a b
Left NS f start
NS f xs
x

instance (Sumlike start (N colorR leftR kR vR rightR) middle,
          Sumlike (v ': middle) (N colorL leftL kL vL rightL) result)
         => Sumlike start 
                    (N color (N colorL leftL kL vL rightL) k v (N colorR leftR kR vR rightR)) 
                    result where
    _prefixNS :: forall (f :: q -> *).
Either
  (NS f start)
  (Variant
     f
     ('N
        color
        ('N colorL leftL kL vL rightL)
        k
        v
        ('N colorR leftR kR vR rightR)))
-> NS f result
_prefixNS = \case
        Left NS f start
x -> 
            forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorL leftL kL vL rightL) (NS f (v : middle)
-> Either
     (NS f (v : middle)) (Variant f ('N colorL leftL kL vL rightL))
forall a b. a -> Either a b
Left (NS f middle -> NS f (v : middle)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorR leftR kR vR rightR) (NS f start
-> Either (NS f start) (Variant f ('N colorR leftR kR vR rightR))
forall a b. a -> Either a b
Left NS f start
x))))
        Right Variant
  f
  ('N
     color
     ('N colorL leftL kL vL rightL)
     k
     v
     ('N colorR leftR kR vR rightR))
x -> 
            case Variant
  f
  ('N
     color
     ('N colorL leftL kL vL rightL)
     k
     v
     ('N colorR leftR kR vR rightR))
x of LookLeft Variant f t
x  -> forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @(v ': middle) @(N colorL leftL kL vL rightL) @result (Variant f ('N colorL leftL kL vL rightL)
-> Either
     (NS f (v : middle)) (Variant f ('N colorL leftL kL vL rightL))
forall a b. b -> Either a b
Right Variant f t
Variant f ('N colorL leftL kL vL rightL)
x) 
                      Here f v
x      -> forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorL leftL kL vL rightL) (NS f (v : middle)
-> Either
     (NS f (v : middle)) (Variant f ('N colorL leftL kL vL rightL))
forall a b. a -> Either a b
Left (f v -> NS f (v : middle)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z f v
x))
                      LookRight Variant f t
x -> forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorL leftL kL vL rightL) (NS f (v : middle)
-> Either
     (NS f (v : middle)) (Variant f ('N colorL leftL kL vL rightL))
forall a b. a -> Either a b
Left (NS f middle -> NS f (v : middle)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ (Variant f t -> Either (NS f start) (Variant f t)
forall a b. b -> Either a b
Right Variant f t
x))))
    _breakNS :: forall (f :: q -> *).
NS f result
-> Either
     (NS f start)
     (Variant
        f
        ('N
           color
           ('N colorL leftL kL vL rightL)
           k
           v
           ('N colorR leftR kR vR rightR)))
_breakNS NS f result
ns = case forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
NS f result -> Either (NS f start) (Variant f t)
_breakNS @_ @(v ': middle) @(N colorL leftL kL vL rightL) NS f result
ns of
        Left NS f (v : middle)
x -> case NS f (v : middle)
x of
            Z f x
x -> Variant
  f
  ('N
     color
     ('N colorL leftL kL vL rightL)
     k
     v
     ('N colorR leftR kR vR rightR))
-> Either
     (NS f start)
     (Variant
        f
        ('N
           color
           ('N colorL leftL kL vL rightL)
           k
           v
           ('N colorR leftR kR vR rightR)))
forall a b. b -> Either a b
Right (f v
-> Variant
     f
     ('N
        color
        ('N colorL leftL kL vL rightL)
        k
        v
        ('N colorR leftR kR vR rightR))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
f x
x)
            S NS f xs
x -> case forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
NS f result -> Either (NS f start) (Variant f t)
_breakNS @_ @start @(N colorR leftR kR vR rightR) NS f xs
x of
                Left NS f start
ns  -> NS f start
-> Either
     (NS f start)
     (Variant
        f
        ('N
           color
           ('N colorL leftL kL vL rightL)
           k
           v
           ('N colorR leftR kR vR rightR)))
forall a b. a -> Either a b
Left NS f start
ns
                Right Variant f ('N colorR leftR kR vR rightR)
v  -> Variant
  f
  ('N
     color
     ('N colorL leftL kL vL rightL)
     k
     v
     ('N colorR leftR kR vR rightR))
-> Either
     (NS f start)
     (Variant
        f
        ('N
           color
           ('N colorL leftL kL vL rightL)
           k
           v
           ('N colorR leftR kR vR rightR)))
forall a b. b -> Either a b
Right (Variant f ('N colorR leftR kR vR rightR)
-> Variant
     f
     ('N
        color
        ('N colorL leftL kL vL rightL)
        k
        v
        ('N colorR leftR kR vR rightR))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f ('N colorR leftR kR vR rightR)
v)
        Right Variant f ('N colorL leftL kL vL rightL)
v -> Variant
  f
  ('N
     color
     ('N colorL leftL kL vL rightL)
     k
     v
     ('N colorR leftR kR vR rightR))
-> Either
     (NS f start)
     (Variant
        f
        ('N
           color
           ('N colorL leftL kL vL rightL)
           k
           v
           ('N colorR leftR kR vR rightR)))
forall a b. b -> Either a b
Right (Variant f ('N colorL leftL kL vL rightL)
-> Variant
     f
     ('N
        color
        ('N colorL leftL kL vL rightL)
        k
        v
        ('N colorR leftR kR vR rightR))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f ('N colorL leftL kL vL rightL)
v)

instance Sumlike (v ': start) (N colorL leftL kL vL rightL) result
         => Sumlike start (N color (N colorL leftL kL vL rightL) k v E) result where
    _prefixNS :: forall (f :: q -> *).
Either
  (NS f start)
  (Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E))
-> NS f result
_prefixNS = \case
        Left NS f start
x  -> 
            forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorL leftL kL vL rightL) (NS f (v : start)
-> Either
     (NS f (v : start)) (Variant f ('N colorL leftL kL vL rightL))
forall a b. a -> Either a b
Left (NS f start -> NS f (v : start)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S NS f start
x))
        Right Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E)
x -> 
            case Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E)
x of LookLeft Variant f t
x  -> forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @(v ': start) @(N colorL leftL kL vL rightL) @result (Variant f ('N colorL leftL kL vL rightL)
-> Either
     (NS f (v : start)) (Variant f ('N colorL leftL kL vL rightL))
forall a b. b -> Either a b
Right Variant f t
Variant f ('N colorL leftL kL vL rightL)
x)
                      Here f v
x      -> forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorL leftL kL vL rightL) (NS f (v : start)
-> Either
     (NS f (v : start)) (Variant f ('N colorL leftL kL vL rightL))
forall a b. a -> Either a b
Left (f v -> NS f (v : start)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z f v
x))
    _breakNS :: forall (f :: q -> *).
NS f result
-> Either
     (NS f start)
     (Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E))
_breakNS NS f result
ns = case forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
NS f result -> Either (NS f start) (Variant f t)
_breakNS @_ @(v ': start) @(N colorL leftL kL vL rightL) NS f result
ns of
        Left NS f (v : start)
x -> case NS f (v : start)
x of
            Z f x
x -> Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E)
-> Either
     (NS f start)
     (Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E))
forall a b. b -> Either a b
Right (f v -> Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
f x
x)
            S NS f xs
x -> NS f start
-> Either
     (NS f start)
     (Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E))
forall a b. a -> Either a b
Left NS f start
NS f xs
x 
        Right Variant f ('N colorL leftL kL vL rightL)
v -> Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E)
-> Either
     (NS f start)
     (Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E))
forall a b. b -> Either a b
Right (Variant f ('N colorL leftL kL vL rightL)
-> Variant f ('N color ('N colorL leftL kL vL rightL) k v 'E)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f ('N colorL leftL kL vL rightL)
v)

instance Sumlike start (N colorR leftR kR vR rightR) middle
         => Sumlike start (N color E k v (N colorR leftR kR vR rightR)) (v ': middle) where
    _prefixNS :: forall (f :: a -> *).
Either
  (NS f start)
  (Variant f ('N color 'E k v ('N colorR leftR kR vR rightR)))
-> NS f (v : middle)
_prefixNS = \case
        Left NS f start
x  -> NS f middle -> NS f (v : middle)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorR leftR kR vR rightR) (NS f start
-> Either (NS f start) (Variant f ('N colorR leftR kR vR rightR))
forall a b. a -> Either a b
Left NS f start
x))
        Right Variant f ('N color 'E k v ('N colorR leftR kR vR rightR))
x -> 
            case Variant f ('N color 'E k v ('N colorR leftR kR vR rightR))
x of Here f v
x      -> f v -> NS f (v : middle)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z f v
f v
x
                      LookRight Variant f t
x -> NS f middle -> NS f (v : middle)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @_ @(N colorR leftR kR vR rightR) (Variant f ('N colorR leftR kR vR rightR)
-> Either (NS f start) (Variant f ('N colorR leftR kR vR rightR))
forall a b. b -> Either a b
Right Variant f t
Variant f ('N colorR leftR kR vR rightR)
x))
    _breakNS :: forall (f :: a -> *).
NS f (v : middle)
-> Either
     (NS f start)
     (Variant f ('N color 'E k v ('N colorR leftR kR vR rightR)))
_breakNS = \case 
        Z f x
x -> Variant f ('N color 'E k v ('N colorR leftR kR vR rightR))
-> Either
     (NS f start)
     (Variant f ('N color 'E k v ('N colorR leftR kR vR rightR)))
forall a b. b -> Either a b
Right (f v -> Variant f ('N color 'E k v ('N colorR leftR kR vR rightR))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
f x
x)
        S NS f xs
x -> case forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
NS f result -> Either (NS f start) (Variant f t)
_breakNS @_ @_ @(N colorR leftR kR vR rightR) NS f xs
x of
            Left  NS f start
ns     -> NS f start
-> Either
     (NS f start)
     (Variant f ('N color 'E k v ('N colorR leftR kR vR rightR)))
forall a b. a -> Either a b
Left NS f start
ns
            Right Variant f ('N colorR leftR kR vR rightR)
v      -> Variant f ('N color 'E k v ('N colorR leftR kR vR rightR))
-> Either
     (NS f start)
     (Variant f ('N color 'E k v ('N colorR leftR kR vR rightR)))
forall a b. b -> Either a b
Right (Variant f ('N colorR leftR kR vR rightR)
-> Variant f ('N color 'E k v ('N colorR leftR kR vR rightR))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f ('N colorR leftR kR vR rightR)
v)

{- | 
    
     Flattens a 'Variant' and adds it to the initial part of the sum.
-}
prefixNS :: forall start t result f. Sumlike start t result => Either (NS f start) (Variant f t) -> NS f result 
prefixNS :: forall {k} (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
prefixNS = forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
_prefixNS @_ @start @t @result

{- | 
     Reconstructs a 'Variant' from the initial part of the sum and returns the unconsumed part.
-}
breakNS :: forall start t result f. Sumlike start t result => NS f result -> Either (NS f start) (Variant f t)
breakNS :: forall {q} (start :: [q]) (t :: Map Symbol q) (result :: [q])
       (f :: q -> *).
Sumlike start t result =>
NS f result -> Either (NS f start) (Variant f t)
breakNS = forall k (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
NS f result -> Either (NS f start) (Variant f t)
_breakNS @_ @start @t @result

{- | Convert a 'Variant' into a n-ary sum. 
 
>>> toNS (injectI @"foo" 'a' :: Variant I (Insert "foo" Char (Insert "bar" Bool Empty)))
S (Z (I 'a')) 

-}
toNS :: forall t result f. Sumlike '[] t result => Variant f t -> NS f result
toNS :: forall {k} (t :: Map Symbol k) (result :: [k]) (f :: k -> *).
Sumlike '[] t result =>
Variant f t -> NS f result
toNS = Either (NS f '[]) (Variant f t) -> NS f result
forall {k} (start :: [k]) (t :: Map Symbol k) (result :: [k])
       (f :: k -> *).
Sumlike start t result =>
Either (NS f start) (Variant f t) -> NS f result
prefixNS (Either (NS f '[]) (Variant f t) -> NS f result)
-> (Variant f t -> Either (NS f '[]) (Variant f t))
-> Variant f t
-> NS f result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variant f t -> Either (NS f '[]) (Variant f t)
forall a b. b -> Either a b
Right

{- | Convert a n-ary sum into a compatible 'Variant'. 
 
>>> :{ 
    prettyShow_VariantI $ 
    fromNS @(FromList [ '("foo",_), '("bar",_) ]) $ 
    toNS $ 
    (injectI @"foo" 'a' :: Variant I (FromList [ '("foo",Char), '("bar",Bool) ]))
:}
"foo ('a')"

-}
fromNS :: forall t result f. Sumlike '[] t result => NS f result -> Variant f t
fromNS :: forall {q} (t :: Map Symbol q) (result :: [q]) (f :: q -> *).
Sumlike '[] t result =>
NS f result -> Variant f t
fromNS NS f result
ns = case NS f result -> Either (NS f '[]) (Variant f t)
forall {q} (start :: [q]) (t :: Map Symbol q) (result :: [q])
       (f :: q -> *).
Sumlike start t result =>
NS f result -> Either (NS f start) (Variant f t)
breakNS NS f result
ns of 
    Left NS f '[]
_ -> String -> Variant f t
forall a. HasCallStack => String -> a
error String
"this never happens"
    Right Variant f t
x -> Variant f t
x

--
--
-- Interfacing with normal records
type ToRecord :: Type -> Constraint
class ToRecord (r :: Type) where
    type RecordCode r :: Map Symbol Type
    -- https://stackoverflow.com/questions/22087549/defaultsignatures-and-associated-type-families/22088808
    type RecordCode r = RecordCode' E (G.Rep r)
    toRecord :: r -> Record I (RecordCode r)
    default toRecord :: (G.Generic r,ToRecordHelper E (G.Rep r),RecordCode r ~ RecordCode' E (G.Rep r)) => r -> Record I (RecordCode r)
    toRecord r
r = Record I 'E -> Rep r Any -> Record I (RecordCode' 'E (Rep r))
forall x.
Record I 'E -> Rep r x -> Record I (RecordCode' 'E (Rep r))
forall (start :: Map Symbol (*)) (g :: * -> *) x.
ToRecordHelper start g =>
Record I start -> g x -> Record I (RecordCode' start g)
toRecord' Record I 'E
forall {q} (f :: q -> *). Record f 'E
unit (r -> Rep r Any
forall x. r -> Rep r x
forall a x. Generic a => a -> Rep a x
G.from r
r)

instance (
    G.Generic r,
    ToRecordHelper E (G.Rep r)
    ) =>
    ToRecord (Generically (r :: Type)) where
    type RecordCode (Generically (r :: Type)) = RecordCode' E (G.Rep r)
    toRecord :: Generically r -> Record I (RecordCode (Generically r))
toRecord (Generically r
r) = Record I 'E -> Rep r Any -> Record I (RecordCode' 'E (Rep r))
forall x.
Record I 'E -> Rep r x -> Record I (RecordCode' 'E (Rep r))
forall (start :: Map Symbol (*)) (g :: * -> *) x.
ToRecordHelper start g =>
Record I start -> g x -> Record I (RecordCode' start g)
toRecord' Record I 'E
forall {q} (f :: q -> *). Record f 'E
unit (r -> Rep r Any
forall x. r -> Rep r x
forall a x. Generic a => a -> Rep a x
G.from r
r)

class ToRecordHelper (start :: Map Symbol Type) (g :: Type -> Type) where
    type RecordCode' start g :: Map Symbol Type
    toRecord' :: Record I start -> g x -> Record I (RecordCode' start g)

instance ToRecordHelper E fields => ToRecordHelper E (D1 meta (C1 metacons fields)) where
    type RecordCode' E (D1 meta (C1 metacons fields)) = RecordCode' E fields
    toRecord' :: forall x.
Record I 'E
-> D1 meta (C1 metacons fields) x
-> Record I (RecordCode' 'E (D1 meta (C1 metacons fields)))
toRecord' Record I 'E
r (M1 (M1 fields x
g)) = forall (start :: Map Symbol (*)) (g :: * -> *) x.
ToRecordHelper start g =>
Record I start -> g x -> Record I (RecordCode' start g)
toRecord' @E @fields Record I 'E
r fields x
g

instance (Insertable k v start) =>
         ToRecordHelper start
                        (S1 ('G.MetaSel ('Just k)
                                        unpackedness
                                        strictness
                                        laziness)
                            (Rec0 v)) 
  where
    type RecordCode'    start
                        (S1 ('G.MetaSel ('Just k)
                                        unpackedness
                                        strictness
                                        laziness)
                            (Rec0 v))                           = Insert k v start
    toRecord' :: forall x.
Record I start
-> S1
     ('MetaSel ('Just k) unpackedness strictness laziness) (Rec0 v) x
-> Record
     I
     (RecordCode'
        start
        (S1
           ('MetaSel ('Just k) unpackedness strictness laziness) (Rec0 v)))
toRecord' Record I start
start (M1 (K1 v
v)) = forall (k :: Symbol) v (t :: Map Symbol (*)).
Insertable k v t =>
v -> Record I t -> Record I (Insert k v t)
insertI @k v
v Record I start
start

instance ( ToRecordHelper start  t2,
           RecordCode'    start  t2 ~ middle,
           ToRecordHelper middle t1 
         ) =>
         ToRecordHelper start (t1 G.:*: t2)
  where
    type RecordCode'    start (t1 G.:*: t2) = RecordCode' (RecordCode' start t2) t1 
    toRecord' :: forall x.
Record I start
-> (:*:) t1 t2 x -> Record I (RecordCode' start (t1 :*: t2))
toRecord'           Record I start
start (t1 x
t1 G.:*: t2 x
t2) = forall (start :: Map Symbol (*)) (g :: * -> *) x.
ToRecordHelper start g =>
Record I start -> g x -> Record I (RecordCode' start g)
toRecord' @middle (forall (start :: Map Symbol (*)) (g :: * -> *) x.
ToRecordHelper start g =>
Record I start -> g x -> Record I (RecordCode' start g)
toRecord' @start Record I start
start t2 x
t2) t1 x
t1 

--
--
type FromRecord :: Type -> Constraint
class ToRecord r => FromRecord (r :: Type) where
    fromRecord :: Record I (RecordCode r) -> r
    default fromRecord :: (G.Generic r, FromRecordHelper (RecordCode r) (G.Rep r)) => Record I (RecordCode r) -> r
    fromRecord Record I (RecordCode r)
r = Rep r Any -> r
forall a x. Generic a => Rep a x -> a
forall x. Rep r x -> r
G.to (forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromRecordHelper t g =>
Record I t -> g x
fromRecord' @(RecordCode r) @(G.Rep r) Record I (RecordCode r)
r)

{- |
     The naming scheme follows that of 'Generics.SOP.IsProductType'.
 -}
type IsRecordType :: Type -> Map Symbol Type -> Constraint
type IsRecordType (r :: Type) (t :: Map Symbol Type) = (G.Generic r, ToRecord r, RecordCode r ~ t, FromRecord r)

-- {- |
--     A version of 'fromRecord' which accepts 'Record' values with more fields than the target nominal record, and possibly in an incompatible order.
--  -}
-- fromRecordSuperset :: forall r subset whole flat. (FromRecord r, RecordCode r ~ subset, ProductlikeSubset subset whole flat) => Record I whole -> r
-- fromRecordSuperset = fromRecord @r . projectSubset @subset @whole @flat

type FromRecordHelper :: Map Symbol Type -> (Type -> Type) -> Constraint
class FromRecordHelper (t :: Map Symbol Type) (g :: Type -> Type) where
    fromRecord' :: Record I t -> g x

instance FromRecordHelper t fields => FromRecordHelper t (D1 meta (C1 metacons fields)) where
    fromRecord' :: forall x. Record I t -> D1 meta (C1 metacons fields) x
fromRecord' Record I t
r = C1 metacons fields x -> M1 D meta (C1 metacons fields) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (fields x -> C1 metacons fields x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromRecordHelper t g =>
Record I t -> g x
fromRecord' @t @fields Record I t
r))

instance (Key k t, Value k t ~ v) =>
         FromRecordHelper t
                          (S1 ('G.MetaSel ('Just k)
                                          unpackedness
                                          strictness
                                          laziness)
                              (Rec0 v)) 
 where
   fromRecord' :: forall x.
Record I t
-> S1
     ('MetaSel ('Just k) unpackedness strictness laziness) (Rec0 v) x
fromRecord' Record I t
r = let v :: Value k t
v = forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Record I t -> Value k t
projectI @k Record I t
r in Rec0 v x
-> M1
     S ('MetaSel ('Just k) unpackedness strictness laziness) (Rec0 v) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (v -> Rec0 v x
forall k i c (p :: k). c -> K1 i c p
K1 v
Value k t
v)

instance ( FromRecordHelper t t1,
           FromRecordHelper t t2
         ) => 
         FromRecordHelper t (t1 G.:*: t2) 
  where 
   fromRecord' :: forall x. Record I t -> (:*:) t1 t2 x
fromRecord' Record I t
r = 
        let v1 :: t1 x
v1 = forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromRecordHelper t g =>
Record I t -> g x
fromRecord' @_ @t1 Record I t
r
            v2 :: t2 x
v2 = forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromRecordHelper t g =>
Record I t -> g x
fromRecord' @_ @t2 Record I t
r
         in t1 x
v1 t1 x -> t2 x -> (:*:) t1 t2 x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
G.:*: t2 x
v2

--
--
--
type VariantCode :: Type -> Map Symbol Type
type family VariantCode (s :: Type) :: Map Symbol Type where
    VariantCode s = VariantCode' E (G.Rep s)

type VariantCode' :: Map Symbol Type -> (Type -> Type) -> Map Symbol Type
type family VariantCode' (acc :: Map Symbol Type) (g :: Type -> Type) :: Map Symbol Type where
    VariantCode' acc (D1 meta fields) = VariantCode' acc fields
    VariantCode' acc (t1 G.:+: t2) = VariantCode' (VariantCode' acc t2) t1
    VariantCode' acc (C1 (G.MetaCons k _ _) (S1 ('G.MetaSel Nothing unpackedness strictness laziness) (Rec0 v))) = Insert k v acc
    VariantCode' acc (C1 (G.MetaCons k _ _) G.U1) = Insert k () acc
     
type FromVariant :: Type -> Constraint     
class FromVariant (s :: Type) where
    fromVariant :: Variant I (VariantCode s) -> s
    default fromVariant :: (G.Generic s, FromVariantHelper (VariantCode s) (G.Rep s)) => Variant I (VariantCode s) -> s
    fromVariant Variant I (VariantCode s)
v = case forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromVariantHelper t g =>
Variant I t -> Maybe (g x)
fromVariant' @(VariantCode s) Variant I (VariantCode s)
v of
        Just Rep s Any
x -> Rep s Any -> s
forall a x. Generic a => Rep a x -> a
forall x. Rep s x -> s
G.to Rep s Any
x
        Maybe (Rep s Any)
Nothing -> String -> s
forall a. HasCallStack => String -> a
error String
"fromVariant match fail. Should not happen."

{- |
     The naming scheme follows that of 'Generics.SOP.IsProductType'.
 -}
type IsVariantType :: Type -> Map Symbol Type -> Constraint
type IsVariantType (v :: Type) (t :: Map Symbol Type) = (G.Generic v, ToVariant v, VariantCode v ~ t, FromVariant v)

class FromVariantHelper (t :: Map Symbol Type) (g :: Type -> Type) where
    fromVariant' :: Variant I t -> Maybe (g x)

instance FromVariantHelper t fields => FromVariantHelper t (D1 meta fields) where
    fromVariant' :: forall x. Variant I t -> Maybe (D1 meta fields x)
fromVariant' Variant I t
v = fields x -> M1 D meta fields x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (fields x -> M1 D meta fields x)
-> Maybe (fields x) -> Maybe (M1 D meta fields x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromVariantHelper t g =>
Variant I t -> Maybe (g x)
fromVariant' @t Variant I t
v

instance (Key k t, Value k t ~ v) 
         => FromVariantHelper t (C1 (G.MetaCons k x y) (S1 ('G.MetaSel Nothing unpackedness strictness laziness) (Rec0 v)))
  where
    fromVariant' :: forall x.
Variant I t
-> Maybe
     (C1
        ('MetaCons k x y)
        (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v))
        x)
fromVariant' Variant I t
v = case forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Variant I t -> Maybe (Value k t)
matchI @k @t Variant I t
v of
        Just Value k t
x -> C1
  ('MetaCons k x y)
  (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v))
  x
-> Maybe
     (C1
        ('MetaCons k x y)
        (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v))
        x)
forall a. a -> Maybe a
Just (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v) x
-> C1
     ('MetaCons k x y)
     (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v))
     x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 v x
-> S1
     ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (v -> Rec0 v x
forall k i c (p :: k). c -> K1 i c p
K1 v
Value k t
x)) )
        Maybe (Value k t)
Nothing -> Maybe
  (C1
     ('MetaCons k x y)
     (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v))
     x)
forall a. Maybe a
Nothing

instance (Key k t, Value k t ~ ()) 
         => FromVariantHelper t (C1 (G.MetaCons k x y) G.U1)
  where
    fromVariant' :: forall x. Variant I t -> Maybe (C1 ('MetaCons k x y) U1 x)
fromVariant' Variant I t
v = case forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Variant I t -> Maybe (Value k t)
matchI @k @t Variant I t
v of
        Just Value k t
x -> C1 ('MetaCons k x y) U1 x -> Maybe (C1 ('MetaCons k x y) U1 x)
forall a. a -> Maybe a
Just (U1 x -> C1 ('MetaCons k x y) U1 x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 x
forall k (p :: k). U1 p
G.U1)
        Maybe (Value k t)
Nothing -> Maybe (C1 ('MetaCons k x y) U1 x)
forall a. Maybe a
Nothing

instance ( FromVariantHelper t t1,
           FromVariantHelper t t2 
         ) =>
         FromVariantHelper t (t1 G.:+: t2)
  where
    fromVariant' :: forall x. Variant I t -> Maybe ((:+:) t1 t2 x)
fromVariant' Variant I t
v = case forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromVariantHelper t g =>
Variant I t -> Maybe (g x)
fromVariant' @t @t1 Variant I t
v of
        Just t1 x
x1 -> (:+:) t1 t2 x -> Maybe ((:+:) t1 t2 x)
forall a. a -> Maybe a
Just (t1 x -> (:+:) t1 t2 x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
G.L1 t1 x
x1)
        Maybe (t1 x)
Nothing -> case forall (t :: Map Symbol (*)) (g :: * -> *) x.
FromVariantHelper t g =>
Variant I t -> Maybe (g x)
fromVariant' @t @t2 Variant I t
v of
            Just t2 x
x2 -> (:+:) t1 t2 x -> Maybe ((:+:) t1 t2 x)
forall a. a -> Maybe a
Just (t2 x -> (:+:) t1 t2 x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
G.R1 t2 x
x2)
            Maybe (t2 x)
Nothing -> Maybe ((:+:) t1 t2 x)
forall a. Maybe a
Nothing

--
--
type ToVariant :: Type -> Constraint
class ToVariant (s :: Type) where
    toVariant :: s -> Variant I (VariantCode s)
    default toVariant :: (G.Generic s, ToVariantHelper (VariantCode s) (G.Rep s)) => s -> Variant I (VariantCode s)
    toVariant s
s = forall (t :: Map Symbol (*)) (g :: * -> *) x.
ToVariantHelper t g =>
g x -> Variant I t
toVariant' @(VariantCode s) @(G.Rep s) (s -> Rep s Any
forall x. s -> Rep s x
forall a x. Generic a => a -> Rep a x
G.from s
s)

class ToVariantHelper (t :: Map Symbol Type) (g :: Type -> Type) where
    toVariant' :: g x -> Variant I t 

instance ToVariantHelper t fields => ToVariantHelper t (D1 meta fields) where
    toVariant' :: forall x. D1 meta fields x -> Variant I t
toVariant' (M1 fields x
fields) = forall (t :: Map Symbol (*)) (g :: * -> *) x.
ToVariantHelper t g =>
g x -> Variant I t
toVariant' @t fields x
fields

instance (Key k t, Value k t ~ v) =>
    ToVariantHelper t (C1 (G.MetaCons k x y) (S1 ('G.MetaSel Nothing unpackedness strictness laziness) (Rec0 v))) 
  where
    toVariant' :: forall x.
C1
  ('MetaCons k x y)
  (S1 ('MetaSel 'Nothing unpackedness strictness laziness) (Rec0 v))
  x
-> Variant I t
toVariant' (M1 (M1 (K1 v
v))) = forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Value k t -> Variant I t
injectI @k v
Value k t
v

instance (Key k t, Value k t ~ ()) =>
    ToVariantHelper t (C1 (G.MetaCons k x y) G.U1) where
    toVariant' :: forall x. C1 ('MetaCons k x y) U1 x -> Variant I t
toVariant' (M1 U1 x
G.U1) = forall (k :: Symbol) (t :: Map Symbol (*)).
Key k t =>
Value k t -> Variant I t
injectI @k ()

instance ( ToVariantHelper t t1,
           ToVariantHelper t t2 
         ) =>
         ToVariantHelper t (t1 G.:+: t2)
  where
    toVariant' :: forall x. (:+:) t1 t2 x -> Variant I t
toVariant' = \case
        G.L1 t1 x
l -> forall (t :: Map Symbol (*)) (g :: * -> *) x.
ToVariantHelper t g =>
g x -> Variant I t
toVariant' @t t1 x
l
        G.R1 t2 x
r -> forall (t :: Map Symbol (*)) (g :: * -> *) x.
ToVariantHelper t g =>
g x -> Variant I t
toVariant' @t t2 x
r

--
--
-- deletion
--
--
--
type DiscriminateBalL :: Map k v -> Map k v -> Bool 
type family DiscriminateBalL (l :: Map k v) (r :: Map k v) :: Bool where
    DiscriminateBalL (N R _ _ _ _) _ = False
    DiscriminateBalL _             _ = True

type BalanceableL :: Map Symbol q -> Symbol -> q -> Map Symbol q -> Constraint
class BalanceableL (l :: Map Symbol q) (k :: Symbol) (v :: q) (r :: Map Symbol q) where
    type BalL l k v r :: Map Symbol q
    balLR :: Record f (N color l k v r) -> Record f (BalL l k v r)
    balLV :: Variant f (N color l k v r) -> Variant f (BalL l k v r)

type BalanceableHelperL :: Bool -> Map Symbol q -> Symbol -> q -> Map Symbol q -> Constraint
class BalanceableHelperL (b :: Bool) (l :: Map Symbol q) (k :: Symbol) (v :: q) (r :: Map Symbol q) where
    type BalL' b l k v r :: Map Symbol q
    balLR' :: Record f (N color l k v r) -> Record f (BalL' b l k v r)
    balLV' :: Variant f (N color l k v r) -> Variant f (BalL' b l k v r)

instance (DiscriminateBalL l r ~ b, BalanceableHelperL b l k v r) => BalanceableL l k v r where
    type BalL l k v r = BalL' (DiscriminateBalL l r) l k v r
    balLR :: forall (f :: q -> *) (color :: Color).
Record f ('N color l k v r) -> Record f (BalL l k v r)
balLR = forall q (b :: Bool) (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableHelperL b l k v r =>
Record f ('N color l k v r) -> Record f (BalL' b l k v r)
balLR' @_ @b @l @k @v @r
    balLV :: forall (f :: q -> *) (color :: Color).
Variant f ('N color l k v r) -> Variant f (BalL l k v r)
balLV = forall q (b :: Bool) (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableHelperL b l k v r =>
Variant f ('N color l k v r) -> Variant f (BalL' b l k v r)
balLV' @_ @b @l @k @v @r

-- balleft :: RB a -> a -> RB a -> RB a
-- balleft (T R a x b) y c = T R (T B a x b) y c
instance BalanceableHelperL False (N R left1 k1 v1 right1) k2 v2 right2 where
    type BalL'              False (N R left1 k1 v1 right1) k2 v2 right2 =
                             (N R (N B left1 k1 v1 right1) k2 v2 right2)
    balLR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color ('N 'R left1 k1 v1 right1) k2 v2 right2)
-> Record f (BalL' 'False ('N 'R left1 k1 v1 right1) k2 v2 right2)
balLR' (Node (Node Record f left
left' f v
v' Record f right
right') f v
v Record f right
right) = Record f ('N 'B left k1 v right)
-> f v
-> Record f right
-> Record f ('N 'R ('N 'B left k1 v right) k2 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f right -> Record f ('N 'B left k1 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left' f v
v' Record f right
right') f v
v Record f right
right
    balLV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color ('N 'R left1 k1 v1 right1) k2 v2 right2)
-> Variant f (BalL' 'False ('N 'R left1 k1 v1 right1) k2 v2 right2)
balLV' Variant f ('N color ('N 'R left1 k1 v1 right1) k2 v2 right2)
v = case Variant f ('N color ('N 'R left1 k1 v1 right1) k2 v2 right2)
v of LookLeft Variant f t
x  -> Variant f ('N 'B left1 k1 v1 right1)
-> Variant f ('N 'R ('N 'B left1 k1 v1 right1) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (case Variant f t
x of LookLeft Variant f t
y  -> Variant f t -> Variant f ('N 'B t k1 v1 right1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
y
                                                            Here f v
y      -> f v -> Variant f ('N 'B left1 k1 v right1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
y
                                                            LookRight Variant f t
y -> Variant f t -> Variant f ('N 'B left1 k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
y)
                         Here f v
x      -> f v -> Variant f ('N 'R ('N 'B left1 k1 v1 right1) k2 v right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x
                         LookRight Variant f t
x -> Variant f t -> Variant f ('N 'R ('N 'B left1 k1 v1 right1) k2 v2 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
x

-- balleft bl x (T B a y b) = balance bl x (T R a y b)
-- the @(N B in the call to balance tree is misleading, as it is ingored...
instance (N R t2 z zv t3 ~ g, BalanceableHelper (ShouldBalance t1 g) t1 y yv g) => 
    BalanceableHelperL True t1 y yv (N B t2 z zv t3) where
    type BalL'         True t1 y yv (N B t2 z zv t3)     
                 =  Balance t1 y yv (N R t2 z zv t3)
    balLR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color t1 y yv ('N 'B t2 z zv t3))
-> Record f (BalL' 'True t1 y yv ('N 'B t2 z zv t3))
balLR' (Node Record f left
left1 f v
v1 (Node Record f left
left2 f v
v2 Record f right
right2)) = 
        forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Record f ('N color left k v right)
-> Record f (Balance left k v right)
balanceR @_ @t1 @y @yv @(N R t2 z zv t3) (Record f t1
-> f yv
-> Record f ('N 'R t2 z zv t3)
-> Record f ('N Any t1 y yv ('N 'R t2 z zv t3))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f t1
Record f left
left1 f yv
f v
v1 (Record f t2 -> f zv -> Record f t3 -> Record f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f t2
Record f left
left2 f zv
f v
v2 Record f t3
Record f right
right2))
    balLV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color t1 y yv ('N 'B t2 z zv t3))
-> Variant f (BalL' 'True t1 y yv ('N 'B t2 z zv t3))
balLV' Variant f ('N color t1 y yv ('N 'B t2 z zv t3))
v = forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @t1 @y @yv @(N R t2 z zv t3) (case Variant f ('N color t1 y yv ('N 'B t2 z zv t3))
v of
        LookLeft Variant f t
l -> Variant f t1 -> Variant f ('N Any t1 y yv ('N 'R t2 z zv t3))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t1
Variant f t
l
        Here f v
x -> f yv -> Variant f ('N Any t1 y yv ('N 'R t2 z zv t3))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f yv
f v
x
        LookRight Variant f t
r -> Variant f ('N 'R t2 z zv t3)
-> Variant f ('N Any t1 y yv ('N 'R t2 z zv t3))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (case Variant f t
r of
                            LookLeft Variant f t
l' -> Variant f t2 -> Variant f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t2
Variant f t
l'
                            Here f v
x' -> f zv -> Variant f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f zv
f v
x'
                            LookRight Variant f t
r' -> Variant f t3 -> Variant f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t3
Variant f t
r'))

-- balleft bl x (T R (T B a y b) z c) = T R (T B bl x a) y (balance b z (sub1 c))
instance (N R l k kv r ~ g, BalanceableHelper    (ShouldBalance t3 g) t3 z zv g) => 
    BalanceableHelperL True t1 y yv (N R (N B t2 u uv t3) z zv (N B l k kv r)) where
    type BalL'         True t1 y yv (N R (N B t2 u uv t3) z zv (N B l k kv r)) =
                             N R (N B t1 y yv t2) u uv (Balance t3 z zv (N R l k kv r))          
    balLR' :: forall (f :: q -> *) (color :: Color).
Record
  f
  ('N color t1 y yv ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)))
-> Record
     f
     (BalL'
        'True t1 y yv ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)))
balLR' (Node Record f left
left1 f v
v1 (Node (Node Record f left
left2 f v
v2 Record f right
right2) f v
vx (Node Record f left
left3 f v
v3 Record f right
right3))) = 
            Record f ('N 'B left y v left)
-> f v
-> Record
     f
     (Balance'
        (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r))
-> Record
     f
     ('N
        'R
        ('N 'B left y v left)
        u
        v
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f left -> Record f ('N 'B left y v left)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left1 f v
v1 Record f left
left2) f v
v2 (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Record f ('N color left k v right)
-> Record f (Balance left k v right)
balanceR @_ @t3 @z @zv @(N R l k kv r) (Record f t3
-> f zv
-> Record f ('N 'R l k kv r)
-> Record f ('N Any t3 z zv ('N 'R l k kv r))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f t3
Record f right
right2 f zv
f v
vx (Record f l -> f kv -> Record f r -> Record f ('N 'R l k kv r)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f l
Record f left
left3 f kv
f v
v3 Record f r
Record f right
right3)))
    balLV' :: forall (f :: q -> *) (color :: Color).
Variant
  f
  ('N color t1 y yv ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)))
-> Variant
     f
     (BalL'
        'True t1 y yv ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)))
balLV' Variant
  f
  ('N color t1 y yv ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)))
v = case Variant
  f
  ('N color t1 y yv ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)))
v of LookLeft Variant f t
left1                          -> Variant f ('N 'B t y yv t2)
-> Variant
     f
     ('N
        'R
        ('N 'B t y yv t2)
        u
        uv
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t y yv t2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
left1)
                         Here f v
v1                                 -> Variant f ('N 'B t1 y v t2)
-> Variant
     f
     ('N
        'R
        ('N 'B t1 y v t2)
        u
        uv
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B t1 y v t2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v1)
                         LookRight (LookLeft (LookLeft Variant f t
left2))   -> Variant f ('N 'B t1 y yv t)
-> Variant
     f
     ('N
        'R
        ('N 'B t1 y yv t)
        u
        uv
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t1 y yv t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
left2)
                         LookRight (LookLeft (Here f v
v2))          -> f v
-> Variant
     f
     ('N
        'R
        ('N 'B t1 y yv t2)
        u
        v
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v2
                         LookRight (LookLeft (LookRight Variant f t
right2)) -> Variant
  f
  (Balance'
     (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r))
-> Variant
     f
     ('N
        'R
        ('N 'B t1 y yv t2)
        u
        uv
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @t3 @z @zv @(N R l k kv r) (Variant f t3 -> Variant f ('N Any t3 z zv ('N 'R l k kv r))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t3
Variant f t
right2))
                         LookRight (Here f v
vx)                     -> Variant
  f
  (Balance'
     (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r))
-> Variant
     f
     ('N
        'R
        ('N 'B t1 y yv t2)
        u
        uv
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @t3 @z @zv @(N R l k kv r) (f zv -> Variant f ('N Any t3 z zv ('N 'R l k kv r))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f zv
f v
vx))
                         LookRight (LookRight Variant f t
rr)                -> Variant
  f
  (Balance'
     (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r))
-> Variant
     f
     ('N
        'R
        ('N 'B t1 y yv t2)
        u
        uv
        (Balance'
           (ShouldBalance t3 ('N 'R l k kv r)) t3 z zv ('N 'R l k kv r)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @t3 @z @zv @(N R l k kv r) (Variant f ('N 'R l k kv r)
-> Variant f ('N Any t3 z zv ('N 'R l k kv r))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (case Variant f t
rr of
                                                                        LookLeft Variant f t
left3 -> Variant f l -> Variant f ('N 'R l k kv r)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f l
Variant f t
left3
                                                                        Here f v
v3 -> f kv -> Variant f ('N 'R l k kv r)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f kv
f v
v3
                                                                        LookRight Variant f t
right3 -> Variant f r -> Variant f ('N 'R l k kv r)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f r
Variant f t
right3)))


-- balright :: RB a -> a -> RB a -> RB a
-- balright a x (T R b y c) = T R a x (T B b y c)
-- balright (T B a x b) y bl = balance (T R a x b) y bl
-- balright (T R a x (T B b y c)) z bl = T R (balance (sub1 a) x b) y (T B c z bl)
type DiscriminateBalR :: Map k v -> Map k v -> Bool
type family DiscriminateBalR (l :: Map k v) (r :: Map k v) :: Bool where
    DiscriminateBalR _ (N R _ _ _ _) = False
    DiscriminateBalR _ _             = True


type BalanceableR :: Map Symbol q -> Symbol -> q -> Map Symbol q -> Constraint
class BalanceableR (l :: Map Symbol q) (k :: Symbol) (v :: q) (r :: Map Symbol q) where
    type BalR l k v r :: Map Symbol q
    balRR :: Record f (N color l k v r) -> Record f (BalR l k v r)
    balRV :: Variant f (N color l k v r) -> Variant f (BalR l k v r)

type BalanceableHelperR :: Bool -> Map Symbol q -> Symbol -> q -> Map Symbol q -> Constraint
class BalanceableHelperR (b :: Bool) (l :: Map Symbol q) (k :: Symbol) (v :: q) (r :: Map Symbol q) where
    type BalR' b l k v r :: Map Symbol q
    balRR' :: Record f (N color l k v r) -> Record f (BalR' b l k v r)
    balRV' :: Variant f (N color l k v r) -> Variant f (BalR' b l k v r)

instance (DiscriminateBalR l r ~ b, BalanceableHelperR b l k v r) => BalanceableR l k v r where
    type BalR l k v r = BalR' (DiscriminateBalR l r) l k v r
    balRR :: forall (f :: q -> *) (color :: Color).
Record f ('N color l k v r) -> Record f (BalR l k v r)
balRR = forall q (b :: Bool) (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableHelperR b l k v r =>
Record f ('N color l k v r) -> Record f (BalR' b l k v r)
balRR' @_ @b @l @k @v @r
    balRV :: forall (f :: q -> *) (color :: Color).
Variant f ('N color l k v r) -> Variant f (BalR l k v r)
balRV = forall q (b :: Bool) (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableHelperR b l k v r =>
Variant f ('N color l k v r) -> Variant f (BalR' b l k v r)
balRV' @_ @b @l @k @v @r

-- balright :: RB a -> a -> RB a -> RB a
-- balright a x (T R b y c) = T R a x (T B b y c)
instance BalanceableHelperR False right2 k2 v2 (N R left1 k1 v1 right1) where
    type BalR'              False right2 k2 v2 (N R left1 k1 v1 right1) =
                                  (N R right2 k2 v2 (N B left1 k1 v1 right1))
    balRR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color right2 k2 v2 ('N 'R left1 k1 v1 right1))
-> Record f (BalR' 'False right2 k2 v2 ('N 'R left1 k1 v1 right1))
balRR' (Node Record f left
right f v
v (Node Record f left
left' f v
v' Record f right
right')) = Record f left
-> f v
-> Record f ('N 'B left k1 v right)
-> Record f ('N 'R left k2 v ('N 'B left k1 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node  Record f left
right f v
v (Record f left
-> f v -> Record f right -> Record f ('N 'B left k1 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left' f v
v' Record f right
right')
    balRV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color right2 k2 v2 ('N 'R left1 k1 v1 right1))
-> Variant f (BalR' 'False right2 k2 v2 ('N 'R left1 k1 v1 right1))
balRV' Variant f ('N color right2 k2 v2 ('N 'R left1 k1 v1 right1))
v = case Variant f ('N color right2 k2 v2 ('N 'R left1 k1 v1 right1))
v of LookLeft Variant f t
x   -> Variant f t -> Variant f ('N 'R t k2 v2 ('N 'B left1 k1 v1 right1))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
x
                         Here f v
x       -> f v -> Variant f ('N 'R right2 k2 v ('N 'B left1 k1 v1 right1))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
x
                         LookRight Variant f t
x  -> Variant f ('N 'B left1 k1 v1 right1)
-> Variant f ('N 'R right2 k2 v2 ('N 'B left1 k1 v1 right1))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (case Variant f t
x of LookLeft Variant f t
y  -> Variant f t -> Variant f ('N 'B t k1 v1 right1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
y
                                                              Here f v
y      -> f v -> Variant f ('N 'B left1 k1 v right1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
y
                                                              LookRight Variant f t
y -> Variant f t -> Variant f ('N 'B left1 k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
y)

-- balright (T B a x b) y bl = balance (T R a x b) y bl
instance (N R t2 z zv t3 ~ g, ShouldBalance g t1 ~ shouldbalance, BalanceableHelper shouldbalance g y yv t1) => 
    BalanceableHelperR True (N B t2 z zv t3) y yv t1 where
    type BalR'         True (N B t2 z zv t3) y yv t1     
             =  Balance (N R t2 z zv t3) y yv t1
    balRR' :: forall (f :: q -> *) (color :: Color).
Record f ('N color ('N 'B t2 z zv t3) y yv t1)
-> Record f (BalR' 'True ('N 'B t2 z zv t3) y yv t1)
balRR' (Node (Node Record f left
left1 f v
v1 Record f right
right1) f v
v2 Record f right
right2) = forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Record f ('N color left k v right)
-> Record f (Balance left k v right)
balanceR @_ @(N R t2 z zv t3) @y @yv @t1 
           (Record f ('N 'R t2 z zv t3)
-> f yv
-> Record f t1
-> Record f ('N Any ('N 'R t2 z zv t3) y yv t1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f t2 -> f zv -> Record f t3 -> Record f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f t2
Record f left
left1 f zv
f v
v1 Record f t3
Record f right
right1) f yv
f v
v2 Record f t1
Record f right
right2)
    balRV' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color ('N 'B t2 z zv t3) y yv t1)
-> Variant f (BalR' 'True ('N 'B t2 z zv t3) y yv t1)
balRV' Variant f ('N color ('N 'B t2 z zv t3) y yv t1)
v = forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @(N R t2 z zv t3) @y @yv @t1 (case Variant f ('N color ('N 'B t2 z zv t3) y yv t1)
v of
        LookLeft Variant f t
l -> Variant f ('N 'R t2 z zv t3)
-> Variant f ('N Any ('N 'R t2 z zv t3) y yv t1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (case Variant f t
l of 
            LookLeft Variant f t
l' -> Variant f t2 -> Variant f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t2
Variant f t
l'
            Here f v
x' -> f zv -> Variant f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f zv
f v
x'
            LookRight Variant f t
r' -> Variant f t3 -> Variant f ('N 'R t2 z zv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t3
Variant f t
r')
        Here f v
x -> f yv -> Variant f ('N Any ('N 'R t2 z zv t3) y yv t1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f yv
f v
x
        LookRight Variant f t
r -> Variant f t1 -> Variant f ('N Any ('N 'R t2 z zv t3) y yv t1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t1
Variant f t
r)

-- balright (T R a x (T B b y c)) z bl = T R (balance (sub1 a) x b) y (T B c z bl)
instance (N R t2 u uv t3 ~ g, ShouldBalance g l ~ shouldbalance, BalanceableHelper shouldbalance g z zv l) => 
    BalanceableHelperR True (N R (N B t2 u uv t3) z zv (N B l k kv r)) y yv t1 where
    type BalR'         True (N R (N B t2 u uv t3) z zv (N B l k kv r)) y yv t1 =
                             N R (Balance (N R t2 u uv t3) z zv l) k kv (N B r y yv t1) 
    balRR' :: forall (f :: q -> *) (color :: Color).
Record
  f
  ('N color ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)) y yv t1)
-> Record
     f
     (BalR'
        'True ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)) y yv t1)
balRR' (Node (Node (Node Record f left
left2 f v
v2 Record f right
right2) f v
vx (Node Record f left
left3 f v
v3 Record f right
right3)) f v
v1 Record f right
left1) = 
            Record f (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
-> f v
-> Record f ('N 'B right y v right)
-> Record
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        v
        ('N 'B right y v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Record f ('N color left k v right)
-> Record f (Balance left k v right)
balanceR @_ @(N R t2 u uv t3) @z @zv @l (Record f ('N 'R t2 u uv t3)
-> f zv
-> Record f l
-> Record f ('N Any ('N 'R t2 u uv t3) z zv l)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f t2 -> f uv -> Record f t3 -> Record f ('N 'R t2 u uv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f t2
Record f left
left2 f uv
f v
v2 Record f t3
Record f right
right2) f zv
f v
vx Record f l
Record f left
left3)) f v
v3 (Record f right
-> f v -> Record f right -> Record f ('N 'B right y v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f right
right3 f v
v1 Record f right
left1)
    balRV' :: forall (f :: q -> *) (color :: Color).
Variant
  f
  ('N color ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)) y yv t1)
-> Variant
     f
     (BalR'
        'True ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)) y yv t1)
balRV' Variant
  f
  ('N color ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)) y yv t1)
v = case Variant
  f
  ('N color ('N 'R ('N 'B t2 u uv t3) z zv ('N 'B l k kv r)) y yv t1)
v of
        LookLeft  (LookLeft Variant f t
rr)                 -> Variant f (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
-> Variant
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        kv
        ('N 'B r y yv t1))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @(N R t2 u uv t3) @z @zv @l (Variant f ('N 'R t2 u uv t3)
-> Variant f ('N Any ('N 'R t2 u uv t3) z zv l)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (case Variant f t
rr of
                                                        LookLeft Variant f t
t2 -> Variant f t2 -> Variant f ('N 'R t2 u uv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t2
Variant f t
t2
                                                        Here f v
uv -> f uv -> Variant f ('N 'R t2 u uv t3)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f uv
f v
uv
                                                        LookRight Variant f t
t3 -> Variant f t3 -> Variant f ('N 'R t2 u uv t3)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t3
Variant f t
t3)))
        LookLeft  (Here f v
zv)                     -> Variant f (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
-> Variant
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        kv
        ('N 'B r y yv t1))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @(N R t2 u uv t3) @z @zv @l (f zv -> Variant f ('N Any ('N 'R t2 u uv t3) z zv l)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f zv
f v
zv))
        LookLeft  (LookRight (LookLeft Variant f t
l))      -> Variant f (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
-> Variant
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        kv
        ('N 'B r y yv t1))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (forall q (left :: Map Symbol q) (k :: Symbol) (v :: q)
       (right :: Map Symbol q) (f :: q -> *) (color :: Color).
Balanceable left k v right =>
Variant f ('N color left k v right)
-> Variant f (Balance left k v right)
balanceV @_ @(N R t2 u uv t3) @z @zv @l (Variant f l -> Variant f ('N Any ('N 'R t2 u uv t3) z zv l)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f l
Variant f t
l))
        LookLeft  (LookRight (Here f v
kv))         -> f v
-> Variant
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        v
        ('N 'B r y yv t1))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
kv
        LookLeft  (LookRight (LookRight Variant f t
r))     -> Variant f ('N 'B t y yv t1)
-> Variant
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        kv
        ('N 'B t y yv t1))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B t y yv t1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
r)
        Here      f v
yv                            -> Variant f ('N 'B r y v t1)
-> Variant
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        kv
        ('N 'B r y v t1))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'B r y v t1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
yv) 
        LookRight Variant f t
t1                            -> Variant f ('N 'B r y yv t)
-> Variant
     f
     ('N
        'R
        (Balance' shouldbalance ('N 'R t2 u uv t3) z zv l)
        k
        kv
        ('N 'B r y yv t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B r y yv t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
t1)

-- app :: RB a -> RB a -> RB a
-- app E x = x
-- app x E = x
-- app (T R a x b) (T R c y d) =
--  case app b c of
--      T R b' z c' -> T R(T R a x b') z (T R c' y d)
--      bc -> T R a x (T R bc y d)
-- app (T B a x b) (T B c y d) = 
--  case app b c of
--      T R b' z c' -> T R(T B a x b') z (T B c' y d)
--      bc -> balleft a x (T B bc y d)
-- app a (T R b x c) = T R (app a b) x c
-- app (T R a x b) c = T R a x (app b c)


type Fuseable :: Map Symbol q -> Map Symbol q -> Constraint
class Fuseable (l :: Map Symbol q) (r :: Map Symbol q) where
    type Fuse l r :: Map Symbol q
    fuseRecord :: Record f l -> Record f r -> Record f (Fuse l r)
    fuseVariant :: Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)

instance Fuseable E E where
    type Fuse E E = E
    fuseRecord :: forall (f :: q -> *).
Record f 'E -> Record f 'E -> Record f (Fuse 'E 'E)
fuseRecord Record f 'E
_ Record f 'E
_ = Record f (Fuse 'E 'E)
Record f 'E
forall {q} (f :: q -> *). Record f 'E
unit
    fuseVariant :: forall (f :: q -> *).
Either (Variant f 'E) (Variant f 'E) -> Variant f (Fuse 'E 'E)
fuseVariant Either (Variant f 'E) (Variant f 'E)
v = case Either (Variant f 'E) (Variant f 'E)
v of

-- app E x = x
instance Fuseable E (N color left k v right) where
    type Fuse E (N color left k v right) = N color left k v right
    fuseRecord :: forall (f :: q -> *).
Record f 'E
-> Record f ('N color left k v right)
-> Record f (Fuse 'E ('N color left k v right))
fuseRecord Record f 'E
_ Record f ('N color left k v right)
r = Record f (Fuse 'E ('N color left k v right))
Record f ('N color left k v right)
r
    fuseVariant :: forall (f :: q -> *).
Either (Variant f 'E) (Variant f ('N color left k v right))
-> Variant f (Fuse 'E ('N color left k v right))
fuseVariant Either (Variant f 'E) (Variant f ('N color left k v right))
e = case Either (Variant f 'E) (Variant f ('N color left k v right))
e of
        Right Variant f ('N color left k v right)
v -> Variant f (Fuse 'E ('N color left k v right))
Variant f ('N color left k v right)
v

-- app x E = x
instance Fuseable (N color left k v right) E where
    type Fuse (N color left k v right) E = N color left k v right
    fuseRecord :: forall (f :: q -> *).
Record f ('N color left k v right)
-> Record f 'E -> Record f (Fuse ('N color left k v right) 'E)
fuseRecord Record f ('N color left k v right)
r Record f 'E
_ = Record f (Fuse ('N color left k v right) 'E)
Record f ('N color left k v right)
r
    fuseVariant :: forall (f :: q -> *).
Either (Variant f ('N color left k v right)) (Variant f 'E)
-> Variant f (Fuse ('N color left k v right) 'E)
fuseVariant Either (Variant f ('N color left k v right)) (Variant f 'E)
e = case Either (Variant f ('N color left k v right)) (Variant f 'E)
e of
        Left Variant f ('N color left k v right)
v -> Variant f (Fuse ('N color left k v right) 'E)
Variant f ('N color left k v right)
v

-- app a (T R b x c) = T R (app a b) x c
instance Fuseable (N B left1 k1 v1 right1) left2 
    => Fuseable (N B left1 k1 v1 right1) (N R left2 k2 v2 right2) where
    type Fuse   (N B left1 k1 v1 right1) (N R left2 k2 v2 right2) = N R (Fuse (N B left1 k1 v1 right1) left2) k2 v2 right2
    fuseRecord :: forall (f :: q -> *).
Record f ('N 'B left1 k1 v1 right1)
-> Record f ('N 'R left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseRecord (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = Record f (Fuse ('N 'B left1 k1 v1 right1) left2)
-> f v
-> Record f right
-> Record
     f ('N 'R (Fuse ('N 'B left1 k1 v1 right1) left2) k2 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Record f l -> Record f r -> Record f (Fuse l r)
fuseRecord @_ @(N B left1 k1 v1 right1) (Record f left1
-> f v1 -> Record f right1 -> Record f ('N 'B left1 k1 v1 right1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left1
Record f left
left1 f v1
f v
v1 Record f right1
Record f right
right1) Record f left
left2) f v
v2 Record f right
right2 
    fuseVariant :: forall (f :: q -> *).
Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseVariant Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
e = case Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
e of 
        Left Variant f ('N 'B left1 k1 v1 right1)
l  -> case Variant f ('N 'B left1 k1 v1 right1)
l of
            LookLeft Variant f t
left1   -> Variant f (Fuse ('N 'B left1 k1 v1 right1) left2)
-> Variant
     f ('N 'R (Fuse ('N 'B left1 k1 v1 right1) left2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft  (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @(N B left1 k1 v1 right1) @left2 (Variant f ('N 'B left1 k1 v1 right1)
-> Either (Variant f ('N 'B left1 k1 v1 right1)) (Variant f left2)
forall a b. a -> Either a b
Left (Variant f left1 -> Variant f ('N 'B left1 k1 v1 right1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f left1
Variant f t
left1)))
            Here f v
v1          -> Variant f (Fuse ('N 'B left1 k1 v1 right1) left2)
-> Variant
     f ('N 'R (Fuse ('N 'B left1 k1 v1 right1) left2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft  (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @(N B left1 k1 v1 right1) @left2 (Variant f ('N 'B left1 k1 v1 right1)
-> Either (Variant f ('N 'B left1 k1 v1 right1)) (Variant f left2)
forall a b. a -> Either a b
Left (f v1 -> Variant f ('N 'B left1 k1 v1 right1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v1
f v
v1)))
            LookRight Variant f t
right1 -> Variant f (Fuse ('N 'B left1 k1 v1 right1) left2)
-> Variant
     f ('N 'R (Fuse ('N 'B left1 k1 v1 right1) left2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft  (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @(N B left1 k1 v1 right1) @left2 (Variant f ('N 'B left1 k1 v1 right1)
-> Either (Variant f ('N 'B left1 k1 v1 right1)) (Variant f left2)
forall a b. a -> Either a b
Left (Variant f right1 -> Variant f ('N 'B left1 k1 v1 right1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f right1
Variant f t
right1)))
        Right Variant f ('N 'R left2 k2 v2 right2)
r -> case Variant f ('N 'R left2 k2 v2 right2)
r of
            LookLeft Variant f t
left2   -> Variant f (Fuse ('N 'B left1 k1 v1 right1) left2)
-> Variant
     f ('N 'R (Fuse ('N 'B left1 k1 v1 right1) left2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft  (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @(N B left1 k1 v1 right1) @left2 (Variant f left2
-> Either (Variant f ('N 'B left1 k1 v1 right1)) (Variant f left2)
forall a b. b -> Either a b
Right Variant f left2
Variant f t
left2))
            Here f v
v2          -> f v
-> Variant
     f ('N 'R (Fuse ('N 'B left1 k1 v1 right1) left2) k2 v right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here      f v
v2
            LookRight Variant f t
right2 -> Variant f t
-> Variant
     f ('N 'R (Fuse ('N 'B left1 k1 v1 right1) left2) k2 v2 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
right2


-- app (T R a x b) c = T R a x (app b c)
instance Fuseable right1 (N B left2 k2 v2 right2) 
    => Fuseable (N R left1 k1 v1 right1) (N B left2 k2 v2 right2) where
    type Fuse   (N R left1 k1 v1 right1) (N B left2 k2 v2 right2) = N R left1 k1 v1 (Fuse right1 (N B left2 k2 v2 right2))
    fuseRecord :: forall (f :: q -> *).
Record f ('N 'R left1 k1 v1 right1)
-> Record f ('N 'B left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseRecord (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = Record f left
-> f v
-> Record f (Fuse right1 ('N 'B left2 k2 v2 right2))
-> Record
     f ('N 'R left k1 v (Fuse right1 ('N 'B left2 k2 v2 right2)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left1 f v
v1 (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Record f l -> Record f r -> Record f (Fuse l r)
fuseRecord @_ @_ @(N B left2 k2 v2 right2) Record f right
right1 (Record f left2
-> f v2 -> Record f right2 -> Record f ('N 'B left2 k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left2
Record f left
left2 f v2
f v
v2 Record f right2
Record f right
right2))
    fuseVariant :: forall (f :: q -> *).
Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseVariant Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
e = case Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
e of
        Left Variant f ('N 'R left1 k1 v1 right1)
l  -> case Variant f ('N 'R left1 k1 v1 right1)
l of
            LookLeft Variant f t
left1   -> Variant f t
-> Variant
     f ('N 'R t k1 v1 (Fuse right1 ('N 'B left2 k2 v2 right2)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
left1
            Here f v
v1          -> f v
-> Variant
     f ('N 'R left1 k1 v (Fuse right1 ('N 'B left2 k2 v2 right2)))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v1
            LookRight Variant f t
right1 -> Variant f (Fuse right1 ('N 'B left2 k2 v2 right2))
-> Variant
     f ('N 'R left1 k1 v1 (Fuse right1 ('N 'B left2 k2 v2 right2)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @(N B left2 k2 v2 right2) (Variant f right1
-> Either (Variant f right1) (Variant f ('N 'B left2 k2 v2 right2))
forall a b. a -> Either a b
Left Variant f right1
Variant f t
right1))
        Right Variant f ('N 'B left2 k2 v2 right2)
r -> case Variant f ('N 'B left2 k2 v2 right2)
r of
            LookLeft Variant f t
left2   -> Variant f (Fuse right1 ('N 'B left2 k2 v2 right2))
-> Variant
     f ('N 'R left1 k1 v1 (Fuse right1 ('N 'B left2 k2 v2 right2)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @(N B left2 k2 v2 right2) (Variant f ('N 'B left2 k2 v2 right2)
-> Either (Variant f right1) (Variant f ('N 'B left2 k2 v2 right2))
forall a b. b -> Either a b
Right (Variant f left2 -> Variant f ('N 'B left2 k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f left2
Variant f t
left2)))
            Here f v
v2          -> Variant f (Fuse right1 ('N 'B left2 k2 v2 right2))
-> Variant
     f ('N 'R left1 k1 v1 (Fuse right1 ('N 'B left2 k2 v2 right2)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @(N B left2 k2 v2 right2) (Variant f ('N 'B left2 k2 v2 right2)
-> Either (Variant f right1) (Variant f ('N 'B left2 k2 v2 right2))
forall a b. b -> Either a b
Right (f v2 -> Variant f ('N 'B left2 k2 v2 right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v2
f v
v2)))
            LookRight Variant f t
right2 -> Variant f (Fuse right1 ('N 'B left2 k2 v2 right2))
-> Variant
     f ('N 'R left1 k1 v1 (Fuse right1 ('N 'B left2 k2 v2 right2)))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @(N B left2 k2 v2 right2) (Variant f ('N 'B left2 k2 v2 right2)
-> Either (Variant f right1) (Variant f ('N 'B left2 k2 v2 right2))
forall a b. b -> Either a b
Right (Variant f right2 -> Variant f ('N 'B left2 k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f right2
Variant f t
right2)))


-- app (T R a x b) (T R c y d) =
instance (Fuseable right1 left2, Fuse right1 left2 ~ fused, FuseableHelper1 fused (N R left1 k1 v1 right1) (N R left2 k2 v2 right2)) 
    => Fuseable (N R left1 k1 v1 right1) (N R left2 k2 v2 right2) where
    type Fuse   (N R left1 k1 v1 right1) (N R left2 k2 v2 right2) = Fuse1 (Fuse right1 left2) (N R left1 k1 v1 right1) (N R left2 k2 v2 right2) 
    fuseRecord :: forall (f :: q -> *).
Record f ('N 'R left1 k1 v1 right1)
-> Record f ('N 'R left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseRecord = forall q (fused :: Map Symbol q) (l :: Map Symbol q)
       (r :: Map Symbol q) (f :: q -> *).
FuseableHelper1 fused l r =>
Record f l -> Record f r -> Record f (Fuse l r)
fuseRecord1 @_ @(Fuse right1 left2) 
    fuseVariant :: forall (f :: q -> *).
Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseVariant = forall q (fused :: Map Symbol q) (l :: Map Symbol q)
       (r :: Map Symbol q) (f :: q -> *).
FuseableHelper1 fused l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant1 @_ @(Fuse right1 left2)

type FuseableHelper1 :: Map Symbol q -> Map Symbol q -> Map Symbol q -> Constraint
class FuseableHelper1 (fused :: Map Symbol q) (l :: Map Symbol q) (r :: Map Symbol q) where
    type Fuse1 fused l r :: Map Symbol q
    fuseRecord1 :: Record f l -> Record f r -> Record f (Fuse l r)
    fuseVariant1 :: Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)

-- app (T R a x b) (T R c y d) =
--  case app b c of
--      T R b' z c' -> T R (T R a x b') z (T R c' y d)
-- FIXME: The Fuseable constraint is repeated from avobe :(
instance (Fuseable right1 left2, Fuse right1 left2 ~ N R s1 z zv s2) 
    => FuseableHelper1 (N R s1 z zv s2) (N R left1 k1 v1 right1) (N R left2 k2 v2 right2) where
    type Fuse1         (N R s1 z zv s2) (N R left1 k1 v1 right1) (N R left2 k2 v2 right2) = N R (N R left1 k1 v1 s1) z zv (N R s2 k2 v2 right2)
    fuseRecord1 :: forall (f :: q -> *).
Record f ('N 'R left1 k1 v1 right1)
-> Record f ('N 'R left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseRecord1 (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = 
        case Record f right -> Record f left -> Record f (Fuse right left)
forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Record f l -> Record f r -> Record f (Fuse l r)
forall (f :: q -> *).
Record f right -> Record f left -> Record f (Fuse right left)
fuseRecord Record f right
right1 Record f left
left2 of
            Node Record f left
s1 f v
zv Record f right
s2 -> Record f ('N 'R left k1 v left)
-> f v
-> Record f ('N 'R right k2 v right)
-> Record
     f ('N 'R ('N 'R left k1 v left) z v ('N 'R right k2 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f left -> Record f ('N 'R left k1 v left)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left1 f v
v1 Record f left
s1) f v
zv (Record f right
-> f v -> Record f right -> Record f ('N 'R right k2 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f right
s2 f v
v2 Record f right
right2)
    fuseVariant1 :: forall (f :: q -> *).
Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseVariant1 Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
e = 
        case Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
e of
            Left Variant f ('N 'R left1 k1 v1 right1)
l  -> case Variant f ('N 'R left1 k1 v1 right1)
l of
                            LookLeft  Variant f t
left1  -> Variant f ('N 'R t k1 v1 s1)
-> Variant
     f ('N 'R ('N 'R t k1 v1 s1) z zv ('N 'R s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'R t k1 v1 s1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
left1)
                            Here      f v
v1     -> Variant f ('N 'R left1 k1 v s1)
-> Variant
     f ('N 'R ('N 'R left1 k1 v s1) z zv ('N 'R s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'R left1 k1 v s1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v1)
                            LookRight Variant f t
right1 -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f right1 -> Either (Variant f right1) (Variant f left2)
forall a b. a -> Either a b
Left Variant f right1
Variant f t
right1) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'R left1 k1 v1 t)
-> Variant
     f ('N 'R ('N 'R left1 k1 v1 t) z zv ('N 'R s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'R left1 k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
s1)
                                                    Here f v
zv      -> f v
-> Variant
     f ('N 'R ('N 'R left1 k1 v1 s1) z v ('N 'R s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
zv
                                                    LookRight Variant f t
s2 -> Variant f ('N 'R t k2 v2 right2)
-> Variant
     f ('N 'R ('N 'R left1 k1 v1 s1) z zv ('N 'R t k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'R t k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
s2)
            Right Variant f ('N 'R left2 k2 v2 right2)
r -> case Variant f ('N 'R left2 k2 v2 right2)
r of 
                            LookLeft  Variant f t
left2  -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f left2 -> Either (Variant f right1) (Variant f left2)
forall a b. b -> Either a b
Right Variant f left2
Variant f t
left2) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'R left1 k1 v1 t)
-> Variant
     f ('N 'R ('N 'R left1 k1 v1 t) z zv ('N 'R s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'R left1 k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
s1)
                                                    Here f v
zv      -> f v
-> Variant
     f ('N 'R ('N 'R left1 k1 v1 s1) z v ('N 'R s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
zv
                                                    LookRight Variant f t
s2 -> Variant f ('N 'R t k2 v2 right2)
-> Variant
     f ('N 'R ('N 'R left1 k1 v1 s1) z zv ('N 'R t k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'R t k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
s2)
                            Here      f v
v2     -> Variant f ('N 'R s2 k2 v right2)
-> Variant
     f ('N 'R ('N 'R left1 k1 v1 s1) z zv ('N 'R s2 k2 v right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'R s2 k2 v right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v2)
                            LookRight Variant f t
right2 -> Variant f ('N 'R s2 k2 v2 t)
-> Variant f ('N 'R ('N 'R left1 k1 v1 s1) z zv ('N 'R s2 k2 v2 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'R s2 k2 v2 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
right2)


-- app (T R a x b) (T R c y d) =
--  case app b c of
--      ...
--      bc -> T R a x (T R bc y d)
-- FIXME: The Fuseable constraint is repeated from above :(
instance (Fuseable right1 left2, Fuse right1 left2 ~ N B s1 z zv s2) 
    => FuseableHelper1 (N B s1 z zv s2) (N R left1 k1 v1 right1) (N R left2 k2 v2 right2) where
    type Fuse1         (N B s1 z zv s2) (N R left1 k1 v1 right1) (N R left2 k2 v2 right2) = N R left1 k1 v1 (N R (N B s1 z zv s2) k2 v2 right2)
    fuseRecord1 :: forall (f :: q -> *).
Record f ('N 'R left1 k1 v1 right1)
-> Record f ('N 'R left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseRecord1 (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = 
        case Record f right -> Record f left -> Record f (Fuse right left)
forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Record f l -> Record f r -> Record f (Fuse l r)
forall (f :: q -> *).
Record f right -> Record f left -> Record f (Fuse right left)
fuseRecord Record f right
right1 Record f left
left2 of
            Node Record f left
s1 f v
zv Record f right
s2 -> Record f left
-> f v
-> Record f ('N 'R ('N 'B left z v right) k2 v right)
-> Record
     f ('N 'R left k1 v ('N 'R ('N 'B left z v right) k2 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left1 f v
v1 (Record f ('N 'B left z v right)
-> f v
-> Record f right
-> Record f ('N 'R ('N 'B left z v right) k2 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f right -> Record f ('N 'B left z v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
s1 f v
zv Record f right
s2) f v
v2 Record f right
right2)
    fuseVariant1 :: forall (f :: q -> *).
Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'R left1 k1 v1 right1) ('N 'R left2 k2 v2 right2))
fuseVariant1 Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
e = 
        case Either
  (Variant f ('N 'R left1 k1 v1 right1))
  (Variant f ('N 'R left2 k2 v2 right2))
e of
            Left Variant f ('N 'R left1 k1 v1 right1)
l  -> case Variant f ('N 'R left1 k1 v1 right1)
l of
                            LookLeft  Variant f t
left1  -> Variant f t
-> Variant
     f ('N 'R t k1 v1 ('N 'R ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
left1
                            Here      f v
v1     -> f v
-> Variant
     f ('N 'R left1 k1 v ('N 'R ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v1
                            LookRight Variant f t
right1 -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f right1 -> Either (Variant f right1) (Variant f left2)
forall a b. a -> Either a b
Left Variant f right1
Variant f t
right1) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'R ('N 'B t z zv s2) k2 v2 right2)
-> Variant
     f ('N 'R left1 k1 v1 ('N 'R ('N 'B t z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B t z zv s2)
-> Variant f ('N 'R ('N 'B t z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t z zv s2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
s1))
                                                    Here f v
zv      -> Variant f ('N 'R ('N 'B s1 z v s2) k2 v2 right2)
-> Variant
     f ('N 'R left1 k1 v1 ('N 'R ('N 'B s1 z v s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z v s2)
-> Variant f ('N 'R ('N 'B s1 z v s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B s1 z v s2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
zv))
                                                    LookRight Variant f t
s2 -> Variant f ('N 'R ('N 'B s1 z zv t) k2 v2 right2)
-> Variant
     f ('N 'R left1 k1 v1 ('N 'R ('N 'B s1 z zv t) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv t)
-> Variant f ('N 'R ('N 'B s1 z zv t) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B s1 z zv t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
s2))
            Right Variant f ('N 'R left2 k2 v2 right2)
r -> case Variant f ('N 'R left2 k2 v2 right2)
r of 
                            LookLeft  Variant f t
left2  -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f left2 -> Either (Variant f right1) (Variant f left2)
forall a b. b -> Either a b
Right Variant f left2
Variant f t
left2) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'R ('N 'B t z zv s2) k2 v2 right2)
-> Variant
     f ('N 'R left1 k1 v1 ('N 'R ('N 'B t z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B t z zv s2)
-> Variant f ('N 'R ('N 'B t z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t z zv s2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
s1))
                                                    Here f v
zv      -> Variant f ('N 'R ('N 'B s1 z v s2) k2 v2 right2)
-> Variant
     f ('N 'R left1 k1 v1 ('N 'R ('N 'B s1 z v s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z v s2)
-> Variant f ('N 'R ('N 'B s1 z v s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B s1 z v s2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
zv))
                                                    LookRight Variant f t
s2 -> Variant f ('N 'R ('N 'B s1 z zv t) k2 v2 right2)
-> Variant
     f ('N 'R left1 k1 v1 ('N 'R ('N 'B s1 z zv t) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv t)
-> Variant f ('N 'R ('N 'B s1 z zv t) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B s1 z zv t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
s2))
                            Here      f v
v2     -> Variant f ('N 'R ('N 'B s1 z zv s2) k2 v right2)
-> Variant
     f ('N 'R left1 k1 v1 ('N 'R ('N 'B s1 z zv s2) k2 v right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'R ('N 'B s1 z zv s2) k2 v right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v2)
                            LookRight Variant f t
right2 -> Variant f ('N 'R ('N 'B s1 z zv s2) k2 v2 t)
-> Variant f ('N 'R left1 k1 v1 ('N 'R ('N 'B s1 z zv s2) k2 v2 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'R ('N 'B s1 z zv s2) k2 v2 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
right2)

-- app (T R a x b) (T R c y d) =
--  case app b c of
--      ...
--      bc -> T R a x (T R bc y d)
instance FuseableHelper1 E (N R left1 k1 v1 E) (N R E k2 v2 right2) where
    type Fuse1           E (N R left1 k1 v1 E) (N R E k2 v2 right2) = N R left1 k1 v1 (N R E k2 v2 right2)
    fuseRecord1 :: forall (f :: q -> *).
Record f ('N 'R left1 k1 v1 'E)
-> Record f ('N 'R 'E k2 v2 right2)
-> Record f (Fuse ('N 'R left1 k1 v1 'E) ('N 'R 'E k2 v2 right2))
fuseRecord1 (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = Record f left
-> f v
-> Record f ('N 'R 'E k2 v right)
-> Record f ('N 'R left k1 v ('N 'R 'E k2 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left1 f v
v1 (Record f 'E
-> f v -> Record f right -> Record f ('N 'R 'E k2 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty f v
v2 Record f right
right2)
    fuseVariant1 :: forall (f :: q -> *).
Either
  (Variant f ('N 'R left1 k1 v1 'E))
  (Variant f ('N 'R 'E k2 v2 right2))
-> Variant f (Fuse ('N 'R left1 k1 v1 'E) ('N 'R 'E k2 v2 right2))
fuseVariant1 Either
  (Variant f ('N 'R left1 k1 v1 'E))
  (Variant f ('N 'R 'E k2 v2 right2))
e = 
        case Either
  (Variant f ('N 'R left1 k1 v1 'E))
  (Variant f ('N 'R 'E k2 v2 right2))
e of
            Left Variant f ('N 'R left1 k1 v1 'E)
l  -> case Variant f ('N 'R left1 k1 v1 'E)
l of
                            LookLeft  Variant f t
left1  -> Variant f t -> Variant f ('N 'R t k1 v1 ('N 'R 'E k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
left1
                            Here      f v
v1     -> f v -> Variant f ('N 'R left1 k1 v ('N 'R 'E k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v1
            Right Variant f ('N 'R 'E k2 v2 right2)
r -> case Variant f ('N 'R 'E k2 v2 right2)
r of 
                            Here      f v
v2     -> Variant f ('N 'R 'E k2 v right2)
-> Variant f ('N 'R left1 k1 v1 ('N 'R 'E k2 v right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'R 'E k2 v right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v2)
                            LookRight Variant f t
right2 -> Variant f ('N 'R 'E k2 v2 t)
-> Variant f ('N 'R left1 k1 v1 ('N 'R 'E k2 v2 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'R 'E k2 v2 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
right2)

-- app (T B a x b) (T B c y d) = 
instance (Fuseable right1 left2, Fuse right1 left2 ~ fused, FuseableHelper2 fused (N B left1 k1 v1 right1) (N B left2 k2 v2 right2)) 
    => Fuseable (N B left1 k1 v1 right1) (N B left2 k2 v2 right2) where
    type Fuse   (N B left1 k1 v1 right1) (N B left2 k2 v2 right2) = Fuse2 (Fuse right1 left2) (N B left1 k1 v1 right1) (N B left2 k2 v2 right2) 
    fuseRecord :: forall (f :: q -> *).
Record f ('N 'B left1 k1 v1 right1)
-> Record f ('N 'B left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseRecord = forall q (fused :: Map Symbol q) (l :: Map Symbol q)
       (r :: Map Symbol q) (f :: q -> *).
FuseableHelper2 fused l r =>
Record f l -> Record f r -> Record f (Fuse l r)
fuseRecord2 @_ @(Fuse right1 left2) 
    fuseVariant :: forall (f :: q -> *).
Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseVariant = forall q (fused :: Map Symbol q) (l :: Map Symbol q)
       (r :: Map Symbol q) (f :: q -> *).
FuseableHelper2 fused l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant2 @_ @(Fuse right1 left2)

-- could FuseableHelper1 and FuseableHelper2 be, well... fused?
class FuseableHelper2 (fused :: Map Symbol q) (l :: Map Symbol q) (r :: Map Symbol q) where
    type Fuse2 fused l r :: Map Symbol q
    fuseRecord2 :: Record f l -> Record f r -> Record f (Fuse l r)
    fuseVariant2 :: Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)

-- app (T B a x b) (T B c y d) = 
--  case app b c of
--      T R b' z c' -> T R (T B a x b') z (T B c' y d)
instance (Fuseable right1 left2, Fuse right1 left2 ~ N R s1 z zv s2) 
    => FuseableHelper2 (N R s1 z zv s2) (N B left1 k1 v1 right1) (N B left2 k2 v2 right2) where
    type Fuse2         (N R s1 z zv s2) (N B left1 k1 v1 right1) (N B left2 k2 v2 right2) = N R (N B left1 k1 v1 s1) z zv (N B s2 k2 v2 right2)
    fuseRecord2 :: forall (f :: q -> *).
Record f ('N 'B left1 k1 v1 right1)
-> Record f ('N 'B left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseRecord2 (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = 
        case Record f right -> Record f left -> Record f (Fuse right left)
forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Record f l -> Record f r -> Record f (Fuse l r)
forall (f :: q -> *).
Record f right -> Record f left -> Record f (Fuse right left)
fuseRecord Record f right
right1 Record f left
left2 of
            Node Record f left
s1 f v
zv Record f right
s2 -> Record f ('N 'B left k1 v left)
-> f v
-> Record f ('N 'B right k2 v right)
-> Record
     f ('N 'R ('N 'B left k1 v left) z v ('N 'B right k2 v right))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f left
-> f v -> Record f left -> Record f ('N 'B left k1 v left)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left1 f v
v1 Record f left
s1) f v
zv (Record f right
-> f v -> Record f right -> Record f ('N 'B right k2 v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f right
s2 f v
v2 Record f right
right2) 
    fuseVariant2 :: forall (f :: q -> *).
Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseVariant2 Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
e =
        case Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
e of
            Left Variant f ('N 'B left1 k1 v1 right1)
l  -> case Variant f ('N 'B left1 k1 v1 right1)
l of
                            LookLeft  Variant f t
left1  -> Variant f ('N 'B t k1 v1 s1)
-> Variant
     f ('N 'R ('N 'B t k1 v1 s1) z zv ('N 'B s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B t k1 v1 s1)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
left1)
                            Here      f v
v1     -> Variant f ('N 'B left1 k1 v s1)
-> Variant
     f ('N 'R ('N 'B left1 k1 v s1) z zv ('N 'B s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f v -> Variant f ('N 'B left1 k1 v s1)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v1)
                            LookRight Variant f t
right1 -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f right1 -> Either (Variant f right1) (Variant f left2)
forall a b. a -> Either a b
Left Variant f right1
Variant f t
right1) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'B left1 k1 v1 t)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 t) z zv ('N 'B s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B left1 k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
s1)
                                                    Here f v
zv      -> f v
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 s1) z v ('N 'B s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
zv
                                                    LookRight Variant f t
s2 -> Variant f ('N 'B t k2 v2 right2)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 s1) z zv ('N 'B t k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B t k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
s2)
            Right Variant f ('N 'B left2 k2 v2 right2)
r -> case Variant f ('N 'B left2 k2 v2 right2)
r of 
                            LookLeft  Variant f t
left2  -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f left2 -> Either (Variant f right1) (Variant f left2)
forall a b. b -> Either a b
Right Variant f left2
Variant f t
left2) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'B left1 k1 v1 t)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 t) z zv ('N 'B s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f t -> Variant f ('N 'B left1 k1 v1 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
s1)
                                                    Here f v
zv      -> f v
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 s1) z v ('N 'B s2 k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
zv
                                                    LookRight Variant f t
s2 -> Variant f ('N 'B t k2 v2 right2)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 s1) z zv ('N 'B t k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B t k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
s2)
                            Here      f v
v2     -> Variant f ('N 'B s2 k2 v right2)
-> Variant
     f ('N 'R ('N 'B left1 k1 v1 s1) z zv ('N 'B s2 k2 v right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v -> Variant f ('N 'B s2 k2 v right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
v2)
                            LookRight Variant f t
right2 -> Variant f ('N 'B s2 k2 v2 t)
-> Variant f ('N 'R ('N 'B left1 k1 v1 s1) z zv ('N 'B s2 k2 v2 t))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f t -> Variant f ('N 'B s2 k2 v2 t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
right2)

-- app (T B a x b) (T B c y d) = 
--  case app b c of
--      ...
--      bc -> balleft a x (T B bc y d)
instance (Fuseable right1 left2, Fuse right1 left2 ~ N B s1 z zv s2, BalanceableL left1 k1 v1 (N B (N B s1 z zv s2) k2 v2 right2)) 
    => FuseableHelper2 (N B s1 z zv s2) (N B left1 k1 v1 right1) (N B left2 k2 v2 right2) where
    type Fuse2         (N B s1 z zv s2) (N B left1 k1 v1 right1) (N B left2 k2 v2 right2) = BalL left1 k1 v1 (N B (N B s1 z zv s2) k2 v2 right2)
    fuseRecord2 :: forall (f :: q -> *).
Record f ('N 'B left1 k1 v1 right1)
-> Record f ('N 'B left2 k2 v2 right2)
-> Record
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseRecord2 (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = 
        case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Record f l -> Record f r -> Record f (Fuse l r)
fuseRecord @_ @right1 @left2 Record f right1
Record f right
right1 Record f left2
Record f left
left2 of
            Node Record f left
s1 f v
zv Record f right
s2 -> forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableL l k v r =>
Record f ('N color l k v r) -> Record f (BalL l k v r)
balLR @_ @left1 @k1 @v1 @(N B (N B s1 z zv s2) k2 v2 right2) (Record f left1
-> f v1
-> Record f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Record
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left1
Record f left
left1 f v1
f v
v1 (Record f ('N 'B s1 z zv s2)
-> f v2
-> Record f right2
-> Record f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (Record f s1 -> f zv -> Record f s2 -> Record f ('N 'B s1 z zv s2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f s1
Record f left
s1 f zv
f v
zv Record f s2
Record f right
s2) f v2
f v
v2 Record f right2
Record f right
right2))
    fuseVariant2 :: forall (f :: q -> *).
Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
-> Variant
     f (Fuse ('N 'B left1 k1 v1 right1) ('N 'B left2 k2 v2 right2))
fuseVariant2 Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
e = forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableL l k v r =>
Variant f ('N color l k v r) -> Variant f (BalL l k v r)
balLV @_ @left1 @k1 @v1 @(N B (N B s1 z zv s2) k2 v2 right2) (case Either
  (Variant f ('N 'B left1 k1 v1 right1))
  (Variant f ('N 'B left2 k2 v2 right2))
e of
            Left Variant f ('N 'B left1 k1 v1 right1)
l  -> case Variant f ('N 'B left1 k1 v1 right1)
l of
                            LookLeft  Variant f t
left1  -> Variant f left1
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f left1
Variant f t
left1
                            Here      f v
v1     -> f v1
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v1
f v
v1
                            LookRight Variant f t
right1 -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f right1 -> Either (Variant f right1) (Variant f left2)
forall a b. a -> Either a b
Left Variant f right1
Variant f t
right1) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv s2)
-> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f s1 -> Variant f ('N 'B s1 z zv s2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f s1
Variant f t
s1))
                                                    Here f v
zv      -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv s2)
-> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f zv -> Variant f ('N 'B s1 z zv s2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f zv
f v
zv))
                                                    LookRight Variant f t
s2 -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv s2)
-> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f s2 -> Variant f ('N 'B s1 z zv s2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f s2
Variant f t
s2))
            Right Variant f ('N 'B left2 k2 v2 right2)
r -> case Variant f ('N 'B left2 k2 v2 right2)
r of 
                            LookLeft  Variant f t
left2  -> case forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @right1 @left2 (Variant f left2 -> Either (Variant f right1) (Variant f left2)
forall a b. b -> Either a b
Right Variant f left2
Variant f t
left2) of
                                                    LookLeft Variant f t
s1  -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv s2)
-> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f s1 -> Variant f ('N 'B s1 z zv s2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f s1
Variant f t
s1))
                                                    Here f v
zv      -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv s2)
-> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (f zv -> Variant f ('N 'B s1 z zv s2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f zv
f v
zv))
                                                    LookRight Variant f t
s2 -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f ('N 'B s1 z zv s2)
-> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (Variant f s2 -> Variant f ('N 'B s1 z zv s2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f s2
Variant f t
s2))
                            Here      f v
v2     -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v2 -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v2
f v
v2)
                            LookRight Variant f t
right2 -> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
-> Variant
     f ('N Any left1 k1 v1 ('N 'B ('N 'B s1 z zv s2) k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f right2
-> Variant f ('N 'B ('N 'B s1 z zv s2) k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f right2
Variant f t
right2))

-- app (T B a x b) (T B c y d) = 
--  case app b c of
--      ...
--      bc -> balleft a x (T B bc y d)
instance (BalanceableL left1 k1 v1 (N B E k2 v2 right2)) 
    => FuseableHelper2 E (N B left1 k1 v1 E) (N B E k2 v2 right2) where
    type Fuse2         E (N B left1 k1 v1 E) (N B E k2 v2 right2) = BalL left1 k1 v1 (N B E k2 v2 right2)
    fuseRecord2 :: forall (f :: q -> *).
Record f ('N 'B left1 k1 v1 'E)
-> Record f ('N 'B 'E k2 v2 right2)
-> Record f (Fuse ('N 'B left1 k1 v1 'E) ('N 'B 'E k2 v2 right2))
fuseRecord2 (Node Record f left
left1 f v
v1 Record f right
right1) (Node Record f left
left2 f v
v2 Record f right
right2) = 
            forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableL l k v r =>
Record f ('N color l k v r) -> Record f (BalL l k v r)
balLR @_ @left1 @k1 @v1 @(N B E k2 v2 right2) (Record f left1
-> f v1
-> Record f ('N 'B 'E k2 v2 right2)
-> Record f ('N Any left1 k1 v1 ('N 'B 'E k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left1
Record f left
left1 f v1
f v
v1 (Record f 'E
-> f v2 -> Record f right2 -> Record f ('N 'B 'E k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty f v2
f v
v2 Record f right2
Record f right
right2))
    fuseVariant2 :: forall (f :: q -> *).
Either
  (Variant f ('N 'B left1 k1 v1 'E))
  (Variant f ('N 'B 'E k2 v2 right2))
-> Variant f (Fuse ('N 'B left1 k1 v1 'E) ('N 'B 'E k2 v2 right2))
fuseVariant2 Either
  (Variant f ('N 'B left1 k1 v1 'E))
  (Variant f ('N 'B 'E k2 v2 right2))
e = forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableL l k v r =>
Variant f ('N color l k v r) -> Variant f (BalL l k v r)
balLV @_ @left1 @k1 @v1 @(N B E k2 v2 right2) (case Either
  (Variant f ('N 'B left1 k1 v1 'E))
  (Variant f ('N 'B 'E k2 v2 right2))
e of
            Left Variant f ('N 'B left1 k1 v1 'E)
l  -> case Variant f ('N 'B left1 k1 v1 'E)
l of
                            LookLeft  Variant f t
left1  -> Variant f left1
-> Variant f ('N Any left1 k1 v1 ('N 'B 'E k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f left1
Variant f t
left1
                            Here      f v
v1     -> f v1 -> Variant f ('N Any left1 k1 v1 ('N 'B 'E k2 v2 right2))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v1
f v
v1
            Right Variant f ('N 'B 'E k2 v2 right2)
r -> case Variant f ('N 'B 'E k2 v2 right2)
r of 
                            Here      f v
v2     -> Variant f ('N 'B 'E k2 v2 right2)
-> Variant f ('N Any left1 k1 v1 ('N 'B 'E k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (f v2 -> Variant f ('N 'B 'E k2 v2 right2)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v2
f v
v2)
                            LookRight Variant f t
right2 -> Variant f ('N 'B 'E k2 v2 right2)
-> Variant f ('N Any left1 k1 v1 ('N 'B 'E k2 v2 right2))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (Variant f right2 -> Variant f ('N 'B 'E k2 v2 right2)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f right2
Variant f t
right2))


--  del E = E
--  del (T _ a y b)
--      | x<y = delformLeft a y b
--      | x>y = delformRight a y b
--      | otherwise = app a b
-- removing the inline kind signatures here breaks stuff...
type Delable :: Symbol -> q -> Map Symbol q -> Constraint
class Delable (k :: Symbol) (v :: q) (t :: Map Symbol q) where
    type Del k v t :: Map Symbol q
    del :: Record f t -> Record f (Del k v t)
    win :: Variant f t -> Either (Variant f (Del k v t)) (f v) 

--  delformLeft a@(T B _ _ _) y b = balleft (del a) y b
--  delformLeft a y b = T R (del a) y b
--  In the term-level code, the k to delete is already on the environment.
class DelableL (k :: Symbol) (v :: q) (l :: Map Symbol q) (kx :: Symbol) (vx :: q) (r :: Map Symbol q) where
    type DelL k v l kx vx r :: Map Symbol q
    delL :: Record f (N color l kx vx r) -> Record f (DelL k v l kx vx r)
    winL :: Variant f (N color l kx vx r) -> Either (Variant f (DelL k v l kx vx r)) (f v) 

--  delformLeft a@(T B _ _ _) y b = balleft (del a) y b
instance (N B leftz kz vz rightz ~ g, Delable k v g, Del k v g ~ deleted, BalanceableL deleted kx vx right) 
    => DelableL k v (N B leftz kz vz rightz) kx vx right where
    type DelL   k v (N B leftz kz vz rightz) kx vx right = BalL (Del k v (N B leftz kz vz rightz)) kx vx right
    delL :: forall (f :: q -> *) (color :: Color).
Record f ('N color ('N 'B leftz kz vz rightz) kx vx right)
-> Record f (DelL k v ('N 'B leftz kz vz rightz) kx vx right)
delL (Node Record f left
left f v
vx Record f right
right) = forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableL l k v r =>
Record f ('N color l k v r) -> Record f (BalL l k v r)
balLR @_ @(Del k v (N B leftz kz vz rightz)) @kx @vx @right (Record f deleted
-> f vx -> Record f right -> Record f ('N Any deleted kx vx right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Record f t -> Record f (Del k v t)
del @_ @k @v Record f left
left) f vx
f v
vx Record f right
Record f right
right)
    winL :: forall (f :: q -> *) (color :: Color).
Variant f ('N color ('N 'B leftz kz vz rightz) kx vx right)
-> Either
     (Variant f (DelL k v ('N 'B leftz kz vz rightz) kx vx right)) (f v)
winL Variant f ('N color ('N 'B leftz kz vz rightz) kx vx right)
v = (Variant f ('N Any deleted kx vx right)
 -> Variant
      f (BalL' (DiscriminateBalL deleted right) deleted kx vx right))
-> Either (Variant f ('N Any deleted kx vx right)) (f v)
-> Either
     (Variant
        f (BalL' (DiscriminateBalL deleted right) deleted kx vx right))
     (f v)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableL l k v r =>
Variant f ('N color l k v r) -> Variant f (BalL l k v r)
balLV @_ @(Del k v (N B leftz kz vz rightz)) @kx @vx @right) (case Variant f ('N color ('N 'B leftz kz vz rightz) kx vx right)
v of
        LookLeft Variant f t
l -> (Variant f deleted -> Variant f ('N Any deleted kx vx right))
-> Either (Variant f deleted) (f v)
-> Either (Variant f ('N Any deleted kx vx right)) (f v)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Variant f deleted -> Variant f ('N Any deleted kx vx right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Variant f t -> Either (Variant f (Del k v t)) (f v)
win @_ @k @v Variant f t
l)
        Here f v
vx -> Variant f ('N Any deleted kx vx right)
-> Either (Variant f ('N Any deleted kx vx right)) (f v)
forall a b. a -> Either a b
Left (Variant f ('N Any deleted kx vx right)
 -> Either (Variant f ('N Any deleted kx vx right)) (f v))
-> Variant f ('N Any deleted kx vx right)
-> Either (Variant f ('N Any deleted kx vx right)) (f v)
forall a b. (a -> b) -> a -> b
$ f v -> Variant f ('N Any deleted kx v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
vx
        LookRight Variant f t
r -> Variant f ('N Any deleted kx vx right)
-> Either (Variant f ('N Any deleted kx vx right)) (f v)
forall a b. a -> Either a b
Left (Variant f ('N Any deleted kx vx right)
 -> Either (Variant f ('N Any deleted kx vx right)) (f v))
-> Variant f ('N Any deleted kx vx right)
-> Either (Variant f ('N Any deleted kx vx right)) (f v)
forall a b. (a -> b) -> a -> b
$ Variant f t -> Variant f ('N Any deleted kx vx t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
r)

--  delformLeft a y b = T R (del a) y b
instance (Delable k v (N R leftz kz vz rightz)) 
    => DelableL k v (N R leftz kz vz rightz) kx vx right where
    type DelL   k v (N R leftz kz vz rightz) kx vx right = N R (Del k v (N R leftz kz vz rightz)) kx vx right
    delL :: forall (f :: q -> *) (color :: Color).
Record f ('N color ('N 'R leftz kz vz rightz) kx vx right)
-> Record f (DelL k v ('N 'R leftz kz vz rightz) kx vx right)
delL (Node Record f left
left f v
vx Record f right
right) = Record f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)
-> f v
-> Record f right
-> Record
     f ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Record f t -> Record f (Del k v t)
del @_ @k @v Record f left
left) f v
vx Record f right
right
    winL :: forall (f :: q -> *) (color :: Color).
Variant f ('N color ('N 'R leftz kz vz rightz) kx vx right)
-> Either
     (Variant f (DelL k v ('N 'R leftz kz vz rightz) kx vx right)) (f v)
winL Variant f ('N color ('N 'R leftz kz vz rightz) kx vx right)
v = case Variant f ('N color ('N 'R leftz kz vz rightz) kx vx right)
v of
        LookLeft Variant f t
l -> (Variant f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)
 -> Variant
      f
      ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx vx right))
-> Either
     (Variant f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)) (f v)
-> Either
     (Variant
        f
        ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx vx right))
     (f v)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Variant f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)
-> Variant
     f
     ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx vx right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Variant f t -> Either (Variant f (Del k v t)) (f v)
win @_ @k @v Variant f t
l)
        Here f v
vx -> Variant
  f ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx v right)
-> Either
     (Variant
        f
        ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx v right))
     (f v)
forall a b. a -> Either a b
Left (f v
-> Variant
     f ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
vx)
        LookRight Variant f t
r -> Variant
  f ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx vx t)
-> Either
     (Variant
        f ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx vx t))
     (f v)
forall a b. a -> Either a b
Left (Variant f t
-> Variant
     f ('N 'R (Del' (CmpSymbol kz k) k v leftz kz vz rightz) kx vx t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
r)

--  delformLeft a y b = T R (del a) y b
instance DelableL k v E kx vx right where
    type DelL     k v E kx vx right = N R E kx vx right
    delL :: forall (f :: q -> *) (color :: Color).
Record f ('N color 'E kx vx right)
-> Record f (DelL k v 'E kx vx right)
delL (Node Record f left
left f v
vx Record f right
right) = Record f 'E
-> f v -> Record f right -> Record f ('N 'R 'E kx v right)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty f v
vx Record f right
right
    winL :: forall (f :: q -> *) (color :: Color).
Variant f ('N color 'E kx vx right)
-> Either (Variant f (DelL k v 'E kx vx right)) (f v)
winL Variant f ('N color 'E kx vx right)
v = case Variant f ('N color 'E kx vx right)
v of
        Here f v
vx -> Variant f ('N 'R 'E kx v right)
-> Either (Variant f ('N 'R 'E kx v right)) (f v)
forall a b. a -> Either a b
Left (f v -> Variant f ('N 'R 'E kx v right)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
vx)
        LookRight Variant f t
r -> Variant f ('N 'R 'E kx vx t)
-> Either (Variant f ('N 'R 'E kx vx t)) (f v)
forall a b. a -> Either a b
Left (Variant f t -> Variant f ('N 'R 'E kx vx t)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight Variant f t
r)

--  delformRight a y b@(T B _ _ _) = balright a y (del b)
--  delformRight a y b = T R a y (del b)
class DelableR (k :: Symbol) (v :: q) (l :: Map Symbol q) (kx :: Symbol) (vx :: q) (r :: Map Symbol q) where
    type DelR k v l kx vx r :: Map Symbol q
    delR :: Record f (N color l kx vx r) -> Record f (DelR k v l kx vx r)
    winR :: Variant f (N color l kx vx r) -> Either (Variant f (DelR k v l kx vx r)) (f v) 

--  delformRight a y b@(T B _ _ _) = balright a y (del b)
instance (N B leftz kz vz rightz ~ g, Delable k v g, Del k v g ~ deleted, BalanceableR left kx vx deleted) 
    => DelableR k v left kx vx (N B leftz kz vz rightz) where
    type DelR   k v left kx vx (N B leftz kz vz rightz) = BalR left kx vx (Del k v (N B leftz kz vz rightz))
    delR :: forall (f :: q -> *) (color :: Color).
Record f ('N color left kx vx ('N 'B leftz kz vz rightz))
-> Record f (DelR k v left kx vx ('N 'B leftz kz vz rightz))
delR (Node Record f left
left f v
vx Record f right
right) = forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableR l k v r =>
Record f ('N color l k v r) -> Record f (BalR l k v r)
balRR @_ @left @kx @vx @(Del k v (N B leftz kz vz rightz)) (Record f left
-> f vx -> Record f deleted -> Record f ('N Any left kx vx deleted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
Record f left
left f vx
f v
vx (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Record f t -> Record f (Del k v t)
del @_ @k @v Record f right
right))
    winR :: forall (f :: q -> *) (color :: Color).
Variant f ('N color left kx vx ('N 'B leftz kz vz rightz))
-> Either
     (Variant f (DelR k v left kx vx ('N 'B leftz kz vz rightz))) (f v)
winR Variant f ('N color left kx vx ('N 'B leftz kz vz rightz))
v = (Variant f ('N Any left kx vx deleted)
 -> Variant
      f (BalR' (DiscriminateBalR left deleted) left kx vx deleted))
-> Either (Variant f ('N Any left kx vx deleted)) (f v)
-> Either
     (Variant
        f (BalR' (DiscriminateBalR left deleted) left kx vx deleted))
     (f v)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall q (l :: Map Symbol q) (k :: Symbol) (v :: q)
       (r :: Map Symbol q) (f :: q -> *) (color :: Color).
BalanceableR l k v r =>
Variant f ('N color l k v r) -> Variant f (BalR l k v r)
balRV @_ @left @kx @vx @(Del k v (N B leftz kz vz rightz))) (case Variant f ('N color left kx vx ('N 'B leftz kz vz rightz))
v of
        LookLeft Variant f t
l -> Variant f ('N Any left kx vx deleted)
-> Either (Variant f ('N Any left kx vx deleted)) (f v)
forall a b. a -> Either a b
Left (Variant f ('N Any left kx vx deleted)
 -> Either (Variant f ('N Any left kx vx deleted)) (f v))
-> Variant f ('N Any left kx vx deleted)
-> Either (Variant f ('N Any left kx vx deleted)) (f v)
forall a b. (a -> b) -> a -> b
$ Variant f t -> Variant f ('N Any t kx vx deleted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
l
        Here f v
vx -> Variant f ('N Any left kx vx deleted)
-> Either (Variant f ('N Any left kx vx deleted)) (f v)
forall a b. a -> Either a b
Left (Variant f ('N Any left kx vx deleted)
 -> Either (Variant f ('N Any left kx vx deleted)) (f v))
-> Variant f ('N Any left kx vx deleted)
-> Either (Variant f ('N Any left kx vx deleted)) (f v)
forall a b. (a -> b) -> a -> b
$ f v -> Variant f ('N Any left kx v deleted)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
vx
        LookRight Variant f t
r -> (Variant f deleted -> Variant f ('N Any left kx vx deleted))
-> Either (Variant f deleted) (f v)
-> Either (Variant f ('N Any left kx vx deleted)) (f v)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Variant f deleted -> Variant f ('N Any left kx vx deleted)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Variant f t -> Either (Variant f (Del k v t)) (f v)
win @_ @k @v Variant f t
r))

--  delformRight a y b = T R a y (del b)
instance (Delable k v (N R leftz kz vz rightz)) 
    => DelableR k v left kx vx (N R leftz kz vz rightz) where
    type   DelR k v left kx vx (N R leftz kz vz rightz) = N R left kx vx (Del k v (N R leftz kz vz rightz))
    delR :: forall (f :: q -> *) (color :: Color).
Record f ('N color left kx vx ('N 'R leftz kz vz rightz))
-> Record f (DelR k v left kx vx ('N 'R leftz kz vz rightz))
delR (Node Record f left
left f v
vx Record f right
right) = Record f left
-> f v
-> Record f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)
-> Record
     f ('N 'R left kx v (Del' (CmpSymbol kz k) k v leftz kz vz rightz))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
vx (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Record f t -> Record f (Del k v t)
del @_ @k @v Record f right
right)
    winR :: forall (f :: q -> *) (color :: Color).
Variant f ('N color left kx vx ('N 'R leftz kz vz rightz))
-> Either
     (Variant f (DelR k v left kx vx ('N 'R leftz kz vz rightz))) (f v)
winR Variant f ('N color left kx vx ('N 'R leftz kz vz rightz))
v = case Variant f ('N color left kx vx ('N 'R leftz kz vz rightz))
v of
        LookLeft Variant f t
l -> Variant
  f ('N 'R t kx vx (Del' (CmpSymbol kz k) k v leftz kz vz rightz))
-> Either
     (Variant
        f ('N 'R t kx vx (Del' (CmpSymbol kz k) k v leftz kz vz rightz)))
     (f v)
forall a b. a -> Either a b
Left (Variant f t
-> Variant
     f ('N 'R t kx vx (Del' (CmpSymbol kz k) k v leftz kz vz rightz))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
l)
        Here f v
vx -> Variant
  f ('N 'R left kx v (Del' (CmpSymbol kz k) k v leftz kz vz rightz))
-> Either
     (Variant
        f ('N 'R left kx v (Del' (CmpSymbol kz k) k v leftz kz vz rightz)))
     (f v)
forall a b. a -> Either a b
Left (f v
-> Variant
     f ('N 'R left kx v (Del' (CmpSymbol kz k) k v leftz kz vz rightz))
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
vx)
        LookRight Variant f t
r -> (Variant f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)
 -> Variant
      f
      ('N 'R left kx vx (Del' (CmpSymbol kz k) k v leftz kz vz rightz)))
-> Either
     (Variant f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)) (f v)
-> Either
     (Variant
        f
        ('N 'R left kx vx (Del' (CmpSymbol kz k) k v leftz kz vz rightz)))
     (f v)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Variant f (Del' (CmpSymbol kz k) k v leftz kz vz rightz)
-> Variant
     f ('N 'R left kx vx (Del' (CmpSymbol kz k) k v leftz kz vz rightz))
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: q).
Variant f t -> Variant f ('N color' left' k' v' t)
LookRight (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Variant f t -> Either (Variant f (Del k v t)) (f v)
win @_ @k @v Variant f t
r)

--  delformRight a y b = T R a y (del b)
instance DelableR k v left kx vx E where
    type DelR     k v left kx vx E = N R left kx vx E
    delR :: forall (f :: q -> *) (color :: Color).
Record f ('N color left kx vx 'E)
-> Record f (DelR k v left kx vx 'E)
delR (Node Record f left
left f v
vx Record f right
right) = Record f left
-> f v -> Record f 'E -> Record f ('N 'R left kx v 'E)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: q)
       (left' :: Map Symbol q) (k' :: Color) (v' :: Symbol).
Record f t
-> f color' -> Record f left' -> Record f ('N k' t v' color' left')
Node Record f left
left f v
vx Record f 'E
forall {q} (f :: q -> *). Record f 'E
Empty
    winR :: forall (f :: q -> *) (color :: Color).
Variant f ('N color left kx vx 'E)
-> Either (Variant f (DelR k v left kx vx 'E)) (f v)
winR Variant f ('N color left kx vx 'E)
v = case Variant f ('N color left kx vx 'E)
v of
        LookLeft Variant f t
l -> Variant f ('N 'R t kx vx 'E)
-> Either (Variant f ('N 'R t kx vx 'E)) (f v)
forall a b. a -> Either a b
Left (Variant f t -> Variant f ('N 'R t kx vx 'E)
forall {q} (f :: q -> *) (t :: Map Symbol q) (color' :: Color)
       (left' :: Symbol) (k' :: q) (v' :: Map Symbol q).
Variant f t -> Variant f ('N color' t left' k' v')
LookLeft Variant f t
l)
        Here f v
vx -> Variant f ('N 'R left kx v 'E)
-> Either (Variant f ('N 'R left kx v 'E)) (f v)
forall a b. a -> Either a b
Left (f v -> Variant f ('N 'R left kx v 'E)
forall {q} (f :: q -> *) (t :: q) (color' :: Color)
       (left' :: Map Symbol q) (k' :: Symbol) (v' :: Map Symbol q).
f t -> Variant f ('N color' left' k' t v')
Here f v
vx)

--  del E = E
instance Delable k v E where
    type Del     k v E = E
    del :: forall (f :: q -> *). Record f 'E -> Record f (Del k v 'E)
del Record f 'E
_ = Record f (Del k v 'E)
Record f 'E
forall {q} (f :: q -> *). Record f 'E
unit
    win :: forall (f :: q -> *).
Variant f 'E -> Either (Variant f (Del k v 'E)) (f v)
win = Variant f 'E -> Either (Variant f (Del k v 'E)) (f v)
Variant f 'E -> Either (Variant f 'E) (f v)
forall {q} (f :: q -> *) b. Variant f Empty -> b
impossible

-- the color is discarded
--  del (T _ a y b)
--      | x<y = delformLeft a y b
--      | x>y = delformRight a y b
--      | otherwise = app a b
instance (CmpSymbol kx k ~ ordering, DelableHelper ordering k v left kx vx right) => Delable k v (N color left kx vx right) where
    type Del k v (N color left kx vx right) = Del' (CmpSymbol kx k) k v left kx vx right
    del :: forall (f :: q -> *).
Record f ('N color left kx vx right)
-> Record f (Del k v ('N color left kx vx right))
del = forall q (ordering :: Ordering) (k :: Symbol) (v :: q)
       (l :: Map Symbol q) (kx :: Symbol) (vx :: q) (r :: Map Symbol q)
       (f :: q -> *) (color :: Color).
DelableHelper ordering k v l kx vx r =>
Record f ('N color l kx vx r)
-> Record f (Del' ordering k v l kx vx r)
del' @_ @(CmpSymbol kx k) @k @v @left @kx @vx @right
    win :: forall (f :: q -> *).
Variant f ('N color left kx vx right)
-> Either (Variant f (Del k v ('N color left kx vx right))) (f v)
win = forall q (ordering :: Ordering) (k :: Symbol) (v :: q)
       (l :: Map Symbol q) (kx :: Symbol) (vx :: q) (r :: Map Symbol q)
       (f :: q -> *) (color :: Color).
DelableHelper ordering k v l kx vx r =>
Variant f ('N color l kx vx r)
-> Either (Variant f (Del' ordering k v l kx vx r)) (f v)
win' @_ @(CmpSymbol kx k) @k @v @left @kx @vx @right

class DelableHelper (ordering :: Ordering) (k :: Symbol) (v :: q) (l :: Map Symbol q) (kx :: Symbol) (vx :: q) (r :: Map Symbol q) where
    type Del' ordering k v l kx vx r :: Map Symbol q
    del' :: Record f (N color l kx vx r) -> Record f (Del' ordering k v l kx vx r)
    win' :: Variant f (N color l kx vx r) -> Either (Variant f (Del' ordering k v l kx vx r)) (f v) 

--      | x<y = delformLeft a y b
instance DelableL k v left kx vx right => DelableHelper GT k v left kx vx right where
    type Del'                                           GT k v left kx vx right = DelL k v left kx vx right
    del' :: forall (f :: q -> *) (color :: Color).
Record f ('N color left kx vx right)
-> Record f (Del' 'GT k v left kx vx right)
del' = forall q (k :: Symbol) (v :: q) (l :: Map Symbol q) (kx :: Symbol)
       (vx :: q) (r :: Map Symbol q) (f :: q -> *) (color :: Color).
DelableL k v l kx vx r =>
Record f ('N color l kx vx r) -> Record f (DelL k v l kx vx r)
delL @_ @k @v @left @kx @vx @right  
    win' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color left kx vx right)
-> Either (Variant f (Del' 'GT k v left kx vx right)) (f v)
win' = forall q (k :: Symbol) (v :: q) (l :: Map Symbol q) (kx :: Symbol)
       (vx :: q) (r :: Map Symbol q) (f :: q -> *) (color :: Color).
DelableL k v l kx vx r =>
Variant f ('N color l kx vx r)
-> Either (Variant f (DelL k v l kx vx r)) (f v)
winL @_ @k @v @left @kx @vx @right  

--      | otherwise = app a b
instance Fuseable left right => DelableHelper EQ k v left k v right where
    type Del'                                 EQ k v left k v right = Fuse left right
    del' :: forall (f :: q -> *) (color :: Color).
Record f ('N color left k v right)
-> Record f (Del' 'EQ k v left k v right)
del' (Node Record f left
left f v
_ Record f right
right) = forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Record f l -> Record f r -> Record f (Fuse l r)
fuseRecord @_ @left @right Record f left
Record f left
left Record f right
Record f right
right 
    win' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color left k v right)
-> Either (Variant f (Del' 'EQ k v left k v right)) (f v)
win' Variant f ('N color left k v right)
v = case Variant f ('N color left k v right)
v of
        LookLeft Variant f t
l  ->  Variant f (Del' 'EQ k v left k v right)
-> Either (Variant f (Del' 'EQ k v left k v right)) (f v)
forall a b. a -> Either a b
Left (Variant f (Del' 'EQ k v left k v right)
 -> Either (Variant f (Del' 'EQ k v left k v right)) (f v))
-> Variant f (Del' 'EQ k v left k v right)
-> Either (Variant f (Del' 'EQ k v left k v right)) (f v)
forall a b. (a -> b) -> a -> b
$ forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @left @right (Variant f left -> Either (Variant f left) (Variant f right)
forall a b. a -> Either a b
Left Variant f left
Variant f t
l)
        Here f v
v      -> f v -> Either (Variant f (Fuse left right)) (f v)
forall a b. b -> Either a b
Right f v
f v
v 
        LookRight Variant f t
r -> Variant f (Del' 'EQ k v left k v right)
-> Either (Variant f (Del' 'EQ k v left k v right)) (f v)
forall a b. a -> Either a b
Left (Variant f (Del' 'EQ k v left k v right)
 -> Either (Variant f (Del' 'EQ k v left k v right)) (f v))
-> Variant f (Del' 'EQ k v left k v right)
-> Either (Variant f (Del' 'EQ k v left k v right)) (f v)
forall a b. (a -> b) -> a -> b
$ forall q (l :: Map Symbol q) (r :: Map Symbol q) (f :: q -> *).
Fuseable l r =>
Either (Variant f l) (Variant f r) -> Variant f (Fuse l r)
fuseVariant @_ @left @right (Variant f right -> Either (Variant f left) (Variant f right)
forall a b. b -> Either a b
Right Variant f right
Variant f t
r)

--      | x>y = delformRight a y b
instance DelableR k v left kx vx right => DelableHelper LT k v left kx vx right where
    type Del'                                           LT k v left kx vx right = DelR k v left kx vx right
    del' :: forall (f :: q -> *) (color :: Color).
Record f ('N color left kx vx right)
-> Record f (Del' 'LT k v left kx vx right)
del' = forall q (k :: Symbol) (v :: q) (l :: Map Symbol q) (kx :: Symbol)
       (vx :: q) (r :: Map Symbol q) (f :: q -> *) (color :: Color).
DelableR k v l kx vx r =>
Record f ('N color l kx vx r) -> Record f (DelR k v l kx vx r)
delR @_ @k @v @left @kx @vx @right  
    win' :: forall (f :: q -> *) (color :: Color).
Variant f ('N color left kx vx right)
-> Either (Variant f (Del' 'LT k v left kx vx right)) (f v)
win' = forall q (k :: Symbol) (v :: q) (l :: Map Symbol q) (kx :: Symbol)
       (vx :: q) (r :: Map Symbol q) (f :: q -> *) (color :: Color).
DelableR k v l kx vx r =>
Variant f ('N color l kx vx r)
-> Either (Variant f (DelR k v l kx vx r)) (f v)
winR @_ @k @v @left @kx @vx @right  

{- | Class that determines if the pair of a 'Symbol' key and a type can
     be deleted from a type-level map.
 
     The associated type family 'Delete' produces the resulting map.

     At the term level, this manifests in 'delete', which removes a field from
     a record, and in 'winnow', which checks if a 'Variant' is of a given
     branch and returns the value in the branch if there's a match, or a
     reduced 'Variant' if there isn't. 'winnow' tends to be more useful in
     practice.

     If the map already has the key but with a /different/ type, the deletion
     fails to compile.
 -}
class Deletable (k :: Symbol) (v :: q) (t :: Map Symbol q) where
    type Delete k v t :: Map Symbol q
    _delete :: Record f t -> Record f (Delete k v t)
    _winnow :: Variant f t -> Either (Variant f (Delete k v t)) (f v) 

instance (Delable k v t, Del k v t ~ deleted, CanMakeBlack deleted) => Deletable k v t where
    type Delete k v t = MakeBlack (Del k v t)
    _delete :: forall (f :: q -> *). Record f t -> Record f (Delete k v t)
_delete Record f t
r = Record f deleted -> Record f (MakeBlack deleted)
forall q (t :: Map Symbol q) (f :: q -> *).
CanMakeBlack t =>
Record f t -> Record f (MakeBlack t)
forall (f :: q -> *).
Record f deleted -> Record f (MakeBlack deleted)
makeBlackR (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Record f t -> Record f (Del k v t)
del @_ @k @v Record f t
r) 
    _winnow :: forall (f :: q -> *).
Variant f t -> Either (Variant f (Delete k v t)) (f v)
_winnow Variant f t
v = (Variant f deleted -> Variant f (MakeBlack deleted))
-> Either (Variant f deleted) (f v)
-> Either (Variant f (MakeBlack deleted)) (f v)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Variant f deleted -> Variant f (MakeBlack deleted)
forall q (t :: Map Symbol q) (f :: q -> *).
CanMakeBlack t =>
Variant f t -> Variant f (MakeBlack t)
forall (f :: q -> *).
Variant f deleted -> Variant f (MakeBlack deleted)
makeBlackV (forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Delable k v t =>
Variant f t -> Either (Variant f (Del k v t)) (f v)
win @_ @k @v Variant f t
v)

{- | 
     Removes a field from a 'Record'.
 -}
delete :: forall k v t f . Deletable k v t => Record f t -> Record f (Delete k v t)
delete :: forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Deletable k v t =>
Record f t -> Record f (Delete k v t)
delete = forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Deletable k v t =>
Record f t -> Record f (Delete k v t)
_delete @_ @k @v @t

{- | 
     Checks if a 'Variant' is of a given branch and returns the value in the
     branch if there's a match, or a reduced 'Variant' if there isn't. 
 -}
winnow :: forall k v t f . Deletable k v t => Variant f t -> Either (Variant f (Delete k v t)) (f v)
winnow :: forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Deletable k v t =>
Variant f t -> Either (Variant f (Delete k v t)) (f v)
winnow = forall q (k :: Symbol) (v :: q) (t :: Map Symbol q) (f :: q -> *).
Deletable k v t =>
Variant f t -> Either (Variant f (Delete k v t)) (f v)
_winnow @_ @k @v @t 

{- | Like 'winnow' but specialized to pure 'Variant's.
 
>>> winnow @"bar" @Bool (injectI @"bar" False :: Variant I (FromList [ '("foo",Char), '("bar",Bool) ]))
Right (I False)

>>> prettyShow_VariantI `first` winnow @"foo" @Char (injectI @"bar" False :: Variant I (FromList [ '("foo",Char), '("bar",Bool) ]))
Left "bar (False)" 

-}
winnowI :: forall k v t . Deletable k v t => Variant I t -> Either (Variant I (Delete k v t)) v
winnowI :: forall (k :: Symbol) v (t :: Map Symbol (*)).
Deletable k v t =>
Variant I t -> Either (Variant I (Delete k v t)) v
winnowI = (I v -> v)
-> Either (Variant I (MakeBlack (Del k v t))) (I v)
-> Either (Variant I (MakeBlack (Del k v t))) v
forall a b.
(a -> b)
-> Either (Variant I (MakeBlack (Del k v t))) a
-> Either (Variant I (MakeBlack (Del k v t))) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap I v -> v
forall a. I a -> a
unI (Either (Variant I (MakeBlack (Del k v t))) (I v)
 -> Either (Variant I (MakeBlack (Del k v t))) v)
-> (Variant I t
    -> Either (Variant I (MakeBlack (Del k v t))) (I v))
-> Variant I t
-> Either (Variant I (MakeBlack (Del k v t))) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {q} (k :: Symbol) (v :: q) (t :: Map Symbol q)
       (f :: q -> *).
Deletable k v t =>
Variant f t -> Either (Variant f (Delete k v t)) (f v)
forall (k :: Symbol) v (t :: Map Symbol (*)) (f :: * -> *).
Deletable k v t =>
Variant f t -> Either (Variant f (Delete k v t)) (f v)
winnow @k @v @t

-- The original term-level code, taken from:
-- https://www.cs.kent.ac.uk/people/staff/smk/redblack/rb.html
--
-- {- Version 1, 'untyped' -}
-- data Color = R | B deriving Show
-- data RB a = E | T Color (RB a) a (RB a) deriving Show
-- 
-- {- Insertion and membership test as by Okasaki -}
-- insert :: Ord a => a -> RB a -> RB a
-- insert x s =
--  T B a z b
--  where
--  T _ a z b = ins s
--  ins E = T R E x E
--  ins s@(T B a y b)
--      | x<y = balance (ins a) y b
--      | x>y = balance a y (ins b)
--      | otherwise = s
--  ins s@(T R a y b)
--      | x<y = T R (ins a) y b
--      | x>y = T R a y (ins b)
--      | otherwise = s
-- 
-- 
-- {- balance: first equation is new,
--    to make it work with a weaker invariant -}
-- balance :: RB a -> a -> RB a -> RB a
-- balance (T R a x b) y (T R c z d) = T R (T B a x b) y (T B c z d)
-- balance (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
-- balance (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
-- balance a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
-- balance a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
-- balance a x b = T B a x b
--
-- member :: Ord a => a -> RB a -> Bool
-- member x E = False
-- member x (T _ a y b)
--  | x<y = member x a
--  | x>y = member x b
--  | otherwise = True
-- 
-- {- deletion a la SMK -}
-- delete :: Ord a => a -> RB a -> RB a
-- delete x t =
--  case del t of {T _ a y b -> T B a y b; _ -> E}
--  where
--  del E = E
--  del (T _ a y b)
--      | x<y = delformLeft a y b
--      | x>y = delformRight a y b
--             | otherwise = app a b
--  delformLeft a@(T B _ _ _) y b = balleft (del a) y b
--  delformLeft a y b = T R (del a) y b
--
--  delformRight a y b@(T B _ _ _) = balright a y (del b)
--  delformRight a y b = T R a y (del b)
-- 
-- balleft :: RB a -> a -> RB a -> RB a
-- balleft (T R a x b) y c = T R (T B a x b) y c
-- balleft bl x (T B a y b) = balance bl x (T R a y b)
-- balleft bl x (T R (T B a y b) z c) = T R (T B bl x a) y (balance b z (sub1 c))
-- 
-- balright :: RB a -> a -> RB a -> RB a
-- balright a x (T R b y c) = T R a x (T B b y c)
-- balright (T B a x b) y bl = balance (T R a x b) y bl
-- balright (T R a x (T B b y c)) z bl = T R (balance (sub1 a) x b) y (T B c z bl)
-- 
-- sub1 :: RB a -> RB a
-- sub1 (T B a x b) = T R a x b
-- sub1 _ = error "invariance violation"
-- 
-- app :: RB a -> RB a -> RB a
-- app E x = x
-- app x E = x
-- app (T R a x b) (T R c y d) =
--  case app b c of
--      T R b' z c' -> T R (T R a x b') z (T R c' y d)
--      bc -> T R a x (T R bc y d)
-- app (T B a x b) (T B c y d) = 
--  case app b c of
--      T R b' z c' -> T R(T B a x b') z (T B c' y d)
--      bc -> balleft a x (T B bc y d)
-- app a (T R b x c) = T R (app a b) x c
-- app (T R a x b) c = T R a x (app b c)