module Control.Proxy.Parse (
draw,
unDraw,
peek,
isEndOfInput,
drawAll,
skipAll,
passUpTo,
passWhile,
wrap,
unwrap,
fmapPull,
returnPull,
bindPull,
zoom,
_fst,
_snd,
module Control.Proxy.Trans.State,
module Data.Monoid
) where
import Control.Monad (forever)
import Control.Proxy ((>->), (\>\), (//>), (>\\), (?>=))
import qualified Control.Proxy as P
import Control.Proxy.Trans.State (
StateP(StateP, unStateP),
state,
stateT,
runStateP,
runStateK,
evalStateP,
evalStateK,
execStateP,
execStateK,
get,
put,
modify,
gets )
import Data.Monoid (Monoid(mempty, mappend))
draw :: (Monad m, P.Proxy p) => StateP [a] p () (Maybe a) y' y m (Maybe a)
draw = do
s <- get
case s of
[] -> P.request ()
a:as -> do
put as
return (Just a)
unDraw :: (Monad m, P.Proxy p) => a -> StateP [a] p x' x y' y m ()
unDraw a = modify (a:)
peek :: (Monad m, P.Proxy p) => StateP [a] p () (Maybe a) y' y m (Maybe a)
peek = do
ma <- draw
case ma of
Nothing -> return ()
Just a -> unDraw a
return ma
isEndOfInput :: (Monad m, P.Proxy p) => StateP [a] p () (Maybe a) y' y m Bool
isEndOfInput = do
ma <- peek
case ma of
Nothing -> return True
Just _ -> return False
drawAll :: (Monad m, P.Proxy p) => () -> StateP [a] p () (Maybe a) y' y m [a]
drawAll = \() -> go id
where
go diffAs = do
ma <- draw
case ma of
Nothing -> return (diffAs [])
Just a -> go (diffAs . (a:))
skipAll :: (Monad m, P.Proxy p) => () -> StateP [a] p () (Maybe a) y' y m ()
skipAll = \() -> go
where
go = do
ma <- draw
case ma of
Nothing -> return ()
Just _ -> go
passUpTo
:: (Monad m, P.Proxy p)
=> Int -> () -> P.Pipe (StateP [a] p) (Maybe a) (Maybe a) m r
passUpTo n0 = \() -> go n0
where
go n0 =
if (n0 <= 0)
then forever $ P.respond Nothing
else do
ma <- draw
P.respond ma
case ma of
Nothing -> forever $ P.respond Nothing
Just _ -> go (n0 1)
passWhile
:: (Monad m, P.Proxy p)
=> (a -> Bool) -> () -> P.Pipe (StateP [a] p) (Maybe a) (Maybe a) m r
passWhile pred = \() -> go
where
go = do
ma <- draw
case ma of
Nothing -> forever $ P.respond Nothing
Just a ->
if (pred a)
then do
P.respond ma
go
else do
unDraw a
forever $ P.respond Nothing
wrap :: (Monad m, P.Proxy p) => p a' a b' b m r -> p a' a b' (Maybe b) m s
wrap = \p -> P.runIdentityP $ do
P.IdentityP p //> \b -> P.respond (Just b)
forever $ P.respond Nothing
unwrap :: (Monad m, P.Proxy p) => x -> p x (Maybe a) x a m ()
unwrap = \x -> P.runIdentityP (go x)
where
go x = do
ma <- P.request x
case ma of
Nothing -> return ()
Just a -> do
x2 <- P.respond a
go x2
fmapPull
:: (Monad m, P.Proxy p)
=> (x -> p x a x b m r)
-> (x -> p x (Maybe a) x (Maybe b) m r)
fmapPull f = bindPull (f >-> returnPull)
returnPull :: (Monad m, P.Proxy p) => x -> p x a x (Maybe a) m r
returnPull = P.mapD Just
bindPull
:: (Monad m, P.Proxy p)
=> (x -> p x a x (Maybe b) m r)
-> (x -> p x (Maybe a) x (Maybe b) m r)
bindPull f = P.runIdentityP . (up \>\ P.IdentityP . f)
where
up a' = do
ma <- P.request a'
case ma of
Nothing -> do
a'2 <- P.respond Nothing
up a'2
Just a -> return a
zoom
:: (Monad m, P.Proxy p)
=> ((s2 -> (s2, s2)) -> (s1 -> (s2, s1)))
-> StateP s2 p a' a b' b m r
-> StateP s1 p a' a b' b m r
zoom lens = \p -> StateP $ \s2_0 ->
let (s1_0, s2_0') = lens (\x -> (x, x)) s2_0
in (up >\\ P.thread_P (unStateP p s1_0) s2_0' //> dn) ?>= nx
where
up ((a', s1), s2) =
let (_, s2') = lens (\x -> (x, s1)) s2
in P.request (a', s2') ?>= \(a, s2'') ->
let (s1', s2''') = lens (\x -> (x, x)) s2''
in P.return_P ((a, s1'), s2''')
dn ((b, s1), s2) =
let (_, s2') = lens (\x -> (x, s1)) s2
in P.respond (b, s2') ?>= \(b', s2'') ->
let (s1', s2''') = lens (\x -> (x, x)) s2''
in P.return_P ((b', s1'), s2''')
nx ((r, s1), s2) =
let (_, s2') = lens (\x -> (x, s1)) s2
in P.return_P (r, s2')
_fst :: (Functor f) => (a -> f b) -> ((a, x) -> f (b, x))
_fst = \f (a, x) -> fmap (\b -> (b, x)) (f a)
_snd :: (Functor f) => (a -> f b) -> ((x, a) -> f (x, b))
_snd = \f (x, a) -> fmap (\b -> (x, b)) (f a)