Refactoring: Make a HasModule class for getModule

compiler/basicTypes/Module.lhs

@@ -48,6 +48,8 @@ module Module
         pprModule,
         mkModule,
         stableModuleCmp,
+        HasModule(..),
+        ContainsModule(..),
 
         -- * The ModuleLocation type
         ModLocation(..),
@@ -276,6 +278,12 @@ pprPackagePrefix p mod = getPprStyle doc
                 -- the PrintUnqualified tells us which modules have to
                 -- be qualified with package names
        | otherwise = empty
+
+class ContainsModule t where
+    extractModule :: t -> Module
+
+class HasModule m where
+    getModule :: m Module
 \end{code}
 
 %************************************************************************

compiler/deSugar/DsForeign.lhs

@@ -212,11 +212,7 @@ dsFCall fn_id co fcall mDeclHeader = do
     (fcall', cDoc) <-
               case fcall of
               CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) ->
-               do thisMod <- getModuleDs
-                  let pkg = packageIdString  (modulePackageId thisMod)
-                      mod = moduleNameString (moduleName      thisMod)
-                      wrapperNameComponents = [pkg, mod, unpackFS cName]
-                  wrapperName <- mkWrapperName "ghc_wrapper" wrapperNameComponents
+               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
                   let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
                       c = includes
                        $$ fun_proto <+> braces (cRet <> semi)

compiler/deSugar/DsMonad.lhs

@@ -167,6 +167,9 @@ data DsGblEnv
         , ds_parr_bi :: PArrBuiltin             -- desugarar names for '-XParallelArrays'
         }
 
+instance ContainsModule DsGblEnv where
+    extractModule = ds_mod
+
 data DsLclEnv = DsLclEnv {
         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs

compiler/rename/RnBinds.lhs

@@ -39,6 +39,7 @@ import RnTypes        ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch
 import RnPat
 import RnEnv
 import DynFlags
+import Module
 import Name
 import NameEnv
 import NameSet

compiler/rename/RnEnv.lhs

@@ -52,7 +52,7 @@ import Name
 import NameSet
 import NameEnv
 import Avail
-import Module           ( ModuleName, moduleName )
+import Module
 import UniqFM
 import DataCon          ( dataConFieldLabels, dataConTyCon )
 import TyCon            ( isTupleTyCon, tyConArity )

compiler/rename/RnExpr.lhs

@@ -40,6 +40,7 @@ import DynFlags
 import BasicTypes	( FixityDirection(..) )
 import PrelNames
 
+import Module
 import Name
 import NameSet
 import RdrName

compiler/simplCore/CoreMonad.lhs

@@ -72,7 +72,7 @@ import PprCore
 import CoreUtils
 import CoreLint		( lintCoreBindings )
 import HscTypes
-import Module           ( Module )
+import Module
 import DynFlags
 import StaticFlags	
 import Rules            ( RuleBase )
@@ -863,9 +863,6 @@ getHscEnv = read cr_hsc_env
 getRuleBase :: CoreM RuleBase
 getRuleBase = read cr_rule_base
 
-getModule :: CoreM Module
-getModule = read cr_module
-
 addSimplCount :: SimplCount -> CoreM ()
 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 
@@ -874,6 +871,9 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 instance HasDynFlags CoreM where
     getDynFlags = fmap hsc_dflags getHscEnv
 
+instance HasModule CoreM where
+    getModule = read cr_module
+
 -- | The original name cache is the current mapping from 'Module' and
 -- 'OccName' to a compiler-wide unique 'Name'
 getOrigNameCache :: CoreM OrigNameCache

compiler/typecheck/TcBinds.lhs

@@ -32,6 +32,7 @@ import TysPrim
 import Id
 import Var
 import VarSet
+import Module
 import Name
 import NameSet
 import NameEnv

compiler/typecheck/TcEnv.lhs

@@ -756,9 +756,7 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM
 mkStableIdFromString str sig_ty loc occ_wrapper = do
     uniq <- newUnique
     mod <- getModule
-    name <- mkWrapperName "stable" [packageIdString  (modulePackageId mod),
-                                    moduleNameString (moduleName      mod),
-                                    str]
+    name <- mkWrapperName "stable" str
     let occ = mkVarOccFS name :: OccName
         gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
         id  = mkExportedLocalId gnm sig_ty :: Id
@@ -769,15 +767,18 @@ mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
 \end{code}
 
 \begin{code}
-mkWrapperName :: (MonadIO m, HasDynFlags m)
-              => String -> [String] -> m FastString
-mkWrapperName what components
+mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
+              => String -> String -> m FastString
+mkWrapperName what nameBase
     = do dflags <- getDynFlags
+         thisMod <- getModule
          let wrapperRef = nextWrapperNum dflags
+             pkg = packageIdString  (modulePackageId thisMod)
+             mod = moduleNameString (moduleName      thisMod)
          wrapperNum <- liftIO $ readIORef wrapperRef
          liftIO $ writeIORef wrapperRef (wrapperNum + 1)
-         let allComponents = what : show wrapperNum : components
-         return $ mkFastString $ zEncodeString $ intercalate ":" allComponents
+         let components = [what, show wrapperNum, pkg, mod, nameBase]
+         return $ mkFastString $ zEncodeString $ intercalate ":" components
 \end{code}
 
 %************************************************************************

compiler/typecheck/TcRnMonad.lhs

@@ -480,9 +480,6 @@ dumpOptTcRn flag doc = whenDOptM flag (dumpTcRn doc)
 %************************************************************************
 
 \begin{code}
-getModule :: TcRn Module
-getModule = do { env <- getGblEnv; return (tcg_mod env) }
-
 setModule :: Module -> TcRn a -> TcRn a
 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
 

compiler/typecheck/TcRnTypes.lhs

@@ -182,6 +182,9 @@ data Env gbl lcl
 instance ContainsDynFlags (Env gbl lcl) where
     extractDynFlags env = hsc_dflags (env_top env)
 
+instance ContainsModule gbl => ContainsModule (Env gbl lcl) where
+    extractModule env = extractModule (env_gbl env)
+
 -- TcGblEnv describes the top-level of the module at the
 -- point at which the typechecker is finished work.
 -- It is this structure that is handed on to the desugarer
@@ -319,6 +322,9 @@ data TcGblEnv
                                              -- as -XSafe (Safe Haskell)
     }
 
+instance ContainsModule TcGblEnv where
+    extractModule env = tcg_mod env
+
 data RecFieldEnv
   = RecFields (NameEnv [Name])  -- Maps a constructor name *in this module*
                                 -- to the fields for that constructor

compiler/typecheck/TcTyClsDecls.lhs

@@ -48,6 +48,7 @@ import MkCore		( rEC_SEL_ERROR_ID )
 import IdInfo
 import Var
 import VarSet
+import Module
 import Name
 import NameSet
 import NameEnv

compiler/utils/IOEnv.hs

@@ -32,6 +32,7 @@ module IOEnv (
 
 import DynFlags
 import Exception
+import Module
 import Panic
 
 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
@@ -93,6 +94,10 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
     getDynFlags = do env <- getEnv
                      return $ extractDynFlags env
 
+instance ContainsModule env => HasModule (IOEnv env) where
+    getModule = do env <- getEnv
+                   return $ extractModule env
+
 ----------------------------------------------------------------------
 -- Fundmantal combinators specific to the monad
 ----------------------------------------------------------------------