@@ -3,7 +3,7 @@
33{-# OPTIONS_GHC -fno-warn-orphans #-}
44-- |
55-- Module : Data.Attoparsec.Text.Internal
6−-- Copyright : Bryan O'Sullivan 2007-2014
6+-- Copyright : Bryan O'Sullivan 2007-2015
77-- License : BSD3
88--
99-- Maintainer : bos@serpentine.com
@@ -65,14 +65,15 @@ module Data.Attoparsec.Text.Internal
6565 , atEnd
6666 ) where
6767
68−import Control.Applicative ((<|>), (<$>))
68+import Control.Applicative ((<|>), (<$>), pure, (*>))
6969import Control.Monad (when)
7070import Data.Attoparsec.Combinator ((<?>))
7171import Data.Attoparsec.Internal
7272import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
7373import qualified Data.Attoparsec.Text.Buffer as Buf
7474import 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)
7677import Data.String (IsString(..))
7778import Data.Text.Internal (Text(..))
7879import Prelude hiding (getChar, succ, take, takeWhile)
@@ -159,9 +160,46 @@ take n = takeWith (max n 0) (const True)
159160-- before failing. In attoparsec, the above parser will /succeed/ on
160161-- that input, because the failed first branch will consume nothing.
161162string :: Text -> Parser Text
162−string s = takeWith (T.length s) (==s)
163+string s = string_ (stringSuspended id) id s
163164{-# INLINE string #-}
164165
166+string_ :: (forall r. Text -> Text -> Buffer -> Pos -> More
167+ -> Failure r -> Success Text r -> Result r)
168+ -> (Text -> Text)
169+ -> Text -> Parser Text
170+string_ suspended f s0 = T.Parser $ \t pos more lose succ ->
171+ let s = f s0
172+ ft = f (Buf.unbufferAt (fromPos pos) t)
173+ in case T.commonPrefixes s ft of
174+ Nothing
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_ #-}
184+
185+stringSuspended :: (Text -> Text)
186+ -> Text -> Text -> Buffer -> Pos -> More
187+ -> Failure r
188+ -> Success Text r
189+ -> Result r
190+stringSuspended f s000 s0 t0 pos0 more0 lose0 succ0 =
191+ runParser (demandInput_ >>= go) t0 pos0 more0 lose0 succ0
192+ where
193+ go s' = T.Parser $ \t pos more lose succ ->
194+ let s = f s'
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"
202+
165203-- | Satisfy a literal string, ignoring case.
166204--
167205-- Note: this function is currently quite inefficient. Unicode case
@@ -184,23 +222,16 @@ stringCI s = go 0
184222
185223-- | Satisfy a literal string, ignoring case for characters in the ASCII range.
186224asciiCI :: Text -> Parser Text
187−asciiCI input = do
188− (k,t) <- ensure n
189− if asciiToLower t == s
190− then advance k >> return t
191− else fail "asciiCI"
192− where
193− n = T.length input
194− s = asciiToLower input
195−
196− -- convert letters in the ASCII range to lower-case
197− asciiToLower = T.map f
198− where
199− offset = ord 'a' - ord 'A'
200− f c | 'A' <= c && c <= 'Z' = chr (ord c + offset)
201− | otherwise = c
225+asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s
202226{-# INLINE asciiCI #-}
203227
228+asciiCharCI :: Char -> Parser Char
229+asciiCharCI c
230+ | isAsciiUpper c = char c <|> char (toLower c)
231+ | isAsciiLower c = char c <|> char (toUpper c)
232+ | otherwise = char c
233+{-# INLINE asciiCharCI #-}
234+
204235-- | Skip past input for as long as the predicate returns 'True'.
205236skipWhile :: (Char -> Bool) -> Parser ()
206237skipWhile p = go
@@ -236,14 +267,25 @@ takeTill p = takeWhile (not . p)
236267-- parsers loop until a failure occurs. Careless use will thus result
237268-- in an infinite loop.
238269takeWhile :: (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
274+ if continue
275+ then takeWhileAcc p [h]
276+ else return h
277+{-# INLINE takeWhile #-}
278+
279+takeWhileAcc :: (Char -> Bool) -> [Text] -> Parser Text
280+takeWhileAcc p = go
240281 where
241282 go acc = do
242283 h <- T.takeWhile p <$> get
243284 continue <- inputSpansChunks (size h)
244285 if continue
245286 then go (h:acc)
246− else return (h:acc)
287+ else return $ concatReverse (h:acc)
288+{-# INLINE takeWhileAcc #-}
247289
248290takeRest :: Parser [Text]
249291takeRest = go []
@@ -266,7 +308,7 @@ takeLazyText :: Parser L.Text
266308takeLazyText = L.fromChunks `fmap` takeRest
267309
268310data Scan s = Continue s
269− | Finished {-# UNPACK #-} !Int Text
311+ | Finished s {-# UNPACK #-} !Int Text
270312
271313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
272314scan_ f s0 p = go [] s0
@@ -275,7 +317,7 @@ scan_ f s0 p = go [] s0
275317 case T.uncons t of
276318 Just (c,t') -> case p s c of
277319 Just s' -> scanner s' (n+1) t'
278− Nothing -> Finished n t
320+ Nothing -> Finished s n t
279321 Nothing -> Continue s
280322 go acc s = do
281323 input <- get
@@ -284,8 +326,8 @@ scan_ f s0 p = go [] s0
284326 if continue
285327 then go (input : acc) s'
286328 else f s' (input : acc)
287− Finished n t -> do advance (size input - size t)
288− f s (T.take n input : acc)
329+ Finished s' n t -> do advance (size input - size t)
330+ f s' (T.take n input : acc)
289331{-# INLINE scan_ #-}
290332
291333-- | A stateful scanner. The predicate consumes and transforms a
@@ -301,16 +343,13 @@ scan_ f s0 p = go [] s0
301343-- parsers loop until a failure occurs. Careless use will thus result
302344-- in an infinite loop.
303345scan :: s -> (s -> Char -> Maybe s) -> Parser Text
304−scan = scan_ $ \_ chunks ->
305− case chunks of
306− [x] -> return x
307− xs -> return . T.concat . reverse $ xs
346+scan = scan_ $ \_ chunks -> return $! concatReverse chunks
308347{-# INLINE scan #-}
309348
310349-- | Like 'scan', but generalized to return the final state of the
311350-- scanner.
312351runScanner :: 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)
314353{-# INLINE runScanner #-}
315354
316355-- | Consume input as long as the predicate returns 'True', and return
@@ -328,8 +367,9 @@ takeWhile1 p = do
328367 advance size'
329368 eoc <- endOfChunk
330369 if eoc
331− then (h<>) `fmap` takeWhile p
370+ then takeWhileAcc p [h]
332371 else return h
372+{-# INLINE takeWhile1 #-}
333373
334374-- | Match any character in a set.
335375--
@@ -429,9 +469,10 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
429469-- @
430470parseOnly :: Parser a -> Text -> Either String a
431471parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of
432− Fail _ _ err -> Left err
433− Done _ a -> Right a
434− _ -> error "parseOnly: impossible error!"
472+ Fail _ [] err -> Left err
473+ Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)
474+ Done _ a -> Right a
475+ _ -> error "parseOnly: impossible error!"
435476{-# INLINE parseOnly #-}
436477
437478get :: Parser Text
@@ -476,7 +517,6 @@ ensure n = T.Parser $ \t pos more lose succ ->
476517 Just n' -> succ t pos more (n', substring pos n' t)
477518 -- The uncommon case is kept out-of-line to reduce code size:
478519 Nothing -> ensureSuspended n t pos more lose succ
479−-- Non-recursive so the bounds check can be inlined:
480520{-# INLINE ensure #-}
481521
482522-- | 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 ->
487527 (substring pos (pos'-pos) t', a)
488528 in runParser p t pos more lose succ'
489529
530+-- | Ensure that at least @n@ code points of input are available.
531+-- Returns the number of words consumed while traversing.
490532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
491533lengthAtLeast pos n t = go 0 (fromPos pos)
492534 where go i !p