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 #-}
|
