X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMonad.lhs;h=62e805334e666fb7c8736dafd2d935207221c402;hp=1238b1a2b54466e016fac1bd71246ee06c150c3c;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=19d8dcbdaac5dc10e551703b824e8237e7d5f0a1

diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 1238b1a..62e8053 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -12,15 +12,16 @@ module DsMonad (
 	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,
@@ -282,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}
@@ -299,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