module Control.Monad.Coroutine.Nested
(
pogoStickNested, coupleNested, seesawNested, seesawNestedSteps,
ChildFunctor(..), AncestorFunctor(..),
liftParent, liftAncestor
)
where
import Control.Monad (liftM)
import Control.Monad.Coroutine
import Control.Monad.Coroutine.SuspensionFunctors (EitherFunctor(..))
pogoStickNested :: forall s1 s2 m x. (Functor s1, Functor s2, Monad m) =>
(s2 (Coroutine (EitherFunctor s1 s2) m x) -> Coroutine (EitherFunctor s1 s2) m x)
-> Coroutine (EitherFunctor s1 s2) m x -> Coroutine s1 m x
pogoStickNested reveal t =
Coroutine{resume= resume t
>>= \s-> case s
of Right result -> return (Right result)
Left (LeftF s') -> return (Left (fmap (pogoStickNested reveal) s'))
Left (RightF c) -> resume (pogoStickNested reveal (reveal c))}
coupleNested :: forall s0 s1 s2 m x y. (Monad m, Functor s0, Monad s0, Functor s1, Functor s2) =>
PairBinder m
-> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y
-> Coroutine (EitherFunctor s0 (SomeFunctor s1 s2)) m (x, y)
coupleNested runPair = coupleNested' where
coupleNested' t1 t2 = Coroutine{resume= runPair (\ st1 st2 -> return (proceed st1 st2)) (resume t1) (resume t2)}
proceed (Right x) (Right y) = Right (x, y)
proceed (Left (RightF s)) (Right y) = Left $ RightF $ fmap (flip coupleNested' (return y)) (LeftSome s)
proceed (Right x) (Left (RightF s)) = Left $ RightF $ fmap (coupleNested' (return x)) (RightSome s)
proceed (Left (RightF s1)) (Left (RightF s2)) = Left $ RightF $ fmap (uncurry coupleNested') (Both $ composePair s1 s2)
proceed l (Left (LeftF s)) = Left $ LeftF $ fmap (coupleNested' (Coroutine $ return l)) s
proceed (Left (LeftF s)) r = Left $ LeftF $ fmap (flip coupleNested' (Coroutine $ return r)) s
seesawNested :: (Monad m, Functor s0, Functor s1, Functor s2) =>
PairBinder m
-> SeesawResolver s1 s2 (EitherFunctor s0 s1) (EitherFunctor s0 s2)
-> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y -> Coroutine s0 m (x, y)
seesawNested runPair resolver t1 t2 = seesawNestedSteps runPair proceed t1 t2 where
proceed cont (Left s1) (Left s2) = resumeBoth resolver cont s1 s2
proceed _ (Left s) (Right y) = liftM (flip (,) y) $ pogoStickNested (resumeLeft resolver) (resumeLeft resolver s)
proceed _ (Right x) (Left s) = liftM ((,) x) $ pogoStickNested (resumeRight resolver) (resumeRight resolver s)
proceed _ (Right x) (Right y) = return (x, y)
seesawNestedSteps :: forall m c1 c2 s0 s1 s2 s1' s2' x y.
(Monad m, Functor s0, Functor s1, Functor s2,
s1' ~ EitherFunctor s0 s1, s2' ~ EitherFunctor s0 s2,
c1 ~ Coroutine s1' m x, c2 ~ Coroutine s2' m y) =>
PairBinder m
-> ((c1 -> c2 -> Coroutine s0 m (x, y))
-> Either (s1 c1) x -> Either (s2 c2) y -> Coroutine s0 m (x, y))
-> c1 -> c2 -> Coroutine s0 m (x, y)
seesawNestedSteps runPair proceed = seesaw' where
seesaw' t1 t2 = Coroutine{resume= bouncePair t1 t2}
bouncePair t1 t2 = runPair proceed' (resume t1) (resume t2)
proceed' :: CoroutineStepResult s1' m x -> CoroutineStepResult s2' m y -> m (CoroutineStepResult s0 m (x, y))
proceed' (Left (LeftF s1)) step2 = return $ Left $ fmap ((flip seesaw' (Coroutine $ return step2))) s1
proceed' step1 (Left (LeftF s2)) = return $ Left $ fmap (seesaw' (Coroutine $ return step1)) s2
proceed' step1 step2 = resume $ proceed seesaw' (local step1) (local step2)
local :: forall s r.
CoroutineStepResult (EitherFunctor s0 s) m r -> Either (s (Coroutine (EitherFunctor s0 s) m r)) r
local (Left (RightF s)) = Left s
local (Left (LeftF _)) = undefined
local (Right r) = Right r
class Functor c => ChildFunctor c where
type Parent c :: * -> *
wrap :: Parent c x -> c x
instance (Functor p, Functor s) => ChildFunctor (EitherFunctor p s) where
type Parent (EitherFunctor p s) = p
wrap = LeftF
class (Functor a, Functor d) => AncestorFunctor a d where
liftFunctor :: a x -> d x
instance Functor a => AncestorFunctor a a where
liftFunctor = id
instance (Functor a, ChildFunctor d, d' ~ Parent d, AncestorFunctor a d') => AncestorFunctor a d where
liftFunctor = wrap . (liftFunctor :: a x -> d' x)
liftParent :: forall m p c x. (Monad m, Functor p, ChildFunctor c, p ~ Parent c) => Coroutine p m x -> Coroutine c m x
liftParent cort = mapSuspension wrap cort
liftAncestor :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Coroutine a m x -> Coroutine d m x
liftAncestor cort = mapSuspension liftFunctor cort