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 ...@@ -48,6 +48,8 @@ module Module
pprModule, pprModule,
mkModule, mkModule,
stableModuleCmp, stableModuleCmp,
HasModule(..),
ContainsModule(..),
-- * The ModuleLocation type -- * The ModuleLocation type
ModLocation(..), ModLocation(..),
...@@ -276,6 +278,12 @@ pprPackagePrefix p mod = getPprStyle doc ...@@ -276,6 +278,12 @@ pprPackagePrefix p mod = getPprStyle doc
-- the PrintUnqualified tells us which modules have to -- the PrintUnqualified tells us which modules have to
-- be qualified with package names -- be qualified with package names
| otherwise = empty | otherwise = empty
class ContainsModule t where
extractModule :: t -> Module
class HasModule m where
getModule :: m Module
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -212,11 +212,7 @@ dsFCall fn_id co fcall mDeclHeader = do ...@@ -212,11 +212,7 @@ dsFCall fn_id co fcall mDeclHeader = do
(fcall', cDoc) <- (fcall', cDoc) <-
case fcall of case fcall of
CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) -> CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) ->
do thisMod <- getModuleDs do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
let pkg = packageIdString (modulePackageId thisMod)
mod = moduleNameString (moduleName thisMod)
wrapperNameComponents = [pkg, mod, unpackFS cName]
wrapperName <- mkWrapperName "ghc_wrapper" wrapperNameComponents
let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
c = includes c = includes
$$ fun_proto <+> braces (cRet <> semi) $$ fun_proto <+> braces (cRet <> semi)
......
...@@ -167,6 +167,9 @@ data DsGblEnv ...@@ -167,6 +167,9 @@ data DsGblEnv
, ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays'
} }
instance ContainsModule DsGblEnv where
extractModule = ds_mod
data DsLclEnv = DsLclEnv { data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcSpan -- to put in pattern-matching error msgs ds_loc :: SrcSpan -- to put in pattern-matching error msgs
......
...@@ -39,6 +39,7 @@ import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch ...@@ -39,6 +39,7 @@ import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch
import RnPat import RnPat
import RnEnv import RnEnv
import DynFlags import DynFlags
import Module
import Name import Name
import NameEnv import NameEnv
import NameSet import NameSet
......
...@@ -52,7 +52,7 @@ import Name ...@@ -52,7 +52,7 @@ import Name
import NameSet import NameSet
import NameEnv import NameEnv
import Avail import Avail
import Module ( ModuleName, moduleName ) import Module
import UniqFM import UniqFM
import DataCon ( dataConFieldLabels, dataConTyCon ) import DataCon ( dataConFieldLabels, dataConTyCon )
import TyCon ( isTupleTyCon, tyConArity ) import TyCon ( isTupleTyCon, tyConArity )
......
...@@ -40,6 +40,7 @@ import DynFlags ...@@ -40,6 +40,7 @@ import DynFlags
import BasicTypes ( FixityDirection(..) ) import BasicTypes ( FixityDirection(..) )
import PrelNames import PrelNames
import Module
import Name import Name
import NameSet import NameSet
import RdrName import RdrName
......
...@@ -72,7 +72,7 @@ import PprCore ...@@ -72,7 +72,7 @@ import PprCore
import CoreUtils import CoreUtils
import CoreLint ( lintCoreBindings ) import CoreLint ( lintCoreBindings )
import HscTypes import HscTypes
import Module ( Module ) import Module
import DynFlags import DynFlags
import StaticFlags import StaticFlags
import Rules ( RuleBase ) import Rules ( RuleBase )
...@@ -863,9 +863,6 @@ getHscEnv = read cr_hsc_env ...@@ -863,9 +863,6 @@ getHscEnv = read cr_hsc_env
getRuleBase :: CoreM RuleBase getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base getRuleBase = read cr_rule_base
getModule :: CoreM Module
getModule = read cr_module
addSimplCount :: SimplCount -> CoreM () addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count }) addSimplCount count = write (CoreWriter { cw_simpl_count = count })
...@@ -874,6 +871,9 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count }) ...@@ -874,6 +871,9 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count })
instance HasDynFlags CoreM where instance HasDynFlags CoreM where
getDynFlags = fmap hsc_dflags getHscEnv getDynFlags = fmap hsc_dflags getHscEnv
instance HasModule CoreM where
getModule = read cr_module
-- | The original name cache is the current mapping from 'Module' and -- | The original name cache is the current mapping from 'Module' and
-- 'OccName' to a compiler-wide unique 'Name' -- 'OccName' to a compiler-wide unique 'Name'
getOrigNameCache :: CoreM OrigNameCache getOrigNameCache :: CoreM OrigNameCache
......
...@@ -32,6 +32,7 @@ import TysPrim ...@@ -32,6 +32,7 @@ import TysPrim
import Id import Id
import Var import Var
import VarSet import VarSet
import Module
import Name import Name
import NameSet import NameSet
import NameEnv import NameEnv
......
...@@ -756,9 +756,7 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM ...@@ -756,9 +756,7 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM
mkStableIdFromString str sig_ty loc occ_wrapper = do mkStableIdFromString str sig_ty loc occ_wrapper = do
uniq <- newUnique uniq <- newUnique
mod <- getModule mod <- getModule
name <- mkWrapperName "stable" [packageIdString (modulePackageId mod), name <- mkWrapperName "stable" str
moduleNameString (moduleName mod),
str]
let occ = mkVarOccFS name :: OccName let occ = mkVarOccFS name :: OccName
gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
id = mkExportedLocalId gnm sig_ty :: Id id = mkExportedLocalId gnm sig_ty :: Id
...@@ -769,15 +767,18 @@ mkStableIdFromName nm = mkStableIdFromString (getOccString nm) ...@@ -769,15 +767,18 @@ mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
\end{code} \end{code}
\begin{code} \begin{code}
mkWrapperName :: (MonadIO m, HasDynFlags m) mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
=> String -> [String] -> m FastString => String -> String -> m FastString
mkWrapperName what components mkWrapperName what nameBase
= do dflags <- getDynFlags = do dflags <- getDynFlags
thisMod <- getModule
let wrapperRef = nextWrapperNum dflags let wrapperRef = nextWrapperNum dflags
pkg = packageIdString (modulePackageId thisMod)
mod = moduleNameString (moduleName thisMod)
wrapperNum <- liftIO $ readIORef wrapperRef wrapperNum <- liftIO $ readIORef wrapperRef
liftIO $ writeIORef wrapperRef (wrapperNum + 1) liftIO $ writeIORef wrapperRef (wrapperNum + 1)
let allComponents = what : show wrapperNum : components let components = [what, show wrapperNum, pkg, mod, nameBase]
return $ mkFastString $ zEncodeString $ intercalate ":" allComponents return $ mkFastString $ zEncodeString $ intercalate ":" components
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -480,9 +480,6 @@ dumpOptTcRn flag doc = whenDOptM flag (dumpTcRn doc) ...@@ -480,9 +480,6 @@ dumpOptTcRn flag doc = whenDOptM flag (dumpTcRn doc)
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
getModule :: TcRn Module
getModule = do { env <- getGblEnv; return (tcg_mod env) }
setModule :: Module -> TcRn a -> TcRn a setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
......
...@@ -182,6 +182,9 @@ data Env gbl lcl ...@@ -182,6 +182,9 @@ data Env gbl lcl
instance ContainsDynFlags (Env gbl lcl) where instance ContainsDynFlags (Env gbl lcl) where
extractDynFlags env = hsc_dflags (env_top env) 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 -- TcGblEnv describes the top-level of the module at the
-- point at which the typechecker is finished work. -- point at which the typechecker is finished work.
-- It is this structure that is handed on to the desugarer -- It is this structure that is handed on to the desugarer
...@@ -319,6 +322,9 @@ data TcGblEnv ...@@ -319,6 +322,9 @@ data TcGblEnv
-- as -XSafe (Safe Haskell) -- as -XSafe (Safe Haskell)
} }
instance ContainsModule TcGblEnv where
extractModule env = tcg_mod env
data RecFieldEnv data RecFieldEnv
= RecFields (NameEnv [Name]) -- Maps a constructor name *in this module* = RecFields (NameEnv [Name]) -- Maps a constructor name *in this module*
-- to the fields for that constructor -- to the fields for that constructor
......
...@@ -48,6 +48,7 @@ import MkCore ( rEC_SEL_ERROR_ID ) ...@@ -48,6 +48,7 @@ import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo import IdInfo
import Var import Var
import VarSet import VarSet
import Module
import Name import Name
import NameSet import NameSet
import NameEnv import NameEnv
......
...@@ -32,6 +32,7 @@ module IOEnv ( ...@@ -32,6 +32,7 @@ module IOEnv (
import DynFlags import DynFlags
import Exception import Exception
import Module
import Panic import Panic
import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
...@@ -93,6 +94,10 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where ...@@ -93,6 +94,10 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
getDynFlags = do env <- getEnv getDynFlags = do env <- getEnv
return $ extractDynFlags env return $ extractDynFlags env
instance ContainsModule env => HasModule (IOEnv env) where
getModule = do env <- getEnv
return $ extractModule env
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Fundmantal combinators specific to the monad -- 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