{-# OPTIONS #-}
module Language.Python.Common.ParserMonad
( P
, execParser
, execParserKeepComments
, runParser
, thenP
, returnP
, setLocation
, getLocation
, getInput
, setInput
, getLastToken
, setLastToken
, setLastEOL
, getLastEOL
, ParseError (..)
, ParseState (..)
, initialState
, pushStartCode
, popStartCode
, getStartCode
, getIndent
, pushIndent
, popIndent
, getIndentStackDepth
, getParen
, pushParen
, popParen
, getParenStackDepth
, addComment
, getComments
, spanError
, throwError
) where
import Language.Python.Common.SrcLocation (SrcLocation (..), SrcSpan (..), Span (..))
import Language.Python.Common.Token (Token (..))
import Language.Python.Common.ParseError (ParseError (..))
import Control.Applicative ((<$>))
import Control.Monad.State.Class
import Control.Monad.State.Strict as State
import Language.Python.Common.Pretty
internalError :: String -> P a
internalError :: String -> P a
internalError = ParseError -> P a
forall a. ParseError -> P a
throwError (ParseError -> P a) -> (String -> ParseError) -> String -> P a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseError
StrError
spanError :: Span a => a -> String -> P b
spanError :: a -> String -> P b
spanError x :: a
x str :: String
str = ParseError -> P b
forall a. ParseError -> P a
throwError (ParseError -> P b) -> ParseError -> P b
forall a b. (a -> b) -> a -> b
$ String -> ParseError
StrError (String -> ParseError) -> String -> ParseError
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [SrcSpan -> String
forall a. Pretty a => a -> String
prettyText (SrcSpan -> String) -> SrcSpan -> String
forall a b. (a -> b) -> a -> b
$ a -> SrcSpan
forall a. Span a => a -> SrcSpan
getSpan a
x, String
str]
data ParseState =
ParseState
{ ParseState -> SrcLocation
location :: !SrcLocation
, ParseState -> String
input :: !String
, ParseState -> Token
previousToken :: !Token
, ParseState -> [Int]
startCodeStack :: [Int]
, ParseState -> [Int]
indentStack :: [Int]
, ParseState -> [Token]
parenStack :: [Token]
, ParseState -> SrcSpan
lastEOL :: !SrcSpan
, :: [Token]
}
deriving Int -> ParseState -> ShowS
[ParseState] -> ShowS
ParseState -> String
(Int -> ParseState -> ShowS)
-> (ParseState -> String)
-> ([ParseState] -> ShowS)
-> Show ParseState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseState] -> ShowS
$cshowList :: [ParseState] -> ShowS
show :: ParseState -> String
$cshow :: ParseState -> String
showsPrec :: Int -> ParseState -> ShowS
$cshowsPrec :: Int -> ParseState -> ShowS
Show
initToken :: Token
initToken :: Token
initToken = SrcSpan -> Token
NewlineToken SrcSpan
SpanEmpty
initialState :: SrcLocation -> String -> [Int] -> ParseState
initialState :: SrcLocation -> String -> [Int] -> ParseState
initialState initLoc :: SrcLocation
initLoc inp :: String
inp scStack :: [Int]
scStack
= $WParseState :: SrcLocation
-> String
-> Token
-> [Int]
-> [Int]
-> [Token]
-> SrcSpan
-> [Token]
-> ParseState
ParseState
{ location :: SrcLocation
location = SrcLocation
initLoc
, input :: String
input = String
inp
, previousToken :: Token
previousToken = Token
initToken
, startCodeStack :: [Int]
startCodeStack = [Int]
scStack
, indentStack :: [Int]
indentStack = [1]
, parenStack :: [Token]
parenStack = []
, lastEOL :: SrcSpan
lastEOL = SrcSpan
SpanEmpty
, comments :: [Token]
comments = []
}
type P a = StateT ParseState (Either ParseError) a
throwError :: ParseError -> P a
throwError :: ParseError -> P a
throwError = Either ParseError a -> P a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either ParseError a -> P a)
-> (ParseError -> Either ParseError a) -> ParseError -> P a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> Either ParseError a
forall a b. a -> Either a b
Left
execParser :: P a -> ParseState -> Either ParseError a
execParser :: P a -> ParseState -> Either ParseError a
execParser = P a -> ParseState -> Either ParseError a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
execParserKeepComments :: P a -> ParseState -> Either ParseError (a, [Token])
parser :: P a
parser state :: ParseState
state =
StateT ParseState (Either ParseError) (a, [Token])
-> ParseState -> Either ParseError (a, [Token])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (P a
parser P a
-> (a -> StateT ParseState (Either ParseError) (a, [Token]))
-> StateT ParseState (Either ParseError) (a, [Token])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: a
x -> P [Token]
getComments P [Token]
-> ([Token] -> StateT ParseState (Either ParseError) (a, [Token]))
-> StateT ParseState (Either ParseError) (a, [Token])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \c :: [Token]
c -> (a, [Token]) -> StateT ParseState (Either ParseError) (a, [Token])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, [Token]
c)) ParseState
state
runParser :: P a -> ParseState -> Either ParseError (a, ParseState)
runParser :: P a -> ParseState -> Either ParseError (a, ParseState)
runParser = P a -> ParseState -> Either ParseError (a, ParseState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
{-# INLINE returnP #-}
returnP :: a -> P a
returnP :: a -> P a
returnP = a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE thenP #-}
thenP :: P a -> (a -> P b) -> P b
thenP :: P a -> (a -> P b) -> P b
thenP = P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)
setLastEOL :: SrcSpan -> P ()
setLastEOL :: SrcSpan -> P ()
setLastEOL span :: SrcSpan
span = (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { lastEOL :: SrcSpan
lastEOL = SrcSpan
span }
getLastEOL :: P SrcSpan
getLastEOL :: P SrcSpan
getLastEOL = (StateType (StateT ParseState (Either ParseError)) -> SrcSpan)
-> P SrcSpan
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> SrcSpan
ParseState -> SrcSpan
lastEOL
setLocation :: SrcLocation -> P ()
setLocation :: SrcLocation -> P ()
setLocation loc :: SrcLocation
loc = (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { location :: SrcLocation
location = SrcLocation
loc }
getLocation :: P SrcLocation
getLocation :: P SrcLocation
getLocation = (StateType (StateT ParseState (Either ParseError)) -> SrcLocation)
-> P SrcLocation
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> SrcLocation
ParseState -> SrcLocation
location
getInput :: P String
getInput :: P String
getInput = (StateType (StateT ParseState (Either ParseError)) -> String)
-> P String
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> String
ParseState -> String
input
setInput :: String -> P ()
setInput :: String -> P ()
setInput inp :: String
inp = (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { input :: String
input = String
inp }
getLastToken :: P Token
getLastToken :: P Token
getLastToken = (StateType (StateT ParseState (Either ParseError)) -> Token)
-> P Token
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> Token
ParseState -> Token
previousToken
setLastToken :: Token -> P ()
setLastToken :: Token -> P ()
setLastToken tok :: Token
tok = (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { previousToken :: Token
previousToken = Token
tok }
pushStartCode :: Int -> P ()
pushStartCode :: Int -> P ()
pushStartCode code :: Int
code = do
[Int]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Int])
-> StateT ParseState (Either ParseError) [Int]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Int]
ParseState -> [Int]
startCodeStack
(StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { startCodeStack :: [Int]
startCodeStack = Int
code Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
oldStack }
popStartCode :: P ()
popStartCode :: P ()
popStartCode = do
[Int]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Int])
-> StateT ParseState (Either ParseError) [Int]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Int]
ParseState -> [Int]
startCodeStack
case [Int]
oldStack of
[] -> String -> P ()
forall a. String -> P a
internalError "fatal error in lexer: attempt to pop empty start code stack"
_:rest :: [Int]
rest -> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { startCodeStack :: [Int]
startCodeStack = [Int]
rest }
getStartCode :: P Int
getStartCode :: P Int
getStartCode = do
[Int]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Int])
-> StateT ParseState (Either ParseError) [Int]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Int]
ParseState -> [Int]
startCodeStack
case [Int]
oldStack of
[] -> String -> P Int
forall a. String -> P a
internalError "fatal error in lexer: start code stack empty on getStartCode"
code :: Int
code:_ -> Int -> P Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
code
pushIndent :: Int -> P ()
pushIndent :: Int -> P ()
pushIndent indent :: Int
indent = do
[Int]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Int])
-> StateT ParseState (Either ParseError) [Int]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Int]
ParseState -> [Int]
indentStack
(StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { indentStack :: [Int]
indentStack = Int
indent Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
oldStack }
popIndent :: P ()
popIndent :: P ()
popIndent = do
[Int]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Int])
-> StateT ParseState (Either ParseError) [Int]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Int]
ParseState -> [Int]
indentStack
case [Int]
oldStack of
[] -> String -> P ()
forall a. String -> P a
internalError "fatal error in lexer: attempt to pop empty indentation stack"
_:rest :: [Int]
rest -> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { indentStack :: [Int]
indentStack = [Int]
rest }
getIndent :: P Int
getIndent :: P Int
getIndent = do
[Int]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Int])
-> StateT ParseState (Either ParseError) [Int]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Int]
ParseState -> [Int]
indentStack
case [Int]
oldStack of
[] -> String -> P Int
forall a. String -> P a
internalError "fatal error in lexer: indent stack empty on getIndent"
indent :: Int
indent:_ -> Int -> P Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
indent
getIndentStackDepth :: P Int
getIndentStackDepth :: P Int
getIndentStackDepth = (StateType (StateT ParseState (Either ParseError)) -> Int) -> P Int
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> (ParseState -> [Int]) -> ParseState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> [Int]
indentStack)
pushParen :: Token -> P ()
pushParen :: Token -> P ()
pushParen symbol :: Token
symbol = do
[Token]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Token])
-> P [Token]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Token]
ParseState -> [Token]
parenStack
(StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { parenStack :: [Token]
parenStack = Token
symbol Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
oldStack }
popParen :: P ()
popParen :: P ()
popParen = do
[Token]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Token])
-> P [Token]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Token]
ParseState -> [Token]
parenStack
case [Token]
oldStack of
[] -> String -> P ()
forall a. String -> P a
internalError "fatal error in lexer: attempt to pop empty paren stack"
_:rest :: [Token]
rest -> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { parenStack :: [Token]
parenStack = [Token]
rest }
getParen :: P (Maybe Token)
getParen :: P (Maybe Token)
getParen = do
[Token]
oldStack <- (StateType (StateT ParseState (Either ParseError)) -> [Token])
-> P [Token]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Token]
ParseState -> [Token]
parenStack
case [Token]
oldStack of
[] -> Maybe Token -> P (Maybe Token)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Token
forall a. Maybe a
Nothing
symbol :: Token
symbol:_ -> Maybe Token -> P (Maybe Token)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Token -> P (Maybe Token)) -> Maybe Token -> P (Maybe Token)
forall a b. (a -> b) -> a -> b
$ Token -> Maybe Token
forall a. a -> Maybe a
Just Token
symbol
getParenStackDepth :: P Int
getParenStackDepth :: P Int
getParenStackDepth = (StateType (StateT ParseState (Either ParseError)) -> Int) -> P Int
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets ([Token] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Token] -> Int) -> (ParseState -> [Token]) -> ParseState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> [Token]
parenStack)
addComment :: Token -> P ()
c :: Token
c = do
[Token]
oldComments <- (StateType (StateT ParseState (Either ParseError)) -> [Token])
-> P [Token]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Token]
ParseState -> [Token]
comments
(StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall (m :: * -> *).
MonadState m =>
(StateType m -> StateType m) -> m ()
modify ((StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ())
-> (StateType (StateT ParseState (Either ParseError))
-> StateType (StateT ParseState (Either ParseError)))
-> P ()
forall a b. (a -> b) -> a -> b
$ \s :: StateType (StateT ParseState (Either ParseError))
s -> StateType (StateT ParseState (Either ParseError))
ParseState
s { comments :: [Token]
comments = Token
c Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
oldComments }
getComments :: P [Token]
= [Token] -> [Token]
forall a. [a] -> [a]
reverse ([Token] -> [Token]) -> P [Token] -> P [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateType (StateT ParseState (Either ParseError)) -> [Token])
-> P [Token]
forall (m :: * -> *) a. MonadState m => (StateType m -> a) -> m a
gets StateType (StateT ParseState (Either ParseError)) -> [Token]
ParseState -> [Token]
comments