{-# LANGUAGE RankNTypes #-}
module Pipes.Parse (
Parser
, draw
, skip
, drawAll
, skipAll
, unDraw
, peek
, isEndOfInput
, foldAll
, foldAllM
, span
, splitAt
, groupBy
, group
, toParser
, toParser_
, parsed
, parsed_
, parseForever
, parseForever_
, module Control.Monad.Trans.Class
, module Control.Monad.Trans.State.Strict
, module Pipes
) where
import Control.Monad (join, forever, liftM)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State.Strict as S
import Control.Monad.Trans.State.Strict (
StateT(StateT, runStateT), evalStateT, execStateT )
import Data.Functor.Constant (Constant(Constant, getConstant))
import Data.Foldable (forM_)
import Pipes.Internal (unsafeHoist, closed)
import Pipes (Producer, yield, next)
import Pipes as NoReexport
import Prelude hiding (span, splitAt)
type Parser a m r = forall x . StateT (Producer a m x) m r
draw :: Monad m => Parser a m (Maybe a)
draw = do
p <- S.get
x <- lift (next p)
case x of
Left r -> do
S.put (return r)
return Nothing
Right (a, p') -> do
S.put p'
return (Just a)
{-# INLINABLE draw #-}
skip :: Monad m => Parser a m Bool
skip = do
x <- draw
return $ case x of
Nothing -> False
Just _ -> True
{-# INLINABLE skip #-}
drawAll :: Monad m => Parser a m [a]
drawAll = go id
where
go diffAs = do
x <- draw
case x of
Nothing -> return (diffAs [])
Just a -> go (diffAs . (a:))
{-# INLINABLE drawAll #-}
skipAll :: Monad m => Parser a m ()
skipAll = go
where
go = do
x <- draw
case x of
Nothing -> return ()
Just _ -> go
{-# INLINABLE skipAll #-}
unDraw :: Monad m => a -> Parser a m ()
unDraw a = S.modify (yield a >>)
{-# INLINABLE unDraw #-}
peek :: Monad m => Parser a m (Maybe a)
peek = do
x <- draw
forM_ x unDraw
return x
{-# INLINABLE peek #-}
isEndOfInput :: Monad m => Parser a m Bool
isEndOfInput = do
x <- peek
return (case x of
Nothing -> True
Just _ -> False )
{-# INLINABLE isEndOfInput #-}
foldAll
:: Monad m
=> (x -> a -> x)
-> x
-> (x -> b)
-> Parser a m b
foldAll step begin done = go begin
where
go x = do
ea <- draw
case ea of
Nothing -> return (done x)
Just a -> go $! step x a
{-# INLINABLE foldAll #-}
foldAllM
:: Monad m
=> (x -> a -> m x)
-> m x
-> (x -> m b)
-> Parser a m b
foldAllM step begin done = do
x0 <- lift begin
go x0
where
go x = do
ea <- draw
case ea of
Nothing -> lift (done x)
Just a -> do
x' <- lift (step x a)
go $! x'
{-# INLINABLE foldAllM #-}
type Lens' a b = forall f . (Functor f) => (b -> f b) -> a -> f a
span
:: Monad m
=> (a -> Bool) -> Lens' (Producer a m x) (Producer a m (Producer a m x))
span predicate k p0 = fmap join (k (to p0))
where
to p = do
x <- lift (next p)
case x of
Left r -> return (return r)
Right (a, p') ->
if predicate a
then do
yield a
to p'
else return (yield a >> p')
{-# INLINABLE span #-}
splitAt
:: Monad m
=> Int -> Lens' (Producer a m x) (Producer a m (Producer a m x))
splitAt n0 k p0 = fmap join (k (to n0 p0))
where
to n p =
if n <= 0
then return p
else do
x <- lift (next p)
case x of
Left r -> return (return r)
Right (a, p') -> do
yield a
to (n - 1) p'
{-# INLINABLE splitAt #-}
(^.) :: a -> ((b -> Constant b b) -> a -> Constant b a) -> b
a ^. lens = getConstant (lens Constant a)
groupBy
:: Monad m
=> (a -> a -> Bool)
-> Lens' (Producer a m x) (Producer a m (Producer a m x))
groupBy equals k p0 = fmap join (k (to p0))
where
to p = do
x <- lift (next p)
case x of
Left r -> return (return r)
Right (a, p') -> (yield a >> p') ^. span (equals a)
{-# INLINABLE groupBy #-}
group
:: (Monad m, Eq a) => Lens' (Producer a m x) (Producer a m (Producer a m x))
group = groupBy (==)
{-# INLINABLE group #-}
toParser :: Monad m => Consumer (Maybe a) m r -> Parser a m r
toParser consumer = runEffect (lift draw >~ unsafeHoist lift consumer)
{-# INLINABLE toParser #-}
toParser_ :: Monad m => Consumer a m X -> Parser a m ()
toParser_ consumer = StateT $ \producer -> do
r <- runEffect (producer >-> fmap closed consumer)
return ((), return r)
{-# INLINABLE toParser_ #-}
parsed
:: Monad m
=> Parser a m (Either e b)
-> Producer a m r -> Producer b m (e, Producer a m r)
parsed parser = go
where
go p = do
(x, p') <- lift (runStateT parser p)
case x of
Left r -> return (r, p')
Right b -> do
yield b
go p'
{-# INLINABLE parsed #-}
parsed_
:: Monad m
=> Parser a m (Maybe b)
-> Producer a m r
-> Producer b m (Producer a m r)
parsed_ parser p = do
((), p') <- parsed parser' p
return p'
where
parser' = do
x <- parser
return (case x of
Nothing -> Left ()
Just b -> Right b )
{-# INLINABLE parsed_ #-}
parseForever ::
Monad m =>
(forall n. Monad n => Parser a n (Either r b)) ->
Pipe a b m r
parseForever parse = go (forever (lift await >>= yield))
where go prod = do (b, prod') <- runStateT parse prod
either return ((>> go prod') . yield) b
{-# DEPRECATED parseForever "Use `parsed` instead" #-}
parseForever_ ::
Monad m =>
(forall n. Monad n => Parser a n (Maybe b)) ->
Pipe a b m ()
parseForever_ parse = parseForever (liftM (maybe (Left ()) Right) parse)
{-# DEPRECATED parseForever_ "Use `parsed_` instead" #-}