module Text.ParserCombinators.ByteStringParser
(
ParseError
, Parser
, parse
, parseAt
, parseTest
, succeed
, (<?>)
, try
, manyTill
, eof
, skipMany
, skipMany1
, count
, lookAhead
, peek
, sepBy
, sepBy1
, satisfy
, letter
, digit
, anyChar
, space
, char
, notChar
, string
, stringCI
, eitherP
, getInput
, getConsumed
, takeWhile
, takeWhile1
, takeTill
, takeAll
, skipWhile
, skipSpace
, notEmpty
, match
, inClass
, notInClass
) where
import Control.Applicative (Alternative(..), Applicative(..), (<$>), (<*), (*>))
import Control.Monad (MonadPlus(..), ap, liftM2)
import qualified Data.ByteString.Char8 as SB
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.ByteString.Lazy.Internal as LB
import Data.Char (isDigit, isLetter, isSpace, toLower)
import Data.Int (Int64)
import Text.ParserCombinators.ByteStringParser.FastSet (FastSet, member, set)
import Prelude hiding (takeWhile)
type ParseError = String
data S = S !SB.ByteString
LB.ByteString
!Int64
mkState :: LB.ByteString -> Int64 -> S
mkState s = case s of
LB.Empty -> S SB.empty s
LB.Chunk x xs -> S x xs
newtype Parser a = Parser {
unParser :: S -> Either (LB.ByteString, [String]) (a, S)
}
instance Functor Parser where
fmap f p =
Parser $ \s ->
case unParser p s of
Right (a, s') -> Right (f a, s')
Left err -> Left err
(+:) :: SB.ByteString -> LB.ByteString -> LB.ByteString
sb +: lb | SB.null sb = lb
| otherwise = LB.Chunk sb lb
instance Monad Parser where
return a = Parser $ \s -> Right (a, s)
m >>= f = Parser $ \s ->
case unParser m s of
Right (a, s') -> unParser (f a) s'
Left (s', msgs) -> Left (s', msgs)
fail err = Parser $ \(S sb lb _) -> Left (sb +: lb, [err])
zero :: Parser a
zero = Parser $ \(S sb lb _) -> Left (sb +: lb, [])
plus :: Parser a -> Parser a -> Parser a
plus p1 p2 =
Parser $ \s@(S sb lb _) ->
case unParser p1 s of
Left (_, msgs1) ->
case unParser p2 s of
Left (_, msgs2) -> Left (sb +: lb, (msgs1 ++ msgs2))
ok -> ok
ok -> ok
instance MonadPlus Parser where
mzero = zero
mplus = plus
#ifdef APPLICATIVE_IN_BASE
instance Applicative Parser where
pure = return
(<*>) = ap
instance Alternative Parser where
empty = zero
(<|>) = plus
#endif
succeed :: a -> Parser a
succeed = return
infix 0 <?>
(<?>) :: Parser a -> String -> Parser a
p <?> msg =
Parser $ \s@(S sb lb _) ->
case unParser p s of
(Left _) -> Left (sb +: lb, [msg])
ok -> ok
nextChunk :: Parser ()
nextChunk = Parser $ \(S _ lb n) ->
case lb of
LB.Chunk sb' lb' -> Right ((), S sb' lb' n)
LB.Empty -> Left (lb, [])
getInput :: Parser LB.ByteString
getInput = Parser $ \s@(S sb lb _) -> Right (sb +: lb, s)
getConsumed :: Parser Int64
getConsumed = Parser $ \s@(S _ _ n) -> Right (n, s)
satisfy :: (Char -> Bool) -> Parser Char
satisfy p =
Parser $ \s@(S sb lb n) ->
case SB.uncons sb of
Just (c, sb') | p c -> Right (c, S sb' lb (n + 1))
| otherwise -> Left (sb +: lb, [])
Nothing -> unParser (nextChunk >> satisfy p) s
letter :: Parser Char
letter = satisfy isLetter <?> "letter"
digit :: Parser Char
digit = satisfy isDigit <?> "digit"
anyChar :: Parser Char
anyChar = satisfy $ const True
space :: Parser Char
space = satisfy isSpace <?> "space"
char :: Char -> Parser Char
char c = satisfy (== c) <?> [c]
notChar :: Char -> Parser Char
notChar c = satisfy (/= c) <?> "not " ++ [c]
charClass :: String -> FastSet
charClass = set . SB.pack . go
where go (a:'-':b:xs) = [a..b] ++ go xs
go (x:xs) = x : go xs
go _ = ""
inClass :: String -> Char -> Bool
inClass s = (`member` myset)
where myset = charClass s
notInClass :: String -> Char -> Bool
notInClass s = not . inClass s
sepBy :: Parser a -> Parser s -> Parser [a]
sepBy p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return []) <|> return []
sepBy1 :: Parser a -> Parser s -> Parser [a]
sepBy1 p s = liftM2 (:) p ((s >> sepBy1 p s) <|> return [])
string :: LB.ByteString -> Parser LB.ByteString
string s = Parser $ \(S sb lb n) ->
let bs = sb +: lb
l = LB.length s
(h, t) = LB.splitAt l bs
in if s == h
then Right (s, mkState t (n + l))
else Left (bs, [])
stringCI :: LB.ByteString -> Parser LB.ByteString
stringCI s = Parser $ \(S sb lb n) ->
let bs = sb +: lb
l = LB.length s
(h, t) = LB.splitAt l bs
in if ls == LB.map toLower h
then Right (s, mkState t (n + l))
else Left (bs, [])
where ls = LB.map toLower s
count :: Int -> Parser a -> Parser [a]
count n p = sequence (replicate n p)
try :: Parser a -> Parser a
try p = Parser $ \s@(S sb lb _) ->
case unParser p s of
Left (_, msgs) -> Left (sb +: lb, msgs)
ok -> ok
eof :: Parser ()
eof = Parser $ \s@(S sb lb _) -> if SB.null sb && LB.null lb
then Right ((), s)
else Left (sb +: lb, ["EOF"])
takeAll :: Parser LB.ByteString
takeAll = Parser $ \(S sb lb n) ->
let bs = sb +: lb
in Right (bs, mkState LB.empty (n + LB.length bs))
oneChunk :: SB.ByteString -> LB.ByteString
oneChunk s = LB.Chunk s LB.Empty
length64 :: SB.ByteString -> Int64
length64 = fromIntegral . SB.length
takeWhile :: (Char -> Bool) -> Parser LB.ByteString
takeWhile p = Parser $ \s@(S sb lb n) ->
let (h, t) = SB.span p sb
in if SB.null t
then unParser ((h +:) <$> (nextChunk *> takeWhile p)) s
else Right (oneChunk h, S t lb (n + length64 h))
takeTill :: (Char -> Bool) -> Parser LB.ByteString
takeTill p = takeWhile (not . p) <* satisfy p
takeWhile1 :: (Char -> Bool) -> Parser LB.ByteString
takeWhile1 p = Parser $ \s@(S sb lb n) ->
let (h, t) = SB.span p sb
in if SB.null t
then case unParser (nextChunk >> takeWhile p) s of
Left err -> Left err
Right (xs, s') ->
let bs = h +: xs
in if LB.null bs
then Left (sb +: lb, [])
else Right (bs, s')
else Right (oneChunk h, S t lb (n + length64 h))
skipWhile :: (Char -> Bool) -> Parser ()
skipWhile p = takeWhile p >> return ()
skipSpace :: Parser ()
skipSpace = takeWhile isSpace >> return ()
manyTill :: Parser a -> Parser b -> Parser [a]
manyTill p end = scan
where scan = (end >> return []) <|> liftM2 (:) p scan
skipMany :: Parser a -> Parser ()
skipMany p = scan
where scan = (p >> scan) <|> return ()
skipMany1 :: Parser a -> Parser ()
skipMany1 p = p >> skipMany p
notEmpty :: Parser LB.ByteString -> Parser LB.ByteString
notEmpty p = Parser $ \s ->
case unParser p s of
o@(Right (a, _)) ->
if LB.null a
then Left (a, ["notEmpty"])
else o
x -> x
match :: Parser a -> Parser LB.ByteString
match p = do bs <- getInput
start <- getConsumed
p
end <- getConsumed
return (LB.take (end start) bs)
eitherP :: Parser a -> Parser b -> Parser (Either a b)
eitherP a b = (Left <$> a) <|> (Right <$> b)
peek :: Parser a -> Parser (Maybe a)
peek p = Parser $ \s ->
case unParser p s of
Right (m, _) -> Right (Just m, s)
_ -> Right (Nothing, s)
lookAhead :: Parser a -> Parser a
lookAhead p = Parser $ \s ->
case unParser p s of
Right (m, _) -> Right (m, s)
Left (e, bs) -> Left (e, bs)
parseAt :: Parser a -> LB.ByteString -> Int64
-> (LB.ByteString, Either ParseError a)
parseAt p bs n =
case unParser p (mkState bs n) of
Left (bs', msg) -> (bs', Left $ showError msg)
Right (a, S sb lb _) -> (sb +: lb, Right a)
where
showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
parse :: Parser a -> LB.ByteString
-> (LB.ByteString, Either ParseError a)
parse p bs = parseAt p bs 0
parseTest :: (Show a) => Parser a -> LB.ByteString -> IO ()
parseTest p s =
case parse p s of
(st, Left msg) -> putStrLn $ msg ++ "\nGot:\n" ++ show st
(_, Right r) -> print r