@@ -0,0 +1,393 @@
1+-----------------------------------------------------------------------------
3+-- Module : Data.ParserCombinators.ByteStringParser
4+-- Copyright : Daan Leijen 1999-2001, Jeremy Shaw 2006, Bryan O'Sullivan 2007-2008
7+-- Maintainer : bos@serpentine.com
8+-- Stability : experimental
9+-- Portability : unknown
11+-- Simple, efficient parser combinators for lazy 'LB.ByteString'
12+-- strings, loosely based on 'Text.ParserCombinators.Parsec'.
14+-----------------------------------------------------------------------------
15+module Data.ParserCombinators.ByteStringParser
29+ -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
41+ -- * Things like in @Parsec.Char@
52+ -- * Parser converters.
55+ -- * Miscellaneous functions.
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)
81+import Prelude hiding (takeWhile)
83+type ParseError = String
85+data S = S {-# UNPACK #-} !SB.ByteString
87+ {-# UNPACK #-} !Int64
89+newtype Parser a = Parser {
90+ unParser :: S -> Either (LB.ByteString, [String]) (a, S)
93+instance Functor Parser where
97+ Right (a, s') -> Right (f a, s')
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])
108+instance MonadFix Parser where
109+ mfix f = Parser $ \s ->
111+ Right (a, _) -> unParser (f a) s
116+zero = Parser $ \(S sb lb _) -> Left (sb +: lb, [])
119+plus :: Parser a -> Parser a -> Parser a
121+ Parser $ \s@(S sb lb _) ->
122+ case unParser p1 s of
124+ case unParser p2 s of
125+ Left (_, msgs2) -> Left (sb +: lb, (msgs1 ++ msgs2))
130+instance MonadPlus Parser where
134+instance Applicative Parser where
138+instance Alternative Parser where
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
147+-- | Turn our chunked representation back into a normal lazy
149+(+:) :: SB.ByteString -> LB.ByteString -> LB.ByteString
150+sb +: lb | SB.null sb = lb
151+ | otherwise = LB.Chunk sb lb
156+-- | Name the parser.
157+(<?>) :: Parser a -> String -> Parser a
159+ Parser $ \s@(S sb lb _) ->
160+ case unParser p s of
161+ (Left _) -> Left (sb +: lb, [msg])
165+nextChunk :: Parser ()
166+nextChunk = Parser $ \(S _ lb n) ->
168+ LB.Chunk sb' lb' -> Right ((), S sb' lb' n)
169+ LB.Empty -> Left (lb, [])
171+-- | Get remaining input.
172+getInput :: Parser LB.ByteString
173+getInput = Parser $ \s@(S sb lb _) -> Right (sb +: lb, s)
175+-- | Get number of bytes consumed so far.
176+getConsumed :: Parser Int64
177+getConsumed = Parser $ \s@(S _ _ n) -> Right (n, s)
179+-- | Character parser.
180+satisfy :: (Char -> Bool) -> Parser Char
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 #-}
189+letter :: Parser Char
190+letter = satisfy isLetter <?> "letter"
191+{-# INLINE letter #-}
194+digit = satisfy isDigit <?> "digit"
197+anyChar :: Parser Char
198+anyChar = satisfy $ const True
199+{-# INLINE anyChar #-}
202+space = satisfy isSpace <?> "space"
205+-- | Satisfy a specific character.
206+char :: Char -> Parser Char
207+char c = satisfy (== c) <?> [c]
210+-- | Satisfy a specific character.
211+notChar :: Char -> Parser Char
212+notChar c = satisfy (/= c) <?> "not " ++ [c]
213+{-# INLINE notChar #-}
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
221+inClass :: String -> Char -> Bool
222+inClass s = (`memberChar` myset)
223+ where myset = charClass s
224+{-# INLINE inClass #-}
226+notInClass :: String -> Char -> Bool
227+notInClass s = not . inClass s
228+{-# INLINE notInClass #-}
230+sepBy :: Parser a -> Parser s -> Parser [a]
231+sepBy p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return []) <|> return []
233+sepBy1 :: Parser a -> Parser s -> Parser [a]
234+sepBy1 p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return [])
236+-- | Satisfy a literal string.
237+string :: LB.ByteString -> Parser LB.ByteString
238+string s = Parser $ \(S sb lb n) ->
241+ (h, t) = LB.splitAt l bs
243+ then Right (s, mkState t (n + l))
245+{-# INLINE string #-}
247+-- | Satisfy a literal string, ignoring case.
248+stringCI :: LB.ByteString -> Parser LB.ByteString
249+stringCI s = Parser $ \(S sb lb n) ->
252+ (h, t) = LB.splitAt l bs
253+ in if ls == LB.map toLower h
254+ then Right (s, mkState t (n + l))
256+ where ls = LB.map toLower s
257+{-# INLINE stringCI #-}
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)
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)
270+-- | Detect 'end of file'.
272+eof = Parser $ \s@(S sb lb _) -> if SB.null sb && LB.null lb
274+ else Left (sb +: lb, ["EOF"])
276+takeAll :: Parser LB.ByteString
277+takeAll = Parser $ \(S sb lb n) ->
279+ in Right (bs, mkState LB.empty (n + LB.length bs))
281+oneChunk :: SB.ByteString -> LB.ByteString
282+oneChunk s = LB.Chunk s LB.Empty
284+length64 :: SB.ByteString -> Int64
285+length64 = fromIntegral . SB.length
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
292+ then unParser ((h +:) <$> (nextChunk *> takeWhile p)) s
293+ else Right (oneChunk h, S t lb (n + length64 h))
294+{-# INLINE takeWhile #-}
296+takeTill :: (Char -> Bool) -> Parser LB.ByteString
297+takeTill p = takeWhile (not . p) <* satisfy p
298+{-# INLINE takeTill #-}
300+takeWhile1 :: (Char -> Bool) -> Parser LB.ByteString
301+takeWhile1 p = Parser $ \s@(S sb lb n) ->
302+ let (h, t) = SB.span p sb
304+ then case unParser (nextChunk *> takeWhile p) s of
305+ Left err -> Left err
309+ then Left (sb +: lb, [])
311+ else Right (oneChunk h, S t lb (n + length64 h))
312+{-# INLINE takeWhile1 #-}
314+-- | Skip over characters while the predicate is true.
315+skipWhile :: (Char -> Bool) -> Parser ()
316+skipWhile p = takeWhile p >> return ()
317+{-# INLINE skipWhile #-}
319+-- | Skip over white space.
320+skipSpace :: Parser ()
321+skipSpace = takeWhile isSpace >> return ()
322+{-# INLINE skipSpace #-}
324+manyTill :: Parser a -> Parser b -> Parser [a]
325+manyTill p end = scan
326+ where scan = (end >> return []) <|> liftM2 (:) p scan
328+-- |'skipMany' - skip zero or many instances of the parser
329+skipMany :: Parser a -> Parser ()
331+ where scan = (p >> scan) <|> return ()
333+-- |'skipMany1' - skip one or many instances of the parser
334+skipMany1 :: Parser a -> Parser ()
335+skipMany1 p = p >> skipMany p
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
343+ then Left (a, ["notEmpty"])
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
354+ return (LB.take (end - start) bs)
356+eitherP :: Parser a -> Parser b -> Parser (Either a b)
357+eitherP a b = (Left <$> a) <|> (Right <$> b)
358+{-# INLINE eitherP #-}
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)
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)
372+parseAt :: Parser a -> LB.ByteString -> Int64
373+ -> (LB.ByteString, Either ParseError (a, Int64))
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'))
379+ showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
380+ showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
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)
389+parseTest :: (Show a) => Parser a -> LB.ByteString -> IO ()
392+ (st, Left msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st
393+ (_, Right r) -> print r