X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMonad.lhs;h=62e805334e666fb7c8736dafd2d935207221c402;hp=83a5d212ae84eb720408de651dc585db50676ba0;hb=927df6486bc0dcb598b82702ca40c8fad0d9b25f;hpb=0db3e625ff0717f36495b375e6008995d6ffb0a3

diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 83a5d21..62e8053 100644
--- 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
@@ -53,10 +57,8 @@ import Type
 import UniqSupply
 import Name
 import NameEnv
-import OccName
 import DynFlags
 import ErrUtils
-import MonadUtils
 import FastString
 
 import Data.IORef
@@ -71,7 +73,6 @@ import Data.IORef
 \begin{code}
 data DsMatchContext
   = DsMatchContext (HsMatchContext Name) SrcSpan
-  | NoMatchContext
   deriving ()
 
 data EquationInfo
@@ -220,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 
@@ -232,7 +233,7 @@ newPredVarDs :: PredType -> DsM Var
 newPredVarDs pred
  | isEqPred pred
  = do { uniq <- newUnique; 
-      ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co"))
+      ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co_pv"))
 	    kind = mkPredTy pred
       ; return (mkCoVar name kind) }
  | otherwise
@@ -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
@@ -320,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}
+