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