module Text.Parsec.Prim where
import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
import Control.Monad()
import Control.Monad.Trans
import Control.Monad.Identity
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Text.Parsec.Pos
import Text.Parsec.Error
unknownError :: State s u -> ParseError
unknownError state = newErrorUnknown (statePos state)
sysUnExpectError :: String -> SourcePos -> Reply s u a
sysUnExpectError msg pos = Error (newErrorMessage (SysUnExpect msg) pos)
unexpected :: (Stream s m t) => String -> ParsecT s u m a
unexpected msg
= ParsecT $ \s -> return $ Empty $ return $
Error (newErrorMessage (UnExpect msg) (statePos s))
data ParsecT s u m a
= ParsecT { runParsecT :: State s u -> m (Consumed (m (Reply s u a))) }
type Parsec s u = ParsecT s u Identity
data Consumed a = Consumed a
| Empty !a
data Reply s u a = Ok a !(State s u) ParseError
| Error ParseError
data State s u = State {
stateInput :: s,
statePos :: !SourcePos,
stateUser :: !u
}
instance Functor Consumed where
fmap f (Consumed x) = Consumed (f x)
fmap f (Empty x) = Empty (f x)
instance Functor (Reply s u) where
fmap f (Ok x s e) = Ok (f x) s e
fmap _ (Error e) = Error e
instance (Monad m) => Functor (ParsecT s u m) where
fmap f p = parsecMap f p
parsecMap :: (Monad m) => (a -> b) -> ParsecT s u m a -> ParsecT s u m b
parsecMap f p
= ParsecT $ \s -> liftM (fmap (liftM (fmap f))) (runParsecT p s)
instance (Monad m) => Applicative.Applicative (ParsecT s u m) where
pure = return
(<*>) = ap
instance (Monad m) => Applicative.Alternative (ParsecT s u m) where
empty = mzero
(<|>) = mplus
instance (Monad m) => Monad (ParsecT s u m) where
return x = parserReturn x
p >>= f = parserBind p f
fail msg = parserFail msg
instance (MonadIO m) => MonadIO (ParsecT s u m) where
liftIO = lift . liftIO
instance (MonadReader r m) => MonadReader r (ParsecT s u m) where
ask = lift ask
local f p = ParsecT $ \s -> local f (runParsecT p s)
instance (MonadState s m) => MonadState s (ParsecT s' u m) where
get = lift get
put = lift . put
instance (MonadCont m) => MonadCont (ParsecT s u m) where
callCC f = ParsecT $ \s ->
callCC $ \c ->
runParsecT (f (\a -> ParsecT $ \s' -> c (pack s' a))) s
where pack s a= Empty $ return (Ok a s (unknownError s))
instance (MonadError e m) => MonadError e (ParsecT s u m) where
throwError = lift . throwError
p `catchError` h = ParsecT $ \s ->
runParsecT p s `catchError` \e ->
runParsecT (h e) s
parserReturn :: (Monad m) => a -> ParsecT s u m a
parserReturn x
= ParsecT $ \s -> return $ Empty $ return (Ok x s (unknownError s))
parserBind :: (Monad m)
=> ParsecT s u m a -> (a -> ParsecT s u m b) -> ParsecT s u m b
parserBind p f
= ParsecT $ \s -> do
res1 <- runParsecT p s
case res1 of
Empty mReply1
-> do reply1 <- mReply1
case reply1 of
Ok x s' err1 -> do
res2 <- runParsecT (f x) s'
case res2 of
Empty mReply2
-> do reply2 <- mReply2
return $ Empty $
return $ mergeErrorReply err1 reply2
other
-> do return $ other
Error err1 -> return $ Empty $ return $ Error err1
Consumed mReply1
-> do reply1 <- mReply1
return $ Consumed $
case reply1 of
Ok x s' err1 -> do
res2 <- runParsecT (f x) s'
case res2 of
Empty mReply2
-> do reply2 <- mReply2
return $ mergeErrorReply err1 reply2
Consumed reply2 -> reply2
Error err1 -> return $ Error err1
mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
mergeErrorReply err1 reply
= case reply of
Ok x state err2 -> Ok x state (mergeError err1 err2)
Error err2 -> Error (mergeError err1 err2)
parserFail :: (Monad m) => String -> ParsecT s u m a
parserFail msg
= ParsecT $ \s -> return $ Empty $ return $
Error (newErrorMessage (Message msg) (statePos s))
instance (Monad m) => MonadPlus (ParsecT s u m) where
mzero = parserZero
mplus p1 p2 = parserPlus p1 p2
parserZero :: (Monad m) => ParsecT s u m a
parserZero
= ParsecT $ \s -> return $ Empty $ return $ Error (unknownError s)
parserPlus :: (Monad m)
=> ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
parserPlus (ParsecT p1) (ParsecT p2)
= ParsecT $ \s -> do
c1 <- p1 s
case c1 of
Empty mReply1
-> do r1 <- mReply1
case r1 of
Error err -> do
c2 <- p2 s
case c2 of
Empty mReply2
-> do reply2 <- mReply2
return $ Empty $ return (mergeErrorReply err reply2)
consumed
-> return $ consumed
other -> return $ Empty $ return $ other
other -> return $ other
instance MonadTrans (ParsecT s u) where
lift amb = ParsecT $ \s -> do
a <- amb
return $ Empty $ return $ Ok a s (unknownError s)
infix 0 <?>
infixr 1 <|>
(<?>) :: (Monad m)
=> (ParsecT s u m a) -> String -> (ParsecT s u m a)
p <?> msg = label p msg
(<|>) :: (Monad m)
=> (ParsecT s u m a) -> (ParsecT s u m a) -> (ParsecT s u m a)
p1 <|> p2 = mplus p1 p2
label :: (Monad m) => ParsecT s u m a -> String -> ParsecT s u m a
label p msg
= labels p [msg]
labels :: (Monad m) => ParsecT s u m a -> [String] -> ParsecT s u m a
labels p msgs
= ParsecT $ \s -> do
r <- runParsecT p s
case r of
Empty mReply -> do
reply <- mReply
return $ Empty $ case reply of
Error err
-> return $ Error (setExpectErrors err msgs)
Ok x s' err
| errorIsUnknown err -> return $ reply
| otherwise -> return (Ok x s' (setExpectErrors err msgs))
other -> return $ other
where
setExpectErrors err [] = setErrorMessage (Expect "") err
setExpectErrors err [msg] = setErrorMessage (Expect msg) err
setExpectErrors err (msg:msgs)
= foldr (\msg' err' -> addErrorMessage (Expect msg') err')
(setErrorMessage (Expect msg) err) msgs
class (Monad m) => Stream s m t | s -> t where
uncons :: s -> m (Maybe (t,s))
tokens :: (Stream s m t, Eq t)
=> ([t] -> String)
-> (SourcePos -> [t] -> SourcePos)
-> [t]
-> ParsecT s u m [t]
tokens _ _ []
= ParsecT $ \s -> return $ Empty $ return $ Ok [] s (unknownError s)
tokens showTokens nextposs tts@(tok:toks)
= ParsecT $ \(State input pos u) ->
let
errEof = return $ Error (setErrorMessage (Expect (showTokens tts))
(newErrorMessage (SysUnExpect "") pos))
errExpect x = return $ Error (setErrorMessage (Expect (showTokens tts))
(newErrorMessage (SysUnExpect (showTokens [x])) pos))
walk [] rs = return (ok rs)
walk (t:ts) rs = do
sr <- uncons rs
case sr of
Nothing -> errEof
Just (x,xs) | t == x -> walk ts xs
| otherwise -> errExpect x
ok rs = let pos' = nextposs pos tts
s' = State rs pos' u
in Ok tts s' (newErrorUnknown pos')
in do
sr <- uncons input
return $ case sr of
Nothing -> Empty $ errEof
Just (x,xs)
| tok == x -> Consumed $ walk toks xs
| otherwise -> Empty $ errExpect x
try :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a
try (ParsecT p)
= ParsecT $ \s@(State _ pos _) -> do
res <- p s
case res of
Consumed rep -> do r <- rep
case r of
Error err -> return $ Empty $ return $ Error
(setErrorPos pos err)
ok -> return $ Consumed $ return $ ok
empty -> return $ empty
token :: (Stream s Identity t)
=> (t -> String)
-> (t -> SourcePos)
-> (t -> Maybe a)
-> Parsec s u a
token showToken tokpos test = tokenPrim showToken nextpos test
where
nextpos _ tok ts = case runIdentity (uncons ts) of
Nothing -> tokpos tok
Just (tok',_) -> tokpos tok'
tokenPrim :: (Stream s m t)
=> (t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim showToken nextpos test = tokenPrimEx showToken nextpos Nothing test
tokenPrimEx :: (Stream s m t)
=> (t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> Maybe (SourcePos -> t -> s -> u -> u)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrimEx showToken nextpos mbNextState test
= case mbNextState of
Nothing
-> ParsecT $ \(State input pos user) -> do
r <- uncons input
case r of
Nothing -> return $ Empty $ return (sysUnExpectError "" pos)
Just (c,cs)
-> case test c of
Just x -> let newpos = nextpos pos c cs
newstate = State cs newpos user
in seq newpos $ seq newstate $
return $ Consumed $ return $
(Ok x newstate (newErrorUnknown newpos))
Nothing -> return $ Empty $ return $
(sysUnExpectError (showToken c) pos)
Just nextState
-> ParsecT $ \(State input pos user) -> do
r <- uncons input
case r of
Nothing -> return $ Empty $ return (sysUnExpectError "" pos)
Just (c,cs)
-> case test c of
Just x -> let newpos = nextpos pos c cs
newuser = nextState pos c cs user
newstate = State cs newpos newuser
in seq newpos $ seq newstate $
return $ Consumed $ return $
(Ok x newstate (newErrorUnknown newpos))
Nothing -> return $ Empty $ return $
(sysUnExpectError (showToken c) pos)
many :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]
many p
= do xs <- manyAccum (:) p
return (reverse xs)
skipMany :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()
skipMany p
= do manyAccum (\_ _ -> []) p
return ()
manyAccum :: (Stream s m t)
=> (a -> [a] -> [a])
-> ParsecT s u m a
-> ParsecT s u m [a]
manyAccum accum p
= ParsecT $ \s ->
let walk xs state mr
= do r <- mr
case r of
Empty mReply
-> do reply <- mReply
case reply of
Error err -> return $ Ok xs state err
_ -> error "Text.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
Consumed mReply
-> do reply <- mReply
case reply of
Error err
-> return $ Error err
Ok x s' _err
-> let ys = accum x xs
in seq ys (walk ys s' (runParsecT p s'))
in do r <- runParsecT p s
case r of
Empty mReply
-> do reply <- mReply
case reply of
Ok _ _ _
-> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
Error err
-> return $ Empty $ return (Ok [] s err)
consumed
-> return $ Consumed $ walk [] s (return consumed)
runPT :: (Stream s m t)
=> ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)
runPT p u name s
= do res <- runParsecT p (State s (initialPos name) u)
r <- parserReply res
case r of
Ok x _ _ -> return (Right x)
Error err -> return (Left err)
where
parserReply res
= case res of
Consumed r -> r
Empty r -> r
runP :: (Stream s Identity t)
=> Parsec s u a -> u -> SourceName -> s -> Either ParseError a
runP p u name s = runIdentity $ runPT p u name s
runParserT :: (Stream s m t)
=> ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)
runParserT = runPT
runParser :: (Stream s Identity t)
=> Parsec s u a -> u -> SourceName -> s -> Either ParseError a
runParser = runP
parse :: (Stream s Identity t)
=> Parsec s () a -> SourceName -> s -> Either ParseError a
parse p = runP p ()
parseTest :: (Stream s Identity t, Show a)
=> Parsec s () a -> s -> IO ()
parseTest p input
= case parse p "" input of
Left err -> do putStr "parse error at "
print err
Right x -> print x
getPosition :: (Monad m) => ParsecT s u m SourcePos
getPosition = do state <- getParserState
return (statePos state)
getInput :: (Monad m) => ParsecT s u m s
getInput = do state <- getParserState
return (stateInput state)
setPosition :: (Monad m) => SourcePos -> ParsecT s u m ()
setPosition pos
= do updateParserState (\(State input _ user) -> State input pos user)
return ()
setInput :: (Monad m) => s -> ParsecT s u m ()
setInput input
= do updateParserState (\(State _ pos user) -> State input pos user)
return ()
getParserState :: (Monad m) => ParsecT s u m (State s u)
getParserState = updateParserState id
setParserState :: (Monad m) => State s u -> ParsecT s u m (State s u)
setParserState st = updateParserState (const st)
updateParserState :: (Monad m)
=> (State s u -> State s u) -> ParsecT s u m (State s u)
updateParserState f
= ParsecT $ \s -> let s' = f s
in return $ Empty $ return (Ok s' s' (unknownError s'))
getState :: (Monad m) => ParsecT s u m u
getState = stateUser `liftM` getParserState
putState :: (Monad m) => u -> ParsecT s u m ()
putState u = do updateParserState $ \s -> s { stateUser = u }
return ()
modifyState :: (Monad m) => (u -> u) -> ParsecT s u m ()
modifyState f = do updateParserState $ \s -> s { stateUser = f (stateUser s) }
return ()
setState :: (Monad m) => u -> ParsecT s u m ()
setState = putState
updateState :: (Monad m) => (u -> u) -> ParsecT s u m ()
updateState = modifyState