@@ -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,34 +222,24 @@ 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− advance (length t)
210− eoc <- endOfChunk
211− when eoc $ do
212− input <- wantInput
213− when input go
241+ continue <- inputSpansChunks (size t)
242+ when continue go
214243{-# INLINE skipWhile #-}
215244
216245-- | Consume input as long as the predicate returns 'False'
@@ -238,19 +267,25 @@ takeTill p = takeWhile (not . p)
238267-- parsers loop until a failure occurs. Careless use will thus result
239268-- in an infinite loop.
240269takeWhile :: (Char -> Bool) -> Parser Text
241−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
242281 where
243282 go acc = do
244283 h <- T.takeWhile p <$> get
245− advance (length h)
246− eoc <- endOfChunk
247− if eoc
248− then do
249− input <- wantInput
250− if input
251− then go (h:acc)
252− else return (h:acc)
253− else return (h:acc)
284+ continue <- inputSpansChunks (size h)
285+ if continue
286+ then go (h:acc)
287+ else return $ concatReverse (h:acc)
288+{-# INLINE takeWhileAcc #-}
254289
255290takeRest :: Parser [Text]
256291takeRest = go []
@@ -260,7 +295,7 @@ takeRest = go []
260295 if input
261296 then do
262297 s <- get
263− advance (length s)
298+ advance (size s)
264299 go (s:acc)
265300 else return (reverse acc)
266301
@@ -273,7 +308,7 @@ takeLazyText :: Parser L.Text
273308takeLazyText = L.fromChunks `fmap` takeRest
274309
275310data Scan s = Continue s
276− | Finished {-# UNPACK #-} !Int Text
311+ | Finished s {-# UNPACK #-} !Int Text
277312
278313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
279314scan_ f s0 p = go [] s0
@@ -282,18 +317,17 @@ scan_ f s0 p = go [] s0
282317 case T.uncons t of
283318 Just (c,t') -> case p s c of
284319 Just s' -> scanner s' (n+1) t'
285− Nothing -> Finished n t
320+ Nothing -> Finished s n t
286321 Nothing -> Continue s
287322 go acc s = do
288323 input <- get
289324 case scanner s 0 input of
290− Continue s' -> do advance (length input)
291− more <- wantInput
292− if more
325+ Continue s' -> do continue <- inputSpansChunks (size input)
326+ if continue
293327 then go (input : acc) s'
294328 else f s' (input : acc)
295− Finished n t -> do advance (length input - length t)
296− 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)
297331{-# INLINE scan_ #-}
298332
299333-- | A stateful scanner. The predicate consumes and transforms a
@@ -309,16 +343,13 @@ scan_ f s0 p = go [] s0
309343-- parsers loop until a failure occurs. Careless use will thus result
310344-- in an infinite loop.
311345scan :: s -> (s -> Char -> Maybe s) -> Parser Text
312−scan = scan_ $ \_ chunks ->
313− case chunks of
314− [x] -> return x
315− xs -> return . T.concat . reverse $ xs
346+scan = scan_ $ \_ chunks -> return $! concatReverse chunks
316347{-# INLINE scan #-}
317348
318349-- | Like 'scan', but generalized to return the final state of the
319350-- scanner.
320351runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
321−runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)
352+runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)
322353{-# INLINE runScanner #-}
323354
324355-- | Consume input as long as the predicate returns 'True', and return
@@ -331,13 +362,14 @@ takeWhile1 :: (Char -> Bool) -> Parser Text
331362takeWhile1 p = do
332363 (`when` demandInput) =<< endOfChunk
333364 h <- T.takeWhile p <$> get
334− let len = length h
335− when (len == 0) $ fail "takeWhile1"
336− advance len
365+ let size' = size h
366+ when (size' == 0) $ fail "takeWhile1"
367+ advance size'
337368 eoc <- endOfChunk
338369 if eoc
339− then (h<>) `fmap` takeWhile p
370+ then takeWhileAcc p [h]
340371 else return h
372+{-# INLINE takeWhile1 #-}
341373
342374-- | Match any character in a set.
343375--
@@ -437,9 +469,10 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
437469-- @
438470parseOnly :: Parser a -> Text -> Either String a
439471parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of
440− Fail _ _ err -> Left err
441− Done _ a -> Right a
442− _ -> 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!"
443476{-# INLINE parseOnly #-}
444477
445478get :: Parser Text
@@ -452,6 +485,16 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->
452485 succ t pos more (pos == lengthOf t)
453486{-# INLINE endOfChunk #-}
454487
488+inputSpansChunks :: Pos -> Parser Bool
489+inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->
490+ let pos = pos_ + i
491+ in if pos < lengthOf t || more == Complete
492+ then succ t pos more False
493+ else let lose' t' pos' more' = succ t' pos' more' False
494+ succ' t' pos' more' = succ t' pos' more' True
495+ in prompt t pos more lose' succ'
496+{-# INLINE inputSpansChunks #-}
497+
455498advance :: Pos -> Parser ()
456499advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()
457500{-# INLINE advance #-}
@@ -474,53 +517,8 @@ ensure n = T.Parser $ \t pos more lose succ ->
474517 Just n' -> succ t pos more (n', substring pos n' t)
475518 -- The uncommon case is kept out-of-line to reduce code size:
476519 Nothing -> ensureSuspended n t pos more lose succ
477−-- Non-recursive so the bounds check can be inlined:
478520{-# INLINE ensure #-}
479521
480−-- | Ask for input. If we receive any, pass it to a success
481−-- continuation, otherwise to a failure continuation.
482−prompt :: Buffer -> Pos -> More
483− -> (Buffer -> Pos -> More -> IResult Text r)
484− -> (Buffer -> Pos -> More -> IResult Text r)
485− -> IResult Text r
486−prompt t pos _more lose succ = Partial $ \s ->
487− if T.null s
488− then lose t pos Complete
489− else succ (t <> buffer s) pos Incomplete
490−
491−-- | Immediately demand more input via a 'Partial' continuation
492−-- result.
493−demandInput :: Parser ()
494−demandInput = T.Parser $ \t pos more lose succ ->
495− case more of
496− Complete -> lose t pos more [] "not enough input"
497− _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input"
498− succ' t' pos' more' = succ t' pos' more' ()
499− in prompt t pos more lose' succ'
500−
501−-- | This parser always succeeds. It returns 'True' if any input is
502−-- available either immediately or on demand, and 'False' if the end
503−-- of all input has been reached.
504−wantInput :: Parser Bool
505−wantInput = T.Parser $ \t pos more _lose succ ->
506− case () of
507− _ | pos < lengthOf t -> succ t pos more True
508− | more == Complete -> succ t pos more False
509− | otherwise -> let lose' t' pos' more' = succ t' pos' more' False
510− succ' t' pos' more' = succ t' pos' more' True
511− in prompt t pos more lose' succ'
512−
513−-- | Match only if all input has been consumed.
514−endOfInput :: Parser ()
515−endOfInput = T.Parser $ \t pos more lose succ ->
516− case () of
517− _| pos < lengthOf t -> lose t pos more [] "endOfInput"
518− | more == Complete -> succ t pos more ()
519− | otherwise ->
520− let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()
521− succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"
522− in runParser demandInput t pos more lose' succ'
523−
524522-- | Return both the result of a parse and the portion of the input
525523-- that was consumed while it was being parsed.
526524match :: Parser a -> Parser (Text, a)
@@ -529,12 +527,8 @@ match p = T.Parser $ \t pos more lose succ ->
529527 (substring pos (pos'-pos) t', a)
530528 in runParser p t pos more lose succ'
531529
532−-- | Return an indication of whether the end of input has been
533−-- reached.
534−atEnd :: Parser Bool
535−atEnd = not <$> wantInput
536−{-# INLINE atEnd #-}
537−
530+-- | Ensure that at least @n@ code points of input are available.
531+-- Returns the number of words consumed while traversing.
538532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
539533lengthAtLeast pos n t = go 0 (fromPos pos)
540534 where go i !p
@@ -551,5 +545,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n
551545lengthOf :: Buffer -> Pos
552546lengthOf = Pos . Buf.length
553547
554−length :: Text -> Pos
555−length = Pos . T.length
548+size :: Text -> Pos
549+size (Text _ _ l) = Pos l