module CSPM.Evaluator.Monad where
import Prelude hiding (lookup)
import CSPM.DataStructures.Names
import CSPM.Evaluator.Exceptions
import CSPM.Evaluator.Environment
import CSPM.Evaluator.Values
import Util.Exception
data EvaluationState =
EvaluationState {
environment :: Environment
}
type EvaluationMonad = LazyEvalMonad EvaluationState
newtype LazyEvalMonad s a = LazyEvalMonad {
unLazyEvalMonad :: s -> a
}
runLazyEvalMonad :: s -> LazyEvalMonad s a -> a
runLazyEvalMonad st (LazyEvalMonad prog) = prog st
gets :: (s -> a) -> LazyEvalMonad s a
gets f = LazyEvalMonad (\st -> f st)
modify :: (s -> s) -> LazyEvalMonad s a -> LazyEvalMonad s a
modify f prog = LazyEvalMonad (\st -> unLazyEvalMonad prog (f st))
instance Monad (LazyEvalMonad a) where
(LazyEvalMonad p1) >>= f =
LazyEvalMonad (\ st ->
let
a = p1 st
LazyEvalMonad p2 = f a
in p2 st)
return k = LazyEvalMonad (\ st -> k)
runEvaluator :: EvaluationState -> EvaluationMonad a -> a
runEvaluator st prog = runLazyEvalMonad st prog
getState :: EvaluationMonad EvaluationState
getState = gets id
getEnvironment :: EvaluationMonad Environment
getEnvironment = gets environment
lookupVar :: Name -> EvaluationMonad Value
lookupVar n = do
env <- getEnvironment
return $ lookup env n
addScopeAndBind :: [(Name, Value)] -> EvaluationMonad a -> EvaluationMonad a
addScopeAndBind bs = addScopeAndBindM $ return bs
addScopeAndBindM :: EvaluationMonad [(Name, Value)] -> EvaluationMonad a -> EvaluationMonad a
addScopeAndBindM binds =
modify (\st -> let
bs = runEvaluator st' binds
env' = newLayerAndBind (environment st) bs
st' = st { environment = env' }
in
st')
throwError :: ErrorMessage -> a
throwError err = throwSourceError [err]