@@ -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,18 +65,16 @@ 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
@@ -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,23 +183,30 @@ 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)
209+ continue <- inputSpansChunks (length t)
242210 when continue go
243211{-# INLINE skipWhile #-}
244212
@@ -267,25 +235,14 @@ takeTill p = takeWhile (not . p)
267235-- parsers loop until a failure occurs. Careless use will thus result
268236-- in an infinite loop.
269237takeWhile :: (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
238+takeWhile p = (T.concat . reverse) `fmap` go []
281239 where
282240 go acc = do
283241 h <- T.takeWhile p <$> get
284− continue <- inputSpansChunks (size h)
242+ continue <- inputSpansChunks (length h)
285243 if continue
286244 then go (h:acc)
287− else return $ concatReverse (h:acc)
288−{-# INLINE takeWhileAcc #-}
245+ else return (h:acc)
289246
290247takeRest :: Parser [Text]
291248takeRest = go []
@@ -295,7 +252,7 @@ takeRest = go []
295252 if input
296253 then do
297254 s <- get
298− advance (size s)
255+ advance (length s)
299256 go (s:acc)
300257 else return (reverse acc)
301258
@@ -308,7 +265,7 @@ takeLazyText :: Parser L.Text
308265takeLazyText = L.fromChunks `fmap` takeRest
309266
310267data Scan s = Continue s
311− | Finished s {-# UNPACK #-} !Int Text
268+ | Finished {-# UNPACK #-} !Int Text
312269
313270scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
314271scan_ f s0 p = go [] s0
@@ -317,17 +274,17 @@ scan_ f s0 p = go [] s0
317274 case T.uncons t of
318275 Just (c,t') -> case p s c of
319276 Just s' -> scanner s' (n+1) t'
320− Nothing -> Finished s n t
277+ Nothing -> Finished n t
321278 Nothing -> Continue s
322279 go acc s = do
323280 input <- get
324281 case scanner s 0 input of
325− Continue s' -> do continue <- inputSpansChunks (size input)
282+ Continue s' -> do continue <- inputSpansChunks (length input)
326283 if continue
327284 then go (input : acc) s'
328285 else f s' (input : acc)
329− Finished s' n t -> do advance (size input - size t)
330− f s' (T.take n input : acc)
286+ Finished n t -> do advance (length input - length t)
287+ f s (T.take n input : acc)
331288{-# INLINE scan_ #-}
332289
333290-- | A stateful scanner. The predicate consumes and transforms a
@@ -343,13 +300,16 @@ scan_ f s0 p = go [] s0
343300-- parsers loop until a failure occurs. Careless use will thus result
344301-- in an infinite loop.
345302scan :: s -> (s -> Char -> Maybe s) -> Parser Text
346−scan = scan_ $ \_ chunks -> return $! concatReverse chunks
303+scan = scan_ $ \_ chunks ->
304+ case chunks of
305+ [x] -> return x
306+ xs -> return . T.concat . reverse $ xs
347307{-# INLINE scan #-}
348308
349309-- | Like 'scan', but generalized to return the final state of the
350310-- scanner.
351311runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
352−runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)
312+runScanner = scan_ $ \s xs -> return (T.concat (reverse xs), s)
353313{-# INLINE runScanner #-}
354314
355315-- | Consume input as long as the predicate returns 'True', and return
@@ -362,14 +322,13 @@ takeWhile1 :: (Char -> Bool) -> Parser Text
362322takeWhile1 p = do
363323 (`when` demandInput) =<< endOfChunk
364324 h <- T.takeWhile p <$> get
365− let size' = size h
366− when (size' == 0) $ fail "takeWhile1"
367− advance size'
325+ let len = length h
326+ when (len == 0) $ fail "takeWhile1"
327+ advance len
368328 eoc <- endOfChunk
369329 if eoc
370− then takeWhileAcc p [h]
330+ then (h<>) `fmap` takeWhile p
371331 else return h
372−{-# INLINE takeWhile1 #-}
373332
374333-- | Match any character in a set.
375334--
@@ -469,10 +428,9 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
469428-- @
470429parseOnly :: Parser a -> Text -> Either String a
471430parseOnly 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!"
431+ Fail _ _ err -> Left err
432+ Done _ a -> Right a
433+ _ -> error "parseOnly: impossible error!"
476434{-# INLINE parseOnly #-}
477435
478436get :: Parser Text
@@ -517,8 +475,53 @@ ensure n = T.Parser $ \t pos more lose succ ->
517475 Just n' -> succ t pos more (n', substring pos n' t)
518476 -- The uncommon case is kept out-of-line to reduce code size:
519477 Nothing -> ensureSuspended n t pos more lose succ
478+-- Non-recursive so the bounds check can be inlined:
520479{-# INLINE ensure #-}
521480
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+
522525-- | Return both the result of a parse and the portion of the input
523526-- that was consumed while it was being parsed.
524527match :: Parser a -> Parser (Text, a)
@@ -527,8 +530,12 @@ match p = T.Parser $ \t pos more lose succ ->
527530 (substring pos (pos'-pos) t', a)
528531 in runParser p t pos more lose succ'
529532
530−-- | Ensure that at least @n@ code points of input are available.
531−-- Returns the number of words consumed while traversing.
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+
532539lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
533540lengthAtLeast pos n t = go 0 (fromPos pos)
534541 where go i !p
@@ -545,5 +552,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n
545552lengthOf :: Buffer -> Pos
546553lengthOf = Pos . Buf.length
547554
548−size :: Text -> Pos
549−size (Text _ _ l) = Pos l
555+length :: Text -> Pos
556+length = Pos . T.length