@@ -3,7 +3,7 @@
3{-# OPTIONS_GHC -fno-warn-orphans #-}
3{-# OPTIONS_GHC -fno-warn-orphans #-}
5-- Module : Data.Attoparsec.Text.Internal
5-- Module : Data.Attoparsec.Text.Internal
6−-- Copyright : Bryan O'Sullivan 2007-2014
6+-- Copyright : Bryan O'Sullivan 2007-2015
7-- License : BSD3
7-- License : BSD3
9-- Maintainer : bos@serpentine.com
9-- Maintainer : bos@serpentine.com
@@ -65,14 +65,15 @@ module Data.Attoparsec.Text.Internal
68−import Control.Applicative ((<|>), (<$>))
68+import Control.Applicative ((<|>), (<$>), pure, (*>))
69import Control.Monad (when)
69import Control.Monad (when)
70import Data.Attoparsec.Combinator ((<?>))
70import Data.Attoparsec.Combinator ((<?>))
71import Data.Attoparsec.Internal
71import Data.Attoparsec.Internal
72import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
72import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
73import qualified Data.Attoparsec.Text.Buffer as Buf
73import qualified Data.Attoparsec.Text.Buffer as Buf
74import Data.Attoparsec.Text.Buffer (Buffer, buffer)
74import Data.Attoparsec.Text.Buffer (Buffer, buffer)
75−import Data.Char (chr, ord)
75+import Data.Char (isAsciiUpper, isAsciiLower, toUpper, toLower)
76+import Data.List (intercalate)
76import Data.String (IsString(..))
77import Data.String (IsString(..))
77import Data.Text.Internal (Text(..))
78import Data.Text.Internal (Text(..))
78import Prelude hiding (getChar, succ, take, takeWhile)
79import Prelude hiding (getChar, succ, take, takeWhile)
@@ -159,9 +160,46 @@ take n = takeWith (max n 0) (const True)
159-- before failing. In attoparsec, the above parser will /succeed/ on
160-- before failing. In attoparsec, the above parser will /succeed/ on
160-- that input, because the failed first branch will consume nothing.
161-- that input, because the failed first branch will consume nothing.
161string :: Text -> Parser Text
162string :: Text -> Parser Text
162−string s = takeWith (T.length s) (==s)
163+string s = string_ (stringSuspended id) id s
163{-# INLINE string #-}
164{-# INLINE string #-}
166+string_ :: (forall r. Text -> Text -> Buffer -> Pos -> More
167+ -> Failure r -> Success Text r -> Result r)
169+ -> Text -> Parser Text
170+string_ suspended f s0 = T.Parser $ \t pos more lose succ ->
172+ ft = f (Buf.unbufferAt (fromPos pos) t)
173+ in case T.commonPrefixes s ft of
175+ | T.null s -> succ t pos more T.empty
176+ | T.null ft -> suspended s s t pos more lose succ
177+ | otherwise -> lose t pos more [] "string"
178+ Just (pfx,ssfx,tsfx)
179+ | T.null ssfx -> let l = Pos (T.lengthWord16 pfx)
180+ in succ t (pos + l) more (substring pos l t)
181+ | not (T.null tsfx) -> lose t pos more [] "string"
182+ | otherwise -> suspended s ssfx t pos more lose succ
183+{-# INLINE string_ #-}
185+stringSuspended :: (Text -> Text)
186+ -> Text -> Text -> Buffer -> Pos -> More
190+stringSuspended f s000 s0 t0 pos0 more0 lose0 succ0 =
191+ runParser (demandInput_ >>= go) t0 pos0 more0 lose0 succ0
193+ go s' = T.Parser $ \t pos more lose succ ->
195+ in case T.commonPrefixes s0 s of
196+ Nothing -> lose t pos more [] "string"
197+ Just (_pfx,ssfx,tsfx)
198+ | T.null ssfx -> let l = Pos (T.lengthWord16 s000)
199+ in succ t (pos + l) more (substring pos l t)
200+ | T.null tsfx -> stringSuspended f s000 ssfx t pos more lose succ
201+ | otherwise -> lose t pos more [] "string"
165-- | Satisfy a literal string, ignoring case.
203-- | Satisfy a literal string, ignoring case.
167-- Note: this function is currently quite inefficient. Unicode case
205-- Note: this function is currently quite inefficient. Unicode case
@@ -184,23 +222,16 @@ stringCI s = go 0
185-- | Satisfy a literal string, ignoring case for characters in the ASCII range.
223-- | Satisfy a literal string, ignoring case for characters in the ASCII range.
186asciiCI :: Text -> Parser Text
224asciiCI :: Text -> Parser Text
187−asciiCI input = do
225+asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s
189− if asciiToLower t == s
190− then advance k >> return t
194− s = asciiToLower input
196− -- convert letters in the ASCII range to lower-case
197− asciiToLower = T.map f
199− offset = ord 'a' - ord 'A'
200− f c | 'A' <= c && c <= 'Z' = chr (ord c + offset)
202{-# INLINE asciiCI #-}
226{-# INLINE asciiCI #-}
228+asciiCharCI :: Char -> Parser Char
230+ | isAsciiUpper c = char c <|> char (toLower c)
231+ | isAsciiLower c = char c <|> char (toUpper c)
232+ | otherwise = char c
233+{-# INLINE asciiCharCI #-}
204-- | Skip past input for as long as the predicate returns 'True'.
235-- | Skip past input for as long as the predicate returns 'True'.
205skipWhile :: (Char -> Bool) -> Parser ()
236skipWhile :: (Char -> Bool) -> Parser ()
206skipWhile p = go
237skipWhile p = go
@@ -236,14 +267,25 @@ takeTill p = takeWhile (not . p)
236-- parsers loop until a failure occurs. Careless use will thus result
267-- parsers loop until a failure occurs. Careless use will thus result
237-- in an infinite loop.
268-- in an infinite loop.
238takeWhile :: (Char -> Bool) -> Parser Text
269takeWhile :: (Char -> Bool) -> Parser Text
239−takeWhile p = (T.concat . reverse) `fmap` go []
270+takeWhile p = do
271+ h <- T.takeWhile p <$> get
272+ continue <- inputSpansChunks (size h)
273+ -- only use slow concat path if necessary
275+ then takeWhileAcc p [h]
277+{-# INLINE takeWhile #-}
279+takeWhileAcc :: (Char -> Bool) -> [Text] -> Parser Text
241 go acc = do
282 go acc = do
242 h <- T.takeWhile p <$> get
283 h <- T.takeWhile p <$> get
243 continue <- inputSpansChunks (size h)
284 continue <- inputSpansChunks (size h)
244 if continue
285 if continue
245 then go (h:acc)
286 then go (h:acc)
246− else return (h:acc)
287+ else return $ concatReverse (h:acc)
288+{-# INLINE takeWhileAcc #-}
248takeRest :: Parser [Text]
290takeRest :: Parser [Text]
249takeRest = go []
291takeRest = go []
@@ -266,7 +308,7 @@ takeLazyText :: Parser L.Text
266takeLazyText = L.fromChunks `fmap` takeRest
308takeLazyText = L.fromChunks `fmap` takeRest
268data Scan s = Continue s
310data Scan s = Continue s
269− | Finished {-# UNPACK #-} !Int Text
311+ | Finished s {-# UNPACK #-} !Int Text
271scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
272scan_ f s0 p = go [] s0
314scan_ f s0 p = go [] s0
@@ -275,7 +317,7 @@ scan_ f s0 p = go [] s0
275 case T.uncons t of
317 case T.uncons t of
276 Just (c,t') -> case p s c of
318 Just (c,t') -> case p s c of
277 Just s' -> scanner s' (n+1) t'
319 Just s' -> scanner s' (n+1) t'
278− Nothing -> Finished n t
320+ Nothing -> Finished s n t
279 Nothing -> Continue s
321 Nothing -> Continue s
280 go acc s = do
322 go acc s = do
281 input <- get
323 input <- get
@@ -284,8 +326,8 @@ scan_ f s0 p = go [] s0
284 if continue
326 if continue
285 then go (input : acc) s'
327 then go (input : acc) s'
286 else f s' (input : acc)
328 else f s' (input : acc)
287− Finished n t -> do advance (size input - size t)
329+ Finished s' n t -> do advance (size input - size t)
288− f s (T.take n input : acc)
330+ f s' (T.take n input : acc)
289{-# INLINE scan_ #-}
331{-# INLINE scan_ #-}
291-- | A stateful scanner. The predicate consumes and transforms a
333-- | A stateful scanner. The predicate consumes and transforms a
@@ -301,16 +343,13 @@ scan_ f s0 p = go [] s0
301-- parsers loop until a failure occurs. Careless use will thus result
343-- parsers loop until a failure occurs. Careless use will thus result
302-- in an infinite loop.
344-- in an infinite loop.
303scan :: s -> (s -> Char -> Maybe s) -> Parser Text
345scan :: s -> (s -> Char -> Maybe s) -> Parser Text
304−scan = scan_ $ \_ chunks ->
346+scan = scan_ $ \_ chunks -> return $! concatReverse chunks
307− xs -> return . T.concat . reverse $ xs
308{-# INLINE scan #-}
347{-# INLINE scan #-}
310-- | Like 'scan', but generalized to return the final state of the
349-- | Like 'scan', but generalized to return the final state of the
311-- scanner.
350-- scanner.
312runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
351runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
313−runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)
352+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)
314{-# INLINE runScanner #-}
353{-# INLINE runScanner #-}
316-- | Consume input as long as the predicate returns 'True', and return
355-- | Consume input as long as the predicate returns 'True', and return
@@ -328,8 +367,9 @@ takeWhile1 p = do
328 advance size'
367 advance size'
329 eoc <- endOfChunk
368 eoc <- endOfChunk
331− then (h<>) `fmap` takeWhile p
370+ then takeWhileAcc p [h]
332 else return h
371 else return h
372+{-# INLINE takeWhile1 #-}
334-- | Match any character in a set.
374-- | Match any character in a set.
@@ -429,9 +469,10 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
430parseOnly :: Parser a -> Text -> Either String a
470parseOnly :: Parser a -> Text -> Either String a
431parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of
471parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of
472+ Fail _ [] err -> Left err
432− Fail _ _ err -> Left err
473+ Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)
433− Done _ a -> Right a
474+ Done _ a -> Right a
434− _ -> error "parseOnly: impossible error!"
475+ _ -> error "parseOnly: impossible error!"
435{-# INLINE parseOnly #-}
476{-# INLINE parseOnly #-}
437get :: Parser Text
478get :: Parser Text
@@ -476,7 +517,6 @@ ensure n = T.Parser $ \t pos more lose succ ->
476 Just n' -> succ t pos more (n', substring pos n' t)
517 Just n' -> succ t pos more (n', substring pos n' t)
477 -- The uncommon case is kept out-of-line to reduce code size:
518 -- The uncommon case is kept out-of-line to reduce code size:
478 Nothing -> ensureSuspended n t pos more lose succ
519 Nothing -> ensureSuspended n t pos more lose succ
479−-- Non-recursive so the bounds check can be inlined:
480{-# INLINE ensure #-}
520{-# INLINE ensure #-}
482-- | Return both the result of a parse and the portion of the input
522-- | Return both the result of a parse and the portion of the input
@@ -487,6 +527,8 @@ match p = T.Parser $ \t pos more lose succ ->
487 (substring pos (pos'-pos) t', a)
527 (substring pos (pos'-pos) t', a)
488 in runParser p t pos more lose succ'
528 in runParser p t pos more lose succ'
530+-- | Ensure that at least @n@ code points of input are available.
531+-- Returns the number of words consumed while traversing.
490lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
491lengthAtLeast pos n t = go 0 (fromPos pos)
533lengthAtLeast pos n t = go 0 (fromPos pos)
492 where go i !p
534 where go i !p