@@ -40,14 +40,11 @@ module Data.ParserCombinators.ByteStringParser
4040
4141 -- * Things like in @Parsec.Char@
4242 , satisfy
43− , letter
44− , digit
45− , anyChar
46− , space
47− , char
48− , notChar
43+ , anyWord8
44+ , word8
45+ , notWord8
4946 , string
50− , stringCI
47+ , stringTransform
5148
5249 -- * Parser converters.
5350 , eitherP
@@ -60,334 +57,9 @@ module Data.ParserCombinators.ByteStringParser
6057 , takeTill
6158 , takeAll
6259 , skipWhile
63− , skipSpace
6460 , notEmpty
6561 , match
66− , inClass
67− , notInClass
6862 ) where
6963
70−import Control.Applicative
71− (Alternative(..), Applicative(..), (<$>), (<*), (*>))
72−import Control.Monad (MonadPlus(..), ap, liftM2)
73−import Control.Monad.Fix (MonadFix(..))
74−import qualified Data.ByteString.Char8 as SB
75−import qualified Data.ByteString.Lazy.Char8 as LB
76−import qualified Data.ByteString.Lazy.Internal as LB
77−import Data.Char (isDigit, isLetter, isSpace, toLower)
78−import Data.Int (Int64)
79−import Data.ParserCombinators.ByteStringParser.FastSet
80− (FastSet, memberChar, set)
64+import Data.ParserCombinators.ByteStringParser.Internal
8165import Prelude hiding (takeWhile)
82−
83−type ParseError = String
84−
85−data S = S {-# UNPACK #-} !SB.ByteString
86− LB.ByteString
87− {-# UNPACK #-} !Int64
88−
89−newtype Parser a = Parser {
90− unParser :: S -> Either (LB.ByteString, [String]) (a, S)
91− }
92−
93−instance Functor Parser where
94− fmap f p =
95− Parser $ \s ->
96− case unParser p s of
97− Right (a, s') -> Right (f a, s')
98− Left err -> Left err
99−
100−instance Monad Parser where
101− return a = Parser $ \s -> Right (a, s)
102− m >>= f = Parser $ \s ->
103− case unParser m s of
104− Right (a, s') -> unParser (f a) s'
105− Left (s', msgs) -> Left (s', msgs)
106− fail err = Parser $ \(S sb lb _) -> Left (sb +: lb, [err])
107−
108−instance MonadFix Parser where
109− mfix f = Parser $ \s ->
110− let r = case r of
111− Right (a, _) -> unParser (f a) s
112− err -> err
113− in r
114−
115−zero :: Parser a
116−zero = Parser $ \(S sb lb _) -> Left (sb +: lb, [])
117−{-# INLINE zero #-}
118−
119−plus :: Parser a -> Parser a -> Parser a
120−plus p1 p2 =
121− Parser $ \s@(S sb lb _) ->
122− case unParser p1 s of
123− Left (_, msgs1) ->
124− case unParser p2 s of
125− Left (_, msgs2) -> Left (sb +: lb, (msgs1 ++ msgs2))
126− ok -> ok
127− ok -> ok
128−{-# INLINE plus #-}
129−
130−instance MonadPlus Parser where
131− mzero = zero
132− mplus = plus
133−
134−instance Applicative Parser where
135− pure = return
136− (<*>) = ap
137−
138−instance Alternative Parser where
139− empty = zero
140− (<|>) = plus
141−
142−mkState :: LB.ByteString -> Int64 -> S
143−mkState s = case s of
144− LB.Empty -> S SB.empty s
145− LB.Chunk x xs -> S x xs
146−
147−-- | Turn our chunked representation back into a normal lazy
148−-- ByteString.
149−(+:) :: SB.ByteString -> LB.ByteString -> LB.ByteString
150−sb +: lb | SB.null sb = lb
151− | otherwise = LB.Chunk sb lb
152−{-# INLINE (+:) #-}
153−
154−infix 0 <?>
155−
156−-- | Name the parser.
157−(<?>) :: Parser a -> String -> Parser a
158−p <?> msg =
159− Parser $ \s@(S sb lb _) ->
160− case unParser p s of
161− (Left _) -> Left (sb +: lb, [msg])
162− ok -> ok
163−{-# INLINE (<?>) #-}
164−
165−nextChunk :: Parser ()
166−nextChunk = Parser $ \(S _ lb n) ->
167− case lb of
168− LB.Chunk sb' lb' -> Right ((), S sb' lb' n)
169− LB.Empty -> Left (lb, [])
170−
171−-- | Get remaining input.
172−getInput :: Parser LB.ByteString
173−getInput = Parser $ \s@(S sb lb _) -> Right (sb +: lb, s)
174−
175−-- | Get number of bytes consumed so far.
176−getConsumed :: Parser Int64
177−getConsumed = Parser $ \s@(S _ _ n) -> Right (n, s)
178−
179−-- | Character parser.
180−satisfy :: (Char -> Bool) -> Parser Char
181−satisfy p =
182− Parser $ \s@(S sb lb n) ->
183− case SB.uncons sb of
184− Just (c, sb') | p c -> Right (c, S sb' lb (n + 1))
185− | otherwise -> Left (sb +: lb, [])
186− Nothing -> unParser (nextChunk >> satisfy p) s
187−{-# INLINE satisfy #-}
188−
189−letter :: Parser Char
190−letter = satisfy isLetter <?> "letter"
191−{-# INLINE letter #-}
192−
193−digit :: Parser Char
194−digit = satisfy isDigit <?> "digit"
195−{-# INLINE digit #-}
196−
197−anyChar :: Parser Char
198−anyChar = satisfy $ const True
199−{-# INLINE anyChar #-}
200−
201−space :: Parser Char
202−space = satisfy isSpace <?> "space"
203−{-# INLINE space #-}
204−
205−-- | Satisfy a specific character.
206−char :: Char -> Parser Char
207−char c = satisfy (== c) <?> [c]
208−{-# INLINE char #-}
209−
210−-- | Satisfy a specific character.
211−notChar :: Char -> Parser Char
212−notChar c = satisfy (/= c) <?> "not " ++ [c]
213−{-# INLINE notChar #-}
214−
215−charClass :: String -> FastSet
216−charClass = set . SB.pack . go
217− where go (a:'-':b:xs) = [a..b] ++ go xs
218− go (x:xs) = x : go xs
219− go _ = ""
220−
221−inClass :: String -> Char -> Bool
222−inClass s = (`memberChar` myset)
223− where myset = charClass s
224−{-# INLINE inClass #-}
225−
226−notInClass :: String -> Char -> Bool
227−notInClass s = not . inClass s
228−{-# INLINE notInClass #-}
229−
230−sepBy :: Parser a -> Parser s -> Parser [a]
231−sepBy p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return []) <|> return []
232−
233−sepBy1 :: Parser a -> Parser s -> Parser [a]
234−sepBy1 p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return [])
235−
236−-- | Satisfy a literal string.
237−string :: LB.ByteString -> Parser LB.ByteString
238−string s = Parser $ \(S sb lb n) ->
239− let bs = sb +: lb
240− l = LB.length s
241− (h, t) = LB.splitAt l bs
242− in if s == h
243− then Right (s, mkState t (n + l))
244− else Left (bs, [])
245−{-# INLINE string #-}
246−
247−-- | Satisfy a literal string, ignoring case.
248−stringCI :: LB.ByteString -> Parser LB.ByteString
249−stringCI s = Parser $ \(S sb lb n) ->
250− let bs = sb +: lb
251− l = LB.length s
252− (h, t) = LB.splitAt l bs
253− in if ls == LB.map toLower h
254− then Right (s, mkState t (n + l))
255− else Left (bs, [])
256− where ls = LB.map toLower s
257−{-# INLINE stringCI #-}
258−
259−-- | Apply the given parser repeatedly, returning every parse result.
260−count :: Int -> Parser a -> Parser [a]
261−count n p = sequence (replicate n p)
262−{-# INLINE count #-}
263−
264−try :: Parser a -> Parser a
265−try p = Parser $ \s@(S sb lb _) ->
266− case unParser p s of
267− Left (_, msgs) -> Left (sb +: lb, msgs)
268− ok -> ok
269−
270−-- | Detect 'end of file'.
271−eof :: Parser ()
272−eof = Parser $ \s@(S sb lb _) -> if SB.null sb && LB.null lb
273− then Right ((), s)
274− else Left (sb +: lb, ["EOF"])
275−
276−takeAll :: Parser LB.ByteString
277−takeAll = Parser $ \(S sb lb n) ->
278− let bs = sb +: lb
279− in Right (bs, mkState LB.empty (n + LB.length bs))
280−
281−oneChunk :: SB.ByteString -> LB.ByteString
282−oneChunk s = LB.Chunk s LB.Empty
283−
284−length64 :: SB.ByteString -> Int64
285−length64 = fromIntegral . SB.length
286−
287−-- | Consume characters while the predicate is true.
288−takeWhile :: (Char -> Bool) -> Parser LB.ByteString
289−takeWhile p = Parser $ \s@(S sb lb n) ->
290− let (h, t) = SB.span p sb
291− in if SB.null t
292− then unParser ((h +:) <$> (nextChunk *> takeWhile p)) s
293− else Right (oneChunk h, S t lb (n + length64 h))
294−{-# INLINE takeWhile #-}
295−
296−takeTill :: (Char -> Bool) -> Parser LB.ByteString
297−takeTill p = takeWhile (not . p) <* satisfy p
298−{-# INLINE takeTill #-}
299−
300−takeWhile1 :: (Char -> Bool) -> Parser LB.ByteString
301−takeWhile1 p = Parser $ \s@(S sb lb n) ->
302− let (h, t) = SB.span p sb
303− in if SB.null t
304− then case unParser (nextChunk *> takeWhile p) s of
305− Left err -> Left err
306− Right (xs, s') ->
307− let bs = h +: xs
308− in if LB.null bs
309− then Left (sb +: lb, [])
310− else Right (bs, s')
311− else Right (oneChunk h, S t lb (n + length64 h))
312−{-# INLINE takeWhile1 #-}
313−
314−-- | Skip over characters while the predicate is true.
315−skipWhile :: (Char -> Bool) -> Parser ()
316−skipWhile p = takeWhile p >> return ()
317−{-# INLINE skipWhile #-}
318−
319−-- | Skip over white space.
320−skipSpace :: Parser ()
321−skipSpace = takeWhile isSpace >> return ()
322−{-# INLINE skipSpace #-}
323−
324−manyTill :: Parser a -> Parser b -> Parser [a]
325−manyTill p end = scan
326− where scan = (end >> return []) <|> liftM2 (:) p scan
327−
328−-- |'skipMany' - skip zero or many instances of the parser
329−skipMany :: Parser a -> Parser ()
330−skipMany p = scan
331− where scan = (p >> scan) <|> return ()
332−
333−-- |'skipMany1' - skip one or many instances of the parser
334−skipMany1 :: Parser a -> Parser ()
335−skipMany1 p = p >> skipMany p
336−
337−-- | Test that a parser returned a non-null ByteString.
338−notEmpty :: Parser LB.ByteString -> Parser LB.ByteString
339−notEmpty p = Parser $ \s ->
340− case unParser p s of
341− o@(Right (a, _)) ->
342− if LB.null a
343− then Left (a, ["notEmpty"])
344− else o
345− x -> x
346−
347−-- | Parse some input with the given parser and return that input
348−-- without copying it.
349−match :: Parser a -> Parser LB.ByteString
350−match p = do bs <- getInput
351− start <- getConsumed
352− p
353− end <- getConsumed
354− return (LB.take (end - start) bs)
355−
356−eitherP :: Parser a -> Parser b -> Parser (Either a b)
357−eitherP a b = (Left <$> a) <|> (Right <$> b)
358−{-# INLINE eitherP #-}
359−
360−peek :: Parser a -> Parser (Maybe a)
361−peek p = Parser $ \s ->
362− case unParser p s of
363− Right (m, _) -> Right (Just m, s)
364− _ -> Right (Nothing, s)
365−
366−lookAhead :: Parser a -> Parser a
367−lookAhead p = Parser $ \s ->
368− case unParser p s of
369− Right (m, _) -> Right (m, s)
370− Left (e, bs) -> Left (e, bs)
371−
372−parseAt :: Parser a -> LB.ByteString -> Int64
373− -> (LB.ByteString, Either ParseError (a, Int64))
374−parseAt p bs n =
375− case unParser p (mkState bs n) of
376− Left (bs', msg) -> (bs', Left $ showError msg)
377− Right (a, S sb lb n') -> (sb +: lb, Right (a, n'))
378− where
379− showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
380− showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
381−
382−-- | Run a parser.
383−parse :: Parser a -> LB.ByteString
384− -> (LB.ByteString, Either ParseError a)
385−parse p bs = case parseAt p bs 0 of
386− (bs', Right (a, _)) -> (bs', Right a)
387− (bs', Left err) -> (bs', Left err)
388−
389−parseTest :: (Show a) => Parser a -> LB.ByteString -> IO ()
390−parseTest p s =
391− case parse p s of
392− (st, Left msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st
393− (_, Right r) -> print r