X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMonad.lhs;h=3bb1493a89a681f8d9834acf7a35eecf87c40d2e;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hp=d3dd0e110f1e4f6b293942af27a5eb3d48d8f93d;hpb=eca538c8c62951d6f140c99c88a97ef2b0a0497d;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index d3dd0e1..3bb1493 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -7,9 +7,10 @@ \begin{code} module DsMonad ( - DsM, mappM, mapAndUnzipM, - initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, - foldlDs, foldrDs, + DsM, mapM, mapAndUnzipM, + initDs, initDsTc, fixDs, + foldlM, foldrM, ifOptM, + Applicative(..),(<$>), newTyVarsDs, newLocalName, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, @@ -20,10 +21,10 @@ module DsMonad ( UniqSupply, newUniqueSupply, getDOptsDs, getGhcModeDs, doptDs, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, + dsLookupClass, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - bindLocalsDs, getLocalBindsDs, getBkptSitesDs, -- Warnings DsWarning, warnDs, failWithDs, @@ -33,8 +34,6 @@ module DsMonad ( CanItFail(..), orFail ) where -#include "HsVersions.h" - import TcRnMonad import CoreSyn import HsSyn @@ -44,6 +43,7 @@ import HscTypes import Bag import DataCon import TyCon +import Class import Id import Module import Var @@ -56,13 +56,10 @@ import NameEnv import OccName import DynFlags import ErrUtils -import Bag -import Breakpoints -import OccName +import MonadUtils +import FastString import Data.IORef - -infixr 9 `thenDs` \end{code} %************************************************************************ @@ -81,7 +78,11 @@ 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 @@ -100,8 +101,9 @@ data MatchResult data CanItFail = CanFail | CantFail +orFail :: CanItFail -> CanItFail -> CanItFail orFail CantFail CantFail = CantFail -orFail _ _ = CanFail +orFail _ _ = CanFail \end{code} @@ -118,14 +120,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 - type DsWarning = (SrcSpan, SDoc) -- Not quite the same as a WarnMsg, we have an SDoc here @@ -136,15 +132,13 @@ data DsGblEnv = DsGblEnv { ds_mod :: Module, -- For SCC profiling ds_unqual :: PrintUnqualified, ds_msgs :: IORef Messages, -- Warning messages - ds_if_env :: (IfGblEnv, IfLclEnv), -- Used for looking up global, + ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things - ds_bkptSites :: IORef SiteMap -- Inserted Breakpoints sites } data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings - ds_loc :: SrcSpan, -- to put in pattern-matching error msgs - ds_locals :: OccEnv Id -- For locals in breakpoints + ds_loc :: SrcSpan -- to put in pattern-matching error msgs } -- Inside [| |] brackets, the desugarer looks @@ -167,14 +161,14 @@ initDs :: HscEnv initDs hsc_env mod rdr_env type_env thing_inside = do { msg_var <- newIORef (emptyBag, emptyBag) - ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var + ; let dflags = hsc_dflags hsc_env + ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ tryM thing_inside -- Catch exceptions (= errors during desugaring) -- Display any errors and warnings -- Note: if -Werror is used, we don't signal an error here. - ; let dflags = hsc_dflags hsc_env ; msgs <- readIORef msg_var ; printErrorsAndWarnings dflags msgs @@ -193,25 +187,23 @@ initDsTc thing_inside = do { this_mod <- getModule ; tcg_env <- getGblEnv ; msg_var <- getErrsVar + ; dflags <- getDOpts ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env - ; ds_envs <- ioToIOEnv$ mkDsEnvs 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 :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) -mkDsEnvs mod rdr_env type_env msg_var - = do - sites_var <- newIORef [] +mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env msg_var + = 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 rdr_env, - ds_msgs = msg_var, - ds_bkptSites = sites_var} + ds_unqual = mkPrintUnqualified dflags rdr_env, + ds_msgs = msg_var} lcl_env = DsLclEnv { ds_meta = emptyNameEnv, - ds_loc = noSrcSpan, - ds_locals = emptyOccEnv } + ds_loc = noSrcSpan } return (gbl_env, lcl_env) @@ -231,33 +223,34 @@ 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 ty = do + uniq <- newUnique + return (mkSysLocal (occNameFS (nameOccName id)) uniq ty) duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local - = newUnique `thenDs` \ uniq -> - returnDs (setIdUnique old_local uniq) +duplicateLocalDs old_local = do + uniq <- newUnique + return (setIdUnique old_local uniq) newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDs ty - = newUnique `thenDs` \ uniq -> - returnDs (mkSysLocal FSLIT("ds") uniq ty) +newSysLocalDs ty = do + uniq <- newUnique + return (mkSysLocal (fsLit "ds") uniq ty) -newSysLocalsDs tys = mappM newSysLocalDs tys +newSysLocalsDs :: [Type] -> DsM [Id] +newSysLocalsDs tys = mapM newSysLocalDs tys -newFailLocalDs ty - = newUnique `thenDs` \ uniq -> - returnDs (mkSysLocal FSLIT("fail") uniq ty) +newFailLocalDs ty = do + uniq <- newUnique + return (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)) +newTyVarsDs tyvar_tmpls = do + uniqs <- newUniqueSupply + return (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs)) \end{code} We can also reach out and either set/grab location information from @@ -286,7 +279,7 @@ 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 @@ -310,18 +303,19 @@ dsLookupGlobal name dsLookupGlobalId :: Name -> DsM Id dsLookupGlobalId name - = dsLookupGlobal name `thenDs` \ thing -> - returnDs (tyThingId thing) + = tyThingId <$> dsLookupGlobal name 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 + = tyThingClass <$> dsLookupGlobal name \end{code} \begin{code} @@ -332,19 +326,3 @@ 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} -getLocalBindsDs :: DsM [Id] -getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) } - -bindLocalsDs :: [Id] -> DsM a -> DsM a -bindLocalsDs new_ids enclosed_scope = - updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids}) - enclosed_scope - where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ] - -getBkptSitesDs :: DsM (IORef SiteMap) -getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) } - -\end{code} -