@@ -3,7 +3,7 @@
33{-# OPTIONS_GHC -fno-warn-orphans #-}
44-- |
55-- Module : Data.Attoparsec.Text.Internal
6−-- Copyright : Bryan O'Sullivan 2007-2015
6+-- Copyright : Bryan O'Sullivan 2007-2014
77-- License : BSD3
88--
99-- Maintainer : bos@serpentine.com
@@ -65,25 +65,23 @@ module Data.Attoparsec.Text.Internal
6565 , atEnd
6666 ) where
6767
68−import Control.Applicative ((<|>), (<$>), pure, (*>))
68+import Control.Applicative ((<|>), (<$>))
6969import Control.Monad (when)
7070import Data.Attoparsec.Combinator ((<?>))
71−import Data.Attoparsec.Internal
7271import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
7372import qualified Data.Attoparsec.Text.Buffer as Buf
7473import Data.Attoparsec.Text.Buffer (Buffer, buffer)
75−import Data.Char (isAsciiUpper, isAsciiLower, toUpper, toLower)
76−import Data.List (intercalate)
74+import Data.Char (chr, ord)
7775import Data.String (IsString(..))
7876import Data.Text.Internal (Text(..))
79−import Prelude hiding (getChar, succ, take, takeWhile)
77+import Prelude hiding (getChar, length, succ, take, takeWhile)
8078import qualified Data.Attoparsec.Internal.Types as T
8179import qualified Data.Attoparsec.Text.FastSet as Set
8280import qualified Data.Text as T
8381import qualified Data.Text.Lazy as L
8482import qualified Data.Text.Unsafe as T
8583
86−type Parser = T.Parser Text
84+type Parser = T.Parser Text Buffer
8785type Result = IResult Text
8886type Failure r = T.Failure Text Buffer r
8987type Success a r = T.Success Text Buffer a r
@@ -160,46 +158,9 @@ take n = takeWith (max n 0) (const True)
160158-- before failing. In attoparsec, the above parser will /succeed/ on
161159-- that input, because the failed first branch will consume nothing.
162160string :: Text -> Parser Text
163−string s = string_ (stringSuspended id) id s
161+string s = takeWith (T.length s) (==s)
164162{-# INLINE string #-}
165163
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−
203164-- | Satisfy a literal string, ignoring case.
204165--
205166-- Note: this function is currently quite inefficient. Unicode case
@@ -222,24 +183,34 @@ stringCI s = go 0
222183
223184-- | Satisfy a literal string, ignoring case for characters in the ASCII range.
224185asciiCI :: Text -> Parser Text
225−asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s
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
226201{-# INLINE asciiCI #-}
227202
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−
235203-- | Skip past input for as long as the predicate returns 'True'.
236204skipWhile :: (Char -> Bool) -> Parser ()
237205skipWhile p = go
238206 where
239207 go = do
240208 t <- T.takeWhile p <$> get
241− continue <- inputSpansChunks (size t)
242− when continue go
209+ advance (length t)
210+ eoc <- endOfChunk
211+ when eoc $ do
212+ input <- wantInput
213+ when input go
243214{-# INLINE skipWhile #-}
244215
245216-- | Consume input as long as the predicate returns 'False'
@@ -267,25 +238,19 @@ takeTill p = takeWhile (not . p)
267238-- parsers loop until a failure occurs. Careless use will thus result
268239-- in an infinite loop.
269240takeWhile :: (Char -> Bool) -> Parser Text
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
241+takeWhile p = (T.concat . reverse) `fmap` go []
281242 where
282243 go acc = do
283244 h <- T.takeWhile p <$> get
284− continue <- inputSpansChunks (size h)
285− if continue
286− then go (h:acc)
287− else return $ concatReverse (h:acc)
288−{-# INLINE takeWhileAcc #-}
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)
289254
290255takeRest :: Parser [Text]
291256takeRest = go []
@@ -295,7 +260,7 @@ takeRest = go []
295260 if input
296261 then do
297262 s <- get
298− advance (size s)
263+ advance (length s)
299264 go (s:acc)
300265 else return (reverse acc)
301266
@@ -308,7 +273,7 @@ takeLazyText :: Parser L.Text
308273takeLazyText = L.fromChunks `fmap` takeRest
309274
310275data Scan s = Continue s
311− | Finished s {-# UNPACK #-} !Int Text
276+ | Finished {-# UNPACK #-} !Int Text
312277
313278scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
314279scan_ f s0 p = go [] s0
@@ -317,17 +282,18 @@ scan_ f s0 p = go [] s0
317282 case T.uncons t of
318283 Just (c,t') -> case p s c of
319284 Just s' -> scanner s' (n+1) t'
320− Nothing -> Finished s n t
285+ Nothing -> Finished n t
321286 Nothing -> Continue s
322287 go acc s = do
323288 input <- get
324289 case scanner s 0 input of
325− Continue s' -> do continue <- inputSpansChunks (size input)
326− if continue
290+ Continue s' -> do advance (length input)
291+ more <- wantInput
292+ if more
327293 then go (input : acc) s'
328294 else f s' (input : acc)
329− Finished s' n t -> do advance (size input - size t)
330− f s' (T.take n input : acc)
295+ Finished n t -> do advance (length input - length t)
296+ f s (T.take n input : acc)
331297{-# INLINE scan_ #-}
332298
333299-- | A stateful scanner. The predicate consumes and transforms a
@@ -343,13 +309,16 @@ scan_ f s0 p = go [] s0
343309-- parsers loop until a failure occurs. Careless use will thus result
344310-- in an infinite loop.
345311scan :: s -> (s -> Char -> Maybe s) -> Parser Text
346−scan = scan_ $ \_ chunks -> return $! concatReverse chunks
312+scan = scan_ $ \_ chunks ->
313+ case chunks of
314+ [x] -> return x
315+ xs -> return . T.concat . reverse $ xs
347316{-# INLINE scan #-}
348317
349318-- | Like 'scan', but generalized to return the final state of the
350319-- scanner.
351320runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
352−runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)
321+runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)
353322{-# INLINE runScanner #-}
354323
355324-- | Consume input as long as the predicate returns 'True', and return
@@ -362,14 +331,13 @@ takeWhile1 :: (Char -> Bool) -> Parser Text
362331takeWhile1 p = do
363332 (`when` demandInput) =<< endOfChunk
364333 h <- T.takeWhile p <$> get
365− let size' = size h
366− when (size' == 0) $ fail "takeWhile1"
367− advance size'
334+ let len = length h
335+ when (len == 0) $ fail "takeWhile1"
336+ advance len
368337 eoc <- endOfChunk
369338 if eoc
370− then takeWhileAcc p [h]
339+ then (h<>) `fmap` takeWhile p
371340 else return h
372−{-# INLINE takeWhile1 #-}
373341
374342-- | Match any character in a set.
375343--
@@ -469,10 +437,9 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
469437-- @
470438parseOnly :: Parser a -> Text -> Either String a
471439parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of
472− Fail _ [] err -> Left err
473− Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)
474− Done _ a -> Right a
475− _ -> error "parseOnly: impossible error!"
440+ Fail _ _ err -> Left err
441+ Done _ a -> Right a
442+ _ -> error "parseOnly: impossible error!"
476443{-# INLINE parseOnly #-}
477444
478445get :: Parser Text
@@ -485,16 +452,6 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->
485452 succ t pos more (pos == lengthOf t)
486453{-# INLINE endOfChunk #-}
487454
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−
498455advance :: Pos -> Parser ()
499456advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()
500457{-# INLINE advance #-}
@@ -517,8 +474,53 @@ ensure n = T.Parser $ \t pos more lose succ ->
517474 Just n' -> succ t pos more (n', substring pos n' t)
518475 -- The uncommon case is kept out-of-line to reduce code size:
519476 Nothing -> ensureSuspended n t pos more lose succ
477+-- Non-recursive so the bounds check can be inlined:
520478{-# INLINE ensure #-}
521479
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+
522524-- | Return both the result of a parse and the portion of the input
523525-- that was consumed while it was being parsed.
524526match :: Parser a -> Parser (Text, a)
@@ -527,8 +529,12 @@ match p = T.Parser $ \t pos more lose succ ->
527529 (substring pos (pos'-pos) t', a)
528530 in runParser p t pos more lose succ'
529531
530−-- | Ensure that at least @n@ code points of input are available.
531−-- Returns the number of words consumed while traversing.
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+
532538lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
533539lengthAtLeast pos n t = go 0 (fromPos pos)
534540 where go i !p
@@ -545,5 +551,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n
545551lengthOf :: Buffer -> Pos
546552lengthOf = Pos . Buf.length
547553
548−size :: Text -> Pos
549−size (Text _ _ l) = Pos l
554+length :: Text -> Pos
555+length = Pos . T.length