{-# LANGUAGE RankNTypes #-}
module Pipes.Parse (
Parser
, draw
, skip
, drawAll
, skipAll
, unDraw
, peek
, isEndOfInput
, foldAll
, foldAllM
, span
, splitAt
, groupBy
, group
, toParser
, toParser_
, module Control.Monad.Trans.Class
, module Control.Monad.Trans.State.Strict
, module Pipes
) where
import Control.Monad (join)
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 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)
skip :: Monad m => Parser a m Bool
skip = do
x <- draw
return $ case x of
Nothing -> False
Just _ -> True
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:))
skipAll :: Monad m => Parser a m ()
skipAll = go
where
go = do
x <- draw
case x of
Nothing -> return ()
Just _ -> go
unDraw :: Monad m => a -> Parser a m ()
unDraw a = S.modify (yield a >>)
peek :: Monad m => Parser a m (Maybe a)
peek = do
x <- draw
case x of
Nothing -> return ()
Just a -> unDraw a
return x
isEndOfInput :: Monad m => Parser a m Bool
isEndOfInput = do
x <- peek
return (case x of
Nothing -> True
Just _ -> False )
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
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'
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')
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'
(^.) :: 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)
group
:: (Monad m, Eq a) => Lens' (Producer a m x) (Producer a m (Producer a m x))
group = groupBy (==)
toParser :: Monad m => Consumer (Maybe a) m r -> Parser a m r
toParser consumer = runEffect (lift draw >~ unsafeHoist lift consumer)
toParser_ :: Monad m => Consumer a m X -> Parser a m ()
toParser_ consumer = StateT $ \producer -> do
r <- runEffect (producer >-> fmap closed consumer)
return ((), return r)