{-# LANGUAGE RankNTypes #-}
module Pipes.Group (
groupsBy,
groups,
chunksOf,
takes,
takes',
drops,
maps,
individually,
concats,
intercalates,
folds,
foldsM,
module Control.Monad.Trans.Class,
module Control.Monad.Trans.Free,
module Pipes
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Free (FreeF(Pure, Free), FreeT(FreeT, runFreeT))
import qualified Control.Monad.Trans.Free as F
import Data.Functor.Constant (Constant(Constant, getConstant))
import Data.Functor.Identity (Identity(Identity, runIdentity))
import Pipes (Producer, yield, next)
import Pipes.Parse (span, splitAt)
import qualified Pipes as P
import Prelude hiding (span, splitAt)
type Lens a' a b' b = forall f . Functor f => (b' -> f b) -> (a' -> f a)
type Setter a' a b' b = (b' -> Identity b) -> (a' -> Identity a)
(^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b
a ^. lens = getConstant (lens Constant a)
groupsBy
:: Monad m
=> (a' -> a' -> Bool) -> Lens (Producer a' m x) (Producer a m x) (FreeT (Producer a' m) m x) (FreeT (Producer a m) m x)
groupsBy equals k p0 = fmap concats (k (_groupsBy p0))
where
_groupsBy p = FreeT $ do
x <- next p
return $ case x of
Left r -> Pure r
Right (a, p') -> Free $
fmap _groupsBy ((yield a >> p')^.span (equals a))
groups :: (Monad m, Eq a') => Lens (Producer a' m x) (Producer a m x) (FreeT (Producer a' m) m x) (FreeT (Producer a m) m x)
groups = groupsBy (==)
chunksOf
:: Monad m => Int -> Lens (Producer a' m x) (Producer a m x) (FreeT (Producer a' m) m x) (FreeT (Producer a m) m x)
chunksOf n0 k p0 = fmap concats (k (_chunksOf p0))
where
_chunksOf p = FreeT $ do
x <- next p
return $ case x of
Left r -> Pure r
Right (a, p') -> Free $ fmap _chunksOf ((yield a >> p')^.splitAt n0)
concats :: Monad m => FreeT (Producer a m) m x -> Producer a m x
concats = go
where
go f = do
x <- lift (runFreeT f)
case x of
Pure r -> return r
Free p -> do
f' <- p
go f'
intercalates
:: Monad m => Producer a m () -> FreeT (Producer a m) m x -> Producer a m x
intercalates sep = go0
where
go0 f = do
x <- lift (runFreeT f)
case x of
Pure r -> return r
Free p -> do
f' <- p
go1 f'
go1 f = do
x <- lift (runFreeT f)
case x of
Pure r -> return r
Free p -> do
sep
f' <- p
go1 f'
takes :: (Functor f, Monad m) => Int -> FreeT f m () -> FreeT f m ()
takes = go
where
go n f =
if (n > 0)
then FreeT $ do
x <- runFreeT f
case x of
Pure () -> return (Pure ())
Free w -> return (Free (fmap (go $! n - 1) w))
else return ()
takes' :: Monad m => Int -> FreeT (Producer a m) m x -> FreeT (Producer a m) m x
takes' = go0
where
go0 n f = FreeT $
if (n > 0)
then do
x <- runFreeT f
return $ case x of
Pure r -> Pure r
Free p -> Free $ fmap (go0 $! n - 1) p
else go1 f
go1 f = do
x <- runFreeT f
case x of
Pure r -> return (Pure r)
Free p -> do
f' <- P.runEffect (P.for p P.discard)
go1 f'
drops :: Monad m => Int -> FreeT (Producer a m) m x -> FreeT (Producer a m) m x
drops = go
where
go n ft
| n <= 0 = ft
| otherwise = FreeT $ do
ff <- runFreeT ft
case ff of
Pure _ -> return ff
Free f -> do
ft' <- P.runEffect $ P.for f P.discard
runFreeT $ go (n-1) ft'
maps
:: (Monad m, Functor g)
=> (forall r . f r -> g r) -> FreeT f m x -> FreeT g m x
maps = F.transFreeT
individually
:: (Monad m, Functor g)
=> Setter (FreeT f m x) (FreeT g m x) (f (FreeT f m x)) (g (FreeT f m x))
individually nat f0 = Identity (go f0)
where
nat' = runIdentity . nat
go f = FreeT $ do
x <- runFreeT f
return $ case x of
Pure r -> Pure r
Free w -> Free (fmap go (nat' w))
folds
:: Monad m
=> (x -> a -> x)
-> x
-> (x -> b)
-> FreeT (Producer a m) m r
-> Producer b m r
folds step begin done = go
where
go f = do
x <- lift (runFreeT f)
case x of
Pure r -> return r
Free p -> do
(f', b) <- lift (fold p begin)
yield b
go f'
fold p x = do
y <- next p
case y of
Left f -> return (f, done x)
Right (a, p') -> fold p' $! step x a
foldsM
:: Monad m
=> (x -> a -> m x)
-> m x
-> (x -> m b)
-> FreeT (Producer a m) m r
-> Producer b m r
foldsM step begin done = go
where
go f = do
y <- lift (runFreeT f)
case y of
Pure r -> return r
Free p -> do
(f', b) <- lift $ do
x <- begin
foldM p x
yield b
go f'
foldM p x = do
y <- next p
case y of
Left f -> do
b <- done x
return (f, b)
Right (a, p') -> do
x' <- step x a
foldM p' $! x'