@@ -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,23 +65,25 @@ 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
81import qualified Data.Text.Lazy as L
83import qualified Data.Text.Lazy as L
82import qualified Data.Text.Unsafe as T
84import qualified Data.Text.Unsafe as T
84−type Parser = T.Parser Text Buffer
86+type Parser = T.Parser Text
85type Result = IResult Text
87type Result = IResult Text
86type Failure r = T.Failure Text Buffer r
88type Failure r = T.Failure Text Buffer r
87type Success a r = T.Success Text Buffer a r
89type Success a r = T.Success Text Buffer a r
@@ -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,34 +222,24 @@ 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− advance (length t)
241+ continue <- inputSpansChunks (size t)
210− eoc <- endOfChunk
242+ when continue go
214{-# INLINE skipWhile #-}
243{-# INLINE skipWhile #-}
216-- | Consume input as long as the predicate returns 'False'
245-- | Consume input as long as the predicate returns 'False'
@@ -238,19 +267,25 @@ takeTill p = takeWhile (not . p)
238-- parsers loop until a failure occurs. Careless use will thus result
267-- parsers loop until a failure occurs. Careless use will thus result
239-- in an infinite loop.
268-- in an infinite loop.
240takeWhile :: (Char -> Bool) -> Parser Text
269takeWhile :: (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
275+ then takeWhileAcc p [h]
277+{-# INLINE takeWhile #-}
279+takeWhileAcc :: (Char -> Bool) -> [Text] -> Parser Text
243 go acc = do
282 go acc = do
244 h <- T.takeWhile p <$> get
283 h <- T.takeWhile p <$> get
245− advance (length h)
284+ continue <- inputSpansChunks (size h)
246− eoc <- endOfChunk
285+ if continue
251− then go (h:acc)
286+ then go (h:acc)
252− else return (h:acc)
287+ else return $ concatReverse (h:acc)
253− else return (h:acc)
288+{-# INLINE takeWhileAcc #-}
255takeRest :: Parser [Text]
290takeRest :: Parser [Text]
256takeRest = go []
291takeRest = go []
@@ -260,7 +295,7 @@ takeRest = go []
263− advance (length s)
298+ advance (size s)
264 go (s:acc)
299 go (s:acc)
265 else return (reverse acc)
300 else return (reverse acc)
@@ -273,7 +308,7 @@ takeLazyText :: Parser L.Text
273takeLazyText = L.fromChunks `fmap` takeRest
308takeLazyText = L.fromChunks `fmap` takeRest
275data Scan s = Continue s
310data Scan s = Continue s
276− | Finished {-# UNPACK #-} !Int Text
311+ | Finished s {-# UNPACK #-} !Int Text
278scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
279scan_ f s0 p = go [] s0
314scan_ f s0 p = go [] s0
@@ -282,18 +317,17 @@ scan_ f s0 p = go [] s0
282 case T.uncons t of
317 case T.uncons t of
283 Just (c,t') -> case p s c of
318 Just (c,t') -> case p s c of
284 Just s' -> scanner s' (n+1) t'
319 Just s' -> scanner s' (n+1) t'
285− Nothing -> Finished n t
320+ Nothing -> Finished s n t
286 Nothing -> Continue s
321 Nothing -> Continue s
287 go acc s = do
322 go acc s = do
288 input <- get
323 input <- get
289 case scanner s 0 input of
324 case scanner s 0 input of
290− Continue s' -> do advance (length input)
325+ Continue s' -> do continue <- inputSpansChunks (size input)
291− more <- wantInput
326+ if continue
293 then go (input : acc) s'
327 then go (input : acc) s'
294 else f s' (input : acc)
328 else f s' (input : acc)
295− Finished n t -> do advance (length input - length t)
329+ Finished s' n t -> do advance (size input - size t)
296− f s (T.take n input : acc)
330+ f s' (T.take n input : acc)
297{-# INLINE scan_ #-}
331{-# INLINE scan_ #-}
299-- | A stateful scanner. The predicate consumes and transforms a
333-- | A stateful scanner. The predicate consumes and transforms a
@@ -309,16 +343,13 @@ scan_ f s0 p = go [] s0
309-- parsers loop until a failure occurs. Careless use will thus result
343-- parsers loop until a failure occurs. Careless use will thus result
310-- in an infinite loop.
344-- in an infinite loop.
311scan :: s -> (s -> Char -> Maybe s) -> Parser Text
345scan :: s -> (s -> Char -> Maybe s) -> Parser Text
312−scan = scan_ $ \_ chunks ->
346+scan = scan_ $ \_ chunks -> return $! concatReverse chunks
315− xs -> return . T.concat . reverse $ xs
316{-# INLINE scan #-}
347{-# INLINE scan #-}
318-- | Like 'scan', but generalized to return the final state of the
349-- | Like 'scan', but generalized to return the final state of the
319-- scanner.
350-- scanner.
320runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
351runScanner :: 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)
322{-# INLINE runScanner #-}
353{-# INLINE runScanner #-}
324-- | Consume input as long as the predicate returns 'True', and return
355-- | Consume input as long as the predicate returns 'True', and return
@@ -331,13 +362,14 @@ takeWhile1 :: (Char -> Bool) -> Parser Text
331takeWhile1 p = do
362takeWhile1 p = do
332 (`when` demandInput) =<< endOfChunk
363 (`when` demandInput) =<< endOfChunk
333 h <- T.takeWhile p <$> get
364 h <- T.takeWhile p <$> get
334− let len = length h
365+ let size' = size h
335− when (len == 0) $ fail "takeWhile1"
366+ when (size' == 0) $ fail "takeWhile1"
336− advance len
367+ advance size'
337 eoc <- endOfChunk
368 eoc <- endOfChunk
339− then (h<>) `fmap` takeWhile p
370+ then takeWhileAcc p [h]
340 else return h
371 else return h
372+{-# INLINE takeWhile1 #-}
342-- | Match any character in a set.
374-- | Match any character in a set.
@@ -437,9 +469,10 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
438parseOnly :: Parser a -> Text -> Either String a
470parseOnly :: Parser a -> Text -> Either String a
439parseOnly 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
440− Fail _ _ err -> Left err
473+ Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)
441− Done _ a -> Right a
474+ Done _ a -> Right a
442− _ -> error "parseOnly: impossible error!"
475+ _ -> error "parseOnly: impossible error!"
443{-# INLINE parseOnly #-}
476{-# INLINE parseOnly #-}
445get :: Parser Text
478get :: Parser Text
@@ -452,6 +485,16 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->
452 succ t pos more (pos == lengthOf t)
485 succ t pos more (pos == lengthOf t)
453{-# INLINE endOfChunk #-}
486{-# INLINE endOfChunk #-}
488+inputSpansChunks :: Pos -> Parser Bool
489+inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->
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 #-}
455advance :: Pos -> Parser ()
498advance :: Pos -> Parser ()
456advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()
499advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()
457{-# INLINE advance #-}
500{-# INLINE advance #-}
@@ -474,53 +517,8 @@ ensure n = T.Parser $ \t pos more lose succ ->
474 Just n' -> succ t pos more (n', substring pos n' t)
517 Just n' -> succ t pos more (n', substring pos n' t)
475 -- 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:
476 Nothing -> ensureSuspended n t pos more lose succ
519 Nothing -> ensureSuspended n t pos more lose succ
477−-- Non-recursive so the bounds check can be inlined:
478{-# INLINE ensure #-}
520{-# INLINE ensure #-}
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)
486−prompt t pos _more lose succ = Partial $ \s ->
488− then lose t pos Complete
489− else succ (t <> buffer s) pos Incomplete
491−-- | Immediately demand more input via a 'Partial' continuation
493−demandInput :: Parser ()
494−demandInput = T.Parser $ \t pos more lose succ ->
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'
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 ->
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'
513−-- | Match only if all input has been consumed.
514−endOfInput :: Parser ()
515−endOfInput = T.Parser $ \t pos more lose succ ->
517− _| pos < lengthOf t -> lose t pos more [] "endOfInput"
518− | more == Complete -> succ t pos more ()
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'
524-- | 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
525-- that was consumed while it was being parsed.
523-- that was consumed while it was being parsed.
526match :: Parser a -> Parser (Text, a)
524match :: Parser a -> Parser (Text, a)
@@ -529,12 +527,8 @@ match p = T.Parser $ \t pos more lose succ ->
529 (substring pos (pos'-pos) t', a)
527 (substring pos (pos'-pos) t', a)
530 in runParser p t pos more lose succ'
528 in runParser p t pos more lose succ'
532−-- | Return an indication of whether the end of input has been
530+-- | Ensure that at least @n@ code points of input are available.
533−-- reached.
531+-- Returns the number of words consumed while traversing.
535−atEnd = not <$> wantInput
538lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
539lengthAtLeast pos n t = go 0 (fromPos pos)
533lengthAtLeast pos n t = go 0 (fromPos pos)
540 where go i !p
534 where go i !p
@@ -551,5 +545,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n
551lengthOf :: Buffer -> Pos
545lengthOf :: Buffer -> Pos
552lengthOf = Pos . Buf.length
546lengthOf = Pos . Buf.length
554−length :: Text -> Pos
548+size :: Text -> Pos
555−length = Pos . T.length
549+size (Text _ _ l) = Pos l