module Data.Attoparsec.Text.Internal
(
Parser
, Result(..)
, parse
, parseOnly
, (<?>)
, try
, module Data.Attoparsec.Combinator
, satisfy
, satisfyWith
, anyChar
, skip
, char
, notChar
, inClass
, notInClass
, digit
, letter
, space
, skipWhile
, skipSpace
, string
, stringTransform
, take
, scan
, takeWhile
, takeWhile1
, takeTill
, takeText
, takeLazyText
, decimal
, hexadecimal
, signed
, double
, rational
, endOfInput
, atEnd
, ensure
, endOfLine
) where
import Control.Applicative (Alternative(..), Applicative(..), (<$>))
import Control.Monad (MonadPlus(..), when)
import Data.Attoparsec.Combinator
import Data.Attoparsec.Text.FastSet (charClass, member)
import Data.Char
import Data.Monoid (Monoid(..))
import Data.Ratio ((%))
import Data.String (IsString(..))
import Prelude hiding (getChar, take, takeWhile)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
data Result r = Fail T.Text [String] String
| Partial (T.Text -> Result r)
| Done T.Text r
instance Show r => Show (Result r) where
show (Fail bs stk msg) =
"Fail " ++ show bs ++ " " ++ show stk ++ " " ++ show msg
show (Partial _) = "Partial _"
show (Done bs r) = "Done " ++ show bs ++ " " ++ show r
fmapR :: (a -> b) -> Result a -> Result b
fmapR _ (Fail st stk msg) = Fail st stk msg
fmapR f (Partial k) = Partial (fmapR f . k)
fmapR f (Done bs r) = Done bs (f r)
instance Functor Result where
fmap = fmapR
newtype Input = I {unI :: T.Text}
newtype Added = A {unA :: T.Text}
newtype Parser a = Parser {
runParser :: forall r. Input -> Added -> More
-> Failure r
-> Success a r
-> Result r
}
type Failure r = Input -> Added -> More -> [String] -> String -> Result r
type Success a r = Input -> Added -> More -> a -> Result r
instance IsString (Parser T.Text) where
fromString = string . T.pack
data More = Complete | Incomplete
deriving (Eq, Show)
addS :: Input -> Added -> More
-> Input -> Added -> More
-> (Input -> Added -> More -> r) -> r
addS i0 a0 m0 _i1 a1 m1 f =
let !i = I (unI i0 +++ unA a1)
a = A (unA a0 +++ unA a1)
!m = m0 <> m1
in f i a m
where
Complete <> _ = Complete
_ <> Complete = Complete
_ <> _ = Incomplete
bindP :: Parser a -> (a -> Parser b) -> Parser b
bindP m g =
Parser $ \i0 a0 m0 kf ks -> runParser m i0 a0 m0 kf $
\i1 a1 m1 a -> runParser (g a) i1 a1 m1 kf ks
returnP :: a -> Parser a
returnP a = Parser (\i0 a0 m0 _kf ks -> ks i0 a0 m0 a)
instance Monad Parser where
return = returnP
(>>=) = bindP
fail = failDesc
noAdds :: Input -> Added -> More
-> (Input -> Added -> More -> r) -> r
noAdds i0 _a0 m0 f = f i0 (A T.empty) m0
plus :: Parser a -> Parser a -> Parser a
plus a b = Parser $ \i0 a0 m0 kf ks ->
let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $
\ i2 a2 m2 -> runParser b i2 a2 m2 kf ks
in noAdds i0 a0 m0 $ \i2 a2 m2 -> runParser a i2 a2 m2 kf' ks
instance MonadPlus Parser where
mzero = failDesc "mzero"
mplus = plus
fmapP :: (a -> b) -> Parser a -> Parser b
fmapP p m = Parser $ \i0 a0 m0 f k ->
runParser m i0 a0 m0 f $ \i1 a1 s1 a -> k i1 a1 s1 (p a)
instance Functor Parser where
fmap = fmapP
apP :: Parser (a -> b) -> Parser a -> Parser b
apP d e = do
b <- d
a <- e
return (b a)
instance Applicative Parser where
pure = returnP
(<*>) = apP
(*>) = (>>)
x <* y = x >>= \a -> y >> return a
instance Monoid (Parser a) where
mempty = failDesc "mempty"
mappend = plus
instance Alternative Parser where
empty = failDesc "empty"
(<|>) = plus
failDesc :: String -> Parser a
failDesc err = Parser (\i0 a0 m0 kf _ks -> kf i0 a0 m0 [] msg)
where msg = "Failed reading: " ++ err
ensure :: Int -> Parser T.Text
ensure !n = 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 = Parser $ \i0 a0 m0 kf ks ->
if m0 == Complete
then kf i0 a0 m0 ["demandInput"] "not enough characters"
else let kf' i a m = kf i a m ["demandInput"] "not enough characters"
ks' i a m = ks i a m ()
in prompt i0 a0 m0 kf' ks'
wantInput :: Parser Bool
wantInput = 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 T.Text
get = Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)
put :: T.Text -> Parser ()
put s = Parser $ \_i0 a0 m0 _kf ks -> ks (I s) a0 m0 ()
(+++) :: T.Text -> T.Text -> T.Text
(+++) = T.append
try :: Parser a -> Parser a
try p = Parser $ \i0 a0 m0 kf ks ->
noAdds i0 a0 m0 $ \i1 a1 m1 ->
let kf' i2 a2 m2 = addS i0 a0 m0 i2 a2 m2 kf
in runParser p i1 a1 m1 kf' ks
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do
s <- ensure 1
case T.uncons s of
Just (h,t) | p h -> put t >> return h
| otherwise -> fail "satisfy"
Nothing -> error "Data.Attoparsec.Text.Internal.satisfy: never here"
skip :: (Char -> Bool) -> Parser ()
skip p = do
s <- ensure 1
case T.uncons s of
Just (h,t) | p h -> put t
| otherwise -> fail "skip"
Nothing -> error "Data.Attoparsec.Text.Internal.skip: never here"
satisfyWith :: (Char -> a) -> (a -> Bool) -> Parser a
satisfyWith f p = do
s <- ensure 1
let Just (h,t) = T.uncons s
c = f h
if p c
then put t >> return c
else fail "satisfyWith"
digit :: Parser Char
digit = satisfy isDigit <?> "digit"
letter :: Parser Char
letter = satisfy isLetter <?> "letter"
space :: Parser Char
space = satisfy isSpace <?> "space"
takeWith :: Int -> (T.Text -> Bool) -> Parser T.Text
takeWith n p = do
s <- ensure n
let (h,t) = T.splitAt n s
if p h
then put t >> return h
else failDesc "takeWith"
take :: Int -> Parser T.Text
take n = takeWith n (const True)
string :: T.Text -> Parser T.Text
string s = takeWith (T.length s) (==s)
stringTransform :: (T.Text -> T.Text) -> T.Text
-> Parser T.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
skipSpace :: Parser ()
skipSpace = skipWhile isSpace >> return ()
takeTill :: (Char -> Bool) -> Parser T.Text
takeTill p = takeWhile (not . p)
takeWhile :: (Char -> Bool) -> Parser T.Text
takeWhile p = (T.concat . reverse) `fmap` go []
where
go acc = do
#if MIN_VERSION_text(0,11,0)
(h,t) <- T.span p <$> get
#else
(h,t) <- T.spanBy p <$> get
#endif
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 [T.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 T.Text
takeText = T.concat `fmap` takeRest
takeLazyText :: Parser TL.Text
takeLazyText = TL.fromChunks `fmap` takeRest
scan :: s -> (s -> Char -> Maybe s) -> Parser T.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
Nothing -> Continue s
Just (c,t') -> case p s c of
Just s' -> scanner s' (n+1) t'
Nothing -> Finished n t
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)
data ScannnerResult s = Continue s | Finished !Int !T.Text
takeWhile1 :: (Char -> Bool) -> Parser T.Text
takeWhile1 p = do
(`when` demandInput) =<< T.null <$> get
#if MIN_VERSION_text(0,11,0)
(h,t) <- T.span p <$> get
#else
(h,t) <- T.spanBy p <$> get
#endif
when (T.null h) $ failDesc "takeWhile1"
put t
if T.null t
then (h+++) `fmapP` takeWhile p
else return h
inClass :: String -> Char -> Bool
inClass s = (`member` mySet)
where mySet = 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
decimal :: Integral a => Parser a
decimal = T.foldl' step 0 `fmap` takeWhile1 asciiIsDigit
where step a w = a * 10 + fromIntegral (fromEnum w 48)
asciiIsDigit :: Char -> Bool
asciiIsDigit c = c >= '0' && c <= '9'
hexadecimal :: Integral a => Parser a
hexadecimal = T.foldl' step 0 `fmap` takeWhile1 asciiIsHexDigit
where step a c | c >= '0' && c <= '9' = a * 16 + fromIntegral (fromEnum c 48)
| otherwise = a * 16 + fromIntegral (asciiToLower c 87)
asciiIsHexDigit :: Char -> Bool
asciiIsHexDigit c = asciiIsDigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')
asciiToLower :: Char -> Int
asciiToLower c | c >= 'A' && c <= 'Z' = fromEnum c + 32
| otherwise = fromEnum c
signed :: Num a => Parser a -> Parser a
signed p = (negate <$> (char '-' *> p))
<|> (char '+' *> p)
<|> p
rational :: RealFloat a => Parser a
rational = floaty $ \real frac fracDenom -> fromRational $
real % 1 + frac % fracDenom
double :: Parser Double
double = floaty $ \real frac fracDenom ->
fromIntegral real +
fromIntegral frac / fromIntegral fracDenom
data T = T !Integer !Int
floaty :: RealFloat a => (Integer -> Integer -> Integer -> a) -> Parser a
floaty f = do
sign <- satisfy (\c -> c == '-' || c == '+') <|> return '+'
real <- decimal
let tryFraction = do
_ <- satisfy (== '.')
ds <- takeWhile asciiIsDigit
case (case parse decimal ds of
Partial k -> k T.empty
r -> r) of
Done _ n -> return $ T n (T.length ds)
_ -> fail "no digits after decimal"
T fraction fracDigits <- tryFraction <|> return (T 0 0)
let e c = c == 'e' || c == 'E'
power <- (satisfy e *> signed decimal) <|> return (0 :: Int)
let n = if fracDigits == 0
then if power == 0
then fromIntegral real
else fromIntegral real * (10 ^^ power)
else if power == 0
then f real fraction (10 ^ fracDigits)
else f real fraction (10 ^ fracDigits) * (10 ^^ power)
return $! if sign == '+' then n else n
endOfInput :: Parser ()
endOfInput = 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 (T.pack "\r\n") >> return ())
(<?>) :: Parser a
-> String
-> Parser a
p <?> msg0 = 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 -> T.Text -> Result a
parse m s = runParser m (I s) (A T.empty) Incomplete failK successK
parseOnly :: Parser a -> T.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!"