module Streaming.Internal (
Stream (..)
, construct
, unfold
, replicates
, repeats
, repeatsM
, delay
, wrap
, layer
, intercalates
, concats
, iterT
, iterTM
, destroy
, destroyWith
, inspect
, maps
, mapsM
, mapsM_
, runEffect
, distribute
, chunksOf
, splitsAt
, takes
, zipsWith
, zips
, interleaves
, unexposed
, hoistExposed
, mapsExposed
, mapsMExposed
, destroyExposed
) where
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Class
import Control.Applicative
import Data.Foldable ( Foldable(..) )
import Data.Traversable
import Control.Monad.Morph
import Data.Monoid
import Data.Functor.Identity
import GHC.Exts ( build )
import Data.Data ( Data, Typeable )
import Prelude hiding (splitAt)
import Data.Functor.Compose
data Stream f m r = Step !(f (Stream f m r))
| Delay (m (Stream f m r))
| Return r
#if __GLASGOW_HASKELL__ >= 710
deriving (Typeable)
#endif
deriving instance (Show r, Show (m (Stream f m r))
, Show (f (Stream f m r))) => Show (Stream f m r)
deriving instance (Eq r, Eq (m (Stream f m r))
, Eq (f (Stream f m r))) => Eq (Stream f m r)
#if __GLASGOW_HASKELL__ >= 710
deriving instance (Typeable f, Typeable m, Data r, Data (m (Stream f m r))
, Data (f (Stream f m r))) => Data (Stream f m r)
#endif
instance (Functor f, Monad m) => Functor (Stream f m) where
fmap f = loop where
loop stream = case stream of
Return r -> Return (f r)
Delay m -> Delay (do {stream' <- m; return (loop stream')})
Step f -> Step (fmap loop f)
a <$ stream0 = loop stream0 where
loop stream = case stream of
Return r -> Return a
Delay m -> Delay (do {stream' <- m; return (loop stream')})
Step f -> Step (fmap loop f)
instance (Functor f, Monad m) => Monad (Stream f m) where
return = Return
stream1 >> stream2 = loop stream1 where
loop stream = case stream of
Return _ -> stream2
Delay m -> Delay (liftM loop m)
Step f -> Step (fmap loop f)
stream >>= f = loop stream where
loop stream0 = case stream0 of
Step f -> Step (fmap loop f)
Delay m -> Delay (liftM loop m)
Return r -> f r
fail = lift . fail
instance (Functor f, Monad m) => Applicative (Stream f m) where
pure = Return
streamf <*> streamx = do {f <- streamf; x <- streamx; return (f x)}
stra0 *> strb = loop stra0 where
loop stra = case stra of
Return _ -> strb
Delay m -> Delay (do {stra' <- m ; return (stra' *> strb)})
Step fstr -> Step (fmap (*> strb) fstr)
stra <* strb0 = loop strb0 where
loop strb = case strb of
Return _ -> stra
Delay m -> Delay (do {strb' <- m ; return (stra <* strb')})
Step fstr -> Step (fmap (stra <*) fstr)
instance Functor f => MonadTrans (Stream f) where
lift = Delay . liftM Return
instance Functor f => MFunctor (Stream f) where
hoist trans = loop . unexposed where
loop stream = case stream of
Return r -> Return r
Delay m -> Delay (trans (liftM loop m))
Step f -> Step (fmap loop f)
instance Functor f => MMonad (Stream f) where
embed phi = loop where
loop stream = case stream of
Return r -> Return r
Delay m -> phi m >>= loop
Step f -> Step (fmap loop f)
instance (MonadIO m, Functor f) => MonadIO (Stream f m) where
liftIO = Delay . liftM Return . liftIO
destroy
:: (Functor f, Monad m) =>
Stream f m r -> (f b -> b) -> (m b -> b) -> (r -> b) -> b
destroy stream0 construct delay done = loop (unexposed stream0) where
loop stream = case stream of
Return r -> done r
Delay m -> delay (liftM loop m)
Step fs -> construct (fmap loop fs)
destroyWith
:: (Functor f, Monad m) =>
(m b -> b) -> (r -> b) -> (f b -> b) -> Stream f m r -> b
destroyWith delay done construct stream = destroy stream construct delay done
construct
:: (forall b . (f b -> b) -> (m b -> b) -> (r -> b) -> b) -> Stream f m r
construct = \phi -> phi Step Delay Return
inspect :: (Functor f, Monad m) =>
Stream f m r -> m (Either r (f (Stream f m r)))
inspect = loop where
loop stream = case stream of
Return r -> return (Left r)
Delay m -> m >>= loop
Step fs -> return (Right fs)
unfold :: (Monad m, Functor f)
=> (s -> m (Either r (f s))) -> s -> Stream f m r
unfold step = loop where
loop s0 = Delay $ do
e <- step s0
case e of
Left r -> return (Return r)
Right fs -> return (Step (fmap loop fs))
maps :: (Monad m, Functor f)
=> (forall x . f x -> g x) -> Stream f m r -> Stream g m r
maps phi = loop where
loop stream = case stream of
Return r -> Return r
Delay m -> Delay (liftM loop m)
Step f -> Step (phi (fmap loop f))
mapsM :: (Monad m, Functor f) => (forall x . f x -> m (g x)) -> Stream f m r -> Stream g m r
mapsM phi = loop where
loop stream = case stream of
Return r -> Return r
Delay m -> Delay (liftM loop m)
Step f -> Delay (liftM Step (phi (fmap loop f)))
runEffect :: Monad m => Stream m m r -> m r
runEffect = loop where
loop stream = case stream of
Return r -> return r
Delay m -> m >>= loop
Step mrest -> mrest >>= loop
mapsM_ :: (Functor f, Monad m) => (forall x . f x -> m x) -> Stream f m r -> m r
mapsM_ f str = runEffect (maps f str)
layer :: (Monad m, Functor f) => f r -> Stream f m r
layer fr = Step (fmap Return fr)
intercalates :: (Monad m, Monad (t m), MonadTrans t) =>
t m a -> Stream (t m) m b -> t m b
intercalates sep = go0
where
go0 f = case f of
Return r -> return r
Delay m -> lift m >>= go0
Step fstr -> do
f' <- fstr
go1 f'
go1 f = case f of
Return r -> return r
Delay m -> lift m >>= go1
Step fstr -> do
sep
f' <- fstr
go1 f'
iterTM ::
(Functor f, Monad m, MonadTrans t,
Monad (t m)) =>
(f (t m a) -> t m a) -> Stream f m a -> t m a
iterTM out stream = destroy stream out (join . lift) return
iterT ::
(Functor f, Monad m) => (f (m a) -> m a) -> Stream f m a -> m a
iterT out stream = destroy stream out join return
concats :: (Monad m, Functor f) => Stream (Stream f m) m r -> Stream f m r
concats = loop where
loop stream = case stream of
Return r -> return r
Delay m -> join $ lift (liftM loop m)
Step fs -> join (fmap loop fs)
splitsAt :: (Monad m, Functor f) => Int -> Stream f m r -> Stream f m (Stream f m r)
splitsAt = loop where
loop !n stream
| n <= 0 = Return stream
| otherwise = case stream of
Return r -> Return (Return r)
Delay m -> Delay (liftM (loop n) m)
Step fs -> case n of
0 -> Return (Step fs)
_ -> Step (fmap (loop (n1)) fs)
takes :: (Monad m, Functor f) => Int -> Stream f m r -> Stream f m ()
takes n = void . splitsAt n
chunksOf :: (Monad m, Functor f) => Int -> Stream f m r -> Stream (Stream f m) m r
chunksOf n0 = loop where
loop stream = case stream of
Return r -> Return r
Delay m -> Delay (liftM loop m)
Step fs -> Step $ Step $ fmap (fmap loop . splitsAt (n01)) fs
distribute :: (Monad m, Functor f, MonadTrans t, MFunctor t, Monad (t (Stream f m)))
=> Stream f (t m) r -> t (Stream f m) r
distribute = loop where
loop stream = case stream of
Return r -> lift $ Return r
Delay tmstr -> hoist lift tmstr >>= distribute
Step fstr -> join $ lift (Step (fmap (Return . distribute) fstr))
repeats :: (Monad m, Functor f) => f () -> Stream f m r
repeats f = loop where
loop = Step $ fmap (\_ -> loop) f
repeatsM :: (Monad m, Functor f) => m (f ()) -> Stream f m r
repeatsM mf = loop where
loop = Delay $ do
f <- mf
return $ Step $ fmap (\_ -> loop) f
replicates :: (Monad m, Functor f) => Int -> f () -> Stream f m ()
replicates n f = splitsAt n (repeats f) >> return ()
cycles :: (Monad m, Functor f) => Stream f m () -> Stream f m r
cycles = forever
hoistExposed trans = loop where
loop stream = case stream of
Return r -> Return r
Delay m -> Delay (trans (liftM loop m))
Step f -> Step (fmap loop f)
mapsExposed :: (Monad m, Functor f)
=> (forall x . f x -> g x) -> Stream f m r -> Stream g m r
mapsExposed phi = loop where
loop stream = case stream of
Return r -> Return r
Delay m -> Delay (liftM loop m)
Step f -> Step (phi (fmap loop f))
mapsMExposed phi = loop where
loop stream = case stream of
Return r -> Return r
Delay m -> Delay (liftM loop m)
Step f -> Delay (liftM Step (phi (fmap loop f)))
destroyExposed stream0 construct delay done = loop stream0 where
loop stream = case stream of
Return r -> done r
Delay m -> delay (liftM loop m)
Step fs -> construct (fmap loop fs)
unexposed :: (Functor f, Monad m) => Stream f m r -> Stream f m r
unexposed = Delay . loop where
loop stream = case stream of
Return r -> return (Return r)
Delay m -> m >>= loop
Step f -> return (Step (fmap (Delay . loop) f))
delay :: (Monad m, Functor f ) => m (Stream f m r) -> Stream f m r
delay = Delay
wrap :: (Monad m, Functor f ) => f (Stream f m r) -> Stream f m r
wrap = Step
zipsWith :: (Monad m, Functor h)
=> (forall x y . f x -> g y -> h (x,y))
-> Stream f m r -> Stream g m r -> Stream h m r
zipsWith phi = curry loop where
loop (s1, s2) = Delay $ go s1 s2
go (Return r) p = return $ Return r
go q (Return s) = return $ Return s
go (Delay m) p = m >>= \s -> go s p
go q (Delay m) = m >>= go q
go (Step f) (Step g) = return $ Step $ fmap loop (phi f g)
zips :: (Monad m, Functor f, Functor g)
=> Stream f m r -> Stream g m r -> Stream (Compose f g) m r
zips = zipsWith go where
go fx gy = Compose (fmap (\x -> fmap (\y -> (x,y)) gy) fx)
interleaves
:: (Monad m, Applicative h) =>
Stream h m r -> Stream h m r -> Stream h m r
interleaves = zipsWith (liftA2 (,))