module Data.ParserCombinators.Attoparsec.Internal
(
ParseError
, Parser
, parse
, parseAt
, parseTest
, (<?>)
, try
, manyTill
, eof
, skipMany
, skipMany1
, count
, lookAhead
, peek
, sepBy
, sepBy1
, satisfy
, anyWord8
, word8
, notWord8
, string
, stringTransform
, eitherP
, getInput
, getConsumed
, takeWhile
, takeWhile1
, takeTill
, takeAll
, skipWhile
, notEmpty
, match
) where
import Control.Applicative (Alternative(..), Applicative(..), (<$>))
import Control.Monad (MonadPlus(..), ap, liftM2)
import Control.Monad.Fix (MonadFix(..))
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Internal as I
import Data.Int (Int64)
import Data.Word (Word8)
import Prelude hiding (takeWhile)
type ParseError = String
data S = S !SB.ByteString
LB.ByteString
!Int64
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
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])
instance MonadFix Parser where
mfix f = Parser $ \s ->
let r = case r of
Right (a, _) -> unParser (f a) s
err -> err
in r
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
instance Applicative Parser where
pure = return
(<*>) = ap
instance Alternative Parser where
empty = zero
(<|>) = plus
mkState :: LB.ByteString -> Int64 -> S
mkState s = case s of
I.Empty -> S SB.empty s
I.Chunk x xs -> S x xs
(+:) :: SB.ByteString -> LB.ByteString -> LB.ByteString
sb +: lb | SB.null sb = lb
| otherwise = I.Chunk sb lb
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
I.Chunk sb' lb' -> Right ((), S sb' lb' n)
I.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 :: (Word8 -> Bool) -> Parser Word8
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
anyWord8 :: Parser Word8
anyWord8 = satisfy $ const True
word8 :: Word8 -> Parser Word8
word8 c = satisfy (== c) <?> show c
notWord8 :: Word8 -> Parser Word8
notWord8 c = satisfy (/= c) <?> "not " ++ show c
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, [])
stringTransform :: (LB.ByteString -> LB.ByteString) -> LB.ByteString
-> Parser LB.ByteString
stringTransform f s = Parser $ \(S sb lb n) ->
let bs = sb +: lb
l = LB.length s
(h, t) = LB.splitAt l bs
in if fs == f h
then Right (s, mkState t (n + l))
else Left (bs, [])
where fs = f 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))
takeWhile :: (Word8 -> Bool) -> Parser LB.ByteString
takeWhile p =
Parser $ \(S sb lb n) ->
case LB.span p (sb +: lb) of
(h,t) -> Right (h, mkState t (n + LB.length h))
takeTill :: (Word8 -> Bool) -> Parser LB.ByteString
takeTill p =
Parser $ \(S sb lb n) ->
case LB.span (not . p) (sb +: lb) of
(h,t) | LB.null t -> Left (h, [])
| otherwise -> Right (h, mkState t (n + LB.length h))
takeWhile1 :: (Word8 -> Bool) -> Parser LB.ByteString
takeWhile1 p =
Parser $ \(S sb lb n) ->
case LB.span p (sb +: lb) of
(h,t) | LB.null h -> Left (t, [])
| otherwise -> Right (h, mkState t (n + LB.length h))
skipWhile :: (Word8 -> Bool) -> Parser ()
skipWhile p = takeWhile p >> 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, Int64))
parseAt p bs n =
case unParser p (mkState bs n) of
Left (bs', msg) -> (bs', Left $ showError msg)
Right (a, S sb lb n') -> (sb +: lb, Right (a, n'))
where
showError [""] = "Parser error\n"
showError [msg] = "Parser error, expected:\n" ++ msg ++ "\n"
showError [] = "Parser error\n"
showError msgs = "Parser error, expected one of:\n" ++ unlines msgs
parse :: Parser a -> LB.ByteString
-> (LB.ByteString, Either ParseError a)
parse p bs = case parseAt p bs 0 of
(bs', Right (a, _)) -> (bs', Right a)
(bs', Left err) -> (bs', Left err)
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