module Control.Proxy.Prelude (
stdinS,
stdoutD,
readLnS,
hGetLineS,
hPutStrLnD,
printD,
printU,
printB,
mapD,
mapU,
mapMD,
mapMU,
useD,
useU,
execD,
execU,
takeB,
takeB_,
takeWhileD,
takeWhileU,
dropD,
dropU,
dropWhileD,
dropWhileU,
filterD,
filterU,
fromListS,
enumFromS,
enumFromToS,
eachS,
rangeS,
foldD,
allD,
allD_,
anyD,
anyD_,
sumD,
productD,
lengthD,
headD,
headD_,
lastD,
toListD,
foldrD,
leftD,
rightD,
zipD,
mergeD,
unitD,
unitU,
foreverK,
module Data.Monoid,
mapB,
mapMB,
useB,
execB,
fromListC,
enumFromC,
enumFromToC,
eachC,
rangeC,
getLineS,
getLineC,
readLnC,
putStrLnD,
putStrLnU,
putStrLnB,
hGetLineC,
hPutStrLnU,
hPutStrLnB,
hPrintD,
hPrintU,
hPrintB,
replicateK,
liftK,
hoistK,
raise,
raiseK,
hoistPK,
raiseP,
raisePK
) where
import Control.Monad (forever)
import Control.Monad.Morph (MFunctor(hoist))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Proxy.Class
import Control.Proxy.Morph (PFunctor(hoistP))
import Control.Proxy.Trans (ProxyTrans(liftP))
import Control.Proxy.Trans.Identity (
IdentityP(IdentityP, runIdentityP), runIdentityK)
import Control.Proxy.Trans.Writer (WriterP, tell)
import Data.Monoid (
Monoid(mempty, mappend),
Endo(Endo, appEndo),
All(All, getAll),
Any(Any, getAny),
Sum(Sum, getSum),
Product(Product, getProduct),
First(First, getFirst),
Last(Last, getLast) )
import qualified System.IO as IO
stdinS :: (Proxy p) => () -> Producer p String IO r
stdinS () = runIdentityP $ forever $ do
str <- lift getLine
respond str
stdoutD :: (Proxy p) => x -> p x String x String IO r
stdoutD = runIdentityK $ foreverK $ \x -> do
a <- request x
lift $ putStrLn a
respond a
readLnS :: (Read b, Proxy p) => () -> Producer p b IO r
readLnS () = runIdentityP $ forever $ do
a <- lift readLn
respond a
hGetLineS :: (Proxy p) => IO.Handle -> () -> Producer p String IO ()
hGetLineS h () = runIdentityP go where
go = do
eof <- lift $ IO.hIsEOF h
if eof
then return ()
else do
str <- lift $ IO.hGetLine h
respond str
go
hPutStrLnD :: (Proxy p) => IO.Handle -> x -> p x String x String IO r
hPutStrLnD h = runIdentityK $ foreverK $ \x -> do
a <- request x
lift $ IO.hPutStrLn h a
respond a
printD :: (Show a, Proxy p) => x -> p x a x a IO r
printD = runIdentityK $ foreverK $ \x -> do
a <- request x
lift $ print a
respond a
printU :: (Show a', Proxy p) => a' -> p a' x a' x IO r
printU = runIdentityK $ foreverK $ \a' -> do
lift $ print a'
x <- request a'
respond x
printB :: (Show a', Show a, Proxy p) => a' -> p a' a a' a IO r
printB = runIdentityK $ foreverK $ \a' -> do
lift $ do
putStr "U: "
print a'
a <- request a'
lift $ do
putStr "D: "
print a
respond a
mapD :: (Monad m, Proxy p) => (a -> b) -> x -> p x a x b m r
mapD f = runIdentityK go where
go x = do
a <- request x
x2 <- respond (f a)
go x2
mapU :: (Monad m, Proxy p) => (b' -> a') -> b' -> p a' x b' x m r
mapU g = runIdentityK go where
go b' = do
x <- request (g b')
b'2 <- respond x
go b'2
mapMD :: (Monad m, Proxy p) => (a -> m b) -> x -> p x a x b m r
mapMD f = runIdentityK go where
go x = do
a <- request x
b <- lift (f a)
x2 <- respond b
go x2
mapMU :: (Monad m, Proxy p) => (b' -> m a') -> b' -> p a' x b' x m r
mapMU g = runIdentityK go where
go b' = do
a' <- lift (g b')
x <- request a'
b'2 <- respond x
go b'2
useD :: (Monad m, Proxy p) => (a -> m r1) -> x -> p x a x a m r
useD f = runIdentityK go where
go x = do
a <- request x
_ <- lift $ f a
x2 <- respond a
go x2
useU :: (Monad m, Proxy p) => (a' -> m r2) -> a' -> p a' x a' x m r
useU g = runIdentityK go where
go a' = do
lift $ g a'
x <- request a'
a'2 <- respond x
go a'2
execD :: (Monad m, Proxy p) => m r1 -> a' -> p a' a a' a m r
execD md = runIdentityK go where
go a' = do
a <- request a'
_ <- lift md
a'2 <- respond a
go a'2
execU :: (Monad m, Proxy p) => m r2 -> a' -> p a' a a' a m r
execU mu = runIdentityK go where
go a' = do
lift mu
a <- request a'
a'2 <- respond a
go a'2
takeB :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m a'
takeB n0 = runIdentityK (go n0) where
go n
| n <= 0 = return
| otherwise = \a' -> do
a <- request a'
a'2 <- respond a
go (n 1) a'2
takeB_ :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m ()
takeB_ n0 = runIdentityK (go n0) where
go n
| n <= 0 = \_ -> return ()
| otherwise = \a' -> do
a <- request a'
a'2 <- respond a
go (n 1) a'2
takeWhileD :: (Monad m, Proxy p) => (a -> Bool) -> a' -> p a' a a' a m ()
takeWhileD p = runIdentityK go where
go a' = do
a <- request a'
if (p a)
then do
a'2 <- respond a
go a'2
else return ()
takeWhileU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' a a' a m ()
takeWhileU p = runIdentityK go where
go a' =
if (p a')
then do
a <- request a'
a'2 <- respond a
go a'2
else return_P ()
dropD :: (Monad m, Proxy p) => Int -> () -> Pipe p a a m r
dropD n0 = \() -> runIdentityP (go n0) where
go n
| n <= 0 = pull ()
| otherwise = do
_ <- request ()
go (n 1)
dropU :: (Monad m, Proxy p) => Int -> a' -> CoPipe p a' a' m r
dropU n0 = runIdentityK (go n0) where
go n
| n <= 0 = pull
| otherwise = \_ -> do
a' <- respond ()
go (n 1) a'
dropWhileD :: (Monad m, Proxy p) => (a -> Bool) -> () -> Pipe p a a m r
dropWhileD p () = runIdentityP go where
go = do
a <- request ()
if (p a)
then go
else do
x <- respond a
pull x
dropWhileU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> CoPipe p a' a' m r
dropWhileU p = runIdentityK go where
go a' =
if (p a')
then do
a2 <- respond ()
go a2
else pull a'
filterD :: (Monad m, Proxy p) => (a -> Bool) -> () -> Pipe p a a m r
filterD p = \() -> runIdentityP go where
go = do
a <- request ()
if (p a)
then do
respond a
go
else go
filterU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> CoPipe p a' a' m r
filterU p = runIdentityK go where
go a' =
if (p a')
then do
request a'
a'2 <- respond ()
go a'2
else do
a'2 <- respond ()
go a'2
fromListS :: (Monad m, Proxy p) => [b] -> () -> Producer p b m ()
fromListS xs = \_ -> foldr (\e a -> respond e ?>= \_ -> a) (return_P ()) xs
enumFromS :: (Enum b, Monad m, Proxy p) => b -> () -> Producer p b m r
enumFromS b0 = \_ -> runIdentityP (go b0) where
go b = do
_ <- respond b
go $! succ b
enumFromToS
:: (Enum b, Ord b, Monad m, Proxy p) => b -> b -> () -> Producer p b m ()
enumFromToS b1 b2 _ = runIdentityP (go b1) where
go b
| b > b2 = return ()
| otherwise = do
_ <- respond b
go $! succ b
eachS :: (Monad m, Proxy p) => [b] -> ProduceT p m b
eachS bs = RespondT (fromListS bs ())
rangeS :: (Enum b, Ord b, Monad m, Proxy p) => b -> b -> ProduceT p m b
rangeS b1 b2 = RespondT (enumFromToS b1 b2 ())
foldD
:: (Monad m, Proxy p, Monoid w) => (a -> w) -> x -> WriterP w p x a x a m r
foldD f = go where
go x = do
a <- request x
tell (f a)
x2 <- respond a
go x2
allD :: (Monad m, Proxy p) => (a -> Bool) -> x -> WriterP All p x a x a m r
allD predicate = foldD (All . predicate)
allD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> WriterP All p x a x a m ()
allD_ predicate = go where
go x = do
a <- request x
if (predicate a)
then do
x2 <- respond a
go x2
else tell (All False)
anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> WriterP Any p x a x a m r
anyD predicate = foldD (Any . predicate)
anyD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> WriterP Any p x a x a m ()
anyD_ predicate = go where
go x = do
a <- request x
if (predicate a)
then tell (Any True)
else do
x2 <- respond a
go x2
sumD :: (Monad m, Proxy p, Num a) => x -> WriterP (Sum a) p x a x a m r
sumD = foldD Sum
productD :: (Monad m, Proxy p, Num a) => x -> WriterP (Product a) p x a x a m r
productD = foldD Product
lengthD :: (Monad m, Proxy p) => x -> WriterP (Sum Int) p x a x a m r
lengthD = foldD (\_ -> Sum 1)
headD :: (Monad m, Proxy p) => x -> WriterP (First a) p x a x a m r
headD = foldD (First . Just)
headD_ :: (Monad m, Proxy p) => x -> WriterP (First a) p x a x a m ()
headD_ x = do
a <- request x
tell $ First (Just a)
lastD :: (Monad m, Proxy p) => x -> WriterP (Last a) p x a x a m r
lastD = foldD (Last . Just)
toListD :: (Monad m, Proxy p) => x -> WriterP [a] p x a x a m r
toListD = foldD (\x -> [x])
foldrD
:: (Monad m, Proxy p)
=> (a -> b -> b) -> x -> WriterP (Endo b) p x a x a m r
foldrD step = foldD (Endo . step)
leftD
:: (Monad m, Proxy p)
=> (q -> p x a x b m r) -> (q -> p x (Either a e) x (Either b e) m r)
leftD k = runIdentityK (up \>\ (IdentityP . k />/ dn))
where
dn b = respond (Left b)
up x = do
ma <- request x
case ma of
Left a -> return a
Right e -> do
x2 <- respond (Right e)
up x2
rightD
:: (Monad m, Proxy p)
=> (q -> p x a x b m r) -> (q -> p x (Either e a) x (Either e b) m r)
rightD k = runIdentityK (up \>\ (IdentityP . k />/ dn))
where
dn b = respond (Right b)
up x = do
ma <- request x
case ma of
Left e -> do
x2 <- respond (Left e)
up x2
Right a -> return a
zipD
:: (Monad m, Proxy p1, Proxy p2, Proxy p3)
=> () -> Consumer p1 a (Consumer p2 b (Producer p3 (a, b) m)) r
zipD () = runIdentityP $ hoist (runIdentityP . hoist runIdentityP) go where
go = do
a <- request ()
lift $ do
b <- request ()
lift $ respond (a, b)
go
mergeD
:: (Monad m, Proxy p1, Proxy p2, Proxy p3)
=> () -> Consumer p1 a (Consumer p2 a (Producer p3 a m)) r
mergeD () = runIdentityP $ hoist (runIdentityP . hoist runIdentityP) go where
go = do
a1 <- request ()
lift $ do
lift $ respond a1
a2 <- request ()
lift $ respond a2
go
unitD :: (Monad m, Proxy p) => q -> p x' x y' () m r
unitD _ = runIdentityP go where
go = do
_ <- respond ()
go
unitU :: (Monad m, Proxy p) => q -> p () x y' y m r
unitU _ = runIdentityP go where
go = do
_ <- request ()
go
foreverK :: (Monad m) => (a -> m a) -> (a -> m b)
foreverK k = let r = \a -> k a >>= r in r
mapB :: (Monad m, Proxy p) => (a -> b) -> (b' -> a') -> b' -> p a' a b' b m r
mapB f g = runIdentityK go where
go b' = do
a <- request (g b')
b'2 <- respond (f a )
go b'2
mapMB
:: (Monad m, Proxy p) => (a -> m b) -> (b' -> m a') -> b' -> p a' a b' b m r
mapMB f g = runIdentityK go where
go b' = do
a' <- lift (g b')
a <- request a'
b <- lift (f a )
b'2 <- respond b
go b'2
useB
:: (Monad m, Proxy p)
=> (a -> m r1) -> (a' -> m r2) -> a' -> p a' a a' a m r
useB f g = runIdentityK go where
go a' = do
lift $ g a'
a <- request a'
lift $ f a
a'2 <- respond a
go a'2
execB :: (Monad m, Proxy p) => m r1 -> m r2 -> a' -> p a' a a' a m r
execB md mu = runIdentityK go where
go a' = do
lift mu
a <- request a'
lift md
a'2 <- respond a
go a'2
fromListC :: (Monad m, Proxy p) => [a'] -> () -> CoProducer p a' m ()
fromListC xs = \_ -> foldr (\e a -> request e ?>= \_ -> a) (return_P ()) xs
enumFromC :: (Enum a', Monad m, Proxy p) => a' -> () -> CoProducer p a' m r
enumFromC a'0 = \_ -> runIdentityP (go a'0) where
go a' = do
request a'
go $! succ a'
enumFromToC
:: (Enum a', Ord a', Monad m, Proxy p)
=> a' -> a' -> () -> CoProducer p a' m ()
enumFromToC a1 a2 _ = runIdentityP (go a1) where
go n
| n > a2 = return ()
| otherwise = do
request n
go $! succ n
eachC :: (Monad m, Proxy p) => [a'] -> CoProduceT p m a'
eachC a's = RequestT (fromListC a's ())
rangeC
:: (Enum a', Ord a', Monad m, Proxy p) => a' -> a' -> CoProduceT p m a'
rangeC a'1 a'2 = RequestT (enumFromToC a'1 a'2 ())
getLineS :: (Proxy p) => () -> Producer p String IO r
getLineS () = runIdentityP $ forever $ do
str <- lift getLine
respond str
getLineC :: (Proxy p) => () -> CoProducer p String IO r
getLineC () = runIdentityP $ forever $ do
str <- lift getLine
request str
readLnC :: (Read a', Proxy p) => () -> CoProducer p a' IO r
readLnC () = runIdentityP $ forever $ do
a <- lift readLn
request a
putStrLnD :: (Proxy p) => x -> p x String x String IO r
putStrLnD = runIdentityK $ foreverK $ \x -> do
a <- request x
lift $ putStrLn a
respond a
putStrLnU :: (Proxy p) => String -> p String x String x IO r
putStrLnU = runIdentityK $ foreverK $ \a' -> do
lift $ putStrLn a'
x <- request a'
respond x
putStrLnB :: (Proxy p) => String -> p String String String String IO r
putStrLnB = runIdentityK $ foreverK $ \a' -> do
lift $ do
putStr "U: "
putStrLn a'
a <- request a'
lift $ do
putStr "D: "
putStrLn a
respond a
hGetLineC :: (Proxy p) => IO.Handle -> () -> CoProducer p String IO ()
hGetLineC h () = runIdentityP go where
go = do
eof <- lift $ IO.hIsEOF h
if eof
then return ()
else do
str <- lift $ IO.hGetLine h
request str
go
hPrintD :: (Show a, Proxy p) => IO.Handle -> x -> p x a x a IO r
hPrintD h = runIdentityK $ foreverK $ \x -> do
a <- request x
lift $ IO.hPrint h a
respond a
hPrintU :: (Show a', Proxy p) => IO.Handle -> a' -> p a' x a' x IO r
hPrintU h = runIdentityK $ foreverK $ \a' -> do
lift $ IO.hPrint h a'
x <- request a'
respond x
hPrintB :: (Show a, Show a', Proxy p) => IO.Handle -> a' -> p a' a a' a IO r
hPrintB h = runIdentityK $ foreverK $ \a' -> do
lift $ do
IO.hPutStr h "U: "
IO.hPrint h a'
a <- request a'
lift $ do
IO.hPutStr h "D: "
IO.hPrint h a
respond a
hPutStrLnU :: (Proxy p) => IO.Handle -> String -> p String x String x IO r
hPutStrLnU h = runIdentityK $ foreverK $ \a' -> do
lift $ IO.hPutStrLn h a'
x <- request a'
respond x
hPutStrLnB
:: (Proxy p) => IO.Handle -> String -> p String String String String IO r
hPutStrLnB h = runIdentityK $ foreverK $ \a' -> do
lift $ do
IO.hPutStr h "U: "
IO.hPutStrLn h a'
a <- request a'
lift $ do
IO.hPutStr h "D: "
IO.hPutStrLn h a
respond a
replicateK :: (Monad m) => Int -> (a -> m a) -> (a -> m a)
replicateK n0 k = go n0 where
go n
| n < 1 = return
| n == 1 = k
| otherwise = \a -> k a >>= go (n 1)
liftK :: (Monad m, MonadTrans t) => (a -> m b) -> (a -> t m b)
liftK k a = lift (k a)
hoistK
:: (Monad m, MFunctor t)
=> (forall a . m a -> n a)
-> (b' -> t m b)
-> (b' -> t n b)
hoistK k p a' = hoist k (p a')
raise :: (Monad m, MFunctor t1, MonadTrans t2) => t1 m r -> t1 (t2 m) r
raise = hoist lift
raiseK
:: (Monad m, MFunctor t1, MonadTrans t2)
=> (q -> t1 m r) -> (q -> t1 (t2 m) r)
raiseK = (hoist lift .)
hoistPK
:: (Monad m, Proxy p1, PFunctor t)
=> (forall _a' _a _b' _b _r .
p1 _a' _a _b' _b m _r -> p2 _a' _a _b' _b n _r)
-> (q -> t p1 a' a b' b m r)
-> (q -> t p2 a' a b' b n r)
hoistPK f = (hoistP f .)
raiseP
:: (Monad m, Proxy p, PFunctor t1, ProxyTrans t2)
=> t1 p a' a b' b m r
-> t1 (t2 p) a' a b' b m r
raiseP = hoistP liftP
raisePK
:: (Monad m, Proxy p, PFunctor t1, ProxyTrans t2)
=> (q -> t1 p a' a b' b m r)
-> (q -> t1 (t2 p) a' a b' b m r)
raisePK = hoistPK liftP