@@ -0,0 +1,393 @@
1+-----------------------------------------------------------------------------
2+-- |
3+-- Module : Data.ParserCombinators.ByteStringParser.Internal
4+-- Copyright : Daan Leijen 1999-2001, Jeremy Shaw 2006, Bryan O'Sullivan 2007-2008
5+-- License : BSD3
6+--
7+-- Maintainer : bos@serpentine.com
8+-- Stability : experimental
9+-- Portability : unknown
10+--
11+-- Simple, efficient parser combinators for lazy 'LB.ByteString'
12+-- strings, loosely based on 'Text.ParserCombinators.Parsec'.
13+--
14+-----------------------------------------------------------------------------
15+module Data.ParserCombinators.ByteStringParser.Internal
16+ (
17+ -- * Parser
18+ ParseError
19+ , Parser
20+
21+ -- * Running parsers
22+ , parse
23+ , parseAt
24+ , parseTest
25+
26+ -- * Combinators
27+ , (<?>)
28+
29+ -- * Things vaguely like those in @Parsec.Combinator@ (and @Parsec.Prim@)
30+ , try
31+ , manyTill
32+ , eof
33+ , skipMany
34+ , skipMany1
35+ , count
36+ , lookAhead
37+ , peek
38+ , sepBy
39+ , sepBy1
40+
41+ -- * Things like in @Parsec.Char@
42+ , satisfy
43+ , letter
44+ , digit
45+ , anyChar
46+ , space
47+ , char
48+ , notChar
49+ , string
50+ , stringCI
51+
52+ -- * Parser converters.
53+ , eitherP
54+
55+ -- * Miscellaneous functions.
56+ , getInput
57+ , getConsumed
58+ , takeWhile
59+ , takeWhile1
60+ , takeTill
61+ , takeAll
62+ , skipWhile
63+ , skipSpace
64+ , notEmpty
65+ , match
66+ , inClass
67+ , notInClass
68+ ) where
69+
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)
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