module Streaming.Internal (
Stream (..)
, construct
, unfold
, replicates
, repeats
, repeatsM
, destroy
, concats
, intercalates
, iterT
, iterTM
, inspect
, maps
, mapsM
, distribute
, chunksOf
, splitsAt
, 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)
data Stream f m r = Step !(f (Stream f m r))
| Delay (m (Stream f m r))
| Return r
deriving (Typeable)
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)
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)
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 (liftM loop m)
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
instance (Functor f, Monad m) => Applicative (Stream f m) where
pure = Return
streamf <*> streamx = do {f <- streamf; x <- streamx; return (f x)}
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 wrap done = loop (unexposed stream0) where
loop stream = case stream of
Return r -> done r
Delay m -> wrap (liftM loop m)
Step fs -> construct (fmap loop fs)
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)))
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)
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 wrap done = loop stream0 where
loop stream = case stream of
Return r -> done r
Delay m -> wrap (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))