aboutsummaryrefslogtreecommitdiffhomepage
path: root/Pipes/Text/Parse.hs
blob: 8c3a13e48ebab50f9b7c9177395b6cfb5eb800dc (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
-- | Parsing utilities for characterstrings, in the style of @pipes-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 byte 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 'Left' if the
    'Producer' is empty
-}
drawChar :: (Monad m) => StateT (Producer Text m r) m (Either r Char)
drawChar = do
    x <- PP.draw
    case x of
        Left  r  -> return (Left r)
        Right txt -> case (T.uncons txt) of
            Nothing        -> drawChar
            Just (c, txt') -> do
                PP.unDraw txt'
                return (Right 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 (Either r Char)
peekChar = do
    x <- drawChar
    case x of
        Left  _  -> return ()
        Right 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
        Left  _ -> True
        Right _ -> 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 #-}