----------------------------------------------------------------------------- -- | -- Module : Text.Parsec.Prim -- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : derek.a.elkins@gmail.com -- Stability : provisional -- Portability : portable -- -- The primitive parser combinators. -- ----------------------------------------------------------------------------- {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, UndecidableInstances #-} module Text.Parsec.Prim ( unknownError , sysUnExpectError , unexpected , ParsecT , runParsecT , mkPT , Parsec , Consumed(..) , Reply(..) , State(..) , parsecMap , parserReturn , parserBind , mergeErrorReply , parserFail , parserZero , parserPlus , (<?>) , (<|>) , label , labels , lookAhead , Stream(..) , tokens , try , token , tokenPrim , tokenPrimEx , many , skipMany , manyAccum , runPT , runP , runParserT , runParser , parse , parseTest , getPosition , getInput , setPosition , setInput , getParserState , setParserState , updateParserState , getState , putState , modifyState , setState , updateState ) 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) -- | The parser @unexpected msg@ always fails with an unexpected error -- message @msg@ without consuming any input. -- -- The parsers 'fail', ('<?>') and @unexpected@ are the three parsers -- used to generate error messages. Of these, only ('<?>') is commonly -- used. For an example of the use of @unexpected@, see the definition -- of 'Text.Parsec.Combinator.notFollowedBy'. unexpected :: (Stream s m t) => String -> ParsecT s u m a unexpected msg = ParsecT $ \s _ _ _ eerr -> eerr $ newErrorMessage (UnExpect msg) (statePos s) -- | ParserT monad transformer and Parser type -- | @ParsecT s u m a@ is a parser with stream type @s@, user state type @u@, -- underlying monad @m@ and return type @a@. Parsec is strict in the user state. -- If this is undesirable, simply used a data type like @data Box a = Box a@ and -- the state type @Box YourStateType@ to add a level of indirection. newtype ParsecT s u m a = ParsecT {unParser :: forall b . State s u -> (a -> State s u -> ParseError -> m b) -- consumed ok -> (ParseError -> m b) -- consumed err -> (a -> State s u -> ParseError -> m b) -- empty ok -> (ParseError -> m b) -- empty err -> m b } -- | Low-level unpacking of the ParsecT type. To run your parser, please look to -- runPT, runP, runParserT, runParser and other such functions. runParsecT :: Monad m => ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a))) runParsecT p s = unParser p s cok cerr eok eerr where cok a s' err = return . Consumed . return $ Ok a s' err cerr err = return . Consumed . return $ Error err eok a s' err = return . Empty . return $ Ok a s' err eerr err = return . Empty . return $ Error err -- | Low-level creation of the ParsecT type. You really shouldn't have to do this. mkPT :: Monad m => (State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a mkPT k = ParsecT $ \s cok cerr eok eerr -> do cons <- k s case cons of Consumed mrep -> do rep <- mrep case rep of Ok x s' err -> cok x s' err Error err -> cerr err Empty mrep -> do rep <- mrep case rep of Ok x s' err -> eok x s' err Error err -> eerr err 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 -- XXX instance Functor (ParsecT s u m) where fmap f p = parsecMap f p parsecMap :: (a -> b) -> ParsecT s u m a -> ParsecT s u m b parsecMap f p = ParsecT $ \s cok cerr eok eerr -> unParser p s (cok . f) cerr (eok . f) eerr instance Applicative.Applicative (ParsecT s u m) where pure = return (<*>) = ap -- TODO: Can this be optimized? instance Applicative.Alternative (ParsecT s u m) where empty = mzero (<|>) = mplus instance 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 = mkPT $ \s -> local f (runParsecT p s) -- I'm presuming the user might want a separate, non-backtracking -- state aside from the Parsec user state. 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 = mkPT $ \s -> callCC $ \c -> runParsecT (f (\a -> mkPT $ \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 = mkPT $ \s -> runParsecT p s `catchError` \e -> runParsecT (h e) s parserReturn :: a -> ParsecT s u m a parserReturn x = ParsecT $ \s _ _ eok _ -> eok x s (unknownError s) parserBind :: ParsecT s u m a -> (a -> ParsecT s u m b) -> ParsecT s u m b {-# INLINE parserBind #-} parserBind m k = ParsecT $ \s cok cerr eok eerr -> let -- consumed-okay case for m mcok x s err = let -- if (k x) consumes, those go straigt up pcok = cok pcerr = cerr -- if (k x) doesn't consume input, but is okay, -- we still return in the consumed continuation peok x s err' = cok x s (mergeError err err') -- if (k x) doesn't consume input, but errors, -- we return the error in the 'consumed-error' -- continuation peerr err' = cerr (mergeError err err') in unParser (k x) s pcok pcerr peok peerr -- empty-ok case for m meok x s err = let -- in these cases, (k x) can return as empty pcok = cok peok x s err' = eok x s (mergeError err err') pcerr = cerr peerr err' = eerr (mergeError err err') in unParser (k x) s pcok pcerr peok peerr -- consumed-error case for m mcerr = cerr -- empty-error case for m meerr = eerr in unParser m s mcok mcerr meok meerr mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a mergeErrorReply err1 reply -- XXX where to put it? = case reply of Ok x state err2 -> Ok x state (mergeError err1 err2) Error err2 -> Error (mergeError err1 err2) parserFail :: String -> ParsecT s u m a parserFail msg = ParsecT $ \s _ _ _ eerr -> eerr $ newErrorMessage (Message msg) (statePos s) instance MonadPlus (ParsecT s u m) where mzero = parserZero mplus p1 p2 = parserPlus p1 p2 -- | @parserZero@ always fails without consuming any input. @parserZero@ is defined -- equal to the 'mzero' member of the 'MonadPlus' class and to the 'Control.Applicative.empty' member -- of the 'Control.Applicative.Applicative' class. parserZero :: ParsecT s u m a parserZero = ParsecT $ \s _ _ _ eerr -> eerr $ unknownError s parserPlus :: ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a {-# INLINE parserPlus #-} parserPlus m n = ParsecT $ \s cok cerr eok eerr -> let meerr err = let neok y s' err' = eok y s' (mergeError err err') neerr err' = eerr $ mergeError err err' in unParser n s cok cerr neok neerr in unParser m s cok cerr eok meerr instance MonadTrans (ParsecT s u) where lift amb = ParsecT $ \s _ _ eok _ -> do a <- amb eok a s $ unknownError s infix 0 <?> infixr 1 <|> -- | The parser @p <?> msg@ behaves as parser @p@, but whenever the -- parser @p@ fails /without consuming any input/, it replaces expect -- error messages with the expect error message @msg@. -- -- This is normally used at the end of a set alternatives where we want -- to return an error message in terms of a higher level construct -- rather than returning all possible characters. For example, if the -- @expr@ parser from the 'try' example would fail, the error -- message is: '...: expecting expression'. Without the @(\<?>)@ -- combinator, the message would be like '...: expecting \"let\" or -- letter', which is less friendly. (<?>) :: (ParsecT s u m a) -> String -> (ParsecT s u m a) p <?> msg = label p msg -- | This combinator implements choice. The parser @p \<|> q@ first -- applies @p@. If it succeeds, the value of @p@ is returned. If @p@ -- fails /without consuming any input/, parser @q@ is tried. This -- combinator is defined equal to the 'mplus' member of the 'MonadPlus' -- class and the ('Control.Applicative.<|>') member of 'Control.Applicative.Alternative'. -- -- The parser is called /predictive/ since @q@ is only tried when -- parser @p@ didn't consume any input (i.e.. the look ahead is 1). -- This non-backtracking behaviour allows for both an efficient -- implementation of the parser combinators and the generation of good -- error messages. (<|>) :: (ParsecT s u m a) -> (ParsecT s u m a) -> (ParsecT s u m a) p1 <|> p2 = mplus p1 p2 label :: ParsecT s u m a -> String -> ParsecT s u m a label p msg = labels p [msg] labels :: ParsecT s u m a -> [String] -> ParsecT s u m a labels p msgs = ParsecT $ \s cok cerr eok eerr -> let eok' x s' error = eok x s' $ if errorIsUnknown error then error else setExpectErrors error msgs eerr' err = eerr $ setExpectErrors err msgs in unParser p s cok cerr eok' eerr' 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 -- TODO: There should be a stronger statement that can be made about this -- | An instance of @Stream@ has stream type @s@, underlying monad @m@ and token type @t@ determined by the stream -- -- Some rough guidelines for a \"correct\" instance of Stream: -- -- * unfoldM uncons gives the [t] corresponding to the stream -- -- * A @Stream@ instance is responsible for maintaining the \"position within the stream\" in the stream state @s@. This is trivial unless you are using the monad in a non-trivial way. 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) -- Pretty print a list of tokens -> (SourcePos -> [t] -> SourcePos) -> [t] -- List of tokens to parse -> ParsecT s u m [t] {-# INLINE tokens #-} tokens _ _ [] = ParsecT $ \s _ _ eok _ -> eok [] s $ unknownError s tokens showTokens nextposs tts@(tok:toks) = ParsecT $ \(State input pos u) cok cerr eok eerr -> let errEof = (setErrorMessage (Expect (showTokens tts)) (newErrorMessage (SysUnExpect "") pos)) errExpect x = (setErrorMessage (Expect (showTokens tts)) (newErrorMessage (SysUnExpect (showTokens [x])) pos)) walk [] rs = ok rs walk (t:ts) rs = do sr <- uncons rs case sr of Nothing -> cerr $ errEof Just (x,xs) | t == x -> walk ts xs | otherwise -> cerr $ errExpect x ok rs = let pos' = nextposs pos tts s' = State rs pos' u in cok tts s' (newErrorUnknown pos') in do sr <- uncons input case sr of Nothing -> eerr $ errEof Just (x,xs) | tok == x -> walk toks xs | otherwise -> eerr $ errExpect x -- | The parser @try p@ behaves like parser @p@, except that it -- pretends that it hasn't consumed any input when an error occurs. -- -- This combinator is used whenever arbitrary look ahead is needed. -- Since it pretends that it hasn't consumed any input when @p@ fails, -- the ('<|>') combinator will try its second alternative even when the -- first parser failed while consuming input. -- -- The @try@ combinator can for example be used to distinguish -- identifiers and reserved words. Both reserved words and identifiers -- are a sequence of letters. Whenever we expect a certain reserved -- word where we can also expect an identifier we have to use the @try@ -- combinator. Suppose we write: -- -- > expr = letExpr <|> identifier <?> "expression" -- > -- > letExpr = do{ string "let"; ... } -- > identifier = many1 letter -- -- If the user writes \"lexical\", the parser fails with: @unexpected -- \'x\', expecting \'t\' in \"let\"@. Indeed, since the ('<|>') combinator -- only tries alternatives when the first alternative hasn't consumed -- input, the @identifier@ parser is never tried (because the prefix -- \"le\" of the @string \"let\"@ parser is already consumed). The -- right behaviour can be obtained by adding the @try@ combinator: -- -- > expr = letExpr <|> identifier <?> "expression" -- > -- > letExpr = do{ try (string "let"); ... } -- > identifier = many1 letter try :: ParsecT s u m a -> ParsecT s u m a try p = ParsecT $ \s cok _ eok eerr -> unParser p s cok eerr eok eerr -- | @lookAhead p@ parses @p@ without consuming any input. -- -- If @p@ fails and consumes some input, so does @lookAhead@. Combine with 'try' -- if this is undesirable. lookAhead :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a lookAhead p = do{ state <- getParserState ; x <- p' ; setParserState state ; return x } where p' = ParsecT $ \s cok cerr eok eerr -> unParser p s eok cerr eok eerr -- | The parser @token showTok posFromTok testTok@ accepts a token @t@ -- with result @x@ when the function @testTok t@ returns @'Just' x@. The -- source position of the @t@ should be returned by @posFromTok t@ and -- the token can be shown using @showTok t@. -- -- This combinator is expressed in terms of 'tokenPrim'. -- It is used to accept user defined token streams. For example, -- suppose that we have a stream of basic tokens tupled with source -- positions. We can than define a parser that accepts single tokens as: -- -- > mytoken x -- > = token showTok posFromTok testTok -- > where -- > showTok (pos,t) = show t -- > posFromTok (pos,t) = pos -- > testTok (pos,t) = if x == t then Just t else Nothing token :: (Stream s Identity t) => (t -> String) -- ^ Token pretty-printing function. -> (t -> SourcePos) -- ^ Computes the position of a token. -> (t -> Maybe a) -- ^ Matching function for the token to parse. -> 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' -- | The parser @tokenPrim showTok nextPos testTok@ accepts a token @t@ -- with result @x@ when the function @testTok t@ returns @'Just' x@. The -- token can be shown using @showTok t@. The position of the /next/ -- token should be returned when @nextPos@ is called with the current -- source position @pos@, the current token @t@ and the rest of the -- tokens @toks@, @nextPos pos t toks@. -- -- This is the most primitive combinator for accepting tokens. For -- example, the 'Text.Parsec.Char.char' parser could be implemented as: -- -- > char c -- > = tokenPrim showChar nextPos testChar -- > where -- > showChar x = "'" ++ x ++ "'" -- > testChar x = if x == c then Just x else Nothing -- > nextPos pos x xs = updatePosChar pos x tokenPrim :: (Stream s m t) => (t -> String) -- ^ Token pretty-printing function. -> (SourcePos -> t -> s -> SourcePos) -- ^ Next position calculating function. -> (t -> Maybe a) -- ^ Matching function for the token to parse. -> ParsecT s u m a {-# INLINE tokenPrim #-} 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 {-# INLINE tokenPrimEx #-} tokenPrimEx showToken nextpos Nothing test = ParsecT $ \(State input pos user) cok cerr eok eerr -> do r <- uncons input case r of Nothing -> eerr $ unexpectError "" 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 $ cok x newstate (newErrorUnknown newpos) Nothing -> eerr $ unexpectError (showToken c) pos tokenPrimEx showToken nextpos (Just nextState) test = ParsecT $ \(State input pos user) cok cerr eok eerr -> do r <- uncons input case r of Nothing -> eerr $ unexpectError "" 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 $ cok x newstate $ newErrorUnknown newpos Nothing -> eerr $ unexpectError (showToken c) pos unexpectError msg pos = newErrorMessage (SysUnExpect msg) pos -- | @many p@ applies the parser @p@ /zero/ or more times. Returns a -- list of the returned values of @p@. -- -- > identifier = do{ c <- letter -- > ; cs <- many (alphaNum <|> char '_') -- > ; return (c:cs) -- > } many :: ParsecT s u m a -> ParsecT s u m [a] many p = do xs <- manyAccum (:) p return (reverse xs) -- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping -- its result. -- -- > spaces = skipMany space skipMany :: ParsecT s u m a -> ParsecT s u m () skipMany p = do manyAccum (\_ _ -> []) p return () manyAccum :: (a -> [a] -> [a]) -> ParsecT s u m a -> ParsecT s u m [a] manyAccum acc p = ParsecT $ \s cok cerr eok eerr -> let walk xs x s' err = unParser p s' (seq xs $ walk $ acc x xs) -- consumed-ok cerr -- consumed-err manyErr -- empty-ok (\e -> cok (acc x xs) s' e) -- empty-err in unParser p s (walk []) cerr manyErr (\e -> eok [] s e) manyErr = error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string." -- < Running a parser: monadic (runPT) and pure (runP) 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 -- | The most general way to run a parser. @runParserT p state filePath -- input@ runs parser @p@ on the input list of tokens @input@, -- obtained from source @filePath@ with the initial user state @st@. -- The @filePath@ is only used in error messages and may be the empty -- string. Returns a computation in the underlying monad @m@ that return either a 'ParseError' ('Left') or a -- value of type @a@ ('Right'). runParserT :: (Stream s m t) => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a) runParserT = runPT -- | The most general way to run a parser over the Identity monad. @runParser p state filePath -- input@ runs parser @p@ on the input list of tokens @input@, -- obtained from source @filePath@ with the initial user state @st@. -- The @filePath@ is only used in error messages and may be the empty -- string. Returns either a 'ParseError' ('Left') or a -- value of type @a@ ('Right'). -- -- > parseFromFile p fname -- > = do{ input <- readFile fname -- > ; return (runParser p () fname input) -- > } runParser :: (Stream s Identity t) => Parsec s u a -> u -> SourceName -> s -> Either ParseError a runParser = runP -- | @parse p filePath input@ runs a parser @p@ over Identity without user -- state. The @filePath@ is only used in error messages and may be the -- empty string. Returns either a 'ParseError' ('Left') -- or a value of type @a@ ('Right'). -- -- > main = case (parse numbers "" "11, 2, 43") of -- > Left err -> print err -- > Right xs -> print (sum xs) -- > -- > numbers = commaSep integer parse :: (Stream s Identity t) => Parsec s () a -> SourceName -> s -> Either ParseError a parse p = runP p () -- | The expression @parseTest p input@ applies a parser @p@ against -- input @input@ and prints the result to stdout. Used for testing -- parsers. 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 -- < Parser state combinators -- | Returns the current source position. See also 'SourcePos'. getPosition :: (Monad m) => ParsecT s u m SourcePos getPosition = do state <- getParserState return (statePos state) -- | Returns the current input getInput :: (Monad m) => ParsecT s u m s getInput = do state <- getParserState return (stateInput state) -- | @setPosition pos@ sets the current source position to @pos@. setPosition :: (Monad m) => SourcePos -> ParsecT s u m () setPosition pos = do updateParserState (\(State input _ user) -> State input pos user) return () -- | @setInput input@ continues parsing with @input@. The 'getInput' and -- @setInput@ functions can for example be used to deal with #include -- files. setInput :: (Monad m) => s -> ParsecT s u m () setInput input = do updateParserState (\(State _ pos user) -> State input pos user) return () -- | Returns the full parser state as a 'State' record. getParserState :: (Monad m) => ParsecT s u m (State s u) getParserState = updateParserState id -- | @setParserState st@ set the full parser state to @st@. setParserState :: (Monad m) => State s u -> ParsecT s u m (State s u) setParserState st = updateParserState (const st) -- | @updateParserState f@ applies function @f@ to the parser state. updateParserState :: (State s u -> State s u) -> ParsecT s u m (State s u) updateParserState f = ParsecT $ \s _ _ eok _ -> let s' = f s in eok s' s' $ unknownError s' -- < User state combinators -- | Returns the current user state. getState :: (Monad m) => ParsecT s u m u getState = stateUser `liftM` getParserState -- | @putState st@ set the user state to @st@. putState :: (Monad m) => u -> ParsecT s u m () putState u = do updateParserState $ \s -> s { stateUser = u } return () -- | @updateState f@ applies function @f@ to the user state. Suppose -- that we want to count identifiers in a source, we could use the user -- state as: -- -- > expr = do{ x <- identifier -- > ; updateState (+1) -- > ; return (Id x) -- > } modifyState :: (Monad m) => (u -> u) -> ParsecT s u m () modifyState f = do updateParserState $ \s -> s { stateUser = f (stateUser s) } return () -- XXX Compat -- | An alias for putState for backwards compatibility. setState :: (Monad m) => u -> ParsecT s u m () setState = putState -- | An alias for modifyState for backwards compatibility. updateState :: (Monad m) => (u -> u) -> ParsecT s u m () updateState = modifyState