module Data.Conduit.List
(
sourceList
, sourceNull
, unfold
, enumFromTo
, fold
, take
, drop
, head
, zip
, zipSinks
, peek
, consume
, sinkNull
, foldM
, mapM_
, map
, concatMap
, concatMapAccum
, groupBy
, isolate
, filter
, mapM
, concatMapM
, concatMapAccumM
) where
import Prelude
( ($), return, (==), (), Int
, (.), id, Maybe (..), Monad
, Bool (..)
, Ordering (..)
, (>>)
, flip
, seq
, otherwise
, Enum (succ), Eq
)
import Data.Conduit
import Data.Conduit.Internal (pipeClose, runFinalize)
import Data.Monoid (mempty)
import Data.Void (absurd)
import Control.Monad (liftM, liftM2)
unfold :: Monad m
=> (b -> Maybe (a, b))
-> b
-> Source m a
unfold f =
go
where
go seed =
case f seed of
Just (a, seed') -> HaveOutput (go seed') (return ()) a
Nothing -> Done Nothing ()
enumFromTo :: (Enum a, Eq a, Monad m)
=> a
-> a
-> Source m a
enumFromTo start stop =
go start
where
go i
| i == stop = HaveOutput (Done Nothing ()) (return ()) i
| otherwise = HaveOutput (go (succ i)) (return ()) i
fold :: Monad m
=> (b -> a -> b)
-> b
-> Sink a m b
fold f accum0 =
go accum0
where
go accum = NeedInput (push accum) (return accum)
push accum input =
let accum' = f accum input
in accum' `seq` go accum'
foldM :: Monad m
=> (b -> a -> m b)
-> b
-> Sink a m b
foldM f accum0 = sinkState
accum0
(\accum input -> do
accum' <- f accum input
return $ StateProcessing accum'
)
return
mapM_ :: Monad m
=> (a -> m ())
-> Sink a m ()
mapM_ f =
NeedInput push close
where
push input = PipeM (f input >> return (NeedInput push close)) (return ())
close = return ()
sourceList :: Monad m => [a] -> Source m a
sourceList [] = Done Nothing ()
sourceList (x:xs) = HaveOutput (sourceList xs) (return ()) x
drop :: Monad m
=> Int
-> Sink a m ()
drop 0 = NeedInput (flip Done () . Just) (return ())
drop count =
NeedInput push (return ())
where
count' = count 1
push _
| count' == 0 = Done Nothing ()
| otherwise = drop count'
take :: Monad m
=> Int
-> Sink a m [a]
take count0 =
go count0 id
where
go count front = NeedInput (push count front) (return $ front [])
push 0 front x = Done (Just x) (front [])
push count front x
| count' == 0 = Done Nothing (front [x])
| otherwise = NeedInput (push count' front') (return $ front' [])
where
count' = count 1
front' = front . (x:)
head :: Monad m => Sink a m (Maybe a)
head =
NeedInput push close
where
push x = Done Nothing (Just x)
close = return Nothing
peek :: Monad m => Sink a m (Maybe a)
peek =
NeedInput push close
where
push x = Done (Just x) (Just x)
close = return Nothing
map :: Monad m => (a -> b) -> Conduit a m b
map f =
NeedInput push close
where
push i = HaveOutput (NeedInput push close) (return ()) (f i)
close = mempty
mapM :: Monad m => (a -> m b) -> Conduit a m b
mapM f =
NeedInput push close
where
push = flip PipeM (return ()) . liftM (HaveOutput (NeedInput push close) (return ())) . f
close = mempty
concatMap :: Monad m => (a -> [b]) -> Conduit a m b
concatMap f =
NeedInput push close
where
push = haveMore (NeedInput push close) (return ()) . f
close = mempty
concatMapM :: Monad m => (a -> m [b]) -> Conduit a m b
concatMapM f =
NeedInput push close
where
push = flip PipeM (return ()) . liftM (haveMore (NeedInput push close) (return ())) . f
close = mempty
concatMapAccum :: Monad m => (a -> accum -> (accum, [b])) -> accum -> Conduit a m b
concatMapAccum f accum = conduitState accum push close
where
push state input = let (state', result) = f input state
in return $ StateProducing state' result
close _ = return []
concatMapAccumM :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> Conduit a m b
concatMapAccumM f accum = conduitState accum push close
where
push state input = do (state', result) <- f input state
return $ StateProducing state' result
close _ = return []
consume :: Monad m => Sink a m [a]
consume =
go id
where
go front = NeedInput (push front) (return $ front [])
push front x = go (front . (x:))
groupBy :: Monad m => (a -> a -> Bool) -> Conduit a m [a]
groupBy f = conduitState
[]
push
close
where
push [] v = return $ StateProducing [v] []
push s@(x:_) v =
if f x v then
return $ StateProducing (v:s) []
else
return $ StateProducing [v] [s]
close s = return [s]
isolate :: Monad m => Int -> Conduit a m a
isolate count0 = conduitState
count0
push
close
where
close _ = return []
push count x = do
if count == 0
then return $ StateFinished (Just x) []
else do
let count' = count 1
return $ if count' == 0
then StateFinished Nothing [x]
else StateProducing count' [x]
filter :: Monad m => (a -> Bool) -> Conduit a m a
filter f =
NeedInput push close
where
push i | f i = HaveOutput (NeedInput push close) (return ()) i
push _ = NeedInput push close
close = mempty
sinkNull :: Monad m => Sink a m ()
sinkNull =
NeedInput push close
where
push _ = sinkNull
close = return ()
sourceNull :: Monad m => Source m a
sourceNull = mempty
zip :: Monad m => Source m a -> Source m b -> Source m (a, b)
zip (Done _ ()) (Done _ ()) = Done Nothing ()
zip (Done _ ()) (HaveOutput _ close _) = PipeM (runFinalize close >> return (Done Nothing ())) close
zip (HaveOutput _ close _) (Done _ ()) = PipeM (runFinalize close >> return (Done Nothing ())) close
zip (Done _ ()) (PipeM _ close) = PipeM (runFinalize close >> return (Done Nothing ())) close
zip (PipeM _ close) (Done _ ()) = PipeM (runFinalize close >> return (Done Nothing ())) close
zip (PipeM mx closex) (PipeM my closey) = PipeM (liftM2 zip mx my) (closex >> closey)
zip (PipeM mx closex) y@(HaveOutput _ closey _) = PipeM (liftM (\x -> zip x y) mx) (closex >> closey)
zip x@(HaveOutput _ closex _) (PipeM my closey) = PipeM (liftM (\y -> zip x y) my) (closex >> closey)
zip (HaveOutput srcx closex x) (HaveOutput srcy closey y) = HaveOutput (zip srcx srcy) (closex >> closey) (x, y)
zip (NeedInput _ c) right = zip c right
zip left (NeedInput _ c) = zip left c
zipSinks :: Monad m => Sink i m r -> Sink i m r' -> Sink i m (r, r')
zipSinks = zipSinks' EQ
zipSinks' :: Monad m => Ordering -> Sink i m r -> Sink i m r' -> Sink i m (r, r')
zipSinks' byInputUsed = (><)
where
PipeM mpx mx >< py = PipeM (liftM (>< py) mpx) (liftM2 (,) mx (pipeClose py))
px >< PipeM mpy my = PipeM (liftM (px ><) mpy) (liftM2 (,) (pipeClose px) my)
Done ix x >< Done iy y = Done i (x, y)
where
i = case byInputUsed of
EQ -> iy >> ix
GT -> ix
LT -> iy
NeedInput fpx px >< NeedInput fpy py = NeedInput (\i -> zipSinks' EQ (fpx i) (fpy i)) (px >< py)
NeedInput fpx px >< py = NeedInput (\i -> zipSinks' GT (fpx i) py) (px >< py)
px >< NeedInput fpy py = NeedInput (\i -> zipSinks' LT px (fpy i)) (px >< py)
HaveOutput _ _ o >< _ = absurd o
_ >< HaveOutput _ _ o = absurd o