module CParserMonad (
P,
execParser,
failP,
getNewName,
addTypedef,
shadowTypedef,
isTypeIdent,
enterScope,
leaveScope,
setPos,
getPos,
getInput,
setInput,
getLastToken,
setLastToken,
) where
import Position (Position(..), Pos(posOf))
import Errors (interr)
import UNames (Name)
import Idents (Ident, lexemeToIdent, identToLexeme)
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
import Control.Monad.Fail (MonadFail (..))
import Data.Set (Set)
import qualified Data.Set as Set (fromList, insert, member, delete)
import CTokens (CToken)
data ParseResult a
= POk !PState a
| PFailed [String] Position
data PState = PState {
curPos :: !Position,
curInput :: !String,
prevToken :: CToken,
namesupply :: ![Name],
tyidents :: !(Set Ident),
scopes :: ![Set Ident]
}
newtype P a = P { unP :: PState -> ParseResult a }
instance MonadFail P where
fail m = getPos >>= \pos -> failP pos [m]
instance Functor P where
fmap = liftM
instance Applicative P where
pure = return
(<*>) = ap
instance Monad P where
return = returnP
(>>=) = thenP
fail m = getPos >>= \pos -> failP pos [m]
execParser :: P a -> String -> Position -> [Ident] -> [Name]
-> Either a ([String], Position)
execParser (P parser) input pos builtins names =
case parser initialState of
POk _ result -> Left result
PFailed message pos -> Right (message, pos)
where initialState = PState {
curPos = pos,
curInput = input,
prevToken = interr "CLexer.execParser: Touched undefined 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)} -> 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=tyidents} ->
POk s{tyidents = ident `Set.insert` tyidents} ())
shadowTypedef :: Ident -> P ()
shadowTypedef ident = (P $ \s@PState{tyidents=tyidents} ->
POk s{tyidents = if ident `Set.member` tyidents
then ident `Set.delete` tyidents
else tyidents } ())
isTypeIdent :: Ident -> P Bool
isTypeIdent ident = P $ \s@PState{tyidents=tyidents} ->
POk s $! Set.member ident tyidents
enterScope :: P ()
enterScope = P $ \s@PState{tyidents=tyidents,scopes=ss} ->
POk s{scopes=tyidents:ss} ()
leaveScope :: P ()
leaveScope = P $ \s@PState{scopes=ss} ->
case ss of
[] -> interr "leaveScope: already in global scope"
(tyidents:ss') -> POk s{tyidents=tyidents, scopes=ss'} ()
getInput :: P String
getInput = P $ \s@PState{curInput=i} -> POk s i
setInput :: String -> P ()
setInput i = P $ \s -> POk s{curInput=i} ()
getLastToken :: P CToken
getLastToken = P $ \s@PState{prevToken=tok} -> POk s tok
setLastToken :: CToken -> P ()
setLastToken tok = P $ \s -> POk s{prevToken=tok} ()