@@ -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,16 +65,18 @@ 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 ((<?>))
71+import Data.Attoparsec.Internal
71import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
72import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
72import qualified Data.Attoparsec.Text.Buffer as Buf
73import qualified Data.Attoparsec.Text.Buffer as Buf
73import Data.Attoparsec.Text.Buffer (Buffer, buffer)
74import Data.Attoparsec.Text.Buffer (Buffer, buffer)
74−import Data.Char (chr, ord)
75+import Data.Char (isAsciiUpper, isAsciiLower, toUpper, toLower)
76+import Data.List (intercalate)
75import Data.String (IsString(..))
77import Data.String (IsString(..))
76import Data.Text.Internal (Text(..))
78import Data.Text.Internal (Text(..))
77−import Prelude hiding (getChar, length, succ, take, takeWhile)
79+import Prelude hiding (getChar, succ, take, takeWhile)
78import qualified Data.Attoparsec.Internal.Types as T
80import qualified Data.Attoparsec.Internal.Types as T
79import qualified Data.Attoparsec.Text.FastSet as Set
81import qualified Data.Attoparsec.Text.FastSet as Set
80import qualified Data.Text as T
82import qualified Data.Text as T
@@ -158,9 +160,46 @@ take n = takeWith (max n 0) (const True)
158-- before failing. In attoparsec, the above parser will /succeed/ on
160-- before failing. In attoparsec, the above parser will /succeed/ on
159-- that input, because the failed first branch will consume nothing.
161-- that input, because the failed first branch will consume nothing.
160string :: Text -> Parser Text
162string :: Text -> Parser Text
161−string s = takeWith (T.length s) (==s)
163+string s = string_ (stringSuspended id) id s
162{-# 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"
164-- | Satisfy a literal string, ignoring case.
203-- | Satisfy a literal string, ignoring case.
166-- Note: this function is currently quite inefficient. Unicode case
205-- Note: this function is currently quite inefficient. Unicode case
@@ -183,30 +222,23 @@ stringCI s = go 0
184-- | 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.
185asciiCI :: Text -> Parser Text
224asciiCI :: Text -> Parser Text
186−asciiCI input = do
225+asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s
188− if asciiToLower t == s
189− then advance k >> return t
193− s = asciiToLower input
195− -- convert letters in the ASCII range to lower-case
196− asciiToLower = T.map f
198− offset = ord 'a' - ord 'A'
199− f c | 'A' <= c && c <= 'Z' = chr (ord c + offset)
201{-# 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 #-}
203-- | Skip past input for as long as the predicate returns 'True'.
235-- | Skip past input for as long as the predicate returns 'True'.
204skipWhile :: (Char -> Bool) -> Parser ()
236skipWhile :: (Char -> Bool) -> Parser ()
205skipWhile p = go
237skipWhile p = go
208 t <- T.takeWhile p <$> get
240 t <- T.takeWhile p <$> get
209− continue <- inputSpansChunks (length t)
241+ continue <- inputSpansChunks (size t)
210 when continue go
242 when continue go
211{-# INLINE skipWhile #-}
243{-# INLINE skipWhile #-}
@@ -235,14 +267,25 @@ takeTill p = takeWhile (not . p)
235-- parsers loop until a failure occurs. Careless use will thus result
267-- parsers loop until a failure occurs. Careless use will thus result
236-- in an infinite loop.
268-- in an infinite loop.
237takeWhile :: (Char -> Bool) -> Parser Text
269takeWhile :: (Char -> Bool) -> Parser Text
238−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
240 go acc = do
282 go acc = do
241 h <- T.takeWhile p <$> get
283 h <- T.takeWhile p <$> get
242− continue <- inputSpansChunks (length h)
284+ continue <- inputSpansChunks (size h)
243 if continue
285 if continue
244 then go (h:acc)
286 then go (h:acc)
245− else return (h:acc)
287+ else return $ concatReverse (h:acc)
288+{-# INLINE takeWhileAcc #-}
247takeRest :: Parser [Text]
290takeRest :: Parser [Text]
248takeRest = go []
291takeRest = go []
@@ -252,7 +295,7 @@ takeRest = go []
255− advance (length s)
298+ advance (size s)
256 go (s:acc)
299 go (s:acc)
257 else return (reverse acc)
300 else return (reverse acc)
@@ -265,7 +308,7 @@ takeLazyText :: Parser L.Text
265takeLazyText = L.fromChunks `fmap` takeRest
308takeLazyText = L.fromChunks `fmap` takeRest
267data Scan s = Continue s
310data Scan s = Continue s
268− | Finished {-# UNPACK #-} !Int Text
311+ | Finished s {-# UNPACK #-} !Int Text
270scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
271scan_ f s0 p = go [] s0
314scan_ f s0 p = go [] s0
@@ -274,17 +317,17 @@ scan_ f s0 p = go [] s0
274 case T.uncons t of
317 case T.uncons t of
275 Just (c,t') -> case p s c of
318 Just (c,t') -> case p s c of
276 Just s' -> scanner s' (n+1) t'
319 Just s' -> scanner s' (n+1) t'
277− Nothing -> Finished n t
320+ Nothing -> Finished s n t
278 Nothing -> Continue s
321 Nothing -> Continue s
279 go acc s = do
322 go acc s = do
280 input <- get
323 input <- get
281 case scanner s 0 input of
324 case scanner s 0 input of
282− Continue s' -> do continue <- inputSpansChunks (length input)
325+ Continue s' -> do continue <- inputSpansChunks (size input)
283 if continue
326 if continue
284 then go (input : acc) s'
327 then go (input : acc) s'
285 else f s' (input : acc)
328 else f s' (input : acc)
286− Finished n t -> do advance (length input - length t)
329+ Finished s' n t -> do advance (size input - size t)
287− f s (T.take n input : acc)
330+ f s' (T.take n input : acc)
288{-# INLINE scan_ #-}
331{-# INLINE scan_ #-}
290-- | A stateful scanner. The predicate consumes and transforms a
333-- | A stateful scanner. The predicate consumes and transforms a
@@ -300,16 +343,13 @@ scan_ f s0 p = go [] s0
300-- parsers loop until a failure occurs. Careless use will thus result
343-- parsers loop until a failure occurs. Careless use will thus result
301-- in an infinite loop.
344-- in an infinite loop.
302scan :: s -> (s -> Char -> Maybe s) -> Parser Text
345scan :: s -> (s -> Char -> Maybe s) -> Parser Text
303−scan = scan_ $ \_ chunks ->
346+scan = scan_ $ \_ chunks -> return $! concatReverse chunks
306− xs -> return . T.concat . reverse $ xs
307{-# INLINE scan #-}
347{-# INLINE scan #-}
309-- | Like 'scan', but generalized to return the final state of the
349-- | Like 'scan', but generalized to return the final state of the
310-- scanner.
350-- scanner.
311runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
351runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
312−runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)
352+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)
313{-# INLINE runScanner #-}
353{-# INLINE runScanner #-}
315-- | Consume input as long as the predicate returns 'True', and return
355-- | Consume input as long as the predicate returns 'True', and return
@@ -322,13 +362,14 @@ takeWhile1 :: (Char -> Bool) -> Parser Text
322takeWhile1 p = do
362takeWhile1 p = do
323 (`when` demandInput) =<< endOfChunk
363 (`when` demandInput) =<< endOfChunk
324 h <- T.takeWhile p <$> get
364 h <- T.takeWhile p <$> get
325− let len = length h
365+ let size' = size h
326− when (len == 0) $ fail "takeWhile1"
366+ when (size' == 0) $ fail "takeWhile1"
327− advance len
367+ advance size'
328 eoc <- endOfChunk
368 eoc <- endOfChunk
330− then (h<>) `fmap` takeWhile p
370+ then takeWhileAcc p [h]
331 else return h
371 else return h
372+{-# INLINE takeWhile1 #-}
333-- | Match any character in a set.
374-- | Match any character in a set.
@@ -428,9 +469,10 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
429parseOnly :: Parser a -> Text -> Either String a
470parseOnly :: Parser a -> Text -> Either String a
430parseOnly 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
431− Fail _ _ err -> Left err
473+ Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)
432− Done _ a -> Right a
474+ Done _ a -> Right a
433− _ -> error "parseOnly: impossible error!"
475+ _ -> error "parseOnly: impossible error!"
434{-# INLINE parseOnly #-}
476{-# INLINE parseOnly #-}
436get :: Parser Text
478get :: Parser Text
@@ -475,53 +517,8 @@ ensure n = T.Parser $ \t pos more lose succ ->
475 Just n' -> succ t pos more (n', substring pos n' t)
517 Just n' -> succ t pos more (n', substring pos n' t)
476 -- 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:
477 Nothing -> ensureSuspended n t pos more lose succ
519 Nothing -> ensureSuspended n t pos more lose succ
478−-- Non-recursive so the bounds check can be inlined:
479{-# INLINE ensure #-}
520{-# INLINE ensure #-}
481−-- | Ask for input. If we receive any, pass it to a success
482−-- continuation, otherwise to a failure continuation.
483−prompt :: Buffer -> Pos -> More
484− -> (Buffer -> Pos -> More -> IResult Text r)
485− -> (Buffer -> Pos -> More -> IResult Text r)
487−prompt t pos _more lose succ = Partial $ \s ->
489− then lose t pos Complete
490− else succ (Buf.pappend t s) pos Incomplete
492−-- | Immediately demand more input via a 'Partial' continuation
494−demandInput :: Parser ()
495−demandInput = T.Parser $ \t pos more lose succ ->
497− Complete -> lose t pos more [] "not enough input"
498− _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input"
499− succ' t' pos' more' = succ t' pos' more' ()
500− in prompt t pos more lose' succ'
502−-- | This parser always succeeds. It returns 'True' if any input is
503−-- available either immediately or on demand, and 'False' if the end
504−-- of all input has been reached.
505−wantInput :: Parser Bool
506−wantInput = T.Parser $ \t pos more _lose succ ->
508− _ | pos < lengthOf t -> succ t pos more True
509− | more == Complete -> succ t pos more False
510− | otherwise -> let lose' t' pos' more' = succ t' pos' more' False
511− succ' t' pos' more' = succ t' pos' more' True
512− in prompt t pos more lose' succ'
514−-- | Match only if all input has been consumed.
515−endOfInput :: Parser ()
516−endOfInput = T.Parser $ \t pos more lose succ ->
518− _| pos < lengthOf t -> lose t pos more [] "endOfInput"
519− | more == Complete -> succ t pos more ()
521− let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()
522− succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"
523− in runParser demandInput t pos more lose' succ'
525-- | 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
526-- that was consumed while it was being parsed.
523-- that was consumed while it was being parsed.
527match :: Parser a -> Parser (Text, a)
524match :: Parser a -> Parser (Text, a)
@@ -530,12 +527,8 @@ match p = T.Parser $ \t pos more lose succ ->
530 (substring pos (pos'-pos) t', a)
527 (substring pos (pos'-pos) t', a)
531 in runParser p t pos more lose succ'
528 in runParser p t pos more lose succ'
533−-- | Return an indication of whether the end of input has been
530+-- | Ensure that at least @n@ code points of input are available.
534−-- reached.
531+-- Returns the number of words consumed while traversing.
536−atEnd = not <$> wantInput
539lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
540lengthAtLeast pos n t = go 0 (fromPos pos)
533lengthAtLeast pos n t = go 0 (fromPos pos)
541 where go i !p
534 where go i !p
@@ -552,5 +545,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n
552lengthOf :: Buffer -> Pos
545lengthOf :: Buffer -> Pos
553lengthOf = Pos . Buf.length
546lengthOf = Pos . Buf.length
555−length :: Text -> Pos
548+size :: Text -> Pos
556−length = Pos . T.length
549+size (Text _ _ l) = Pos l