module Pipes.Extras (
arr
, left
, right
, (+++)
, input
, output
, check
, delay
, progress
, fold
, foldM
, scan
, scanM
, scan1
, scan1M
, scan1i
, scan1iM
, toProxy
, fromProxy
) where
import Control.Concurrent (threadDelay)
import Data.Char (toLower)
import Data.Functor.Identity (Identity(Identity, runIdentity))
import Control.Foldl (purely, impurely, Fold, FoldM)
import Pipes
import Pipes.Core (request, respond, (>\\), (//>))
import Pipes.Internal (Proxy(..))
import qualified Pipes.Prelude as Pipes
arr :: Monad m => (a -> b) -> Pipe a b m r
arr = Pipes.map
left :: Monad m => Pipe a b m r -> Pipe (Either a x) (Either b x) m r
left p = await' >~ for p yield'
where
yield' b = yield (Left b)
await' = do
e <- await
case e of
Left a -> return a
Right x -> do
yield (Right x)
await'
right :: Monad m => Pipe a b m r -> Pipe (Either x a) (Either x b) m r
right p = await' >~ for p yield'
where
yield' b = yield (Right b)
await' = do
e <- await
case e of
Left x -> do
yield (Left x)
await'
Right a -> return a
(+++)
:: Monad m
=> Pipe a b m r -> Pipe c d m r -> Pipe (Either a c) (Either b d) m r
pL +++ pR = left pL >-> right pR
type Setter s t a b = (a -> Identity b) -> (s -> Identity t)
input :: Monad m => Setter (Proxy x' b y' y m r) (Proxy x' a y' y m r) a b
input k p = Identity (request' >\\ p)
where
request' a' = fmap (\a -> runIdentity (k a)) (request a')
output :: Monad m => Setter (Proxy x' x y' a m r) (Proxy x' x y' b m r) a b
output k p = Identity (p //> respond')
where
respond' a = respond (runIdentity (k a))
check :: Show a => Pipe a a IO r
check = Pipes.filterM $ \a -> do
let prompt = do
putStrLn ("Allow <" ++ show a ++ "> [Y/n]?")
str <- getLine
case map toLower str of
"" -> return True
"y" -> return True
"yes" -> return True
"n" -> return False
"no" -> return False
_ -> do
putStrLn "Please enter (y)es or (n)o."
prompt
prompt
progress :: Pipe a a IO r
progress = go (0 :: Integer)
where
go n = do
let str = bar n ++ " " ++ show n
lift $ putStr str
a <- await
yield a
lift $ putStr (replicate (length str) '\b')
go (n + 1)
bar n = case n `mod` 4 of
0 -> "|"
1 -> "/"
2 -> "-"
_ -> "\\"
delay :: Double -> Pipe a a IO r
delay seconds = for cat $ \a -> do
yield a
lift $ threadDelay (truncate (seconds * 1000000))
fold :: Monad m => Fold a b -> Producer a m () -> m b
fold = purely Pipes.fold
foldM :: Monad m => FoldM m a b -> Producer a m () -> m b
foldM = impurely Pipes.foldM
scan :: Monad m => Fold a b -> Pipe a b m r
scan = purely Pipes.scan
scanM :: Monad m => FoldM m a b -> Pipe a b m r
scanM = impurely Pipes.scanM
scan1i :: Monad m => (a -> a -> a) -> Pipe a a m r
scan1i step = scan1 step id id
scan1iM :: Monad m => (a -> a -> m a) -> Pipe a a m r
scan1iM step = scan1M step return return
scan1 :: Monad m => (x -> a -> x) -> (a -> x) -> (x -> b) -> Pipe a b m r
scan1 step begin done = do
initial <- await
Pipes.scan step (begin initial) done
scan1M :: Monad m => (x -> a -> m x) -> (a -> m x) -> (x -> m b) -> Pipe a b m r
scan1M step begin done = do
initial <- await
Pipes.scanM step (begin initial) done
toProxy
:: Monad n
=> ( forall m
. Monad m
=> (a' -> (a -> m r) -> m r)
-> (b -> (b' -> m r) -> m r)
-> m r
)
-> Proxy a' a b' b n r
toProxy k = k
(\a' fa -> request a' >>= fa )
(\b fb' -> respond b >>= fb')
fromProxy
:: Monad m
=> Proxy a' a b' b m r
-> (a' -> (a -> m r) -> m r)
-> (b -> (b' -> m r) -> m r)
-> m r
fromProxy p request' respond' = case p of
Request a' fa -> do
request' a' (\a -> fromProxy (fa a ) request' respond')
Respond b fb' -> do
respond' b (\b' -> fromProxy (fb' b') request' respond')
M m -> do
p' <- m
fromProxy p' request' respond'
Pure r -> return r