module Data.Attoparsec.Text.Internal
(
Parser
, Result
, parse
, parseOnly
, (<?>)
, try
, module Data.Attoparsec.Combinator
, satisfy
, satisfyWith
, anyChar
, skip
, char
, notChar
, inClass
, notInClass
, skipWhile
, string
, stringTransform
, take
, scan
, takeWhile
, takeWhile1
, takeTill
, takeText
, takeLazyText
, endOfInput
, atEnd
, ensure
, endOfLine
) where
import Control.Applicative ((<|>), (<$>))
import Control.Monad (when)
import Data.Attoparsec.Combinator
import Data.Attoparsec.Internal.Types hiding (Parser, Input, Added, Failure, Success)
import Data.Text (Text)
import Prelude hiding (getChar, take, takeWhile)
import qualified Data.Attoparsec.Internal.Types as T
import qualified Data.Attoparsec.Text.FastSet as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
type Parser a = T.Parser Text a
type Result a = IResult Text a
type Input = T.Input Text
type Added = T.Added Text
type Failure r = T.Failure Text r
type Success a r = T.Success Text a r
ensure :: Int -> Parser Text
ensure !n = T.Parser $ \i0 a0 m0 kf ks ->
if T.length (unI i0) >= n
then ks i0 a0 m0 (unI i0)
else runParser (demandInput >> ensure n) i0 a0 m0 kf ks
prompt :: Input -> Added -> More
-> (Input -> Added -> More -> Result r)
-> (Input -> Added -> More -> Result r)
-> Result r
prompt i0 a0 _m0 kf ks = Partial $ \s ->
if T.null s
then kf i0 a0 Complete
else ks (I (unI i0 <> s)) (A (unA a0 <> s)) Incomplete
demandInput :: Parser ()
demandInput = T.Parser $ \i0 a0 m0 kf ks ->
if m0 == Complete
then kf i0 a0 m0 ["demandInput"] "not enough input"
else let kf' i a m = kf i a m ["demandInput"] "not enough input"
ks' i a m = ks i a m ()
in prompt i0 a0 m0 kf' ks'
wantInput :: Parser Bool
wantInput = T.Parser $ \i0 a0 m0 _kf ks ->
case () of
_ | not (T.null (unI i0)) -> ks i0 a0 m0 True
| m0 == Complete -> ks i0 a0 m0 False
| otherwise -> let kf' i a m = ks i a m False
ks' i a m = ks i a m True
in prompt i0 a0 m0 kf' ks'
get :: Parser Text
get = T.Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)
put :: Text -> Parser ()
put s = T.Parser $ \_i0 a0 m0 _kf ks -> ks (I s) a0 m0 ()
try :: Parser a -> Parser a
try p = p
unsafeHead :: Text -> Char
unsafeHead = T.head
unsafeTail :: Text -> Text
unsafeTail = T.tail
unsafeTake :: Int -> Text -> Text
unsafeTake = T.take
unsafeDrop :: Int -> Text -> Text
unsafeDrop = T.drop
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do
s <- ensure 1
let w = unsafeHead s
if p w
then put (unsafeTail s) >> return w
else fail "satisfy"
skip :: (Char -> Bool) -> Parser ()
skip p = do
s <- ensure 1
if p (unsafeHead s)
then put (unsafeTail s)
else fail "skip"
satisfyWith :: (Char -> a) -> (a -> Bool) -> Parser a
satisfyWith f p = do
s <- ensure 1
let c = f (unsafeHead s)
if p c
then put (unsafeTail s) >> return c
else fail "satisfyWith"
takeWith :: Int -> (Text -> Bool) -> Parser Text
takeWith n p = do
s <- ensure n
let h = unsafeTake n s
t = unsafeDrop n s
if p h
then put t >> return h
else fail "takeWith"
take :: Int -> Parser Text
take n = takeWith n (const True)
string :: Text -> Parser Text
string s = takeWith (T.length s) (==s)
stringTransform :: (Text -> Text) -> Text
-> Parser Text
stringTransform f s = takeWith (T.length s) ((==f s) . f)
skipWhile :: (Char -> Bool) -> Parser ()
skipWhile p = go
where
go = do
t <- T.dropWhile p <$> get
put t
when (T.null t) $ do
input <- wantInput
when input go
takeTill :: (Char -> Bool) -> Parser Text
takeTill p = takeWhile (not . p)
takeWhile :: (Char -> Bool) -> Parser Text
takeWhile p = (T.concat . reverse) `fmap` go []
where
go acc = do
(h,t) <- T.span p <$> get
put t
if T.null t
then do
input <- wantInput
if input
then go (h:acc)
else return (h:acc)
else return (h:acc)
takeRest :: Parser [Text]
takeRest = go []
where
go acc = do
input <- wantInput
if input
then do
s <- get
put T.empty
go (s:acc)
else return (reverse acc)
takeText :: Parser Text
takeText = T.concat `fmap` takeRest
takeLazyText :: Parser L.Text
takeLazyText = L.fromChunks `fmap` takeRest
data Scan s = Continue s
| Finished !Int T.Text
scan :: s -> (s -> Char -> Maybe s) -> Parser Text
scan s0 p = do
chunks <- go [] s0
case chunks of
[x] -> return x
xs -> return . T.concat . reverse $ xs
where
scanner s !n t =
case T.uncons t of
Just (c,t') -> case p s c of
Just s' -> scanner s' (n+1) t'
Nothing -> Finished n t
Nothing -> Continue s
go acc s = do
input <- get
case scanner s 0 input of
Continue s' -> do put T.empty
more <- wantInput
if more
then go (input : acc) s'
else return (input : acc)
Finished n t -> put t >> return (T.take n input : acc)
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 p = do
(`when` demandInput) =<< T.null <$> get
(h,t) <- T.span p <$> get
when (T.null h) $ fail "takeWhile1"
put t
if T.null t
then (h<>) `fmap` takeWhile p
else return h
inClass :: String -> Char -> Bool
inClass s = (`Set.member` mySet)
where mySet = Set.charClass s
notInClass :: String -> Char -> Bool
notInClass s = not . inClass s
anyChar :: Parser Char
anyChar = satisfy $ const True
char :: Char -> Parser Char
char c = satisfy (== c) <?> show c
notChar :: Char -> Parser Char
notChar c = satisfy (/= c) <?> "not " ++ show c
endOfInput :: Parser ()
endOfInput = T.Parser $ \i0 a0 m0 kf ks ->
if T.null (unI i0)
then if m0 == Complete
then ks i0 a0 m0 ()
else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $
\ i2 a2 m2 -> ks i2 a2 m2 ()
ks' i1 a1 m1 _ = addS i0 a0 m0 i1 a1 m1 $
\ i2 a2 m2 -> kf i2 a2 m2 []
"endOfInput"
in runParser demandInput i0 a0 m0 kf' ks'
else kf i0 a0 m0 [] "endOfInput"
atEnd :: Parser Bool
atEnd = not <$> wantInput
endOfLine :: Parser ()
endOfLine = (char '\n' >> return ()) <|> (string "\r\n" >> return ())
(<?>) :: Parser a
-> String
-> Parser a
p <?> msg0 = T.Parser $ \i0 a0 m0 kf ks ->
let kf' i a m strs msg = kf i a m (msg0:strs) msg
in runParser p i0 a0 m0 kf' ks
infix 0 <?>
failK :: Failure a
failK i0 _a0 _m0 stack msg = Fail (unI i0) stack msg
successK :: Success a a
successK i0 _a0 _m0 a = Done (unI i0) a
parse :: Parser a -> Text -> Result a
parse m s = runParser m (I s) (A T.empty) Incomplete failK successK
parseOnly :: Parser a -> Text -> Either String a
parseOnly m s = case runParser m (I s) (A T.empty) Complete failK successK of
Fail _ _ err -> Left err
Done _ a -> Right a
_ -> error "parseOnly: impossible error!"