module Language.PureScript.TypeChecker.Monad where
import Data.Maybe
import qualified Data.Map as M
import Control.Applicative
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Unify
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a
bindNames newNames action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
a <- action
modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
return a
bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a
bindTypes newNames action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
a <- action
modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
return a
withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
withTypeClassDictionaries entries action = do
orig <- get
let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
a <- action
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
return a
getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
bindLocalVariables moduleName bindings =
bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))
bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
bindLocalTypeVariables moduleName bindings =
bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
makeBindingGroupVisible action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }
a <- action
modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
return a
lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
lookupVariable currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
Nothing -> throwError . strMsg $ show var ++ " is undefined"
Just (ty, _, _) -> return ty
getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
getVisibility currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
Nothing -> throwError . strMsg $ show var ++ " is undefined"
Just (_, _, vis) -> return vis
checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
checkVisibility currentModule name@(Qualified _ var) = do
vis <- getVisibility currentModule name
case vis of
Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."
_ -> return ()
lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable currentModule (Qualified moduleName name) = do
env <- getEnv
case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"
Just (k, _) -> return k
data CheckState = CheckState {
checkEnv :: Environment
, checkNextVar :: Int
, checkNextDictName :: Int
, checkCurrentModule :: Maybe ModuleName
}
newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }
deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadState CheckState, MonadError ErrorStack)
getEnv :: (Functor m, MonadState CheckState m) => m Environment
getEnv = checkEnv <$> get
putEnv :: (MonadState CheckState m) => Environment -> m ()
putEnv env = modify (\s -> s { checkEnv = env })
modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
runCheck :: Options mode -> Check a -> Either String (a, Environment)
runCheck opts = runCheck' opts initEnvironment
runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)
runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do
(a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
return (a, checkEnv s)
guardWith :: (MonadError e m) => e -> Bool -> m ()
guardWith _ True = return ()
guardWith e False = throwError e
freshDictionaryName :: Check Int
freshDictionaryName = do
n <- checkNextDictName <$> get
modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
return n
liftCheck :: Check a -> UnifyT t Check a
liftCheck = UnifyT . lift
liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
liftUnify unify = do
st <- get
(a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
return (a, unifyCurrentSubstitution ust)