@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12-----------------------------------------------------------------------------
23-- |
34-- Module : Text.ParserCombinators.ByteStringParser
@@ -11,219 +12,261 @@
1112-- Primitive parser combinators for ByteStrings loosely based on Parsec.
1213--
1314-----------------------------------------------------------------------------
14−module Text.ParserCombinators.ByteStringParser where
15−
16−import Data.Char
17−import Control.Monad
15+module Text.ParserCombinators.ByteStringParser
16+ (
17+ -- * Parser
18+ ParseError
19+ , Parser
20+
21+ -- * Running parsers
22+ , parse
23+ , parseTest
24+
25+ -- * Combinators
26+ , succeed
27+ , (<|>)
28+ , (<?>)
29+
30+ -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
31+ , try
32+ , many
33+ , many1
34+ , manyTill
35+ , eof
36+ , skipMany
37+ , skipMany1
38+
39+ -- * Things like in @Parsec.Char@
40+ , satisfy
41+ , letter
42+ , digit
43+ , anyChar
44+ , space
45+ , char
46+ , string
47+
48+ -- * Miscellaneous functions.
49+ , getInput
50+ , getConsumed
51+ , takeWhile
52+ , skipWhile
53+ ) where
54+
55+#ifdef APPLICATIVE_IN_BASE
56+import Control.Applicative (Applicative(..))
57+#endif
58+
59+import Control.Monad (MonadPlus(..), ap)
1860import qualified Data.ByteString.Lazy.Char8 as C
61+import Data.Char (isDigit, isLetter, isSpace)
62+import Data.Int (Int64)
63+import Prelude hiding (takeWhile)
1964
20−-- * Parser
21−
22−type ParserError state = (state, String)
65+type ParseError = (C.ByteString, String)
2366
2467-- * Parser Monad
2568
26−newtype Parser state a = Parser { unParser :: (state -> Either (state,[String]) (a, state)) }
69+data S = S C.ByteString
70+ {-# UNPACK #-} !Int64
2771
28−type CharParser = Parser C.ByteString Char
72+newtype Parser a = Parser {
73+ unParser :: S -> Either (C.ByteString, [String]) (a, S)
74+ }
2975
30−instance Functor (Parser state) where
31− fmap f (Parser p) =
32− Parser $ \st ->
33− case p st of
34− Right (a, st') -> Right (f a, st')
76+instance Functor Parser where
77+ fmap f p =
78+ Parser $ \s ->
79+ case unParser p s of
80+ Right (a, s') -> Right (f a, s')
3581 Left err -> Left err
3682
37−instance Monad (Parser state) where
38− return a = Parser (\s -> Right (a,s))
39− m >>= f =
40− Parser $ \state ->
41− let r = (unParser m) state in
42− case r of
43− Right (a,state') -> unParser (f a) $ state'
44− (Left (st, msgs)) -> (Left (st, msgs))
45−
46−instance MonadPlus (Parser state) where
47− mzero = Parser (\st -> (Left (st, [])))
48− mplus (Parser p1) (Parser p2) =
49− Parser (\s -> case p1 s of
50− (Left (_, msgs1)) ->
83+instance Monad Parser where
84+ return a = Parser $ \s -> Right (a, s)
85+ m >>= f = Parser $ \s ->
86+ case unParser m s of
87+ Right (a, s') -> unParser (f a) s'
88+ Left (s', msgs) -> Left (s', msgs)
89+ fail err = Parser $ \(S bs _) -> Left (bs, [err])
90+
91+instance MonadPlus Parser where
92+ mzero = Parser $ \(S bs _) -> Left (bs, [])
93+ Parser p1 `mplus` Parser p2 =
94+ Parser $ \s@(S bs _) -> case p1 s of
95+ Left (_, msgs1) ->
5196 case p2 s of
52− Left (_, msgs2) -> Left (s, (msgs1 ++ msgs2))
53− o -> o
54− o -> o
55− )
56−
57−-- |Always succeed
58−succeed :: a -> Parser state a
97+ Left (_, msgs2) -> Left (bs, (msgs1 ++ msgs2))
98+ ok -> ok
99+ ok -> ok
100+
101+#ifdef APPLICATIVE_IN_BASE
102+instance Applicative Parser where
103+ pure = return
104+ (<*>) = ap
105+#endif
106+
107+-- | Always succeed.
108+succeed :: a -> Parser a
59109succeed = return
60110
61−-- |Always fail
62−fail :: Parser state a
63−fail = Parser (\st -> Left (st, []))
64−
65111infix 0 <?>
66112infixr 1 <|>
67113
68−-- |choice
69−(<|>) :: Parser state a -> Parser state a -> Parser state a
114+-- | Choice.
115+(<|>) :: Parser a -> Parser a -> Parser a
70116(<|>) = mplus
71117
72−-- |name the parser
73−(<?>) :: Parser state a -> String -> Parser state a
118+-- | Name the parser.
119+(<?>) :: Parser a -> String -> Parser a
74120p <?> msg =
75− Parser $ \st ->
76− case (unParser p) st of
77− (Left _) -> Left (st, [msg])
121+ Parser $ \s@(S bs _) ->
122+ case unParser p s of
123+ (Left _) -> Left (bs, [msg])
78124 ok -> ok
79125
80−-- |get remaining input
81−getInput :: Parser C.ByteString C.ByteString
82−getInput = Parser (\st -> Right (st,st))
83−
126+-- | Get remaining input.
127+getInput :: Parser C.ByteString
128+getInput = Parser $ \s@(S bs _) -> Right (bs, s)
84129
85−-- * Things like in @Parsec.Char@
130+-- | Get remaining input.
131+getConsumed :: Parser Int64
132+getConsumed = Parser $ \s@(S _ n) -> Right (n, s)
86133
87−{-# INLINE satisfy #-}
88−
89−-- |character parser
90−satisfy :: (Char -> Bool) -> CharParser
91134
135+-- | Character parser.
136+satisfy :: (Char -> Bool) -> Parser Char
92137satisfy f =
93− Parser $ \bs ->
138+ Parser $ \(S bs n) ->
94139 if C.null bs
95140 then Left (bs, [])
96− else let (s,ss) = (C.head bs, C.tail bs) in
97− if (f s)
98− then Right (s,ss)
141+ else let Just (s, bs') = C.uncons bs in
142+ if f s
143+ then Right (s, S bs' (n + 1))
99144 else Left (bs, [])
145+{-# INLINE satisfy #-}
100146
101−letter :: CharParser
102147
148+letter :: Parser Char
103149letter = satisfy isLetter
150+{-# INLINE letter #-}
104151
105−digit :: CharParser
106−
152+digit :: Parser Char
107153digit = satisfy isDigit
154+{-# INLINE digit #-}
108155
109−anyChar :: CharParser
110−
156+anyChar :: Parser Char
111157anyChar = satisfy $ const True
158+{-# INLINE anyChar #-}
112159
113−space :: CharParser
114−
160+space :: Parser Char
115161space = satisfy isSpace
162+{-# INLINE space #-}
116163
117−-- |satisfy a specific character
118−
119−char :: Char -> CharParser
164+-- | Satisfy a specific character.
120165
166+char :: Char -> Parser Char
121167char c = satisfy (== c) <?> [c]
168+{-# INLINE char #-}
122169
123−string :: String -> Parser C.ByteString String
124−
125−string s = mapM char s
126− <?> show s
127−
128−count :: Int -> Parser st a -> Parser st [a]
170+string :: String -> Parser String
171+string s = mapM char s <?> show s
172+{-# INLINE string #-}
129173
174+count :: Int -> Parser a -> Parser [a]
130175count n p = sequence (replicate n p)
176+{-# INLINE count #-}
131177
132−-- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
133−
134−try :: Parser st a -> Parser st a
135−
136−try (Parser p)
137− = Parser $ \state -> case p state of
138− (Left (_, msgs)) -> Left (state, msgs)
139− ok -> ok
178+try :: Parser a -> Parser a
179+try p = Parser $ \s@(S bs _) ->
180+ case unParser p s of
181+ Left (_, msgs) -> Left (bs, msgs)
182+ ok -> ok
140183
141−-- |detect 'end of file'
142−eof :: Parser C.ByteString ()
143−eof =
144− Parser $ \bs -> if C.null bs then Right ((),bs) else (Left (bs, ["EOF"]))
184+-- | Detect 'end of file'.
185+eof :: Parser ()
186+eof = Parser $ \s@(S bs _) -> if C.null bs
187+ then Right ((), s)
188+ else Left (bs, ["EOF"])
145189
146−-- |takeWhile take characters while the predicate is true
147−takeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString
148−takeWhile f =
149− Parser $ \bs -> Right (C.span f bs)
190+-- | Consume characters while the predicate is true.
191+takeWhile :: (Char -> Bool) -> Parser C.ByteString
192+takeWhile f = Parser $ \(S bs n) ->
193+ let (h, bs') = C.span f bs
194+ in Right (h, S bs' (n + C.length h))
150195
151−-- |skipWhile skip over characters while the predicate is true
152−skipWhile :: (Char -> Bool) -> Parser C.ByteString ()
153−skipWhile p =
154− Parser $ \bs -> Right ((), C.dropWhile p bs)
196+-- | Skip over characters while the predicate is true.
197+skipWhile :: (Char -> Bool) -> Parser ()
198+skipWhile p = takeWhile p >> return ()
155199
156−-- |'many' - take zero or more instances of the parser
157−many :: Parser st a -> Parser st [a]
200+-- | Take zero or more instances of the parser.
201+many :: Parser a -> Parser [a]
158202many p = scan id
159203 where scan f = do x <- p
160− scan (\xs -> f (x:xs))
204+ scan (f . (x:))
161205 <|> return (f [])
162206
163−-- |'many1' - take one or more instances of the parser
164−many1 :: Parser st a -> Parser st [a]
207+-- | Take one or more instances of the parser.
208+many1 :: Parser a -> Parser [a]
165209many1 p =
166210 do x <- p
167211 xs <- many p
168212 return (x:xs)
169213
170−manyTill :: Parser st a -> Parser st end -> Parser st [a]
214+manyTill :: Parser a -> Parser b -> Parser [a]
171215manyTill p end = scan
172− where scan = do end
173− return []
216+ where scan = do end; return []
174217 <|>
175218 do x <- p
176219 xs <- scan
177220 return (x:xs)
178221
179222-- |'skipMany' - skip zero or many instances of the parser
180−skipMany :: Parser st a -> Parser st ()
223+skipMany :: Parser a -> Parser ()
181224skipMany p = scan
182225 where
183226 scan = (p >> scan) <|> return ()
184227
185228-- |'skipMany1' - skip one or many instances of the parser
186−skipMany1 :: Parser st a -> Parser st ()
229+skipMany1 :: Parser a -> Parser ()
187230skipMany1 p = p >> skipMany p
188231
189−-- |'notEmpty' - tests that a parser returned a non-null ByteString
190−notEmpty :: Parser C.ByteString C.ByteString -> Parser C.ByteString C.ByteString
191−notEmpty (Parser p) =
192− Parser $ \s -> case p s of
193− o@(Right (a, _)) ->
194− if C.null a
195− then Left (a, ["notEmpty"])
196− else o
197− x -> x
198−
199−-- | parse some input with the given parser and return that input without copying it
200−match :: Parser C.ByteString a -> Parser C.ByteString C.ByteString
201−match p = do start <- getInput
232+-- | Test that a parser returned a non-null ByteString.
233+notEmpty :: Parser C.ByteString -> Parser C.ByteString
234+notEmpty p = Parser $ \s ->
235+ case unParser p s of
236+ o@(Right (a, _)) ->
237+ if C.null a
238+ then Left (a, ["notEmpty"])
239+ else o
240+ x -> x
241+
242+-- | Parse some input with the given parser and return that input
243+-- without copying it.
244+match :: Parser a -> Parser C.ByteString
245+match p = do bs <- getInput
246+ start <- getConsumed
202247 p
203− end <- getInput
204− return (C.take (C.length start - C.length end) start)
205−
206−lookAhead :: Parser C.ByteString a -> Parser C.ByteString a
207−
208−lookAhead (Parser p)
209− = Parser $ \state -> case p state of
210− Left (_, msgs) -> Left (state, msgs)
211− Right (m, _) -> Right (m, state)
212−
213−-- * Running parsers
214−
215−-- |'parse' - run a parser
216−parse :: Parser state a -> state -> Either (ParserError state) (a, state)
217−parse p s =
218− case ((unParser p) s) of
219− Left (st, msg) -> Left (st, showError msg)
220− (Right r) -> (Right r)
248+ end <- getConsumed
249+ return (C.take (end - start) bs)
250+
251+lookAhead :: Parser a -> Parser a
252+
253+lookAhead p = Parser $ \s@(S bs _) ->
254+ case unParser p s of
255+ Left (_, msgs) -> Left (bs, msgs)
256+ Right (m, _) -> Right (m, s)
257+
258+-- | Run a parser.
259+parse :: Parser a -> C.ByteString
260+ -> Either ParseError (a, C.ByteString)
261+parse p bs =
262+ case unParser p (S bs 0) of
263+ Left (bs', msg) -> Left (bs', showError msg)
264+ Right (a, S bs' _) -> Right (a, bs')
221265 where
222266 showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
223267 showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
224268
225−parseTest :: (Show st, Show a) => Parser st a -> st -> IO ()
226−
269+parseTest :: (Show a) => Parser a -> C.ByteString -> IO ()
227270parseTest p s =
228271 case parse p s of
229272 Left (st, msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st