lensification under way

[github/fretlink/text-pipes.git] / Pipes / Text / Parse.hs

-- | Parsing utilities for texts, in the style of @pipes-parse@ and @Pipes.ByteString.Parse@

module Pipes.Text.Parse (
    -- * Parsers
    nextChar,
    drawChar,
    unDrawChar,
    peekChar,
    isEndOfChars,
    take,
    takeWhile
    ) where

import Control.Monad.Trans.State.Strict (StateT, modify)
import qualified Data.Text as T
import Data.Text (Text)

import Pipes
import qualified Pipes.Parse as PP

import Prelude hiding (take, takeWhile)

{-| Consume the first character from a 'Text' stream

    'next' either fails with a 'Left' if the 'Producer' has no more characters or
    succeeds with a 'Right' providing the next character and the remainder of the
    'Producer'.
-}
nextChar
    :: (Monad m)
    => Producer Text m r
    -> m (Either r (Char, Producer Text m r))
nextChar = go
  where
    go p = do
        x <- next p
        case x of
            Left   r       -> return (Left r)
            Right (txt, p') -> case (T.uncons txt) of
                Nothing        -> go p'
                Just (c, txt') -> return (Right (c, yield txt' >> p'))
{-# INLINABLE nextChar #-}

{-| Draw one 'Char' from the underlying 'Producer', returning 'Nothing' if the
    'Producer' is empty
-}
drawChar :: (Monad m) => StateT (Producer Text m r) m (Maybe Char)
drawChar = do
    x <- PP.draw
    case x of
        Nothing  -> return Nothing
        Just txt -> case (T.uncons txt) of
            Nothing        -> drawChar
            Just (c, txt') -> do
                PP.unDraw txt'
                return (Just c)
{-# INLINABLE drawChar #-}

-- | Push back a 'Char' onto the underlying 'Producer'
unDrawChar :: (Monad m) => Char -> StateT (Producer Text m r) m ()
unDrawChar c = modify (yield (T.singleton c) >>)
{-# INLINABLE unDrawChar #-}

{-| 'peekChar' checks the first 'Char' in the stream, but uses 'unDrawChar' to
    push the 'Char' back

> peekChar = do
>     x <- drawChar
>     case x of
>         Left  _  -> return ()
>         Right c -> unDrawChar c
>     return x
-}
peekChar :: (Monad m) => StateT (Producer Text m r) m (Maybe Char)
peekChar = do
    x <- drawChar
    case x of
        Nothing  -> return ()
        Just c -> unDrawChar c
    return x
{-# INLINABLE peekChar #-}

{-| Check if the underlying 'Producer' has no more characters

    Note that this will skip over empty 'Text' chunks, unlike
    'PP.isEndOfInput' from @pipes-parse@.

> isEndOfChars = liftM isLeft peekChar
-}
isEndOfChars :: (Monad m) => StateT (Producer Text m r) m Bool
isEndOfChars = do
    x <- peekChar
    return (case x of
        Nothing -> True
        Just _-> False )
{-# INLINABLE isEndOfChars #-}

{-| @(take n)@ only allows @n@ characters to pass

    Unlike 'take', this 'PP.unDraw's unused characters
-}
take :: (Monad m, Integral a) => a -> Pipe Text Text (StateT (Producer Text m r) m) ()
take n0 = go n0 where
    go n
        | n <= 0 = return ()
        | otherwise = do
            txt <- await
            let len = fromIntegral (T.length txt)
            if (len > n)
                then do
                    let n' = fromIntegral n
                    lift . PP.unDraw $ T.drop n' txt
                    yield $ T.take n' txt
                else do
                    yield txt
                    go (n - len)
{-# INLINABLE take #-}

{-| Take characters until they fail the predicate

    Unlike 'takeWhile', this 'PP.unDraw's unused characters
-}
takeWhile
    :: (Monad m)
    => (Char -> Bool)
    -> Pipe Text Text (StateT (Producer Text m r) m) ()
takeWhile predicate = go
  where
    go = do
        txt <- await
        let (prefix, suffix) = T.span predicate txt
        if (T.null suffix)
            then do
                yield txt
                go
            else do
                lift $ PP.unDraw suffix
                yield prefix
{-# INLINABLE takeWhile #-}