module Control.Monad.Coroutine.SuspensionFunctors
(
Yield(Yield), Await(Await), Request(Request), EitherFunctor(LeftF, RightF),
yield, await, request,
concatYields, concatAwaits,
awaitYieldResolver, awaitMaybeYieldResolver, awaitYieldChunkResolver, requestsResolver,
tickerYieldResolver, tickerRequestResolver, lazyTickerRequestResolver,
liftedTickerYieldResolver, liftedTickerRequestResolver, liftedLazyTickerRequestResolver,
)
where
import Prelude hiding (foldl, foldr)
import Control.Monad (Monad, liftM)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Foldable (Foldable, foldl, foldr)
import Control.Monad.Coroutine
import Control.Cofunctor.Ticker (Ticker, splitTicked)
data Yield x y = Yield x y
instance Functor (Yield x) where
fmap f (Yield x y) = Yield x (f y)
newtype Await x y = Await (x -> y)
instance Functor (Await x) where
fmap f (Await g) = Await (f . g)
data Request request response x = Request request (response -> x)
instance Functor (Request x f) where
fmap f (Request x g) = Request x (f . g)
data EitherFunctor l r x = LeftF (l x) | RightF (r x)
instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
fmap f (LeftF l) = LeftF (fmap f l)
fmap f (RightF r) = RightF (fmap f r)
yield :: Monad m => x -> Coroutine (Yield x) m ()
yield x = suspend (Yield x (return ()))
await :: Monad m => Coroutine (Await x) m x
await = suspend (Await return)
request :: Monad m => x -> Coroutine (Request x y) m y
request x = suspend (Request x return)
concatYields :: (Monad m, Foldable f) => Coroutine (Yield (f x)) m r -> Coroutine (Yield x) m r
concatYields c = Coroutine{resume= resume c >>= foldChunk}
where foldChunk (Right r) = return (Right r)
foldChunk (Left (Yield s c)) = foldr f (resume $ concatYields c) s
f x rest = return (Left $ Yield x (Coroutine rest))
concatAwaits :: (Monad m, Foldable f) => Coroutine (Await x) m r -> Coroutine (Await (f x)) m r
concatAwaits c = lift (resume c) >>= either concat return
where concat s = do chunk <- await
concatAwaits (feedAll chunk (suspend s))
awaitYieldResolver :: SeesawResolver (Await x) (Yield x) s1 s2
awaitYieldResolver = SeesawResolver {
resumeLeft= undefined,
resumeRight= \(Yield _ c)-> c,
resumeBoth= \cont (Await f) (Yield x c2)-> cont (f x) c2
}
awaitMaybeYieldResolver :: SeesawResolver (Await (Maybe x)) (Yield x) s1 s2
awaitMaybeYieldResolver = SeesawResolver {
resumeLeft= \(Await f)-> f Nothing,
resumeRight= \(Yield _ c)-> c,
resumeBoth= \cont (Await f) (Yield x c2)-> cont (f $ Just x) c2
}
awaitYieldChunkResolver :: SeesawResolver (Await [x]) (Yield [x]) s1 s2
awaitYieldChunkResolver = SeesawResolver {
resumeLeft= \(Await f)-> f [],
resumeRight= \(Yield _ c)-> c,
resumeBoth= \cont (Await f) (Yield chunk c2)-> cont (f chunk) c2
}
requestsResolver :: SeesawResolver (Request x y) (Request y x) s1 s2
requestsResolver = SeesawResolver {
resumeLeft= undefined,
resumeRight= undefined,
resumeBoth= \cont (Request x c1) (Request y c2)-> cont (c1 y) (c2 x)
}
tickerYieldResolver :: SeesawResolver (Request (Ticker x) [x]) (Yield [x]) (Request (Ticker x) [x]) (Yield [x])
tickerYieldResolver = liftedTickerYieldResolver id id
liftedTickerYieldResolver :: (Functor s1, Functor s2) =>
(forall a. Request (Ticker x) [x] a -> s1 a) -> (forall a. Yield [x] a -> s2 a)
-> SeesawResolver (Request (Ticker x) [x]) (Yield [x]) s1 s2
liftedTickerYieldResolver lift1 lift2 = SeesawResolver {
resumeLeft= \(Request _ c)-> c [],
resumeRight= \(Yield _ c)-> c,
resumeBoth= \cont (Request t c1) (Yield xs c2)->
let (t', chunk, rest) = splitTicked t xs
in case rest
of [] -> cont (suspend $ lift1 $ Request t' c1) c2
_ -> cont (c1 chunk) (suspend $ lift2 $ Yield rest c2)
}
tickerRequestResolver :: SeesawResolver (Request (Ticker x) [x]) (Request [x] [x])
(Request (Ticker x) [x]) (Request [x] [x])
tickerRequestResolver = liftedTickerRequestResolver id id
liftedTickerRequestResolver :: (Functor s1, Functor s2) =>
(forall a. Request (Ticker x) [x] a -> s1 a) -> (forall a. Request [x] [x] a -> s2 a)
-> SeesawResolver (Request (Ticker x) [x]) (Request [x] [x]) s1 s2
liftedTickerRequestResolver lift1 lift2 = SeesawResolver {
resumeLeft= \(Request _ c)-> c [],
resumeRight= \(Request chunk c)-> c chunk,
resumeBoth= \cont (Request t c1) (Request xs c2)->
let (t', chunk, rest) = splitTicked t xs
in case rest
of [] -> cont (suspend $ lift1 $ Request t' c1) (c2 [])
_ -> cont (c1 chunk) (suspend $ lift2 $ Request rest c2)
}
lazyTickerRequestResolver :: SeesawResolver (Request (Ticker x) ([x], Either x (Ticker x))) (Request [x] [x])
(Request (Ticker x) ([x], Either x (Ticker x))) (Request [x] [x])
lazyTickerRequestResolver = liftedLazyTickerRequestResolver id
liftedLazyTickerRequestResolver ::
(Functor s1, Functor s2) =>
(forall a. Request [x] [x] a -> s2 a)
-> SeesawResolver (Request (Ticker x) ([x], Either x (Ticker x))) (Request [x] [x]) s1 s2
liftedLazyTickerRequestResolver lift = SeesawResolver {
resumeLeft= \(Request t c)-> c ([], Right t),
resumeRight= \(Request chunk c)-> c chunk,
resumeBoth= \cont (Request t c1) (Request xs c2)->
let (t', chunk, rest) = splitTicked t xs
in case rest
of [] -> cont (c1 (chunk, Right t')) (c2 [])
next:_ -> cont (c1 (chunk, Left next)) (suspend $ lift $ Request rest c2)
}
feed :: Monad m => x -> Coroutine (Await x) m r -> Coroutine (Await x) m r
feed x c = bounce (\(Await f)-> f x) c
feedAll :: (Foldable f, Monad m) => f x -> Coroutine (Await x) m r -> Coroutine (Await x) m r
feedAll chunk c = foldl (flip feed) c chunk