{-# LANGUAGE RankNTypes, Trustworthy #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Pipes.Prelude (
stdinLn
, readLn
, fromHandle
, repeatM
, replicateM
, stdoutLn
, print
, toHandle
, drain
, map
, mapM
, sequence
, mapFoldable
, filter
, filterM
, take
, takeWhile
, drop
, dropWhile
, concat
, elemIndices
, findIndices
, scan
, scanM
, chain
, read
, show
, fold
, foldM
, all
, any
, and
, or
, elem
, notElem
, find
, findIndex
, head
, index
, last
, length
, maximum
, minimum
, null
, sum
, product
, toList
, toListM
, zip
, zipWith
, tee
, generalize
) where
import Control.Exception (throwIO, try)
import Control.Monad (liftM, replicateM_, when, unless)
import Control.Monad.Trans.State.Strict (get, put)
import Data.Functor.Identity (Identity, runIdentity)
import Foreign.C.Error (Errno(Errno), ePIPE)
import Pipes
import Pipes.Core
import Pipes.Internal
import Pipes.Lift (evalStateP)
import qualified GHC.IO.Exception as G
import qualified System.IO as IO
import qualified Prelude
import Prelude hiding (
all
, and
, any
, concat
, drop
, dropWhile
, elem
, filter
, head
, last
, length
, map
, mapM
, maximum
, minimum
, notElem
, null
, or
, print
, product
, read
, readLn
, sequence
, show
, sum
, take
, takeWhile
, zip
, zipWith
)
stdinLn :: MonadIO m => Producer' String m ()
stdinLn = fromHandle IO.stdin
readLn :: (MonadIO m, Read a) => Producer' a m ()
readLn = stdinLn >-> read
fromHandle :: MonadIO m => IO.Handle -> Producer' String m ()
fromHandle h = go
where
go = do
eof <- liftIO $ IO.hIsEOF h
unless eof $ do
str <- liftIO $ IO.hGetLine h
yield str
go
repeatM :: Monad m => m a -> Producer' a m r
repeatM m = lift m >~ cat
{-# RULES
"repeatM m >-> p" forall m p . repeatM m >-> p = lift m >~ p
#-}
replicateM :: Monad m => Int -> m a -> Producer' a m ()
replicateM n m = lift m >~ take n
stdoutLn :: MonadIO m => Consumer' String m ()
stdoutLn = go
where
go = do
str <- await
x <- liftIO $ try (putStrLn str)
case x of
Left (G.IOError { G.ioe_type = G.ResourceVanished
, G.ioe_errno = Just ioe })
| Errno ioe == ePIPE
-> return ()
Left e -> liftIO (throwIO e)
Right () -> go
print :: (MonadIO m, Show a) => Consumer' a m r
print = for cat (\a -> liftIO (Prelude.print a))
{-# RULES
"p >-> print" forall p .
p >-> print = for p (\a -> liftIO (Prelude.print a))
#-}
toHandle :: MonadIO m => IO.Handle -> Consumer' String m r
toHandle handle = for cat (\str -> liftIO (IO.hPutStrLn handle str))
{-# RULES
"p >-> toHandle handle" forall p handle .
p >-> toHandle handle = for p (\str -> liftIO (IO.hPutStrLn handle str))
#-}
drain :: Monad m => Consumer' a m r
drain = for cat discard
{-# RULES
"p >-> drain" forall p .
p >-> drain = for p discard
#-}
map :: Monad m => (a -> b) -> Pipe a b m r
map f = for cat (\a -> yield (f a))
{-# RULES
"p >-> map f" forall p f . p >-> map f = for p (\a -> yield (f a))
; "map f >-> p" forall p f . map f >-> p = (do
a <- await
return (f a) ) >~ p
#-}
mapM :: Monad m => (a -> m b) -> Pipe a b m r
mapM f = for cat $ \a -> do
b <- lift (f a)
yield b
{-# RULES
"p >-> mapM f" forall p f . p >-> mapM f = for p (\a -> do
b <- lift (f a)
yield b )
; "mapM f >-> p" forall p f . mapM f >-> p = (do
a <- await
b <- lift (f a)
return b ) >~ p
#-}
sequence :: Monad m => Pipe (m a) a m r
sequence = mapM id
mapFoldable :: (Monad m, Foldable t) => (a -> t b) -> Pipe a b m r
mapFoldable f = for cat (\a -> each (f a))
{-# RULES
"p >-> mapFoldable f" forall p f .
p >-> mapFoldable f = for p (\a -> each (f a))
#-}
filter :: Monad m => (a -> Bool) -> Pipe a a m r
filter predicate = for cat $ \a -> when (predicate a) (yield a)
{-# RULES
"p >-> filter predicate" forall p predicate.
p >-> filter predicate = for p (\a -> when (predicate a) (yield a))
#-}
filterM :: Monad m => (a -> m Bool) -> Pipe a a m r
filterM predicate = for cat $ \a -> do
b <- lift (predicate a)
when b (yield a)
{-# RULES
"p >-> filterM predicate" forall p predicate .
p >-> filterM predicate = for p (\a -> do
b <- lift (predicate a)
when b (yield a) )
#-}
take :: Monad m => Int -> Pipe a a m ()
take n = replicateM_ n $ do
a <- await
yield a
takeWhile :: Monad m => (a -> Bool) -> Pipe a a m ()
takeWhile predicate = go
where
go = do
a <- await
if (predicate a)
then do
yield a
go
else return ()
drop :: Monad m => Int -> Pipe a a m r
drop n = do
replicateM_ n await
cat
dropWhile :: Monad m => (a -> Bool) -> Pipe a a m r
dropWhile predicate = go
where
go = do
a <- await
if (predicate a)
then go
else do
yield a
cat
concat :: (Monad m, Foldable f) => Pipe (f a) a m r
concat = for cat each
{-# RULES
"p >-> concat" forall p . p >-> concat = for p each
#-}
elemIndices :: (Monad m, Eq a) => a -> Pipe a Int m r
elemIndices a = findIndices (a ==)
findIndices :: Monad m => (a -> Bool) -> Pipe a Int m r
findIndices predicate = loop 0
where
loop n = do
a <- await
when (predicate a) (yield n)
loop $! n + 1
scan :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Pipe a b m r
scan step begin done = loop begin
where
loop x = do
yield (done x)
a <- await
let x' = step x a
loop $! x'
scanM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Pipe a b m r
scanM step begin done = do
x <- lift begin
loop x
where
loop x = do
b <- lift (done x)
yield b
a <- await
x' <- lift (step x a)
loop $! x'
chain :: Monad m => (a -> m ()) -> Pipe a a m r
chain f = for cat $ \a -> do
lift (f a)
yield a
{-# RULES
"p >-> chain f" forall p f .
p >-> chain f = for p (\a -> do
lift (f a)
yield a )
; "chain f >-> p" forall p f .
chain f >-> p = (do
a <- await
lift (f a)
return a ) >~ p
#-}
read :: (Monad m, Read a) => Pipe String a m r
read = for cat $ \str -> case (reads str) of
[(a, "")] -> yield a
_ -> return ()
{-# RULES
"p >-> read" forall p .
p >-> read = for p (\str -> case (reads str) of
[(a, "")] -> yield a
_ -> return () )
#-}
show :: (Monad m, Show a) => Pipe a String m r
show = map Prelude.show
fold :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Producer a m () -> m b
fold step begin done p0 = loop p0 begin
where
loop p x = case p of
Request v _ -> closed v
Respond a fu -> loop (fu ()) $! step x a
M m -> m >>= \p' -> loop p' x
Pure _ -> return (done x)
foldM
:: Monad m
=> (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b
foldM step begin done p0 = do
x0 <- begin
loop p0 x0
where
loop p x = case p of
Request v _ -> closed v
Respond a fu -> do
x' <- step x a
loop (fu ()) $! x'
M m -> m >>= \p' -> loop p' x
Pure _ -> done x
all :: Monad m => (a -> Bool) -> Producer a m () -> m Bool
all predicate p = null $ p >-> filter (\a -> not (predicate a))
any :: Monad m => (a -> Bool) -> Producer a m () -> m Bool
any predicate p = liftM not $ null (p >-> filter predicate)
and :: Monad m => Producer Bool m () -> m Bool
and = all id
or :: Monad m => Producer Bool m () -> m Bool
or = any id
elem :: (Monad m, Eq a) => a -> Producer a m () -> m Bool
elem a = any (a ==)
notElem :: (Monad m, Eq a) => a -> Producer a m () -> m Bool
notElem a = all (a /=)
find :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe a)
find predicate p = head (p >-> filter predicate)
findIndex :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe Int)
findIndex predicate p = head (p >-> findIndices predicate)
head :: Monad m => Producer a m () -> m (Maybe a)
head p = do
x <- next p
return $ case x of
Left _ -> Nothing
Right (a, _) -> Just a
index :: Monad m => Int -> Producer a m () -> m (Maybe a)
index n p = head (p >-> drop n)
last :: Monad m => Producer a m () -> m (Maybe a)
last p0 = do
x <- next p0
case x of
Left _ -> return Nothing
Right (a, p') -> loop a p'
where
loop a p = do
x <- next p
case x of
Left _ -> return (Just a)
Right (a', p') -> loop a' p'
length :: Monad m => Producer a m () -> m Int
length = fold (\n _ -> n + 1) 0 id
maximum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a)
maximum = fold step Nothing id
where
step x a = Just $ case x of
Nothing -> a
Just a' -> max a a'
minimum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a)
minimum = fold step Nothing id
where
step x a = Just $ case x of
Nothing -> a
Just a' -> min a a'
null :: Monad m => Producer a m () -> m Bool
null p = do
x <- next p
return $ case x of
Left _ -> True
Right _ -> False
sum :: (Monad m, Num a) => Producer a m () -> m a
sum = fold (+) 0 id
product :: (Monad m, Num a) => Producer a m () -> m a
product = fold (*) 1 id
toList :: Producer a Identity () -> [a]
toList = loop
where
loop p = case p of
Request v _ -> closed v
Respond a fu -> a:loop (fu ())
M m -> loop (runIdentity m)
Pure _ -> []
toListM :: Monad m => Producer a m () -> m [a]
toListM = loop
where
loop p = case p of
Request v _ -> closed v
Respond a fu -> do
as <- loop (fu ())
return (a:as)
M m -> m >>= loop
Pure _ -> return []
zip :: Monad m
=> (Producer a m r)
-> (Producer b m r)
-> (Producer' (a, b) m r)
zip = zipWith (,)
zipWith :: Monad m
=> (a -> b -> c)
-> (Producer a m r)
-> (Producer b m r)
-> (Producer' c m r)
zipWith f = go
where
go p1 p2 = do
e1 <- lift $ next p1
case e1 of
Left r -> return r
Right (a, p1') -> do
e2 <- lift $ next p2
case e2 of
Left r -> return r
Right (b, p2') -> do
yield (f a b)
go p1' p2'
tee :: Monad m => Consumer a m r -> Pipe a a m r
tee p = evalStateP Nothing $ do
r <- up >\\ (hoist lift p //> dn)
ma <- lift get
case ma of
Nothing -> return ()
Just a -> yield a
return r
where
up () = do
ma <- lift get
case ma of
Nothing -> return ()
Just a -> yield a
a <- await
lift $ put (Just a)
return a
dn v = closed v
generalize :: Monad m => Pipe a b m r -> x -> Proxy x a x b m r
generalize p x0 = evalStateP x0 $ up >\\ hoist lift p //> dn
where
up () = do
x <- lift get
request x
dn a = do
x <- respond a
lift $ put x