module Data.Attoparsec.Text.Internal
(
Parser
, Result(..)
, S(input)
, parse
, (<?>)
, try
, module Data.Attoparsec.Combinator
, satisfy
, satisfyWith
, anyChar
, skip
, char
, notChar
, inClass
, notInClass
, digit
, letter
, space
, skipWhile
, skipSpace
, string
, stringTransform
, take
, takeWhile
, takeWhile1
, takeTill
, decimal
, hexadecimal
, signed
, double
, rational
, endOfInput
, 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
data Result r = Fail S [String] String
| Partial (T.Text -> Result r)
| Done S r
newtype Parser a = Parser {
runParser :: forall r. S
-> Failure r
-> Success a r
-> Result r
}
type Failure r = S -> [String] -> String -> Result r
type Success a r = S -> a -> Result r
instance IsString (Parser T.Text) where
fromString = string . T.pack
data More = Complete | Incomplete
deriving (Eq, Show)
plusMore :: More -> More -> More
plusMore Complete _ = Complete
plusMore _ Complete = Complete
plusMore _ _ = Incomplete
instance Monoid More where
mempty = Incomplete
mappend = plusMore
data S = S {
input :: !T.Text
, _added :: !T.Text
, more :: !More
} deriving (Show)
instance Show r => Show (Result r) where
show (Fail _ stack msg) = "Fail " ++ show stack ++ " " ++ show msg
show (Partial _) = "Partial _"
show (Done bs r) = "Done " ++ show bs ++ " " ++ show r
addS :: S -> S -> S
addS (S s0 a0 c0) (S _s1 a1 c1) = S (s0 +++ a1) (a0 +++ a1) (mappend c0 c1)
instance Monoid S where
mempty = S T.empty T.empty Incomplete
mappend = addS
bindP :: Parser a -> (a -> Parser b) -> Parser b
bindP m g =
Parser (\st0 kf ks -> runParser m st0 kf (\s a -> runParser (g a) s kf ks))
returnP :: a -> Parser a
returnP a = Parser (\st0 _kf ks -> ks st0 a)
instance Monad Parser where
return = returnP
(>>=) = bindP
fail = failDesc
noAdds :: S -> S
noAdds (S s0 _a0 c0) = S s0 T.empty c0
plus :: Parser a -> Parser a -> Parser a
plus a b = Parser $ \st0 kf ks ->
let kf' st1 _ _ = runParser b (mappend st0 st1) kf ks
!st2 = noAdds st0
in runParser a st2 kf' ks
instance MonadPlus Parser where
mzero = failDesc "mzero"
mplus = plus
fmapP :: (a -> b) -> Parser a -> Parser b
fmapP p m = Parser (\st0 f k -> runParser m st0 f (\s a -> k s (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 Alternative Parser where
empty = failDesc "empty"
(<|>) = plus
failDesc :: String -> Parser a
failDesc err = Parser (\st0 kf _ks -> kf st0 [] msg)
where msg = "Failed reading: " ++ err
ensure :: Int -> Parser ()
ensure n = Parser $ \st0@(S s0 _a0 _c0) kf ks ->
if T.length s0 >= n
then ks st0 ()
else runParser (demandInput >> ensure n) st0 kf ks
prompt :: S -> (S -> Result r) -> (S -> Result r) -> Result r
prompt (S s0 a0 _c0) kf ks = Partial $ \s ->
if T.null s
then kf $! S s0 a0 Complete
else ks $! S (s0 +++ s) (a0 +++ s) Incomplete
demandInput :: Parser ()
demandInput = Parser $ \st0 kf ks ->
if more st0 == Complete
then kf st0 ["demandInput"] "not enough characters"
else prompt st0 (\st -> kf st ["demandInput"] "not enough characters") (`ks` ())
wantInput :: Parser Bool
wantInput = Parser $ \st0@(S s0 _a0 c0) _kf ks ->
case () of
_ | not (T.null s0) -> ks st0 True
| c0 == Complete -> ks st0 False
| otherwise -> prompt st0 (`ks` False) (`ks` True)
get :: Parser T.Text
get = Parser (\st0 _kf ks -> ks st0 (input st0))
put :: T.Text -> Parser ()
put s = Parser (\(S _s0 a0 c0) _kf ks -> ks (S s a0 c0) ())
(+++) :: T.Text -> T.Text -> T.Text
(+++) = T.append
try :: Parser a -> Parser a
try p = Parser $ \st0 kf ks ->
runParser p (noAdds st0) (kf . mappend st0) ks
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do
ensure 1
s <- get
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
ensure 1
s <- get
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
ensure 1
s <- get
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
ensure n
s <- get
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
input <- wantInput
when input $ do
t <- T.dropWhile p <$> get
put t
when (T.null t) 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 = go []
where
go acc = do
input <- wantInput
if input
then 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 go (h:acc)
else return $ if null acc then h else T.concat $ reverse (h:acc)
else return $ case acc of
[] -> T.empty
[x] -> x
_ -> T.concat $ reverse acc
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 $ \st0@S{..} kf ks ->
if T.null input
then if more == Complete
then ks st0 ()
else let kf' st1 _ _ = ks (mappend st0 st1) ()
ks' st1 _ = kf (mappend st0 st1) [] "endOfInput"
in runParser demandInput st0 kf' ks'
else kf st0 [] "endOfInput"
endOfLine :: Parser ()
endOfLine = (char '\n' >> return ()) <|> (string (T.pack "\r\n") >> return ())
(<?>) :: Parser a
-> String
-> Parser a
p <?> msg = Parser $ \s kf ks -> runParser p s (\s' strs m -> kf s' (msg:strs) m) ks
infix 0 <?>
failK :: Failure a
failK st0 stack msg = Fail st0 stack msg
successK :: Success a a
successK state a = Done state a
parse :: Parser a -> T.Text -> Result a
parse m s = runParser m (S s T.empty Incomplete) failK successK