{-# LANGUAGE CPP #-}
module Language.C.Parser.ParserMonad (
P,
execParser,
failP,
getNewName,
addTypedef,
shadowTypedef,
isTypeIdent,
enterScope,
leaveScope,
setPos,
getPos,
getInput,
setInput,
getLastToken,
getSavedToken,
setLastToken,
handleEofToken,
getCurrentPosition,
ParseError(..),
) where
import Language.C.Data.Error (internalErr, showErrorInfo,ErrorInfo(..),ErrorLevel(..))
import Language.C.Data.Position (Position(..))
import Language.C.Data.InputStream
import Language.C.Data.Name (Name)
import Language.C.Data.Ident (Ident)
import Language.C.Parser.Tokens (CToken(CTokEof))
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail (MonadFail (..))
#endif
import Data.Set (Set)
import qualified Data.Set as Set (fromList, insert, member, delete)
newtype ParseError = ParseError ([String],Position)
instance Show ParseError where
show (ParseError (msgs,pos)) = showErrorInfo "Syntax Error !" (ErrorInfo LevelError pos msgs)
data ParseResult a
= POk !PState a
| PFailed [String] Position
data PState = PState {
curPos :: !Position,
curInput :: !InputStream,
prevToken :: CToken,
savedToken :: CToken,
namesupply :: ![Name],
tyidents :: !(Set Ident),
scopes :: ![Set Ident]
}
newtype P a = P { unP :: PState -> ParseResult a }
instance Functor P where
fmap = liftM
instance Applicative P where
pure = return
(<*>) = ap
instance Monad P where
return = returnP
(>>=) = thenP
#if !MIN_VERSION_base(4,13,0)
fail m = getPos >>= \pos -> failP pos [m]
#endif
#if MIN_VERSION_base(4,9,0)
instance MonadFail P where
fail m = getPos >>= \pos -> failP pos [m]
#endif
execParser :: P a -> InputStream -> Position -> [Ident] -> [Name]
-> Either ParseError (a,[Name])
execParser (P parser) input pos builtins names =
case parser initialState of
PFailed message errpos -> Left (ParseError (message,errpos))
POk st result -> Right (result, namesupply st)
where initialState = PState {
curPos = pos,
curInput = input,
prevToken = internalErr "CLexer.execParser: Touched undefined token!",
savedToken = internalErr "CLexer.execParser: Touched undefined token (safed token)!",
namesupply = names,
tyidents = Set.fromList builtins,
scopes = []
}
{-# INLINE returnP #-}
returnP :: a -> P a
returnP a = P $ \s -> POk s a
{-# INLINE thenP #-}
thenP :: P a -> (a -> P b) -> P b
(P m) `thenP` k = P $ \s ->
case m s of
POk s' a -> (unP (k a)) s'
PFailed err pos -> PFailed err pos
failP :: Position -> [String] -> P a
failP pos msg = P $ \_ -> PFailed msg pos
getNewName :: P Name
getNewName = P $ \s@PState{namesupply=(n:ns)} -> n `seq` POk s{namesupply=ns} n
setPos :: Position -> P ()
setPos pos = P $ \s -> POk s{curPos=pos} ()
getPos :: P Position
getPos = P $ \s@PState{curPos=pos} -> POk s pos
addTypedef :: Ident -> P ()
addTypedef ident = (P $ \s@PState{tyidents=tyids} ->
POk s{tyidents = ident `Set.insert` tyids} ())
shadowTypedef :: Ident -> P ()
shadowTypedef ident = (P $ \s@PState{tyidents=tyids} ->
POk s{tyidents = if ident `Set.member` tyids
then ident `Set.delete` tyids
else tyids } ())
isTypeIdent :: Ident -> P Bool
isTypeIdent ident = P $ \s@PState{tyidents=tyids} ->
POk s $! Set.member ident tyids
enterScope :: P ()
enterScope = P $ \s@PState{tyidents=tyids,scopes=ss} ->
POk s{scopes=tyids:ss} ()
leaveScope :: P ()
leaveScope = P $ \s@PState{scopes=ss} ->
case ss of
[] -> error "leaveScope: already in global scope"
(tyids:ss') -> POk s{tyidents=tyids, scopes=ss'} ()
getInput :: P InputStream
getInput = P $ \s@PState{curInput=i} -> POk s i
setInput :: InputStream -> P ()
setInput i = P $ \s -> POk s{curInput=i} ()
getLastToken :: P CToken
getLastToken = P $ \s@PState{prevToken=tok} -> POk s tok
getSavedToken :: P CToken
getSavedToken = P $ \s@PState{savedToken=tok} -> POk s tok
setLastToken :: CToken -> P ()
setLastToken CTokEof = P $ \s -> POk s{savedToken=(prevToken s)} ()
setLastToken tok = P $ \s -> POk s{prevToken=tok,savedToken=(prevToken s)} ()
handleEofToken :: P ()
handleEofToken = P $ \s -> POk s{savedToken=(prevToken s)} ()
getCurrentPosition :: P Position
getCurrentPosition = P $ \s@PState{curPos=pos} -> POk s pos