X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMonad.lhs;h=fa968119bdf925233dc3932b93946cf9aa486634;hb=3f888bd95df5154a535673a33fee13cf88c3838e;hp=145ba9e37129b11d06594d343a6ec23e94c4ec83;hpb=3b2cd7b311da1e7056ef66b42efc2571add5a8aa;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 145ba9e..fa96811 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -14,7 +14,7 @@ module DsMonad ( newLocalName, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, - newFailLocalDs, + newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, getModuleDs, newUnique, @@ -25,6 +25,8 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, + dsLoadModule, + -- Warnings DsWarning, warnDs, failWithDs, @@ -38,6 +40,7 @@ import TcRnMonad import CoreSyn import HsSyn import TcIface +import LoadIface import RdrName import HscTypes import Bag @@ -53,10 +56,8 @@ import Type import UniqSupply import Name import NameEnv -import OccName import DynFlags import ErrUtils -import MonadUtils import FastString import Data.IORef @@ -224,12 +225,22 @@ newUniqueId :: Name -> Type -> DsM Id newUniqueId id = mkSysLocalM (occNameFS (nameOccName id)) duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local = do - uniq <- newUnique - return (setIdUnique old_local uniq) - +duplicateLocalDs old_local + = do { uniq <- newUnique + ; return (setIdUnique old_local uniq) } + +newPredVarDs :: PredType -> DsM Var +newPredVarDs pred + | isEqPred pred + = do { uniq <- newUnique; + ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co_pv")) + kind = mkPredTy pred + ; return (mkCoVar name kind) } + | otherwise + = newSysLocalDs (mkPredTy pred) + newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDs = mkSysLocalM (fsLit "ds") +newSysLocalDs = mkSysLocalM (fsLit "ds") newFailLocalDs = mkSysLocalM (fsLit "fail") newSysLocalsDs :: [Type] -> DsM [Id] @@ -310,3 +321,13 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside \end{code} + +\begin{code} +dsLoadModule :: SDoc -> Module -> DsM () +dsLoadModule doc mod + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (loadSysInterface doc mod >> return ()) + } +\end{code} +