X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=a6e08ae6873a1e1004fadc78efff9f4fb6e9e23f;hb=d0f325ce37d6ee322168e44392f10e0ed52f8294;hp=dcdc7186fecc2ee6adb81c0f16f0d307eb2685e0;hpb=9c26739695219d8343505a88457cb55c76b65449;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index dcdc718..a6e08ae 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -4,65 +4,48 @@ \section[RnMonad]{The monad used by the renamer} \begin{code} -#include "HsVersions.h" - module RnMonad( - EXP_MODULE(RnMonad), - -- close it up (partly done to allow unfoldings) - EXP_MODULE(SST), - SYN_IE(Module), + module RnMonad, + Module, FiniteMap, Bag, Name, - SYN_IE(RdrNameHsDecl), - SYN_IE(RdrNameInstDecl), - SYN_IE(Version), - SYN_IE(NameSet), + RdrNameHsDecl, + RdrNameInstDecl, + Version, + NameSet, OccName, Fixity ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import SST -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST ) -#define MkIO -#else -import GlaExts -import IO -import ST -import IOBase -#define IOError13 IOError -#define MkIO IO -#endif +import GlaExts ( RealWorld, stToIO ) import HsSyn import RdrHsSyn -import BasicTypes ( SYN_IE(Version), NewOrData ) -import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning) +import BasicTypes ( Version, NewOrData, pprModule ) +import SrcLoc ( noSrcLoc ) +import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, + pprBagOfErrors, ErrMsg, WarnMsg ) -import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet, +import Name ( Module, Name, OccName, PrintUnqualified, NameSet, emptyNameSet, isLocallyDefinedName, modAndOcc, NamedThing(..) ) import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas ) import PrelInfo ( builtinNames ) -import TyCon ( TyCon {- instance NamedThing -} ) import TysWiredIn ( boolTyCon ) -import Pretty -import Outputable ( PprStyle(..) ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique ) import UniqFM ( UniqFM ) -import FiniteMap ( FiniteMap, emptyFM, bagToFM ) +import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) import UniqSet -import Util -#if __GLASGOW_HASKELL__ >= 202 import UniqSupply -#endif +import Util +import Outputable infixr 9 `thenRn`, `thenRn_` \end{code} @@ -75,28 +58,19 @@ infixr 9 `thenRn`, `thenRn_` %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ >= 200 -# define REAL_WORLD RealWorld -#else -# define REAL_WORLD _RealWorld -#endif -\end{code} - -\begin{code} -sstToIO :: SST REAL_WORLD r -> IO r -sstToIO sst = - MkIO ( - sstToST sst `thenStrictlyST` \ r -> - returnStrictlyST (Right r)) - -ioToRnMG :: IO r -> RnMG (Either IOError13 r) -ioToRnMG (MkIO io) rn_down g_down = stToSST io - -traceRn :: Doc -> RnMG () -traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (show msg) >> - hPutStr stderr "\n") `thenRn_` - returnRn () +sstToIO :: SST RealWorld r -> IO r +sstToIO sst = stToIO (sstToST sst) + +ioToRnMG :: IO r -> RnMG (Either IOError r) +ioToRnMG io rn_down g_down = ioToSST io + +traceRn :: SDoc -> RnMG () +traceRn msg | opt_D_show_rn_trace = putDocRn msg | otherwise = returnRn () + +putDocRn :: SDoc -> RnMG () +putDocRn msg = ioToRnMG (printErrs msg) `thenRn_` + returnRn () \end{code} @@ -112,16 +86,18 @@ traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (show msg) >> \begin{code} type RnM s d r = RnDown s -> d -> SST s r -type RnMS s r = RnM s (SDown s) r -- Renaming source -type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc -type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this +type RnMS s r = RnM s (SDown s) r -- Renaming source +type RnMG r = RnM RealWorld GDown r -- Getting global names etc +type SSTRWRef a = SSTRef RealWorld a -- ToDo: there ought to be a standard defn of this -- Common part data RnDown s = RnDown SrcLoc - (MutableVar s RnNameSupply) - (MutableVar s (Bag Warning, Bag Error)) - (MutableVar s ([Name],[Name])) -- Occurrences: compulsory and optional resp + (SSTRef s (GenRnNameSupply s)) + (SSTRef s (Bag WarnMsg, Bag ErrMsg)) + (SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp + +type Occurrence = (Name, SrcLoc) -- The srcloc is the occurrence site data Necessity = Compulsory | Optional -- We *must* find definitions for -- compulsory occurrences; we *may* find them @@ -130,7 +106,7 @@ data Necessity = Compulsory | Optional -- We *must* find definitions for -- For getting global names data GDown = GDown SearchPath - (MutVar Ifaces) + (SSTRWRef Ifaces) -- For renaming source code data SDown s = SDown @@ -142,12 +118,15 @@ data SDown s = SDown data RnSMode = SourceMode -- Renaming source code - | InterfaceMode Necessity -- Renaming interface declarations. The "necessity" + | InterfaceMode -- Renaming interface declarations. + Necessity -- The "necessity" -- flag says free variables *must* be found and slurped -- or whether they need not be. For value signatures of -- things that are themselves compulsorily imported - -- we arrange that the type signature is read in compulsory mode, + -- we arrange that the type signature is read + -- in compulsory mode, -- but the pragmas in optional mode. + (Name -> PrintUnqualified) -- Tells whether the thing can be printed unqualified type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search -- for interface files. @@ -159,18 +138,31 @@ type FreeVars = NameSet =================================================== \begin{code} -type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name) +type RnNameSupply = GenRnNameSupply RealWorld + +type GenRnNameSupply s + = ( UniqSupply + , FiniteMap FAST_STRING (SSTRef s Int) + , FiniteMap (Module,OccName) Name + ) -- Ensures that one (m,n) pair gets one unique - -- The Int is used to give a number to each instance declaration; - -- it's really a separate name supply. + -- The finite map on FAST_STRINGS is used to give a per-class unique to each + -- instance declaration; it's really a separate name supply. + +data RnEnv = RnEnv GlobalNameEnv FixityEnv +emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv -data RnEnv = RnEnv NameEnv FixityEnv -emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv +type GlobalNameEnv = FiniteMap RdrName (Name, HowInScope) +emptyGlobalNameEnv = emptyFM + +data HowInScope -- Used for error messages only + = FromLocalDefn SrcLoc + | FromImportDecl Module SrcLoc type NameEnv = FiniteMap RdrName Name emptyNameEnv = emptyFM -type FixityEnv = FiniteMap RdrName (Fixity, Provenance) +type FixityEnv = FiniteMap RdrName (Fixity, HowInScope) emptyFixityEnv = emptyFM -- It's possible to have a different fixity for B.op than for op: -- @@ -181,11 +173,8 @@ emptyFixityEnv = emptyFM data ExportEnv = ExportEnv Avails Fixities type Avails = [AvailInfo] -type Fixities = [(OccName, (Fixity, Provenance))] - -- Can contain duplicates, if one module defines the same fixity, - -- or the same type/class/id, more than once. Hence a boring old list. - -- This allows us to report duplicates in just one place, namely plusRnEnv. - +type Fixities = [(OccName, Fixity)] + type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers -- Includes avails only from *unqualified* imports -- (see 1.4 Report Section 5.1.1) @@ -196,12 +185,14 @@ type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" e -- not constructors (see defn of availEntityNames) -data AvailInfo = NotAvailable - | 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 +data GenAvailInfo name = NotAvailable + | 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 \end{code} =================================================== @@ -209,9 +200,18 @@ data AvailInfo = NotAvailable =================================================== \begin{code} -type ExportItem = (Module, [(OccName, [OccName])]) +type ExportItem = (Module, IfaceFlavour, [RdrAvailInfo]) type VersionInfo name = [ImportVersion name] -type ImportVersion name = (Module, Version, [LocalVersion name]) + +type ImportVersion name = (Module, IfaceFlavour, Version, WhatsImported name) +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) data ParsedIface @@ -225,7 +225,7 @@ data ParsedIface [(Version, RdrNameHsDecl)] -- Local definitions [RdrNameInstDecl] -- Local instance declarations -type InterfaceDetails = (VersionInfo Name, -- Version information +type InterfaceDetails = (VersionInfo Name, -- Version information for what this module imports ExportEnv, -- What this module exports [Module]) -- Instance modules @@ -233,9 +233,11 @@ type RdrNamePragma = () -- Fudge for now ------------------- data Ifaces = Ifaces - Module -- Name of this module - (FiniteMap Module Version) - (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports + Module -- Name of this module + (FiniteMap Module (IfaceFlavour, -- Exports + Version, + Avails, + [(OccName,Fixity)])) DeclsMap NameSet -- All the names (whether "big" or "small", whether wired-in or not, @@ -279,14 +281,14 @@ type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl \begin{code} initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc -> RnMG r - -> IO (r, Bag Error, Bag Warning) + -> IO (r, Bag ErrMsg, Bag WarnMsg) initRn mod us dirs loc do_rn = sstToIO $ - newMutVarSST (us, 1, builtins) `thenSST` \ names_var -> - newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> - newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var -> - newMutVarSST initOccs `thenSST` \ occs_var -> + newMutVarSST (us, emptyFM, builtins) `thenSST` \ names_var -> + newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> + newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var -> + newMutVarSST initOccs `thenSST` \ occs_var -> let rn_down = RnDown loc names_var errs_var occs_var g_down = GDown dirs iface_var @@ -299,23 +301,23 @@ initRn mod us dirs loc do_rn returnSST (res, errs, warns) -initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r +initRnMS :: RnEnv -> Module -> RnSMode -> RnMS RealWorld r -> RnMG r initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down = let - s_down = SDown rn_env name_env mod_name mode + s_down = SDown rn_env emptyNameEnv mod_name mode in m rn_down s_down emptyIfaces :: Module -> Ifaces -emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM [] +emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM [] builtins :: FiniteMap (Module,OccName) Name builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames) -- Initial value for the occurrence pool. -initOccs :: ([Name],[Name]) -- Compulsory and optional respectively -initOccs = ([getName boolTyCon], []) +initOccs :: ([Occurrence],[Occurrence]) -- Compulsory and optional respectively +initOccs = ([(getName boolTyCon, noSrcLoc)], []) -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and -- rather implausible that not one will be used in the module. -- We could add some other common types, notably lists, but the general idea is @@ -335,8 +337,8 @@ once you must either split it, or install a fresh unique supply. \begin{code} renameSourceCode :: Module - -> RnNameSupply - -> RnMS REAL_WORLD r + -> RnNameSupply + -> RnMS RealWorld r -> r -- Alas, we can't use the real runST, with the desired signature: @@ -350,23 +352,25 @@ renameSourceCode mod_name name_supply m newMutVarSST ([],[]) `thenSST` \ occs_var -> let rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var - s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory) + s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory (\_ -> False)) in m rn_down s_down `thenSST` \ result -> readMutVarSST errs_var `thenSST` \ (warns,errs) -> (if not (isEmptyBag errs) then - trace ("Urk! renameSourceCode found errors" ++ display errs) + pprTrace "Urk! renameSourceCode found errors" (display errs) +#ifdef DEBUG else if not (isEmptyBag warns) then - trace ("Urk! renameSourceCode found warnings" ++ display warns) + pprTrace "Urk! renameSourceCode found warnings" (display warns) +#endif else id) $ returnSST result ) where - display errs = show (pprBagOfErrors PprDebug errs) + display errs = pprBagOfErrors errs {-# INLINE thenRn #-} {-# INLINE thenRn_ #-} @@ -378,6 +382,7 @@ thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b] +mapMaybeRn :: (a -> RnM s d b) -> b -> Maybe a -> RnM s d b sequenceRn :: [RnM s d a] -> RnM s d [a] foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c]) @@ -418,6 +423,9 @@ mapAndUnzip3Rn f (x:xs) = f x `thenRn` \ (r1, r2, r3) -> mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> returnRn (r1:rs1, r2:rs2, r3:rs3) + +mapMaybeRn f def Nothing = returnRn def +mapMaybeRn f def (Just v) = f v \end{code} @@ -432,7 +440,7 @@ mapAndUnzip3Rn f (x:xs) ================ Errors and warnings ===================== \begin{code} -failWithRn :: a -> Error -> RnM s d a +failWithRn :: a -> ErrMsg -> RnM s d a failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` @@ -440,7 +448,7 @@ failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down where err = addShortErrLocLine loc msg -warnWithRn :: a -> Warning -> RnM s d a +warnWithRn :: a -> WarnMsg -> RnM s d a warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` @@ -448,14 +456,14 @@ warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down where warn = addShortWarnLocLine loc msg -addErrRn :: Error -> RnM s d () +addErrRn :: ErrMsg -> RnM s d () addErrRn err = failWithRn () err -checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true +checkRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true checkRn False err = addErrRn err checkRn True err = returnRn () -addWarnRn :: Warning -> RnM s d () +addWarnRn :: WarnMsg -> RnM s d () addWarnRn warn = warnWithRn () warn checkErrsRn :: RnM s d Bool -- True <=> no errors so far @@ -480,21 +488,34 @@ getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down ================ Name supply ===================== \begin{code} -getNameSupplyRn :: RnM s d RnNameSupply +getNameSupplyRn :: RnM s d (GenRnNameSupply s) getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST names_var -setNameSupplyRn :: RnNameSupply -> RnM s d () +setNameSupplyRn :: GenRnNameSupply s -> RnM s d () setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down = writeMutVarSST names_var names' --- The "instance-decl unique supply", inst, is just an integer that's used to --- give a unique number for each instance declaration. -newInstUniq :: RnM s d Int -newInstUniq (RnDown loc names_var errs_var occs_var) l_down - = readMutVarSST names_var `thenSST` \ (us, inst, cache) -> - writeMutVarSST names_var (us, inst+1, cache) `thenSST_` - returnSST inst +-- The "instance-decl unique supply", inst, is really a map from class names +-- to unique supplies. Having per-class unique numbers for instance decls helps +-- the recompilation checker. +newInstUniq :: FAST_STRING -> RnM s d Int +newInstUniq cname (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) -> + case lookupFM mapInst cname of + Just class_us -> + readMutVarSST class_us `thenSST` \ v -> + writeMutVarSST class_us (v+1) `thenSST_` + returnSST v + Nothing -> -- first time caller gets to add a unique supply + -- to the finite map for that class. + newMutVarSST 1 `thenSST` \ class_us -> + let + mapInst' = addToFM mapInst cname class_us + in + writeMutVarSST names_var (us, mapInst', cache) `thenSST_` + returnSST 0 + \end{code} ================ Occurrences ===================== @@ -534,15 +555,13 @@ addOccurrenceName name (RnDown loc names_var errs_var occs_var) = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) -> let new_occ_pair = case necessity of - Optional -> (comp_occs, name:opt_occs) - Compulsory -> (name:comp_occs, opt_occs) + Optional -> (comp_occs, (name,loc):opt_occs) + Compulsory -> ((name,loc):comp_occs, opt_occs) in writeMutVarSST occs_var new_occ_pair `thenSST_` returnSST name where - necessity = case mode of - SourceMode -> Compulsory - InterfaceMode necessity -> necessity + necessity = modeToNecessity mode addOccurrenceNames :: [Name] -> RnMS s () @@ -555,34 +574,34 @@ addOccurrenceNames names (RnDown loc names_var errs_var occs_var) = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) -> let new_occ_pair = case necessity of - Optional -> (comp_occs, non_local_names ++ opt_occs) - Compulsory -> (non_local_names ++ comp_occs, opt_occs) + Optional -> (comp_occs, non_local_occs ++ opt_occs) + Compulsory -> (non_local_occs ++ comp_occs, opt_occs) in writeMutVarSST occs_var new_occ_pair where - non_local_names = filter (not . isLocallyDefinedName) names - necessity = case mode of - SourceMode -> Compulsory - InterfaceMode necessity -> necessity + non_local_occs = [(name, loc) | name <- names, not (isLocallyDefinedName name)] + necessity = modeToNecessity mode -- Never look for optional things if we're -- ignoring optional input interface information not_necessary Compulsory = False not_necessary Optional = opt_IgnoreIfacePragmas -popOccurrenceName :: Necessity -> RnM s d (Maybe Name) -popOccurrenceName necessity (RnDown loc names_var errs_var occs_var) l_down +popOccurrenceName :: RnSMode -> RnM s d (Maybe Occurrence) +popOccurrenceName mode (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST occs_var `thenSST` \ occs -> - case (necessity, occs) of + case (mode, occs) of -- Find a compulsory occurrence - (Compulsory, (comp:comps, opts)) -> writeMutVarSST occs_var (comps, opts) `thenSST_` - returnSST (Just comp) + (InterfaceMode Compulsory _, (comp:comps, opts)) + -> writeMutVarSST occs_var (comps, opts) `thenSST_` + returnSST (Just comp) -- Find an optional occurrence -- We shouldn't be looking unless we've done all the compulsories - (Optional, (comps, opt:opts)) -> ASSERT( null comps ) - writeMutVarSST occs_var (comps, opts) `thenSST_` - returnSST (Just opt) + (InterfaceMode Optional _, (comps, opt:opts)) + -> ASSERT( null comps ) + writeMutVarSST occs_var (comps, opts) `thenSST_` + returnSST (Just opt) -- No suitable occurrence other -> returnSST Nothing @@ -598,7 +617,7 @@ findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down = newMutVarSST ([],[]) `thenSST` \ new_occs_var -> enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_` readMutVarSST new_occs_var `thenSST` \ (occs,_) -> - returnSST occs + returnSST (map fst occs) \end{code} @@ -611,16 +630,32 @@ findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down ================ RnEnv ===================== \begin{code} -getGlobalNameEnv :: RnMS s NameEnv -getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) - = returnSST global_env - -getNameEnv :: RnMS s NameEnv -getNameEnv rn_down (SDown rn_env local_env mod_name mode) +-- Look in global env only +lookupGlobalNameRn :: RdrName -> RnMS s (Maybe Name) +lookupGlobalNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) + = case lookupFM global_env rdr_name of + Just (name, _) -> returnSST (Just name) + Nothing -> returnSST Nothing + +-- Look in both local and global env +lookupNameRn :: RdrName -> RnMS s (Maybe Name) +lookupNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) + = case lookupFM local_env rdr_name of + Just name -> returnSST (Just name) + Nothing -> case lookupFM global_env rdr_name of + Just (name, _) -> returnSST (Just name) + Nothing -> returnSST Nothing + +getNameEnvs :: RnMS s (GlobalNameEnv, NameEnv) +getNameEnvs rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) + = returnSST (global_env, local_env) + +getLocalNameEnv :: RnMS s NameEnv +getLocalNameEnv rn_down (SDown rn_env local_env mod_name mode) = returnSST local_env -setNameEnv :: NameEnv -> RnMS s a -> RnMS s a -setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode) +setLocalNameEnv :: NameEnv -> RnMS s a -> RnMS s a +setLocalNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode) = m rn_down (SDown rn_env local_env' mod_name mode) getFixityEnv :: RnMS s FixityEnv @@ -666,3 +701,22 @@ getSearchPathRn :: RnMG SearchPath getSearchPathRn rn_down (GDown dirs iface_var) = returnSST dirs \end{code} + +%************************************************************************ +%* * +\subsection{HowInScope} +%* * +%************************************************************************ + +\begin{code} +instance Outputable HowInScope where + ppr (FromLocalDefn loc) = ptext SLIT("Defined at") <+> ppr loc + ppr (FromImportDecl mod loc) = ptext SLIT("Imported from") <+> quotes (pprModule mod) <+> + ptext SLIT("at") <+> ppr loc +\end{code} + + +\begin{code} +modeToNecessity SourceMode = Compulsory +modeToNecessity (InterfaceMode necessity _) = necessity +\end{code}