add comment

[ghc-hetmet.git] / compiler / deSugar / DsMonad.lhs

diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index e275cb9..62e8053 100644 (file)
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -9,22 +9,25 @@
 module DsMonad (
        DsM, mapM, mapAndUnzipM,
        initDs, initDsTc, fixDs,
-       foldlM, foldrM, ifOptM,
+       foldlM, foldrM, ifDOptM, unsetOptM,
        Applicative(..),(<$>),
 
-       newLocalName,
-       duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
-       newFailLocalDs, newPredVarDs,
-       getSrcSpanDs, putSrcSpanDs,
-       getModuleDs,
-       newUnique, 
-       UniqSupply, newUniqueSupply,
-       getDOptsDs, getGhcModeDs, doptDs,
-       dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
+        newLocalName,
+        duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
+        newFailLocalDs, newPredVarDs,
+        getSrcSpanDs, putSrcSpanDs,
+        getModuleDs,
+        mkPrintUnqualifiedDs,
+        newUnique, 
+        UniqSupply, newUniqueSupply,
+        getDOptsDs, getGhcModeDs, doptDs,
+        dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
         dsLookupClass,
 
        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
+        dsLoadModule,
+
        -- Warnings
        DsWarning, warnDs, failWithDs,
 
@@ -38,6 +41,7 @@ import TcRnMonad
 import CoreSyn
 import HsSyn
 import TcIface
+import LoadIface
 import RdrName
 import HscTypes
 import Bag
@@ -69,7 +73,6 @@ import Data.IORef
 \begin{code}
 data DsMatchContext
   = DsMatchContext (HsMatchContext Name) SrcSpan
-  | NoMatchContext
   deriving ()
 
 data EquationInfo
@@ -218,8 +221,8 @@ it easier to read debugging output.
 
 \begin{code}
 -- Make a new Id with the same print name, but different type, and new unique
-newUniqueId :: Name -> Type -> DsM Id
-newUniqueId id = mkSysLocalM (occNameFS (nameOccName id))
+newUniqueId :: Id -> Type -> DsM Id
+newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
 
 duplicateLocalDs :: Id -> DsM Id
 duplicateLocalDs old_local 
@@ -280,6 +283,9 @@ failWithDs err
        ; let msg = mkErrMsg loc (ds_unqual env) err
        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
        ; failM }
+
+mkPrintUnqualifiedDs :: DsM PrintUnqualified
+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
 \end{code}
 
 \begin{code}
@@ -297,6 +303,19 @@ dsLookupGlobalId :: Name -> DsM Id
 dsLookupGlobalId name 
   = tyThingId <$> dsLookupGlobal name
 
+-- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked
+-- up name is located, varies with the active DPH backend.
+--
+dsLookupDPHId :: (PackageId -> Name) -> DsM Id
+dsLookupDPHId nameInPkg
+  = do { dflags <- getDOpts
+       ; case dphPackageMaybe dflags of
+           Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg)
+           Nothing  -> failWithDs $ ptext err
+       }
+  where
+    err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
+
 dsLookupTyCon :: Name -> DsM TyCon
 dsLookupTyCon name
   = tyThingTyCon <$> dsLookupGlobal name
@@ -318,3 +337,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}
+