]>
Commit | Line | Data |
---|---|---|
1 | -- | Parsing utilities for characterstrings, in the style of @pipes-parse@ | |
2 | ||
3 | module Data.Text.Pipes.Parse ( | |
4 | -- * Parsers | |
5 | nextChar, | |
6 | drawChar, | |
7 | unDrawChar, | |
8 | peekChar, | |
9 | isEndOfChars, | |
10 | take, | |
11 | takeWhile | |
12 | ) where | |
13 | ||
14 | import Control.Monad.Trans.State.Strict (StateT, modify) | |
15 | import qualified Data.Text as T | |
16 | import Data.Text (Text) | |
17 | ||
18 | import Pipes | |
19 | import qualified Pipes.Parse as PP | |
20 | ||
21 | import Prelude hiding (take, takeWhile) | |
22 | ||
23 | {-| Consume the first character from a 'Text' stream | |
24 | ||
25 | 'next' either fails with a 'Left' if the 'Producer' has no more characters or | |
26 | succeeds with a 'Right' providing the next byte and the remainder of the | |
27 | 'Producer'. | |
28 | -} | |
29 | nextChar | |
30 | :: (Monad m) | |
31 | => Producer Text m r | |
32 | -> m (Either r (Char, Producer Text m r)) | |
33 | nextChar = go | |
34 | where | |
35 | go p = do | |
36 | x <- next p | |
37 | case x of | |
38 | Left r -> return (Left r) | |
39 | Right (txt, p') -> case (T.uncons txt) of | |
40 | Nothing -> go p' | |
41 | Just (c, txt') -> return (Right (c, yield txt' >> p')) | |
42 | {-# INLINABLE nextChar #-} | |
43 | ||
44 | {-| Draw one 'Char' from the underlying 'Producer', returning 'Left' if the | |
45 | 'Producer' is empty | |
46 | -} | |
47 | drawChar :: (Monad m) => StateT (Producer Text m r) m (Either r Char) | |
48 | drawChar = do | |
49 | x <- PP.draw | |
50 | case x of | |
51 | Left r -> return (Left r) | |
52 | Right txt -> case (T.uncons txt) of | |
53 | Nothing -> drawChar | |
54 | Just (c, txt') -> do | |
55 | PP.unDraw txt' | |
56 | return (Right c) | |
57 | {-# INLINABLE drawChar #-} | |
58 | ||
59 | -- | Push back a 'Char' onto the underlying 'Producer' | |
60 | unDrawChar :: (Monad m) => Char -> StateT (Producer Text m r) m () | |
61 | unDrawChar c = modify (yield (T.singleton c) >>) | |
62 | {-# INLINABLE unDrawChar #-} | |
63 | ||
64 | {-| 'peekChar' checks the first 'Char' in the stream, but uses 'unDrawChar' to | |
65 | push the 'Char' back | |
66 | ||
67 | > peekChar = do | |
68 | > x <- drawChar | |
69 | > case x of | |
70 | > Left _ -> return () | |
71 | > Right c -> unDrawChar c | |
72 | > return x | |
73 | -} | |
74 | peekChar :: (Monad m) => StateT (Producer Text m r) m (Either r Char) | |
75 | peekChar = do | |
76 | x <- drawChar | |
77 | case x of | |
78 | Left _ -> return () | |
79 | Right c -> unDrawChar c | |
80 | return x | |
81 | {-# INLINABLE peekChar #-} | |
82 | ||
83 | {-| Check if the underlying 'Producer' has no more characters | |
84 | ||
85 | Note that this will skip over empty 'Text' chunks, unlike | |
86 | 'PP.isEndOfInput' from @pipes-parse@. | |
87 | ||
88 | > isEndOfChars = liftM isLeft peekChar | |
89 | -} | |
90 | isEndOfChars :: (Monad m) => StateT (Producer Text m r) m Bool | |
91 | isEndOfChars = do | |
92 | x <- peekChar | |
93 | return (case x of | |
94 | Left _ -> True | |
95 | Right _ -> False ) | |
96 | {-# INLINABLE isEndOfChars #-} | |
97 | ||
98 | {-| @(take n)@ only allows @n@ characters to pass | |
99 | ||
100 | Unlike 'take', this 'PP.unDraw's unused characters | |
101 | -} | |
102 | take :: (Monad m, Integral a) => a -> Pipe Text Text (StateT (Producer Text m r) m) () | |
103 | take n0 = go n0 where | |
104 | go n | |
105 | | n <= 0 = return () | |
106 | | otherwise = do | |
107 | txt <- await | |
108 | let len = fromIntegral (T.length txt) | |
109 | if (len > n) | |
110 | then do | |
111 | let n' = fromIntegral n | |
112 | lift . PP.unDraw $ T.drop n' txt | |
113 | yield $ T.take n' txt | |
114 | else do | |
115 | yield txt | |
116 | go (n - len) | |
117 | {-# INLINABLE take #-} | |
118 | ||
119 | {-| Take characters until they fail the predicate | |
120 | ||
121 | Unlike 'takeWhile', this 'PP.unDraw's unused characters | |
122 | -} | |
123 | takeWhile | |
124 | :: (Monad m) | |
125 | => (Char -> Bool) | |
126 | -> Pipe Text Text (StateT (Producer Text m r) m) () | |
127 | takeWhile predicate = go | |
128 | where | |
129 | go = do | |
130 | txt <- await | |
131 | let (prefix, suffix) = T.span predicate txt | |
132 | if (T.null suffix) | |
133 | then do | |
134 | yield txt | |
135 | go | |
136 | else do | |
137 | lift $ PP.unDraw suffix | |
138 | yield prefix | |
139 | {-# INLINABLE takeWhile #-} |