module Control.Monad.Coroutine.SuspensionFunctors
(
Yield(Yield), Await(Await), Request(Request), ParseRequest, EitherFunctor(LeftF, RightF), eitherFunctor,
yield, await, request, requestParse,
concatYields, concatAwaits,
awaitYieldResolver, awaitMaybeYieldResolver, awaitYieldChunkResolver, requestsResolver,
tickerYieldResolver, tickerRequestResolver, lazyTickerRequestResolver,
parserRequestResolver, lazyParserRequestResolver,
liftedTickerYieldResolver, liftedTickerRequestResolver, liftedLazyTickerRequestResolver,
liftedParserRequestResolver, nestedLazyParserRequestResolver,
)
where
import Prelude hiding (foldl, foldr)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Foldable (Foldable, foldl, foldr)
import Data.Monoid (Monoid, mempty)
import Data.Monoid.Null (MonoidNull, mnull)
import Text.ParserCombinators.Incremental (Parser, feed, feedEof, results, (><))
import Control.Monad.Coroutine
import Data.Functor.Contravariant.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 ParseRequest x z = forall y. MonoidNull y =>
ParseRequest ([x] -> [x]) (Parser [x] y) ((y, Maybe (Parser [x] y)) -> z)
instance Functor (ParseRequest x) where
fmap f (ParseRequest b p g) = ParseRequest b p (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)
eitherFunctor :: (l x -> y) -> (r x -> y) -> EitherFunctor l r x -> y
eitherFunctor left _ (LeftF f) = left f
eitherFunctor _ right (RightF f) = right f
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)
requestParse :: (Monad m, MonoidNull y) => Parser [x] y -> Coroutine (ParseRequest x) m (y, Maybe (Parser [x] y))
requestParse p = suspend (ParseRequest id p 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 concatenate return
where concatenate s = do chunk <- await
concatAwaits (feedAll chunk (suspend s))
feedAll :: (Foldable f, Monad m) => f x -> Coroutine (Await x) m r -> Coroutine (Await x) m r
feedAll chunk c = foldl (flip feedCoroutine) c chunk
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 lifter = 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 $ lifter $ Request rest c2)
}
parserRequestResolver :: Monoid y => SeesawResolver (Request (Parser [x] y) y) (Request [x] [x])
(Request (Parser [x] y) y) (Request [x] [x])
parserRequestResolver = liftedParserRequestResolver id id
liftedParserRequestResolver :: (Functor s1, Functor s2, Monoid y) =>
(forall a. Request (Parser [x] y) y a -> s1 a) -> (forall a. Request [x] [x] a -> s2 a)
-> SeesawResolver (Request (Parser [x] y) y) (Request [x] [x]) s1 s2
liftedParserRequestResolver lift1 lift2 = SeesawResolver {
resumeLeft= \(Request _ c)-> c mempty,
resumeRight= \(Request chunk c)-> c chunk,
resumeBoth= \cont (Request p c1) (Request xs c2)->
case results (feed xs p)
of ([], Just (r, p')) -> cont (suspend $ lift1 $ Request (return r >< p') c1) (c2 [])
([(r, [])], Nothing) -> cont (c1 r) (c2 [])
([(r, rest)], Nothing) -> cont (c1 r) (suspend $ lift2 $ Request rest c2)
_ -> error "Multiple results!"
}
lazyParserRequestResolver :: SeesawResolver (ParseRequest x) (Request [x] [x]) (ParseRequest x) (Request [x] [x])
lazyParserRequestResolver = SeesawResolver {
resumeLeft= \(ParseRequest b p c)-> mapFirstSuspension (prependToParseRequest b) $
case results (feedEof p)
of ([], Nothing) -> c (mempty, Nothing)
([(r, _)], Nothing) -> c (r, Nothing)
_ -> error "Multiple results!",
resumeRight= \(Request chunk c)-> c chunk,
resumeBoth= \cont (ParseRequest b p c1) (Request xs c2)->
case results (if null xs then feedEof p else feed xs p)
of ([], Nothing) ->
cont (c1 (mempty, Nothing)) (if null xs then c2 $ b [] else suspend $ Request (b xs) c2)
([], Just (r, p')) ->
cont (if mnull r then suspend $ ParseRequest (b . (xs ++)) p' c1 else c1 (r, Just p')) (c2 [])
([(r, [])], Nothing) -> cont (c1 (r, Nothing)) (c2 [])
([(r, rest)], Nothing) -> cont (c1 (r, Nothing)) (suspend $ Request rest c2)
(_, Nothing) -> error "Multiple results!"
}
nestedLazyParserRequestResolver ::
(Functor s1, Functor s2) =>
SeesawResolver (ParseRequest x) (Request [x] [x])
(EitherFunctor s1 (ParseRequest x)) (EitherFunctor s2 (Request [x] [x]))
nestedLazyParserRequestResolver = SeesawResolver {
resumeLeft= \(ParseRequest b p c)-> case results (feedEof p)
of ([], Nothing) -> mapFirstSuspension (retry b) $ c (mempty, Nothing)
([(r, t)], Nothing) -> mapFirstSuspension (retry (t ++)) $ c (r, Nothing)
(_, Nothing) -> error "Multiple results!",
resumeRight= \(Request chunk c)-> c chunk,
resumeBoth= \cont (ParseRequest b p c1) (Request xs c2)->
case results (if null xs then feedEof p else feed xs p)
of ([], Nothing) ->
cont (c1 (mempty, Nothing)) (if null xs then c2 (b []) else suspend $ RightF $ Request (b xs) c2)
([], Just (r, p')) ->
cont
(if mnull r then suspend $ RightF $ ParseRequest (b . (xs ++)) p' c1 else c1 (r, Just p'))
(c2 [])
([(r, rest)], Nothing) ->
cont (c1 (r, Nothing)) (if null rest then c2 [] else suspend $ RightF $ Request rest c2)
_ -> error "Multiple results!"
}
where retry prefix = eitherFunctor LeftF (RightF . feedList prefix)
feedList b (ParseRequest b' p c) = ParseRequest (b' . b) (feed (b []) p) c
feedCoroutine :: Monad m => x -> Coroutine (Await x) m r -> Coroutine (Await x) m r
feedCoroutine x c = bounce (\(Await f)-> f x) c
prependToParseRequest b (ParseRequest b' p' c') = ParseRequest (b . b') p' c'