module Language.ObjC.Parser.ParserMonad (
LP,
P,
IType (..),
TMap,
execParser,
execLazyParser,
failP,
getNewName,
addTypedef,
shadowSymbol,
isTypeIdent,
addClass,
isClass,
isSpecial,
enterScope,
leaveScope,
setPos,
getPos,
getInput,
setInput,
getLastToken,
getSavedToken,
setLastToken,
handleEofToken,
getCurrentPosition,
ParseError(..),
parsedLazily,
) where
import Language.ObjC.Data.Error (internalErr, showErrorInfo,ErrorInfo(..),ErrorLevel(..))
import Language.ObjC.Data.Position (Position(..))
import Language.ObjC.Data.InputStream
import Language.ObjC.Data.Name (Name)
import Language.ObjC.Data.Ident (Ident)
import Language.ObjC.Parser.Tokens (CToken(CTokEof))
import Language.ObjC.Syntax.AST (CExtDecl)
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Applicative
newtype ParseError = ParseError ([String],Position)
instance Show ParseError where
show (ParseError (msgs,pos)) = showErrorInfo "Syntax Error !" (ErrorInfo LevelError pos msgs)
data IType = TyDef | CName deriving (Eq, Show, Ord, Enum)
type TMap = Map Ident IType
data ParseResult a
= POk !PState a
| PFailed [String] Position
deriving (Functor)
data PState = PState {
curPos :: !Position,
curInput :: !InputStream,
prevToken :: CToken,
savedToken :: CToken,
namesupply :: ![Name],
tyidents :: !(TMap),
scopes :: [TMap]
}
class (Functor p, Monad p) => PMonad p where
get :: p PState
put :: PState -> p ()
modify :: (PState -> PState) -> p ()
modify f = get >>= put . f
failP :: Position -> [String] -> LP s a
failP pos m = LP $ \s pSt -> (PFailed m pos, s)
type P a = LP [CExtDecl] a
newtype LP s a = LP { unLP :: s -> PState -> (ParseResult a, s) }
deriving (Functor)
instance Monad (LP s) where
return a = LP $ \s !pSt -> (POk pSt a, s)
(LP m) >>= f = LP $ \s !pSt ->
let (r1, s1) = m s2 pSt
(r2, s2) = case r1 of
POk pSt' a -> unLP (f a) s pSt'
PFailed err pos -> (PFailed err pos, s)
in (r2, s1)
fail m = LP $ \s pSt -> (PFailed [m] (curPos pSt), s)
instance PMonad (LP s) where
get = LP $ \s !pst -> (POk pst pst, s)
put st = LP $ \s _ -> (POk st (), s)
modify f = LP $ \s !pst -> (POk (f pst) (), s)
getL :: LP s s
getL = LP $ \s !pst -> (POk pst s, s)
modifyL :: (s -> s) -> LP s ()
modifyL f = LP $ \s !pst -> (POk pst (),f s)
putL :: s -> LP s ()
putL = modifyL . const
instance Applicative (LP s) where
pure = return
f <*> m = f >>= \f' -> m >>= \m' -> pure (f' m')
execParser :: LP [s] a -> InputStream -> Position -> [Ident] -> [Name]
-> Either ParseError (a,[Name])
execParser (LP parser) input pos builtins names =
case fst $ 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 = Map.fromList $ map (,TyDef) builtins,
scopes = []
}
execLazyParser
:: LP [s] a
-> InputStream
-> Position
-> [Ident]
-> [Name]
-> ([s], Either ParseError a)
execLazyParser (LP parser) input pos builtins names =
let (res, lzparse) = parser [] initialState
procRes = case res of
PFailed message errpos -> Left (ParseError (message,errpos))
POk _ result -> Right result
in (lzparse, procRes)
where initialState = PState {
curPos = pos,
curInput = input,
prevToken = internalErr "CLexer.execParser: Touched undefined token!",
savedToken = internalErr "CLexer.execParser: Touched undefined token (saved token)!",
namesupply = names,
tyidents = Map.fromList $ map (,TyDef) builtins,
scopes = []
}
withState :: PMonad p => (PState -> (PState, a)) -> p a
withState f = get >>= \p -> case f p of
(pst', a) -> put pst' >> return a
withState' :: PMonad p => (PState -> (PState, a)) -> p a
withState' f = get >>= \p -> case f p of
(pst', !a) -> put pst' >> return a
getNewName :: (PMonad p) => p Name
getNewName = withState' $ \s@PState{namesupply=(n:ns)} -> (s{namesupply=ns}, n)
setPos :: (PMonad p) => Position -> p ()
setPos pos = modify $ \ !s -> s{curPos=pos}
getPos :: (PMonad p) => p Position
getPos = (\st -> curPos st) <$> get
addTypedef :: (PMonad p) => Ident -> p ()
addTypedef ident = modify $ \s@PState{tyidents=tyids} ->
s{tyidents = Map.insert ident TyDef tyids}
shadowSymbol :: (PMonad p) => Ident -> p ()
shadowSymbol ident = modify $ \s@PState{tyidents=tyids} ->
s{tyidents = if ident `Map.member` tyids
then ident `Map.delete` tyids
else tyids }
isTypeIdent :: (PMonad p) => Ident -> p Bool
isTypeIdent ident = (\s -> maybe False (== TyDef)
. Map.lookup ident $ tyidents s)
<$> get
addClass :: (PMonad p) => Ident -> p ()
addClass ident = modify $ \s@PState{tyidents=tyids} ->
s{tyidents = Map.insert ident CName tyids}
isClass :: (PMonad p) => Ident -> p Bool
isClass ident = (\s -> maybe False (== CName)
. Map.lookup ident $ tyidents s)
<$> get
isSpecial :: (PMonad p) => Ident -> p (Maybe IType)
isSpecial ident = (\s -> Map.lookup ident $ tyidents s) <$> get
enterScope :: (PMonad p) => p ()
enterScope = modify $ \s@PState{tyidents=tyids,scopes=ss} -> s{scopes=tyids:ss}
leaveScope :: (PMonad p) => p ()
leaveScope = modify $ \s@PState{scopes=ss} ->
case ss of
[] -> error "leaveScope: already in global scope"
(tyids:ss') -> s{tyidents=tyids, scopes=ss'}
getInput :: (PMonad p) => p InputStream
getInput = curInput <$> get
setInput :: (PMonad p) => InputStream -> p ()
setInput i = modify (\s -> s{curInput=i})
getLastToken :: (PMonad p) => p CToken
getLastToken = prevToken <$> get
getSavedToken :: (PMonad p) => p CToken
getSavedToken = savedToken <$> get
setLastToken :: (PMonad p) => CToken -> p ()
setLastToken CTokEof = modify $ \s -> s{savedToken=(prevToken s)}
setLastToken tok = modify $ \s -> s{prevToken=tok,savedToken=(prevToken s)}
handleEofToken :: (PMonad p) => p ()
handleEofToken = modify $ \s -> s{savedToken=(prevToken s)}
getCurrentPosition :: (PMonad p) => p Position
getCurrentPosition = curPos <$> get
parsedLazily :: s -> LP [s] s
parsedLazily s = s <$ modifyL (s:)