X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMonad.lhs;h=62e805334e666fb7c8736dafd2d935207221c402;hp=279416d8cc2bcffefc6205d24275fadc29d27d5e;hb=927df6486bc0dcb598b82702ca40c8fad0d9b25f;hpb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 279416d..62e8053 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -6,31 +6,28 @@ @DsMonad@: monadery used in desugaring \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module DsMonad ( - DsM, mappM, mapAndUnzipM, - initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, - foldlDs, foldrDs, ifOptDs, - - newTyVarsDs, newLocalName, - duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, - newFailLocalDs, - getSrcSpanDs, putSrcSpanDs, - getModuleDs, - newUnique, - UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, - dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, + DsM, mapM, mapAndUnzipM, + initDs, initDsTc, fixDs, + foldlM, foldrM, ifDOptM, unsetOptM, + Applicative(..),(<$>), + + 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, @@ -40,12 +37,11 @@ module DsMonad ( CanItFail(..), orFail ) where -#include "HsVersions.h" - import TcRnMonad import CoreSyn import HsSyn import TcIface +import LoadIface import RdrName import HscTypes import Bag @@ -61,13 +57,11 @@ import Type import UniqSupply import Name import NameEnv -import OccName import DynFlags import ErrUtils +import FastString import Data.IORef - -infixr 9 `thenDs` \end{code} %************************************************************************ @@ -79,14 +73,17 @@ infixr 9 `thenDs` \begin{code} data DsMatchContext = DsMatchContext (HsMatchContext Name) SrcSpan - | NoMatchContext deriving () data EquationInfo = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn eqn_rhs :: MatchResult } -- What to do after match +instance Outputable EquationInfo where + ppr (EqnInfo pats _) = ppr pats + type DsWrapper = CoreExpr -> CoreExpr +idDsWrapper :: DsWrapper idDsWrapper e = e -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult @@ -105,8 +102,9 @@ data MatchResult data CanItFail = CanFail | CantFail +orFail :: CanItFail -> CanItFail -> CanItFail orFail CantFail CantFail = CantFail -orFail _ _ = CanFail +orFail _ _ = CanFail \end{code} @@ -123,14 +121,8 @@ presumably include source-file location information: type DsM result = TcRnIf DsGblEnv DsLclEnv result -- Compatibility functions +fixDs :: (a -> DsM a) -> DsM a fixDs = fixM -thenDs = thenM -returnDs = returnM -listDs = sequenceM -foldlDs = foldlM -foldrDs = foldrM -mapAndUnzipDs = mapAndUnzipM -ifOptDs = ifOptM type DsWarning = (SrcSpan, SDoc) -- Not quite the same as a WarnMsg, we have an SDoc here @@ -165,7 +157,7 @@ data DsMetaVal initDs :: HscEnv -> Module -> GlobalRdrEnv -> TypeEnv -> DsM a - -> IO (Maybe a) + -> IO (Messages, Maybe a) -- Print errors and warnings, if any arise initDs hsc_env mod rdr_env type_env thing_inside @@ -179,7 +171,6 @@ initDs hsc_env mod rdr_env type_env thing_inside -- Display any errors and warnings -- Note: if -Werror is used, we don't signal an error here. ; msgs <- readIORef msg_var - ; printErrorsAndWarnings dflags msgs ; let final_res | errorsFound dflags msgs = Nothing | otherwise = case either_res of @@ -189,7 +180,7 @@ initDs hsc_env mod rdr_env type_env thing_inside -- a UserError exception. Then it should have put an error -- message in msg_var, so we just discard the exception - ; return final_res } + ; return (msgs, final_res) } initDsTc :: DsM a -> TcM a initDsTc thing_inside @@ -199,15 +190,14 @@ initDsTc thing_inside ; dflags <- getDOpts ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env - ; ds_envs <- ioToIOEnv$ mkDsEnvs dflags this_mod rdr_env type_env msg_var + ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var ; setEnvs ds_envs thing_inside } mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) mkDsEnvs dflags mod rdr_env type_env msg_var - = do - sites_var <- newIORef [] + = do -- TODO: unnecessarily monadic let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } - if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) + if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod) gbl_env = DsGblEnv { ds_mod = mod, ds_if_env = (if_genv, if_lenv), ds_unqual = mkPrintUnqualified dflags rdr_env, @@ -216,7 +206,6 @@ mkDsEnvs dflags mod rdr_env type_env msg_var ds_loc = noSrcSpan } return (gbl_env, lcl_env) - \end{code} %************************************************************************ @@ -232,34 +221,30 @@ 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 ty - = newUnique `thenDs` \ uniq -> - returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty) +newUniqueId :: Id -> Type -> DsM Id +newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local - = newUnique `thenDs` \ uniq -> - returnDs (setIdUnique old_local uniq) - + = 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 ty - = newUnique `thenDs` \ uniq -> - returnDs (mkSysLocal FSLIT("ds") uniq ty) +newSysLocalDs = mkSysLocalM (fsLit "ds") +newFailLocalDs = mkSysLocalM (fsLit "fail") -newSysLocalsDs tys = mappM newSysLocalDs tys - -newFailLocalDs ty - = newUnique `thenDs` \ uniq -> - returnDs (mkSysLocal FSLIT("fail") uniq ty) - -- The UserLocal bit just helps make the code a little clearer -\end{code} - -\begin{code} -newTyVarsDs :: [TyVar] -> DsM [TyVar] -newTyVarsDs tyvar_tmpls - = newUniqueSupply `thenDs` \ uniqs -> - returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs)) +newSysLocalsDs :: [Type] -> DsM [Id] +newSysLocalsDs tys = mapM newSysLocalDs tys \end{code} We can also reach out and either set/grab location information from @@ -288,9 +273,8 @@ warnDs :: SDoc -> DsM () warnDs warn = do { env <- getGblEnv ; loc <- getSrcSpanDs ; let msg = mkWarnMsg loc (ds_unqual env) - (ptext SLIT("Warning:") <+> warn) + (ptext (sLit "Warning:") <+> warn) ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } - where failWithDs :: SDoc -> DsM a failWithDs err @@ -299,10 +283,15 @@ failWithDs err ; let msg = mkErrMsg loc (ds_unqual env) err ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) ; failM } - where + +mkPrintUnqualifiedDs :: DsM PrintUnqualified +mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv \end{code} \begin{code} +instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where + lookupThing = dsLookupGlobal + dsLookupGlobal :: Name -> DsM TyThing -- Very like TcEnv.tcLookupGlobal dsLookupGlobal name @@ -312,23 +301,32 @@ dsLookupGlobal name dsLookupGlobalId :: Name -> DsM Id dsLookupGlobalId name - = dsLookupGlobal name `thenDs` \ thing -> - returnDs (tyThingId thing) + = 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 - = dsLookupGlobal name `thenDs` \ thing -> - returnDs (tyThingTyCon thing) + = tyThingTyCon <$> dsLookupGlobal name dsLookupDataCon :: Name -> DsM DataCon dsLookupDataCon name - = dsLookupGlobal name `thenDs` \ thing -> - returnDs (tyThingDataCon thing) + = tyThingDataCon <$> dsLookupGlobal name dsLookupClass :: Name -> DsM Class dsLookupClass name - = dsLookupGlobal name `thenDs` \ thing -> - returnDs (tyThingClass thing) + = tyThingClass <$> dsLookupGlobal name \end{code} \begin{code} @@ -339,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} +