@@ -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,23 +65,25 @@ 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 ((<?>))
71+import Data.Attoparsec.Internal
7172import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
7273import qualified Data.Attoparsec.Text.Buffer as Buf
7374import 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)
7577import Data.String (IsString(..))
7678import Data.Text.Internal (Text(..))
77−import Prelude hiding (getChar, length, succ, take, takeWhile)
79+import Prelude hiding (getChar, succ, take, takeWhile)
7880import qualified Data.Attoparsec.Internal.Types as T
7981import qualified Data.Attoparsec.Text.FastSet as Set
8082import qualified Data.Text as T
8183import qualified Data.Text.Lazy as L
8284import qualified Data.Text.Unsafe as T
8385
84−type Parser = T.Parser Text Buffer
86+type Parser = T.Parser Text
8587type Result = IResult Text
8688type Failure r = T.Failure Text Buffer r
8789type Success a r = T.Success Text Buffer a r
@@ -158,9 +160,46 @@ take n = takeWith (max n 0) (const True)
158160-- before failing. In attoparsec, the above parser will /succeed/ on
159161-- that input, because the failed first branch will consume nothing.
160162string :: Text -> Parser Text
161−string s = takeWith (T.length s) (==s)
163+string s = string_ (stringSuspended id) id s
162164{-# INLINE string #-}
163165
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+
164203-- | Satisfy a literal string, ignoring case.
165204--
166205-- Note: this function is currently quite inefficient. Unicode case
@@ -183,30 +222,23 @@ stringCI s = go 0
183222
184223-- | Satisfy a literal string, ignoring case for characters in the ASCII range.
185224asciiCI :: Text -> Parser Text
186−asciiCI input = do
187− (k,t) <- ensure n
188− if asciiToLower t == s
189− then advance k >> return t
190− else fail "asciiCI"
191− where
192− n = T.length input
193− s = asciiToLower input
194−
195− -- convert letters in the ASCII range to lower-case
196− asciiToLower = T.map f
197− where
198− offset = ord 'a' - ord 'A'
199− f c | 'A' <= c && c <= 'Z' = chr (ord c + offset)
200− | otherwise = c
225+asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s
201226{-# INLINE asciiCI #-}
202227
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+
203235-- | Skip past input for as long as the predicate returns 'True'.
204236skipWhile :: (Char -> Bool) -> Parser ()
205237skipWhile p = go
206238 where
207239 go = do
208240 t <- T.takeWhile p <$> get
209− continue <- inputSpansChunks (length t)
241+ continue <- inputSpansChunks (size t)
210242 when continue go
211243{-# INLINE skipWhile #-}
212244
@@ -235,14 +267,25 @@ takeTill p = takeWhile (not . p)
235267-- parsers loop until a failure occurs. Careless use will thus result
236268-- in an infinite loop.
237269takeWhile :: (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
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
239281 where
240282 go acc = do
241283 h <- T.takeWhile p <$> get
242− continue <- inputSpansChunks (length h)
284+ continue <- inputSpansChunks (size h)
243285 if continue
244286 then go (h:acc)
245− else return (h:acc)
287+ else return $ concatReverse (h:acc)
288+{-# INLINE takeWhileAcc #-}
246289
247290takeRest :: Parser [Text]
248291takeRest = go []
@@ -252,7 +295,7 @@ takeRest = go []
252295 if input
253296 then do
254297 s <- get
255− advance (length s)
298+ advance (size s)
256299 go (s:acc)
257300 else return (reverse acc)
258301
@@ -265,7 +308,7 @@ takeLazyText :: Parser L.Text
265308takeLazyText = L.fromChunks `fmap` takeRest
266309
267310data Scan s = Continue s
268− | Finished {-# UNPACK #-} !Int Text
311+ | Finished s {-# UNPACK #-} !Int Text
269312
270313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
271314scan_ f s0 p = go [] s0
@@ -274,17 +317,17 @@ scan_ f s0 p = go [] s0
274317 case T.uncons t of
275318 Just (c,t') -> case p s c of
276319 Just s' -> scanner s' (n+1) t'
277− Nothing -> Finished n t
320+ Nothing -> Finished s n t
278321 Nothing -> Continue s
279322 go acc s = do
280323 input <- get
281324 case scanner s 0 input of
282− Continue s' -> do continue <- inputSpansChunks (length input)
325+ Continue s' -> do continue <- inputSpansChunks (size input)
283326 if continue
284327 then go (input : acc) s'
285328 else f s' (input : acc)
286− Finished n t -> do advance (length input - length t)
287− 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)
288331{-# INLINE scan_ #-}
289332
290333-- | A stateful scanner. The predicate consumes and transforms a
@@ -300,16 +343,13 @@ scan_ f s0 p = go [] s0
300343-- parsers loop until a failure occurs. Careless use will thus result
301344-- in an infinite loop.
302345scan :: s -> (s -> Char -> Maybe s) -> Parser Text
303−scan = scan_ $ \_ chunks ->
304− case chunks of
305− [x] -> return x
306− xs -> return . T.concat . reverse $ xs
346+scan = scan_ $ \_ chunks -> return $! concatReverse chunks
307347{-# INLINE scan #-}
308348
309349-- | Like 'scan', but generalized to return the final state of the
310350-- scanner.
311351runScanner :: 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)
313353{-# INLINE runScanner #-}
314354
315355-- | Consume input as long as the predicate returns 'True', and return
@@ -322,13 +362,14 @@ takeWhile1 :: (Char -> Bool) -> Parser Text
322362takeWhile1 p = do
323363 (`when` demandInput) =<< endOfChunk
324364 h <- T.takeWhile p <$> get
325− let len = length h
326− when (len == 0) $ fail "takeWhile1"
327− advance len
365+ let size' = size h
366+ when (size' == 0) $ fail "takeWhile1"
367+ advance size'
328368 eoc <- endOfChunk
329369 if eoc
330− then (h<>) `fmap` takeWhile p
370+ then takeWhileAcc p [h]
331371 else return h
372+{-# INLINE takeWhile1 #-}
332373
333374-- | Match any character in a set.
334375--
@@ -428,9 +469,10 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
428469-- @
429470parseOnly :: Parser a -> Text -> Either String a
430471parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of
431− Fail _ _ err -> Left err
432− Done _ a -> Right a
433− _ -> 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!"
434476{-# INLINE parseOnly #-}
435477
436478get :: Parser Text
@@ -475,53 +517,8 @@ ensure n = T.Parser $ \t pos more lose succ ->
475517 Just n' -> succ t pos more (n', substring pos n' t)
476518 -- The uncommon case is kept out-of-line to reduce code size:
477519 Nothing -> ensureSuspended n t pos more lose succ
478−-- Non-recursive so the bounds check can be inlined:
479520{-# INLINE ensure #-}
480521
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)
486− -> IResult Text r
487−prompt t pos _more lose succ = Partial $ \s ->
488− if T.null s
489− then lose t pos Complete
490− else succ (Buf.pappend t s) pos Incomplete
491−
492−-- | Immediately demand more input via a 'Partial' continuation
493−-- result.
494−demandInput :: Parser ()
495−demandInput = T.Parser $ \t pos more lose succ ->
496− case more of
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'
501−
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 ->
507− case () of
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'
513−
514−-- | Match only if all input has been consumed.
515−endOfInput :: Parser ()
516−endOfInput = T.Parser $ \t pos more lose succ ->
517− case () of
518− _| pos < lengthOf t -> lose t pos more [] "endOfInput"
519− | more == Complete -> succ t pos more ()
520− | otherwise ->
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'
524−
525522-- | Return both the result of a parse and the portion of the input
526523-- that was consumed while it was being parsed.
527524match :: Parser a -> Parser (Text, a)
@@ -530,12 +527,8 @@ match p = T.Parser $ \t pos more lose succ ->
530527 (substring pos (pos'-pos) t', a)
531528 in runParser p t pos more lose succ'
532529
533−-- | Return an indication of whether the end of input has been
534−-- reached.
535−atEnd :: Parser Bool
536−atEnd = not <$> wantInput
537−{-# INLINE atEnd #-}
538−
530+-- | Ensure that at least @n@ code points of input are available.
531+-- Returns the number of words consumed while traversing.
539532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
540533lengthAtLeast pos n t = go 0 (fromPos pos)
541534 where go i !p
@@ -552,5 +545,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n
552545lengthOf :: Buffer -> Pos
553546lengthOf = Pos . Buf.length
554547
555−length :: Text -> Pos
556−length = Pos . T.length
548+size :: Text -> Pos
549+size (Text _ _ l) = Pos l