module Cascade.Sum where
import Cascade
import Cascade.Util.ListKind
import Control.Arrow (Kleisli(..))
import Control.Comonad (Cokleisli(..), Comonad(..), liftW, (=>>))
import Control.Monad (liftM)
import Control.Monad.Identity (Identity(..))
import Data.Void
data SumW (w :: * -> *) (ts :: [*]) where
Here :: w a -> SumW w (a ': as)
There :: SumW w as -> SumW w (a ': as)
type family SumW' w (ts :: [*]) where
SumW' w ('[]) = Void
SumW' w (a ': as) = Either (w a) (SumW' w as)
toEither :: SumW w as -> SumW' w as
toEither (Here wa) = Left wa
toEither (There oo) = Right (toEither oo)
type Sum = SumW Identity
here :: a -> Sum (a ': as)
here = Here . Identity
there :: Sum as -> Sum (a ': as)
there = There
instance Show (SumW Identity '[]) where
showsPrec _ _ = error "impossible value of type Sum '[]"
instance (Show a, Show (SumW Identity as)) => Show (SumW Identity (a ': as)) where
showsPrec (1) (Here (Identity a)) = showString "here $ " . showsPrec 0 a
showsPrec (1) (There as) = showString "there." . showsPrec (1) as
showsPrec p (Here (Identity a)) = showParen (p > 10) $ showString "here " . showsPrec 11 a
showsPrec p (There as) = showParen True $ showString "there." . showsPrec (1) as
type family TailSumsW (w :: * -> *) (ts :: [*]) :: [*] where
TailSumsW w '[] = '[]
TailSumsW w (a ': as) = SumW w (a ': as) ': TailSumsW w as
type TailSums ts = TailSumsW Identity ts
pops :: Monad m
=> (w x -> m (w y))
-> SumW w (x ': y ': zs) -> m (SumW w (y ': zs))
pops _ (There oo) = return oo
pops f (Here wx) = liftM Here $ f wx
resumeC :: Monad m
=> (forall a b. c a b -> w a -> m (w b))
-> CascadeC c ts
-> CascadeM m (TailSumsW w ts)
resumeC over Done = Done
resumeC over (f :>>> fs) = pops (over f) >=>: resumeC over fs
resumeM :: Monad m => CascadeM m ts -> CascadeM m (TailSums ts)
resumeM = resumeC $ \c -> liftM Identity . runKleisli c . runIdentity
resumeW :: Comonad w => CascadeW w ts -> Cascade (TailSumsW w ts)
resumeW = unwrapM . resumeC (\c -> Identity . (=>> runCokleisli c))
resume :: Cascade ts -> Cascade (TailSums ts)
resume = unwrapM . resumeC (\c -> fmap (Identity . c))