@@ -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-2015
6+-- Copyright : Bryan O'Sullivan 2007-2014
7-- License : BSD3
7-- License : BSD3
9-- Maintainer : bos@serpentine.com
9-- Maintainer : bos@serpentine.com
@@ -65,25 +65,23 @@ module Data.Attoparsec.Text.Internal
68−import Control.Applicative ((<|>), (<$>), pure, (*>))
68+import Control.Applicative ((<|>), (<$>))
69import Control.Monad (when)
69import Control.Monad (when)
70import Data.Attoparsec.Combinator ((<?>))
70import Data.Attoparsec.Combinator ((<?>))
71−import Data.Attoparsec.Internal
72import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
71import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)
73import qualified Data.Attoparsec.Text.Buffer as Buf
72import qualified Data.Attoparsec.Text.Buffer as Buf
74import Data.Attoparsec.Text.Buffer (Buffer, buffer)
73import Data.Attoparsec.Text.Buffer (Buffer, buffer)
75−import Data.Char (isAsciiUpper, isAsciiLower, toUpper, toLower)
74+import Data.Char (chr, ord)
76−import Data.List (intercalate)
77import Data.String (IsString(..))
75import Data.String (IsString(..))
78import Data.Text.Internal (Text(..))
76import Data.Text.Internal (Text(..))
79−import Prelude hiding (getChar, succ, take, takeWhile)
77+import Prelude hiding (getChar, length, succ, take, takeWhile)
80import qualified Data.Attoparsec.Internal.Types as T
78import qualified Data.Attoparsec.Internal.Types as T
81import qualified Data.Attoparsec.Text.FastSet as Set
79import qualified Data.Attoparsec.Text.FastSet as Set
82import qualified Data.Text as T
80import qualified Data.Text as T
83import qualified Data.Text.Lazy as L
81import qualified Data.Text.Lazy as L
84import qualified Data.Text.Unsafe as T
82import qualified Data.Text.Unsafe as T
86−type Parser = T.Parser Text
84+type Parser = T.Parser Text Buffer
87type Result = IResult Text
85type Result = IResult Text
88type Failure r = T.Failure Text Buffer r
86type Failure r = T.Failure Text Buffer r
89type Success a r = T.Success Text Buffer a r
87type Success a r = T.Success Text Buffer a r
@@ -160,46 +158,9 @@ take n = takeWith (max n 0) (const True)
160-- before failing. In attoparsec, the above parser will /succeed/ on
158-- before failing. In attoparsec, the above parser will /succeed/ on
161-- that input, because the failed first branch will consume nothing.
159-- that input, because the failed first branch will consume nothing.
162string :: Text -> Parser Text
160string :: Text -> Parser Text
163−string s = string_ (stringSuspended id) id s
161+string s = takeWith (T.length s) (==s)
164{-# INLINE string #-}
162{-# 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"
203-- | Satisfy a literal string, ignoring case.
164-- | Satisfy a literal string, ignoring case.
205-- Note: this function is currently quite inefficient. Unicode case
166-- Note: this function is currently quite inefficient. Unicode case
@@ -222,24 +183,34 @@ stringCI s = go 0
223-- | Satisfy a literal string, ignoring case for characters in the ASCII range.
184-- | Satisfy a literal string, ignoring case for characters in the ASCII range.
224asciiCI :: Text -> Parser Text
185asciiCI :: Text -> Parser Text
225−asciiCI s = fmap fst $ match $ T.foldr ((*>) . asciiCharCI) (pure ()) s
186+asciiCI input = do
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)
226{-# INLINE asciiCI #-}
201{-# 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 #-}
235-- | Skip past input for as long as the predicate returns 'True'.
203-- | Skip past input for as long as the predicate returns 'True'.
236skipWhile :: (Char -> Bool) -> Parser ()
204skipWhile :: (Char -> Bool) -> Parser ()
237skipWhile p = go
205skipWhile p = go
240 t <- T.takeWhile p <$> get
208 t <- T.takeWhile p <$> get
241− continue <- inputSpansChunks (size t)
209+ advance (length t)
242− when continue go
210+ eoc <- endOfChunk
243{-# INLINE skipWhile #-}
214{-# INLINE skipWhile #-}
245-- | Consume input as long as the predicate returns 'False'
216-- | Consume input as long as the predicate returns 'False'
@@ -267,25 +238,19 @@ takeTill p = takeWhile (not . p)
267-- parsers loop until a failure occurs. Careless use will thus result
238-- parsers loop until a failure occurs. Careless use will thus result
268-- in an infinite loop.
239-- in an infinite loop.
269takeWhile :: (Char -> Bool) -> Parser Text
240takeWhile :: (Char -> Bool) -> Parser Text
270−takeWhile p = do
241+takeWhile p = (T.concat . reverse) `fmap` go []
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
282 go acc = do
243 go acc = do
283 h <- T.takeWhile p <$> get
244 h <- T.takeWhile p <$> get
284− continue <- inputSpansChunks (size h)
245+ advance (length h)
285− if continue
246+ eoc <- endOfChunk
286− then go (h:acc)
251+ then go (h:acc)
287− else return $ concatReverse (h:acc)
252+ else return (h:acc)
288−{-# INLINE takeWhileAcc #-}
253+ else return (h:acc)
290takeRest :: Parser [Text]
255takeRest :: Parser [Text]
291takeRest = go []
256takeRest = go []
@@ -295,7 +260,7 @@ takeRest = go []
298− advance (size s)
263+ advance (length s)
299 go (s:acc)
264 go (s:acc)
300 else return (reverse acc)
265 else return (reverse acc)
@@ -308,7 +273,7 @@ takeLazyText :: Parser L.Text
308takeLazyText = L.fromChunks `fmap` takeRest
273takeLazyText = L.fromChunks `fmap` takeRest
310data Scan s = Continue s
275data Scan s = Continue s
311− | Finished s {-# UNPACK #-} !Int Text
276+ | Finished {-# UNPACK #-} !Int Text
313scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
278scan_ :: (s -> [Text] -> Parser r) -> s -> (s -> Char -> Maybe s) -> Parser r
314scan_ f s0 p = go [] s0
279scan_ f s0 p = go [] s0
@@ -317,17 +282,18 @@ scan_ f s0 p = go [] s0
317 case T.uncons t of
282 case T.uncons t of
318 Just (c,t') -> case p s c of
283 Just (c,t') -> case p s c of
319 Just s' -> scanner s' (n+1) t'
284 Just s' -> scanner s' (n+1) t'
320− Nothing -> Finished s n t
285+ Nothing -> Finished n t
321 Nothing -> Continue s
286 Nothing -> Continue s
322 go acc s = do
287 go acc s = do
323 input <- get
288 input <- get
324 case scanner s 0 input of
289 case scanner s 0 input of
325− Continue s' -> do continue <- inputSpansChunks (size input)
290+ Continue s' -> do advance (length input)
326− if continue
291+ more <- wantInput
327 then go (input : acc) s'
293 then go (input : acc) s'
328 else f s' (input : acc)
294 else f s' (input : acc)
329− Finished s' n t -> do advance (size input - size t)
295+ Finished n t -> do advance (length input - length t)
330− f s' (T.take n input : acc)
296+ f s (T.take n input : acc)
331{-# INLINE scan_ #-}
297{-# INLINE scan_ #-}
333-- | A stateful scanner. The predicate consumes and transforms a
299-- | A stateful scanner. The predicate consumes and transforms a
@@ -343,13 +309,16 @@ scan_ f s0 p = go [] s0
343-- parsers loop until a failure occurs. Careless use will thus result
309-- parsers loop until a failure occurs. Careless use will thus result
344-- in an infinite loop.
310-- in an infinite loop.
345scan :: s -> (s -> Char -> Maybe s) -> Parser Text
311scan :: s -> (s -> Char -> Maybe s) -> Parser Text
346−scan = scan_ $ \_ chunks -> return $! concatReverse chunks
312+scan = scan_ $ \_ chunks ->
315+ xs -> return . T.concat . reverse $ xs
347{-# INLINE scan #-}
316{-# INLINE scan #-}
349-- | Like 'scan', but generalized to return the final state of the
318-- | Like 'scan', but generalized to return the final state of the
350-- scanner.
319-- scanner.
351runScanner :: s -> (s -> Char -> Maybe s) -> Parser (Text, s)
320runScanner :: 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)
353{-# INLINE runScanner #-}
322{-# INLINE runScanner #-}
355-- | Consume input as long as the predicate returns 'True', and return
324-- | Consume input as long as the predicate returns 'True', and return
@@ -362,14 +331,13 @@ takeWhile1 :: (Char -> Bool) -> Parser Text
362takeWhile1 p = do
331takeWhile1 p = do
363 (`when` demandInput) =<< endOfChunk
332 (`when` demandInput) =<< endOfChunk
364 h <- T.takeWhile p <$> get
333 h <- T.takeWhile p <$> get
365− let size' = size h
334+ let len = length h
366− when (size' == 0) $ fail "takeWhile1"
335+ when (len == 0) $ fail "takeWhile1"
367− advance size'
336+ advance len
368 eoc <- endOfChunk
337 eoc <- endOfChunk
370− then takeWhileAcc p [h]
339+ then (h<>) `fmap` takeWhile p
371 else return h
340 else return h
372−{-# INLINE takeWhile1 #-}
374-- | Match any character in a set.
342-- | Match any character in a set.
@@ -469,10 +437,9 @@ parse m s = runParser m (buffer s) 0 Incomplete failK successK
470parseOnly :: Parser a -> Text -> Either String a
438parseOnly :: Parser a -> Text -> Either String a
471parseOnly m s = case runParser m (buffer s) 0 Complete failK successK of
439parseOnly 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)
440+ Fail _ _ err -> Left err
474− Done _ a -> Right a
441+ Done _ a -> Right a
475− _ -> error "parseOnly: impossible error!"
442+ _ -> error "parseOnly: impossible error!"
476{-# INLINE parseOnly #-}
443{-# INLINE parseOnly #-}
478get :: Parser Text
445get :: Parser Text
@@ -485,16 +452,6 @@ endOfChunk = T.Parser $ \t pos more _lose succ ->
485 succ t pos more (pos == lengthOf t)
452 succ t pos more (pos == lengthOf t)
486{-# INLINE endOfChunk #-}
453{-# 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 #-}
498advance :: Pos -> Parser ()
455advance :: Pos -> Parser ()
499advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()
456advance n = T.Parser $ \t pos more _lose succ -> succ t (pos+n) more ()
500{-# INLINE advance #-}
457{-# INLINE advance #-}
@@ -517,8 +474,53 @@ ensure n = T.Parser $ \t pos more lose succ ->
517 Just n' -> succ t pos more (n', substring pos n' t)
474 Just n' -> succ t pos more (n', substring pos n' t)
518 -- The uncommon case is kept out-of-line to reduce code size:
475 -- The uncommon case is kept out-of-line to reduce code size:
519 Nothing -> ensureSuspended n t pos more lose succ
476 Nothing -> ensureSuspended n t pos more lose succ
477+-- Non-recursive so the bounds check can be inlined:
520{-# INLINE ensure #-}
478{-# 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'
522-- | Return both the result of a parse and the portion of the input
524-- | Return both the result of a parse and the portion of the input
523-- that was consumed while it was being parsed.
525-- that was consumed while it was being parsed.
524match :: Parser a -> Parser (Text, a)
526match :: Parser a -> Parser (Text, a)
@@ -527,8 +529,12 @@ match p = T.Parser $ \t pos more lose succ ->
527 (substring pos (pos'-pos) t', a)
529 (substring pos (pos'-pos) t', a)
528 in runParser p t pos more lose succ'
530 in runParser p t pos more lose succ'
530−-- | Ensure that at least @n@ code points of input are available.
532+-- | Return an indication of whether the end of input has been
531−-- Returns the number of words consumed while traversing.
533+-- reached.
535+atEnd = not <$> wantInput
532lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
538lengthAtLeast :: Pos -> Int -> Buffer -> Maybe Pos
533lengthAtLeast pos n t = go 0 (fromPos pos)
539lengthAtLeast pos n t = go 0 (fromPos pos)
534 where go i !p
540 where go i !p
@@ -545,5 +551,5 @@ substring (Pos pos) (Pos n) = Buf.substring pos n
545lengthOf :: Buffer -> Pos
551lengthOf :: Buffer -> Pos
546lengthOf = Pos . Buf.length
552lengthOf = Pos . Buf.length
548−size :: Text -> Pos
554+length :: Text -> Pos
549−size (Text _ _ l) = Pos l
555+length = Pos . T.length