module Fusion
(
Step(..)
, StepList(..)
, Stream(..), mapS, concatS, fromList, fromListM
, toListS, lazyToListS, runEffect, emptyStream
, bracketS, next
, ListT(..), concat
, Producer, Pipe, Consumer
, each, mapP
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Data.Foldable
import Data.Functor.Identity
import Data.Void
import Pipes.Safe
import System.IO.Unsafe
data Step s a r = Done r | Skip s | Yield s a deriving Functor
newtype StepList s r a = StepList { getStepList :: Step s a r }
instance Functor (StepList s r) where
fmap _ (StepList (Done r)) = StepList $ Done r
fmap _ (StepList (Skip s)) = StepList $ Skip s
fmap f (StepList (Yield s a)) = StepList $ Yield s (f a)
data Stream a m r where
Stream :: (s -> m (Step s a r)) -> m s -> Stream a m r
instance Show a => Show (Stream a Identity r) where
show xs = "Stream " ++ show (runIdentity (toListS xs))
instance Functor m => Functor (Stream a m) where
fmap f (Stream k m) = Stream (fmap (fmap f) . k) m
instance Monad m => Applicative (Stream a m) where
pure x = Stream (pure . Done) (pure x)
sf <*> sx = Stream (pure . Done) (runEffect sf <*> runEffect sx)
instance MonadTrans (Stream a) where
lift = Stream (return . Done)
mapS :: Functor m => (a -> b) -> Stream a m r -> Stream b m r
mapS f (Stream s i) = Stream (fmap go . s) i
where
go (Done r) = Done r
go (Skip s') = Skip s'
go (Yield s' a) = Yield s' (f a)
concatS :: Monad m => Stream (Stream a m r) m r -> Stream a m r
concatS (Stream xs i) =
Stream (\case Left s -> xs s >>= go Nothing
Right (st, t) -> go (Just t) st)
(Left `liftM` i)
where
go _ (Done r) = return $ Done r
go _ (Skip s) = return $ Skip (Left s)
go Nothing e@(Yield _ z) = go (Just z) e
go (Just (Stream ys j)) e@(Yield s _) = go' `liftM` (j >>= ys)
where
go' (Done _) = Skip (Left s)
go' (Skip s') = Skip (Right (e, Stream ys (pure s')))
go' (Yield s' a) = Yield (Right (e, Stream ys (pure s'))) a
fromList :: Foldable f => Applicative m => f a -> Stream a m ()
fromList = Stream (\case [] -> pure $ Done ()
(x:xs) -> pure $ Yield xs x) . pure . toList
fromListM :: (Monad m, Foldable f) => m (f a) -> Stream a m ()
fromListM xs = Stream (\case [] -> return $ Done ()
(y:ys) -> return $ Yield ys y)
(toList <$> xs)
runEffect :: Monad m => Stream a m r -> m r
runEffect (Stream f i) = i >>= f >>= go
where
go (Done r) = return r
go (Skip s) = f s >>= go
go (Yield s _) = f s >>= go
toListS :: Monad m => Stream a m r -> m [a]
toListS (Stream f i) = i >>= f >>= go
where
go (Done _) = return []
go (Skip s) = f s >>= go
go (Yield s a) = f s >>= liftM (a:) . go
lazyToListS :: Stream a IO r -> IO [a]
lazyToListS (Stream f i) = i >>= f >>= go
where
go (Done _) = return []
go (Skip s) = f s >>= go
go (Yield s a) = f s >>= liftM (a:) . unsafeInterleaveIO . go
emptyStream :: Monad m => Stream Void m ()
emptyStream = pure ()
bracketS :: (Monad m, MonadMask m, MonadSafe m)
=> Base m s
-> (s -> Base m ())
-> (forall r. s -> (a -> s -> m r) -> (s -> m r) -> m r -> m r)
-> Stream a m ()
bracketS i f step = Stream go $ mask $ \_unmask -> do
s <- liftBase i
key <- register (f s)
return (s, key)
where
go (s, key) =
step s (\a s' -> return $ Yield (s', key) a)
(\s' -> return $ Skip (s', key))
(release key >> (const (Done ()) `liftM` liftBase (f s)))
next :: Monad m => Stream a m r -> m (Either r (a, Stream a m r))
next (Stream xs i) = do
s <- i
x <- xs s
case x of
Done r -> return $ Left r
Skip s' -> next (Stream xs (return s'))
Yield s' a -> return $ Right (a, Stream xs (return s'))
newtype ListT m a = ListT { getListT :: Stream a m () }
instance Functor m => Functor (ListT m) where
fmap f (ListT s) = ListT $ mapS f s
instance Monad m => Applicative (ListT m) where
pure = return
(<*>) = ap
instance Monad m => Monad (ListT m) where
return x = ListT $ fromList [x]
m >>= f = concatL $ fmap f m
concatL :: Monad m => ListT m (ListT m a) -> ListT m a
concatL = ListT . concatS . getListT . fmap getListT
type Producer b m r = Stream b m r
type Pipe a b m r = Stream a m () -> Stream b m r
type Consumer a m r = Stream a m () -> m r
each :: (Monad m, Foldable f) => f a -> Producer a m ()
each = fromList
mapP :: Monad m => (a -> b) -> Pipe a b m ()
mapP f = getListT . fmap f . ListT