Commit fb31191a authored by ian@well-typed.com's avatar ian@well-typed.com

Refactoring: Make a HasModule class for getModule

parent 0a7c4efe
......@@ -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}
%************************************************************************
......
......@@ -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)
......
......@@ -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
......
......@@ -39,6 +39,7 @@ import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch
import RnPat
import RnEnv
import DynFlags
import Module
import Name
import NameEnv
import NameSet
......
......@@ -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 )
......
......@@ -40,6 +40,7 @@ import DynFlags
import BasicTypes ( FixityDirection(..) )
import PrelNames
import Module
import Name
import NameSet
import RdrName
......
......@@ -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
......
......@@ -32,6 +32,7 @@ import TysPrim
import Id
import Var
import VarSet
import Module
import Name
import NameSet
import NameEnv
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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
......
......@@ -48,6 +48,7 @@ import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo
import Var
import VarSet
import Module
import Name
import NameSet
import NameEnv
......
......@@ -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
----------------------------------------------------------------------
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment