\begin{code}
module RnMonad(
module RnMonad,
+
+ module RdrName, -- Re-exports
+ module Name, -- from these two
+
Module,
FiniteMap,
Bag,
- Name,
RdrNameHsDecl,
RdrNameInstDecl,
Version,
#include "HsVersions.h"
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 405
+import IOExts ( fixIO )
+#elif defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 302
import PrelIOBase ( fixIO ) -- Should be in GlaExts
+#else
+import IOBase ( fixIO )
+#endif
import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )
import HsSyn
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig )
-import BasicTypes ( Version )
-import SrcLoc ( noSrcLoc )
+import HscTypes ( Finder,
+ AvailEnv, lookupTypeEnv,
+ OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv,
+ WhetherHasOrphans, ImportVersion,
+ PersistentRenamerState(..), IsBootInterface, Avails,
+ DeclsMap, IfaceInsts, IfaceRules,
+ HomeSymbolTable, PackageSymbolTable,
+ PersistentCompilerState(..), GlobalRdrEnv,
+ HomeIfaceTable, PackageIfaceTable,
+ RdrAvailInfo, ModIface )
+import BasicTypes ( Version, defaultFixity )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg, Message
)
-import Name ( Name, OccName, NamedThing(..),
- isLocallyDefinedName, nameModule, nameOccName,
- decode, mkLocalName
+import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
+ RdrNameEnv, emptyRdrEnv, extendRdrEnv,
+ lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts
)
-import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,
- mkModuleHiMaps, moduleName
+import Name ( Name, OccName, NamedThing(..), getSrcLoc,
+ isLocallyDefinedName, nameModule, nameOccName,
+ decode, mkLocalName, mkKnownKeyGlobal,
+ NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
+ extendNameEnvList
)
+import Module ( Module, ModuleName, lookupModuleEnvByName )
import NameSet
-import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc )
-import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas )
-import PrelInfo ( builtinNames )
-import TysWiredIn ( boolTyCon )
-import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
-import Unique ( Unique, getUnique, unboundKey )
-import UniqFM ( UniqFM )
-import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM,
- addListToFM_C, addToFM_C, eltsFM
- )
-import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
-import Maybes ( mapMaybe )
-import UniqSet
-import UniqFM
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
+import SrcLoc ( SrcLoc, generatedSrcLoc )
+import Unique ( Unique )
+import FiniteMap ( FiniteMap, emptyFM )
+import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import UniqSupply
-import Util
import Outputable
+import PrelNames ( mkUnboundName )
+import Maybes ( maybeToBool, seqMaybe, orElse )
infixr 9 `thenRn`, `thenRn_`
\end{code}
(\ err -> return (Left err))
traceRn :: SDoc -> RnM d ()
-traceRn msg | opt_D_dump_rn_trace = putDocRn msg
- | otherwise = returnRn ()
+traceRn msg
+ = doptRn Opt_D_dump_rn_trace `thenRn` \b ->
+ if b then putDocRn msg else returnRn ()
putDocRn :: SDoc -> RnM d ()
putDocRn msg = ioToRnM (printErrs msg) `thenRn_`
%* *
%************************************************************************
-===================================================
- MONAD TYPES
-===================================================
+%===================================================
+\subsubsection{ MONAD TYPES}
+%===================================================
\begin{code}
type RnM d r = RnDown -> d -> IO r
type RnMG r = RnM () r -- Getting global names etc
-- Common part
-data RnDown = RnDown {
- rn_mod :: ModuleName,
- rn_loc :: SrcLoc,
- rn_omit :: Name -> Bool, -- True <=> omit qualifier when printing
- rn_ns :: IORef RnNameSupply,
- rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),
- rn_ifaces :: IORef Ifaces,
- rn_hi_maps :: (ModuleHiMap, -- for .hi files
- ModuleHiMap) -- for .hi-boot files
- }
+data RnDown
+ = RnDown {
+ rn_mod :: Module, -- This module
+ rn_loc :: SrcLoc, -- Current locn
+
+ rn_finder :: Finder,
+ rn_dflags :: DynFlags,
+
+ rn_hit :: HomeIfaceTable,
+ rn_done :: Name -> Bool, -- Tells what things (both in the
+ -- home package and other packages)
+ -- were already available (i.e. in
+ -- the relevant SymbolTable) before
+ -- compiling this module
+
+ rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),
+
+ -- The second and third components are a flattened-out OrigNameEnv
+ rn_ns :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv),
+ rn_ifaces :: IORef Ifaces
+ }
-- For renaming source code
data SDown = SDown {
rn_mode :: RnMode,
- rn_genv :: GlobalRdrEnv, -- Global envt; the fixity component gets extended
- -- with local fixity decls
+ rn_genv :: GlobalRdrEnv, -- Global envt
rn_lenv :: LocalRdrEnv, -- Local name envt
- -- Does *not* includes global name envt; may shadow it
- -- Includes both ordinary variables and type variables;
- -- they are kept distinct because tyvar have a different
- -- occurrence contructor (Name.TvOcc)
- -- We still need the unsullied global name env so that
- -- we can look up record field names
-
- rn_fixenv :: FixityEnv -- Local fixities
- -- The global ones are held in the
- -- rn_ifaces field
+ -- Does *not* include global name envt; may shadow it
+ -- Includes both ordinary variables and type variables;
+ -- they are kept distinct because tyvar have a different
+ -- occurrence contructor (Name.TvOcc)
+ -- We still need the unsullied global name env so that
+ -- we can look up record field names
+
+ rn_fixenv :: LocalFixityEnv -- Local fixities
+ -- The global fixities are held in the
+ -- rn_ifaces field. Why? See the comments
+ -- with RnIfaces.lookupLocalFixity
}
data RnMode = SourceMode -- Renaming source code
| InterfaceMode -- Renaming interface declarations.
\end{code}
-===================================================
- ENVIRONMENTS
-===================================================
+%===================================================
+\subsubsection{ ENVIRONMENTS}
+%===================================================
\begin{code}
--------------------------------
-type RdrNameEnv a = FiniteMap RdrName a
-type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes
- -- These only get reported on lookup,
- -- not on construction
-type LocalRdrEnv = RdrNameEnv Name
-
-emptyRdrEnv :: RdrNameEnv a
-lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a
-addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a
-extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
-
-emptyRdrEnv = emptyFM
-lookupRdrEnv = lookupFM
-addListToRdrEnv = addListToFM
-rdrEnvElts = eltsFM
-extendRdrEnv = addToFM
-
---------------------------------
-type NameEnv a = UniqFM a -- Domain is Name
-
-emptyNameEnv :: NameEnv a
-nameEnvElts :: NameEnv a -> [a]
-addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
-addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a
-plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
-extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
-lookupNameEnv :: NameEnv a -> Name -> Maybe a
-delFromNameEnv :: NameEnv a -> Name -> NameEnv a
-elemNameEnv :: Name -> NameEnv a -> Bool
-
-emptyNameEnv = emptyUFM
-nameEnvElts = eltsUFM
-addToNameEnv_C = addToUFM_C
-addToNameEnv = addToUFM
-plusNameEnv = plusUFM
-extendNameEnv = addListToUFM
-lookupNameEnv = lookupUFM
-delFromNameEnv = delFromUFM
-elemNameEnv = elemUFM
-
---------------------------------
-type FixityEnv = NameEnv RenamedFixitySig
+type LocalRdrEnv = RdrNameEnv Name
+type LocalFixityEnv = NameEnv RenamedFixitySig
-- We keep the whole fixity sig so that we
-- can report line-number info when there is a duplicate
-- fixity declaration
+
+lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
+lookupLocalFixity env name
+ = case lookupNameEnv env name of
+ Just (FixitySig _ fix _) -> fix
+ Nothing -> defaultFixity
\end{code}
\begin{code}
---------------------------------
-type RnNameSupply
- = ( UniqSupply
-
- , FiniteMap (OccName, OccName) Int
- -- This is used as a name supply for dictionary functions
- -- From the inst decl we derive a (class, tycon) pair;
- -- this map then gives a unique int for each inst decl with that
- -- (class, tycon) pair. (In Haskell 98 there can only be one,
- -- but not so in more extended versions.)
- --
- -- We could just use one Int for all the instance decls, but this
- -- way the uniques change less when you add an instance decl,
- -- hence less recompilation
-
- , FiniteMap (ModuleName, OccName) Name
- -- Ensures that one (module,occname) pair gets one unique
- )
-
-
---------------------------------
-data ExportEnv = ExportEnv Avails Fixities
-type Avails = [AvailInfo]
-type Fixities = [(Name, Fixity)]
+type ExportAvails = (FiniteMap ModuleName Avails,
+ -- Used to figure out "module M" export specifiers
+ -- Includes avails only from *unqualified* imports
+ -- (see 1.4 Report Section 5.1.1)
-type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers
- -- Includes avails only from *unqualified* imports
- -- (see 1.4 Report Section 5.1.1)
-
- NameEnv AvailInfo) -- Used to figure out all other export specifiers.
- -- Maps a Name to the AvailInfo that contains it
-
-
-data GenAvailInfo name = Avail name -- An ordinary identifier
- | AvailTC name -- The name of the type or class
- [name] -- The available pieces of type/class. NB: If the type or
- -- class is itself to be in scope, it must be in this list.
- -- Thus, typically: AvailTC Eq [Eq, ==, /=]
-type AvailInfo = GenAvailInfo Name
-type RdrAvailInfo = GenAvailInfo OccName
+ AvailEnv) -- Used to figure out all other export specifiers.
\end{code}
-===================================================
- INTERFACE FILE STUFF
-===================================================
+%===================================================
+\subsubsection{ INTERFACE FILE STUFF}
+%===================================================
\begin{code}
-type ExportItem = (ModuleName, [RdrAvailInfo])
-type VersionInfo name = [ImportVersion name]
-
-type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name)
-
-type WhetherHasOrphans = Bool
- -- An "orphan" is
- -- * an instance decl in a module other than the defn module for
- -- one of the tycons or classes in the instance head
- -- * a transformation rule in a module other than the one defining
- -- the function in the head of the rule.
-
-data WhatsImported name = Everything
- | Specifically [LocalVersion name] -- List guaranteed non-empty
-
- -- ("M", hif, ver, Everything) means there was a "module M" in
- -- this module's export list, so we just have to go by M's version, "ver",
- -- not the list of LocalVersions.
-
-
-type LocalVersion name = (name, Version)
+type ExportItem = (ModuleName, [RdrAvailInfo])
data ParsedIface
= ParsedIface {
- pi_mod :: Version, -- Module version number
+ pi_mod :: Module, -- Complete with package info
+ pi_vers :: Version, -- Module version number
pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
pi_usages :: [ImportVersion OccName], -- Usages
- pi_exports :: [ExportItem], -- Exports
- pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
+ pi_exports :: (Version, [ExportItem]), -- Exports
pi_insts :: [RdrNameInstDecl], -- Local instance declarations
- pi_rules :: [RdrNameRuleDecl] -- Rules
+ pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
+ pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations,
+ pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
+ pi_deprecs :: [RdrNameDeprecation] -- Deprecations
}
+\end{code}
-type InterfaceDetails = (WhetherHasOrphans,
- VersionInfo Name, -- Version information for what this module imports
- ExportEnv) -- What modules this one depends on
-
-
--- needed by Main to fish out the fixities assoc list.
-getIfaceFixities :: InterfaceDetails -> Fixities
-getIfaceFixities (_, _, ExportEnv _ fs) = fs
-
-
-type RdrNamePragma = () -- Fudge for now
--------------------
+%************************************************************************
+%* *
+\subsection{The renamer state}
+%* *
+%************************************************************************
+\begin{code}
data Ifaces = Ifaces {
- iImpModInfo :: ImportedModuleInfo,
- -- Modules this one depends on: that is, the union
- -- of the modules its direct imports depend on.
-
- iDecls :: DeclsMap, -- A single, global map of Names to decls
-
- iFixes :: FixityEnv, -- A single, global map of Names to fixities
-
- iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not,
- -- whether locally defined or not) that have been slurped in so far.
-
- iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined
- -- names that have been slurped in so far, with their versions.
- -- This is used to generate the "usage" information for this module.
- -- Subset of the previous field.
-
- iInsts :: Bag GatedDecl,
- -- The as-yet un-slurped instance decls; this bag is depleted when we
- -- slurp an instance decl so that we don't slurp the same one twice.
- -- Each is 'gated' by the names that must be available before
- -- this instance decl is needed.
-
- iRules :: Bag GatedDecl
- -- Ditto transformation rules
- }
-
-type GatedDecl = (NameSet, (Module, RdrNameHsDecl))
-
-type ImportedModuleInfo
- = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails))
- -- Suppose the domain element is module 'A'
- --
- -- The first Bool is True if A contains
- -- 'orphan' rules or instance decls
-
- -- The second Bool is true if the interface file actually
- -- read was an .hi-boot file
-
- -- Nothing => A's interface not yet read, but this module has
- -- imported a module, B, that itself depends on A
- --
- -- Just xx => A's interface has been read. The Module in
- -- the Just has the correct Dll flag
-
- -- This set is used to decide whether to look for
- -- A.hi or A.hi-boot when importing A.f.
- -- Basically, we look for A.hi if A is in the map, and A.hi-boot
- -- otherwise
-
-type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl))
- -- A DeclsMap contains a binding for each Name in the declaration
- -- including the constructors of a type decl etc.
- -- The Bool is True just for the 'main' Name.
+ -- PERSISTENT FIELDS
+ iPIT :: PackageIfaceTable,
+ -- The ModuleIFaces for modules in other packages
+ -- whose interfaces we have opened
+ -- The declarations in these interface files are held in
+ -- iDecls, iInsts, iRules (below), not in the mi_decls fields
+ -- of the iPIT. What _is_ in the iPIT is:
+ -- * The Module
+ -- * Version info
+ -- * Its exports
+ -- * Fixities
+ -- * Deprecations
+ -- The iPIT field is initialised from the compiler's persistent
+ -- package symbol table, and the renamer incrementally adds
+ -- to it.
+
+ iDecls :: DeclsMap,
+ -- A single, global map of Names to unslurped decls
+
+ iInsts :: IfaceInsts,
+ -- The as-yet un-slurped instance decls; this bag is depleted when we
+ -- slurp an instance decl so that we don't slurp the same one twice.
+ -- Each is 'gated' by the names that must be available before
+ -- this instance decl is needed.
+
+ iRules :: IfaceRules,
+ -- Similar to instance decls, only for rules
+
+ -- EPHEMERAL FIELDS
+ -- These fields persist during the compilation of a single module only
+ iImpModInfo :: ImportedModuleInfo,
+ -- Modules this one depends on: that is, the union
+ -- of the modules its *direct* imports depend on.
+ -- NB: The direct imports have .hi files that enumerate *all* the
+ -- dependencies (direct or not) of the imported module.
+
+ iSlurp :: NameSet,
+ -- All the names (whether "big" or "small", whether wired-in or not,
+ -- whether locally defined or not) that have been slurped in so far.
+
+ iVSlurp :: [Name]
+ -- All the (a) non-wired-in (b) "big" (c) non-locally-defined
+ -- names that have been slurped in so far, with their versions.
+ -- This is used to generate the "usage" information for this module.
+ -- Subset of the previous field.
+ -- It's worth keeping separately, because there's no very easy
+ -- way to distinguish the "big" names from the "non-big" ones.
+ -- But this is a decision we might want to revisit.
+ }
+
+type ImportedModuleInfo = FiniteMap ModuleName
+ (WhetherHasOrphans, IsBootInterface, IsLoaded)
+type IsLoaded = Bool
\end{code}
%************************************************************************
\begin{code}
-initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc
- -> RnMG r
- -> IO (r, Bag ErrMsg, Bag WarnMsg)
-
-initRn mod us dirs loc do_rn = do
- himaps <- mkModuleHiMaps dirs
- names_var <- newIORef (us, emptyFM, builtins)
- errs_var <- newIORef (emptyBag,emptyBag)
- iface_var <- newIORef emptyIfaces
- let
- rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var,
- rn_errs = errs_var,
- rn_hi_maps = himaps,
- rn_ifaces = iface_var,
- rn_mod = mod }
-
+initRn :: DynFlags
+ -> Finder
+ -> HomeIfaceTable
+ -> HomeSymbolTable
+ -> PersistentCompilerState
+ -> Module
+ -> SrcLoc
+ -> RnMG t
+ -> IO (t, (Bag WarnMsg, Bag ErrMsg), PersistentCompilerState)
+
+initRn dflags finder hit hst pcs mod loc do_rn
+ = do
+ let prs = pcs_PRS pcs
+ let pst = pcs_PST pcs
+
+ uniqs <- mkSplitUniqSupply 'r'
+ names_var <- newIORef (uniqs, origNames (prsOrig prs),
+ origIParam (prsOrig prs))
+ errs_var <- newIORef (emptyBag,emptyBag)
+ iface_var <- newIORef (initIfaces pcs)
+ let rn_down = RnDown { rn_mod = mod,
+ rn_loc = loc,
+
+ rn_finder = finder,
+ rn_dflags = dflags,
+ rn_hit = hit,
+ rn_done = is_done hst pst,
+
+ rn_ns = names_var,
+ rn_errs = errs_var,
+ rn_ifaces = iface_var,
+ }
+
-- do the business
- res <- do_rn rn_down ()
-
- -- grab errors and return
- (warns, errs) <- readIORef errs_var
-
- return (res, errs, warns)
+ res <- do_rn rn_down ()
+
+ -- Grab state and record it
+ (warns, errs) <- readIORef errs_var
+ new_ifaces <- readIORef iface_var
+ (_, new_origN, new_origIP) <- readIORef names_var
+ let new_orig = Orig { origNames = new_origN, origIParam = new_origIP }
+ let new_prs = prs { prsOrig = new_orig,
+ prsDecls = iDecls new_ifaces,
+ prsInsts = iInsts new_ifaces,
+ prsRules = iRules new_ifaces }
+ let new_pcs = pcs { pcs_PIT = iPIT new_ifaces,
+ pcs_PRS = new_prs }
+
+ return (res, (warns, errs), new_pcs)
+
+is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool
+-- Returns True iff the name is in either symbol table
+is_done hst pst n = maybeToBool (lookupTypeEnv pst n `seqMaybe` lookupTypeEnv hst n)
+
+lookupIface :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> ModIface
+lookupIface hit pit mod = lookupModuleEnvByName hit mod `orElse`
+ lookupModuleEnvByName pit mod `orElse`
+ pprPanic "lookupIface" (ppr mod)
+
+initIfaces :: PersistentCompilerState -> Ifaces
+initIfaces (PCS { pcs_PIT = pit, pcs_PRS = prs })
+ = Ifaces { iPIT = pit,
+ iDecls = prsDecls prs,
+ iInsts = prsInsts prs,
+ iRules = prsRules prs,
+
+ iImpModInfo = emptyFM,
+ iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),
+ -- Pretend that the dummy unbound name has already been
+ -- slurped. This is what's returned for an out-of-scope name,
+ -- and we don't want thereby to try to suck it in!
+ iVSlurp = []
+ }
-initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r
+initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode -> RnMS r -> RnM d r
initRnMS rn_env fixity_env mode thing_inside rn_down g_down
= let
s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv,
initIfaceRnMS :: Module -> RnMS r -> RnM d r
initIfaceRnMS mod thing_inside
= initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $
- setModuleRn (moduleName mod) thing_inside
+ setModuleRn mod thing_inside
-emptyIfaces :: Ifaces
-emptyIfaces = Ifaces { iImpModInfo = emptyFM,
- iDecls = emptyNameEnv,
- iFixes = emptyNameEnv,
- iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),
- -- Pretend that the dummy unbound name has already been
- -- slurped. This is what's returned for an out-of-scope name,
- -- and we don't want thereby to try to suck it in!
- iVSlurp = [],
- iInsts = emptyBag,
- iRules = emptyBag
- }
-
--- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
--- during compiler debugging.
-mkUnboundName :: RdrName -> Name
-mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
-
-isUnboundName :: Name -> Bool
-isUnboundName name = getUnique name == unboundKey
-
-builtins :: FiniteMap (ModuleName,OccName) Name
-builtins =
- bagToFM (
- mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name))
- builtinNames)
\end{code}
-@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
-the main renamer. Sole examples: derived definitions, which are only generated
-in the type checker.
+@renameSourceCode@ is used to rename stuff ``out-of-line'';
+that is, not as part of the main renamer.
+Sole examples: derived definitions,
+which are only generated in the type checker.
-The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
+The @NameSupply@ includes a @UniqueSupply@, so if you call it more than
once you must either split it, or install a fresh unique supply.
\begin{code}
-renameSourceCode :: ModuleName
- -> RnNameSupply
+renameSourceCode :: DynFlags
+ -> Module
+ -> PersistentRenamerState
-> RnMS r
-> r
-renameSourceCode mod_name name_supply m
+renameSourceCode dflags mod prs m
= unsafePerformIO (
-- It's not really unsafe! When renaming source code we
-- only do any I/O if we need to read in a fixity declaration;
-- and that doesn't happen in pragmas etc
- newIORef name_supply >>= \ names_var ->
- newIORef (emptyBag,emptyBag) >>= \ errs_var ->
+ mkSplitUniqSupply 'r' >>= \ new_us ->
+ newIORef (new_us, origNames (prsOrig prs),
+ origIParam (prsOrig prs)) >>= \ names_var ->
+ newIORef (emptyBag,emptyBag) >>= \ errs_var ->
let
- rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var,
- rn_errs = errs_var,
- rn_mod = mod_name }
- s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc
+ rn_down = RnDown { rn_dflags = dflags,
+ rn_loc = generatedSrcLoc, rn_ns = names_var,
+ rn_errs = errs_var,
+ rn_mod = mod,
+ rn_done = bogus "rn_done", rn_hit = bogus "rn_hit",
+ rn_ifaces = bogus "rn_ifaces", rn_finder = bogus "rn_finder"
+ }
+ s_down = SDown { rn_mode = InterfaceMode,
+ -- So that we can refer to PrelBase.True etc
rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
rn_fixenv = emptyNameEnv }
in
where
display errs = pprBagOfErrors errs
+bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields
+
{-# INLINE thenRn #-}
{-# INLINE thenRn_ #-}
{-# INLINE returnRn #-}
mapRn :: (a -> RnM d b) -> [a] -> RnM d [b]
mapRn_ :: (a -> RnM d b) -> [a] -> RnM d ()
mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b]
+flatMapRn :: (a -> RnM d [b]) -> [a] -> RnM d [b]
sequenceRn :: [RnM d a] -> RnM d [a]
foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b
mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c])
case maybe_r of
Nothing -> returnRn rs
Just r -> returnRn (r:rs)
+
+flatMapRn f [] = returnRn []
+flatMapRn f (x:xs) = f x `thenRn` \ r ->
+ flatMapRn f xs `thenRn` \ rs ->
+ returnRn (r ++ rs)
\end{code}
%************************************************************************
-================ Errors and warnings =====================
+%================
+\subsubsection{ Errors and warnings}
+%=====================
\begin{code}
failWithRn :: a -> Message -> RnM d a
checkErrsRn (RnDown {rn_errs = errs_var}) l_down
= readIORef errs_var >>= \ (warns,errs) ->
return (isEmptyBag errs)
+
+doptRn :: DynFlag -> RnM d Bool
+doptRn dflag (RnDown { rn_dflags = dflags}) l_down
+ = return (dopt dflag dflags)
+
+getDOptsRn :: RnM d DynFlags
+getDOptsRn (RnDown { rn_dflags = dflags}) l_down
+ = return dflags
\end{code}
-================ Source location =====================
+%================
+\subsubsection{Source location}
+%=====================
\begin{code}
pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a
= return (rn_loc down)
\end{code}
-================ Name supply =====================
+%================
+\subsubsection{The finder and home symbol table}
+%=====================
+
+\begin{code}
+getFinderRn :: RnM d Finder
+getFinderRn down l_down = return (rn_finder down)
+
+getHomeIfaceTableRn :: RnM d HomeIfaceTable
+getHomeIfaceTableRn down l_down = return (rn_hit down)
+
+checkAlreadyAvailable :: Name -> RnM d Bool
+checkAlreadyAvailable name down l_down = return (rn_done down name)
+\end{code}
+
+%================
+\subsubsection{Name supply}
+%=====================
\begin{code}
-getNameSupplyRn :: RnM d RnNameSupply
+getNameSupplyRn :: RnM d (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv)
getNameSupplyRn rn_down l_down
= readIORef (rn_ns rn_down)
-setNameSupplyRn :: RnNameSupply -> RnM d ()
+setNameSupplyRn :: (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) -> RnM d ()
setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
= writeIORef names_var names'
--- See comments with RnNameSupply above.
-newInstUniq :: (OccName, OccName) -> RnM d Int
-newInstUniq key (RnDown {rn_ns = names_var}) l_down
- = readIORef names_var >>= \ (us, mapInst, cache) ->
- let
- uniq = case lookupFM mapInst key of
- Just x -> x+1
- Nothing -> 0
- mapInst' = addToFM mapInst key uniq
- in
- writeIORef names_var (us, mapInst', cache) >>
- return uniq
-
getUniqRn :: RnM d Unique
getUniqRn (RnDown {rn_ns = names_var}) l_down
- = readIORef names_var >>= \ (us, mapInst, cache) ->
+ = readIORef names_var >>= \ (us, cache, ipcache) ->
let
(us1,us') = splitUniqSupply us
in
- writeIORef names_var (us', mapInst, cache) >>
+ writeIORef names_var (us', cache, ipcache) >>
return (uniqFromSupply us1)
\end{code}
-================ Module =====================
+%================
+\subsubsection{ Module}
+%=====================
\begin{code}
-getModuleRn :: RnM d ModuleName
-getModuleRn (RnDown {rn_mod = mod_name}) l_down
- = return mod_name
+getModuleRn :: RnM d Module
+getModuleRn (RnDown {rn_mod = mod}) l_down
+ = return mod
-setModuleRn :: ModuleName -> RnM d a -> RnM d a
+setModuleRn :: Module -> RnM d a -> RnM d a
setModuleRn new_mod enclosed_thing rn_down l_down
= enclosed_thing (rn_down {rn_mod = new_mod}) l_down
\end{code}
-\begin{code}
-setOmitQualFn :: (Name -> Bool) -> RnM d a -> RnM d a
-setOmitQualFn fn m g_down l_down = m (g_down { rn_omit = fn }) l_down
-
-getOmitQualFn :: RnM d (Name -> Bool)
-getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down
- = return omit_fn
-\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-================ RnEnv =====================
+%================
+\subsubsection{ RnEnv}
+%=====================
\begin{code}
-getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv)
-getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env})
- = return (global_env, local_env)
-
getLocalNameEnv :: RnMS LocalRdrEnv
getLocalNameEnv rn_down (SDown {rn_lenv = local_env})
= return local_env
+getGlobalNameEnv :: RnMS GlobalRdrEnv
+getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
+ = return global_env
+
setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
setLocalNameEnv local_env' m rn_down l_down
= m rn_down (l_down {rn_lenv = local_env'})
-getFixityEnv :: RnMS FixityEnv
+getFixityEnv :: RnMS LocalFixityEnv
getFixityEnv rn_down (SDown {rn_fixenv = fixity_env})
= return fixity_env
extendFixityEnv fixes enclosed_scope
rn_down l_down@(SDown {rn_fixenv = fixity_env})
= let
- new_fixity_env = extendNameEnv fixity_env fixes
+ new_fixity_env = extendNameEnvList fixity_env fixes
in
enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env})
\end{code}
-================ Mode =====================
+%================
+\subsubsection{ Mode}
+%=====================
\begin{code}
getModeRn :: RnMS RnMode
setIfacesRn :: Ifaces -> RnM d ()
setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _
= writeIORef iface_var ifaces
-
-getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap)
-getHiMaps (RnDown {rn_hi_maps = himaps}) _
- = return himaps
\end{code}
projects / ghc-hetmet.git / blobdiff