@@ -1,14 +1,15 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}
1+{-# LANGUAGE BangPatterns, CPP, GADTs, OverloadedStrings, RankNTypes,
2+ RecordWildCards #-}
23-- |
34-- Module : Data.Attoparsec.ByteString.Internal
4−-- Copyright : Bryan O'Sullivan 2007-2014
5+-- Copyright : Bryan O'Sullivan 2007-2015
56-- License : BSD3
67--
78-- Maintainer : bos@serpentine.com
89-- Stability : experimental
910-- Portability : unknown
1011--
11−-- Simple, efficient parser combinators for 'B.ByteString' strings,
12+-- Simple, efficient parser combinators for 'ByteString' strings,
1213-- loosely based on the Parsec library.
1314
1415module Data.Attoparsec.ByteString.Internal
@@ -46,7 +47,7 @@ module Data.Attoparsec.ByteString.Internal
4647 -- * Efficient string handling
4748 , skipWhile
4849 , string
49− , stringTransform
50+ , stringCI
5051 , take
5152 , scan
5253 , runScanner
@@ -65,14 +66,19 @@ module Data.Attoparsec.ByteString.Internal
6566 , atEnd
6667 ) where
6768
68−import Control.Applicative ((<|>), (<$>))
69+#if !MIN_VERSION_base(4,8,0)
70+import Control.Applicative ((<$>))
71+#endif
72+import Control.Applicative ((<|>))
6973import Control.Monad (when)
7074import Data.Attoparsec.ByteString.Buffer (Buffer, buffer)
7175import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8)
7276import Data.Attoparsec.Combinator ((<?>))
77+import Data.Attoparsec.Internal
7378import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)
7479import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
7580import Data.ByteString (ByteString)
81+import Data.List (intercalate)
7682import Data.Word (Word8)
7783import Foreign.ForeignPtr (withForeignPtr)
7884import Foreign.Ptr (castPtr, minusPtr, plusPtr)
@@ -86,10 +92,10 @@ import qualified Data.ByteString.Internal as B
8692import qualified Data.ByteString.Lazy as L
8793import qualified Data.ByteString.Unsafe as B
8894
89−type Parser = T.Parser B.ByteString Buffer
90−type Result = IResult B.ByteString
91−type Failure r = T.Failure B.ByteString Buffer r
92−type Success a r = T.Success B.ByteString Buffer a r
95+type Parser = T.Parser ByteString
96+type Result = IResult ByteString
97+type Failure r = T.Failure ByteString Buffer r
98+type Success a r = T.Success ByteString Buffer a r
9399
94100-- | The parser @satisfy p@ succeeds for any byte for which the
95101-- predicate @p@ returns 'True'. Returns the byte that is actually
@@ -135,22 +141,15 @@ storable = hack undefined
135141 hack :: Storable b => b -> Parser b
136142 hack dummy = do
137143 (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy)
138− return . B.inlinePerformIO . withForeignPtr fp $ \p ->
144+ return . inlinePerformIO . withForeignPtr fp $ \p ->
139145 peek (castPtr $ p `plusPtr` o)
140146
141−-- | Consume @n@ bytes of input, but succeed only if the predicate
142−-- returns 'True'.
143−takeWith :: Int -> (B.ByteString -> Bool) -> Parser B.ByteString
144−takeWith n0 p = do
147+-- | Consume exactly @n@ bytes of input.
148+take :: Int -> Parser ByteString
149+take n0 = do
145150 let n = max n0 0
146151 s <- ensure n
147− if p s
148− then advance n >> return s
149− else fail "takeWith"
150−
151−-- | Consume exactly @n@ bytes of input.
152−take :: Int -> Parser B.ByteString
153−take n = takeWith n (const True)
152+ advance n >> return s
154153{-# INLINE take #-}
155154
156155-- | @string s@ parses a sequence of bytes that identically match
@@ -166,16 +165,62 @@ take n = takeWith n (const True)
166165--
167166-- The reason for its failure is that the first branch is a
168167-- partial match, and will consume the letters @\'f\'@ and @\'o\'@
169−-- before failing. In Attoparsec, the above parser will /succeed/ on
168+-- before failing. In attoparsec, the above parser will /succeed/ on
170169-- that input, because the failed first branch will consume nothing.
171−string :: B.ByteString -> Parser B.ByteString
172−string s = takeWith (B.length s) (==s)
170+string :: ByteString -> Parser ByteString
171+string s = string_ (stringSuspended id) id s
173172{-# INLINE string #-}
174173
175−stringTransform :: (B.ByteString -> B.ByteString) -> B.ByteString
176− -> Parser B.ByteString
177−stringTransform f s = takeWith (B.length s) ((==f s) . f)
178−{-# INLINE stringTransform #-}
174+-- ASCII-specific but fast, oh yes.
175+toLower :: Word8 -> Word8
176+toLower w | w >= 65 && w <= 90 = w + 32
177+ | otherwise = w
178+
179+-- | Satisfy a literal string, ignoring case.
180+stringCI :: ByteString -> Parser ByteString
181+stringCI s = string_ (stringSuspended lower) lower s
182+ where lower = B8.map toLower
183+{-# INLINE stringCI #-}
184+
185+string_ :: (forall r. ByteString -> ByteString -> Buffer -> Pos -> More
186+ -> Failure r -> Success ByteString r -> Result r)
187+ -> (ByteString -> ByteString)
188+ -> ByteString -> Parser ByteString
189+string_ suspended f s0 = T.Parser $ \t pos more lose succ ->
190+ let n = B.length s
191+ s = f s0
192+ in if lengthAtLeast pos n t
193+ then let t' = substring pos (Pos n) t
194+ in if s == f t'
195+ then succ t (pos + Pos n) more t'
196+ else lose t pos more [] "string"
197+ else let t' = Buf.unsafeDrop (fromPos pos) t
198+ in if f t' `B.isPrefixOf` s
199+ then suspended s (B.drop (B.length t') s) t pos more lose succ
200+ else lose t pos more [] "string"
201+{-# INLINE string_ #-}
202+
203+stringSuspended :: (ByteString -> ByteString)
204+ -> ByteString -> ByteString -> Buffer -> Pos -> More
205+ -> Failure r
206+ -> Success ByteString r
207+ -> Result r
208+stringSuspended f s0 s t pos more lose succ =
209+ runParser (demandInput_ >>= go) t pos more lose succ
210+ where go s'0 = T.Parser $ \t' pos' more' lose' succ' ->
211+ let m = B.length s
212+ s' = f s'0
213+ n = B.length s'
214+ in if n >= m
215+ then if B.unsafeTake m s' == s
216+ then let o = Pos (B.length s0)
217+ in succ' t' (pos' + o) more'
218+ (substring pos' o t')
219+ else lose' t' pos' more' [] "string"
220+ else if s' == B.unsafeTake n s
221+ then stringSuspended f s0 (B.unsafeDrop n s)
222+ t' pos' more' lose' succ'
223+ else lose' t' pos' more' [] "string"
179224
180225-- | Skip past input for as long as the predicate returns 'True'.
181226skipWhile :: (Word8 -> Bool) -> Parser ()
@@ -183,11 +228,8 @@ skipWhile p = go
183228 where
184229 go = do
185230 t <- B8.takeWhile p <$> get
186− advance (B.length t)
187− eoc <- endOfChunk
188− when eoc $ do
189− input <- wantInput
190− when input go
231+ continue <- inputSpansChunks (B.length t)
232+ when continue go
191233{-# INLINE skipWhile #-}
192234
193235-- | Consume input as long as the predicate returns 'False'
@@ -200,7 +242,7 @@ skipWhile p = go
200242-- combinators such as 'Control.Applicative.many', because such
201243-- parsers loop until a failure occurs. Careless use will thus result
202244-- in an infinite loop.
203−takeTill :: (Word8 -> Bool) -> Parser B.ByteString
245+takeTill :: (Word8 -> Bool) -> Parser ByteString
204246takeTill p = takeWhile (not . p)
205247{-# INLINE takeTill #-}
206248
@@ -214,23 +256,27 @@ takeTill p = takeWhile (not . p)
214256-- combinators such as 'Control.Applicative.many', because such
215257-- parsers loop until a failure occurs. Careless use will thus result
216258-- in an infinite loop.
217−takeWhile :: (Word8 -> Bool) -> Parser B.ByteString
218−takeWhile p = (B.concat . reverse) `fmap` go []
259+takeWhile :: (Word8 -> Bool) -> Parser ByteString
260+takeWhile p = do
261+ s <- B8.takeWhile p <$> get
262+ continue <- inputSpansChunks (B.length s)
263+ if continue
264+ then takeWhileAcc p [s]
265+ else return s
266+{-# INLINE takeWhile #-}
267+
268+takeWhileAcc :: (Word8 -> Bool) -> [ByteString] -> Parser ByteString
269+takeWhileAcc p = go
219270 where
220271 go acc = do
221272 s <- B8.takeWhile p <$> get
222− advance (B.length s)
223− eoc <- endOfChunk
224− if eoc
225− then do
226− input <- wantInput
227− if input
228− then go (s:acc)
229− else return (s:acc)
230− else return (s:acc)
231−{-# INLINE takeWhile #-}
273+ continue <- inputSpansChunks (B.length s)
274+ if continue
275+ then go (s:acc)
276+ else return $ concatReverse (s:acc)
277+{-# INLINE takeWhileAcc #-}
232278
233−takeRest :: Parser [B.ByteString]
279+takeRest :: Parser [ByteString]
234280takeRest = go []
235281 where
236282 go acc = do
@@ -243,7 +289,7 @@ takeRest = go []
243289 else return (reverse acc)
244290
245291-- | Consume all remaining input and return it as a single string.
246−takeByteString :: Parser B.ByteString
292+takeByteString :: Parser ByteString
247293takeByteString = B.concat `fmap` takeRest
248294
249295-- | Consume all remaining input and return it as a single string.
@@ -252,7 +298,7 @@ takeLazyByteString = L.fromChunks `fmap` takeRest
252298
253299data T s = T {-# UNPACK #-} !Int s
254300
255−scan_ :: (s -> [B.ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s)
301+scan_ :: (s -> [ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s)
256302 -> Parser r
257303scan_ f s0 p = go [] s0
258304 where
@@ -273,14 +319,9 @@ scan_ f s0 p = go [] s0
273319 bs <- get
274320 let T i s' = inlinePerformIO $ scanner bs
275321 !h = B.unsafeTake i bs
276− advance i
277− eoc <- endOfChunk
278− if eoc
279− then do
280− input <- wantInput
281− if input
282− then go (h:acc) s'
283− else f s' (h:acc)
322+ continue <- inputSpansChunks i
323+ if continue
324+ then go (h:acc) s'
284325 else f s' (h:acc)
285326{-# INLINE scan_ #-}
286327
@@ -296,17 +337,14 @@ scan_ f s0 p = go [] s0
296337-- combinators such as 'Control.Applicative.many', because such
297338-- parsers loop until a failure occurs. Careless use will thus result
298339-- in an infinite loop.
299−scan :: s -> (s -> Word8 -> Maybe s) -> Parser B.ByteString
300−scan = scan_ $ \_ chunks ->
301− case chunks of
302− [x] -> return x
303− xs -> return $! B.concat $ reverse xs
340+scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString
341+scan = scan_ $ \_ chunks -> return $! concatReverse chunks
304342{-# INLINE scan #-}
305343
306344-- | Like 'scan', but generalized to return the final state of the
307345-- scanner.
308−runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (B.ByteString, s)
309−runScanner = scan_ $ \s xs -> return (B.concat (reverse xs), s)
346+runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s)
347+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)
310348{-# INLINE runScanner #-}
311349
312350-- | Consume input as long as the predicate returns 'True', and return
@@ -315,7 +353,7 @@ runScanner = scan_ $ \s xs -> return (B.concat (reverse xs), s)
315353-- This parser requires the predicate to succeed on at least one byte
316354-- of input: it will fail if the predicate never returns 'True' or if
317355-- there is no input left.
318−takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString
356+takeWhile1 :: (Word8 -> Bool) -> Parser ByteString
319357takeWhile1 p = do
320358 (`when` demandInput) =<< endOfChunk
321359 s <- B8.takeWhile p <$> get
@@ -326,8 +364,9 @@ takeWhile1 p = do
326364 advance len
327365 eoc <- endOfChunk
328366 if eoc
329− then (s<>) `fmap` takeWhile p
367+ then takeWhileAcc p [s]
330368 else return s
369+{-# INLINE takeWhile1 #-}
331370
332371-- | Match any byte in a set.
333372--
@@ -381,7 +420,7 @@ peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ ->
381420 | more == Complete ->
382421 succ t pos more Nothing
383422 | otherwise ->
384− let succ' t' pos' more' = let !w = Buf.unsafeIndex t pos_
423+ let succ' t' pos' more' = let !w = Buf.unsafeIndex t' pos_
385424 in succ t' pos' more' (Just w)
386425 lose' t' pos' more' = succ t' pos' more' Nothing
387426 in prompt t pos more lose' succ'
@@ -413,16 +452,25 @@ successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a
413452{-# INLINE successK #-}
414453
415454-- | Run a parser.
416−parse :: Parser a -> B.ByteString -> Result a
455+parse :: Parser a -> ByteString -> Result a
417456parse m s = T.runParser m (buffer s) (Pos 0) Incomplete failK successK
418457{-# INLINE parse #-}
419458
420459-- | Run a parser that cannot be resupplied via a 'Partial' result.
421−parseOnly :: Parser a -> B.ByteString -> Either String a
460+--
461+-- This function does not force a parser to consume all of its input.
462+-- Instead, any residual input will be discarded. To force a parser
463+-- to consume all of its input, use something like this:
464+--
465+-- @
466+--'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput')
467+-- @
468+parseOnly :: Parser a -> ByteString -> Either String a
422469parseOnly m s = case T.runParser m (buffer s) (Pos 0) Complete failK successK of
423− Fail _ _ err -> Left err
424− Done _ a -> Right a
425− _ -> error "parseOnly: impossible error!"
470+ Fail _ [] err -> Left err
471+ Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)
472+ Done _ a -> Right a
473+ _ -> error "parseOnly: impossible error!"
426474{-# INLINE parseOnly #-}
427475
428476get :: Parser ByteString
@@ -435,6 +483,16 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->
435483 succ t pos more (fromPos pos == Buf.length t)
436484{-# INLINE endOfChunk #-}
437485
486+inputSpansChunks :: Int -> Parser Bool
487+inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->
488+ let pos = pos_ + Pos i
489+ in if fromPos pos < Buf.length t || more == Complete
490+ then succ t pos more False
491+ else let lose' t' pos' more' = succ t' pos' more' False
492+ succ' t' pos' more' = succ t' pos' more' True
493+ in prompt t pos more lose' succ'
494+{-# INLINE inputSpansChunks #-}
495+
438496advance :: Int -> Parser ()
439497advance n = T.Parser $ \t pos more _lose succ ->
440498 succ t (pos + Pos n) more ()
@@ -459,54 +517,8 @@ ensure n = T.Parser $ \t pos more lose succ ->
459517 then succ t pos more (substring pos (Pos n) t)
460518 -- The uncommon case is kept out-of-line to reduce code size:
461519 else ensureSuspended n t pos more lose succ
462−-- Non-recursive so the bounds check can be inlined:
463520{-# INLINE ensure #-}
464521
465−-- | Ask for input. If we receive any, pass it to a success
466−-- continuation, otherwise to a failure continuation.
467−prompt :: Buffer -> Pos -> More
468− -> (Buffer -> Pos -> More -> IResult ByteString r)
469− -> (Buffer -> Pos -> More -> IResult ByteString r)
470− -> IResult ByteString r
471−prompt t pos _more lose succ = Partial $ \s ->
472− if B.null s
473− then lose t pos Complete
474− else succ (t <> buffer s) pos Incomplete
475−
476−-- | Immediately demand more input via a 'Partial' continuation
477−-- result.
478−demandInput :: Parser ()
479−demandInput = T.Parser $ \t pos more lose succ ->
480− case more of
481− Complete -> lose t pos more [] "not enough input"
482− _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input"
483− succ' t' pos' more' = succ t' pos' more' ()
484− in prompt t pos more lose' succ'
485−
486−-- | This parser always succeeds. It returns 'True' if any input is
487−-- available either immediately or on demand, and 'False' if the end
488−-- of all input has been reached.
489−wantInput :: Parser Bool
490−wantInput = T.Parser $ \t pos more _lose succ ->
491− case () of
492− _ | lengthAtLeast pos 1 t -> succ t pos more True
493− | more == Complete -> succ t pos more False
494− | otherwise -> let lose' t' pos' more' = succ t' pos' more' False
495− succ' t' pos' more' = succ t' pos' more' True
496− in prompt t pos more lose' succ'
497−{-# INLINE wantInput #-}
498−
499−-- | Match only if all input has been consumed.
500−endOfInput :: Parser ()
501−endOfInput = T.Parser $ \t pos more lose succ ->
502− case () of
503− _| lengthAtLeast pos 1 t -> lose t pos more [] "endOfInput"
504− | more == Complete -> succ t pos more ()
505− | otherwise ->
506− let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()
507− succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"
508− in runParser demandInput t pos more lose' succ'
509−
510522-- | Return both the result of a parse and the portion of the input
511523-- that was consumed while it was being parsed.
512524match :: Parser a -> Parser (ByteString, a)
@@ -515,12 +527,6 @@ match p = T.Parser $ \t pos more lose succ ->
515527 succ t' pos' more' (substring pos (pos'-pos) t', a)
516528 in runParser p t pos more lose succ'
517529
518−-- | Return an indication of whether the end of input has been
519−-- reached.
520−atEnd :: Parser Bool
521−atEnd = not <$> wantInput
522−{-# INLINE atEnd #-}
523−
524530lengthAtLeast :: Pos -> Int -> Buffer -> Bool
525531lengthAtLeast (Pos pos) n bs = Buf.length bs >= pos + n
526532{-# INLINE lengthAtLeast #-}