X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=189649b593862a967c3b8ce857711a164a0a068e;hb=90c0b29e6d8d847e5357bd0a9df98e2846046db7;hp=176b3f7bc4744d89124fb406829d7bd7327d055f;hpb=4e6d0831f8260f6cf1f8b9f118123d2c4fb86ee1;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 176b3f7..189649b 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -27,17 +27,23 @@ import List ( intersperse ) import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig ) -import BasicTypes ( Version, IfaceFlavour(..) ) +import BasicTypes ( Version ) import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, ErrMsg, WarnMsg + pprBagOfErrors, ErrMsg, WarnMsg, Message ) -import Name ( Module, Name, OccName, PrintUnqualified, - isLocallyDefinedName, pprModule, - modAndOcc, NamedThing(..) +import Name ( Name, OccName, NamedThing(..), + isLocallyDefinedName, nameModule, nameOccName, + decode + ) +import Module ( Module, IfaceFlavour, setModuleFlavour, mkSysModuleFS, + bootFlavour, moduleString, moduleIfaceFlavour, mkDynFlavour ) import NameSet -import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, opt_WarnHiShadows ) +import RdrName ( RdrName ) +import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, + opt_WarnHiShadows, opt_Static + ) import PrelInfo ( builtinNames ) import TysWiredIn ( boolTyCon ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) @@ -54,6 +60,7 @@ import UniqSupply import Util import Outputable import DirUtils ( getDirectoryContents ) +import Directory ( doesFileExist ) import IO ( hPutStrLn, stderr, isDoesNotExistError ) import Monad ( foldM ) import Maybe ( fromMaybe ) @@ -103,11 +110,16 @@ 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 - (SSTRef s RnNameSupply) - (SSTRef s (Bag WarnMsg, Bag ErrMsg)) - (SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp +data RnDown s = RnDown { + rn_loc :: SrcLoc, + rn_omit :: Name -> Bool, -- True <=> omit qualifier when printing + rn_ns :: SSTRef s RnNameSupply, + rn_errs :: SSTRef s (Bag WarnMsg, Bag ErrMsg), + rn_occs :: SSTRef s ([Occurrence],[Occurrence]), -- Occurrences: compulsory and optional resp + rn_hi_map :: ModuleHiMap, -- for .hi files + rn_hiboot_map :: ModuleHiMap, -- for .hi-boot files + rn_mod :: Module + } type Occurrence = (Name, SrcLoc) -- The srcloc is the occurrence site @@ -116,27 +128,25 @@ data Necessity = Compulsory | Optional -- We *must* find definitions for -- for optional ones. -- For getting global names -data GDown = GDown - ModuleHiMap -- for .hi files - ModuleHiMap -- for .hi-boot files - (SSTRWRef Ifaces) +data GDown = GDown { + rn_ifaces :: SSTRWRef Ifaces + } -- For renaming source code -data SDown s = SDown - RnEnv -- Global envt; the fixity component gets extended +data SDown s = SDown { + rn_mode :: RnMode, + rn_genv :: RnEnv, -- Global envt; the fixity component gets extended -- with local fixity decls - LocalRdrEnv -- Local name 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 - Module - RnSMode - + } -data RnSMode = SourceMode -- Renaming source code +data RnMode = SourceMode -- Renaming source code | InterfaceMode -- Renaming interface declarations. Necessity -- The "necessity" -- flag says free variables *must* be found and slurped @@ -149,7 +159,7 @@ data RnSMode = SourceMode -- Renaming source code type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search -- for interface files. -type ModuleHiMap = FiniteMap String String +type ModuleHiMap = FiniteMap String (String, Bool) -- mapping from module name to the file path of its corresponding -- interface file. \end{code} @@ -240,8 +250,7 @@ type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" e -- Maps a Name to the AvailInfo that contains it -data GenAvailInfo name = NotAvailable - | Avail name -- An ordinary identifier +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. @@ -255,10 +264,10 @@ type RdrAvailInfo = GenAvailInfo OccName =================================================== \begin{code} -type ExportItem = (Module, IfaceFlavour, [RdrAvailInfo]) +type ExportItem = (Module, [RdrAvailInfo]) type VersionInfo name = [ImportVersion name] -type ImportVersion name = (Module, IfaceFlavour, Version, WhatsImported name) +type ImportVersion name = (Module, Version, WhatsImported name) data WhatsImported name = Everything | Specifically [LocalVersion name] -- List guaranteed non-empty @@ -271,7 +280,6 @@ type LocalVersion name = (name, Version) data ParsedIface = ParsedIface - Module -- Module name Version -- Module version number [ImportVersion OccName] -- Usages [ExportItem] -- Exports @@ -283,11 +291,17 @@ type InterfaceDetails = (VersionInfo Name, -- Version information for what this ExportEnv, -- What this module exports [Module]) -- Instance modules + +-- needed by Main to fish out the fixities assoc list. +getIfaceFixities :: InterfaceDetails -> Fixities +getIfaceFixities (_, ExportEnv _ fs, _) = fs + + type RdrNamePragma = () -- Fudge for now ------------------- data Ifaces = Ifaces { - iMod :: Module, -- Name of this module + iMod :: Module, -- Name of the module being compiled iModMap :: FiniteMap Module (IfaceFlavour, -- Exports Version, @@ -347,14 +361,17 @@ initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc -> IO (r, Bag ErrMsg, Bag WarnMsg) initRn mod us dirs loc do_rn = do + (himap, hibmap) <- mkModuleHiMaps dirs names_var <- sstToIO (newMutVarSST (us, emptyFM, builtins)) errs_var <- sstToIO (newMutVarSST (emptyBag,emptyBag)) iface_var <- sstToIO (newMutVarSST (emptyIfaces mod)) occs_var <- sstToIO (newMutVarSST initOccs) - (himap, hibmap) <- mkModuleHiMaps dirs let - rn_down = RnDown loc names_var errs_var occs_var - g_down = GDown himap hibmap iface_var + rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var, + rn_errs = errs_var, rn_occs = occs_var, + rn_hi_map = himap, rn_hiboot_map = hibmap, + rn_mod = mod } + g_down = GDown {rn_ifaces = iface_var } -- do the business res <- sstToIO (do_rn rn_down g_down) @@ -364,10 +381,10 @@ initRn mod us dirs loc do_rn = do return (res, errs, warns) -initRnMS :: RnEnv -> Module -> RnSMode -> RnMS RealWorld r -> RnMG r -initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down +initRnMS :: RnEnv -> RnMode -> RnMS RealWorld r -> RnMG r +initRnMS rn_env mode m rn_down g_down = let - s_down = SDown rn_env emptyRdrEnv mod_name mode + s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, rn_mode = mode } in m rn_down s_down @@ -383,9 +400,11 @@ emptyIfaces mod = Ifaces { iMod = mod, iDefData = emptyNameEnv, iInstMods = [] } - builtins :: FiniteMap (Module,OccName) Name -builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames) +builtins = + bagToFM ( + mapBag (\ name -> ((nameModule name, nameOccName name), name)) + builtinNames) -- Initial value for the occurrence pool. initOccs :: ([Occurrence],[Occurrence]) -- Compulsory and optional respectively @@ -396,24 +415,45 @@ initOccs = ([(getName boolTyCon, noSrcLoc)], []) -- to do as much as possible explicitly. \end{code} +We (allege) that it is quicker to build up a mapping from module names +to the paths to their corresponding interface files once, than to search +along the import part every time we slurp in a new module (which we +do quite a lot of.) + \begin{code} mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap) mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs where env = emptyFM +{- a pseudo file which signals that the interface files + contained in a particular directory have got their + corresponding object codes stashed away in a DLL + + This stuff is only needed to deal with Win32 DLLs, + and conceivably we conditionally compile in support + for handling it. (ToDo?) +-} +dir_contain_dll_his = "dLL_ifs.hi" + getAllFilesMatching :: SearchPath -> (ModuleHiMap, ModuleHiMap) -> (FilePath, String) -> IO (ModuleHiMap, ModuleHiMap) getAllFilesMatching dirs hims (dir_path, suffix) = ( do -- fpaths entries do not have dir_path prepended - fpaths <- getDirectoryContents dir_path - return (foldl addModules hims fpaths) + fpaths <- getDirectoryContents dir_path + is_dyns <- catch + (if opt_Static || dir_path == "." then + return False + else + doesFileExist (dir_path ++ '/': dir_contain_dll_his)) + (\ _ {-don't care-} -> return False) + return (foldl (addModules is_dyns) hims fpaths) ) -- soft failure `catch` (\ err -> do - hPutStrLn stderr + hPutStrLn stderr ("Import path element `" ++ dir_path ++ if (isDoesNotExistError err) then "' does not exist, ignoring." @@ -435,14 +475,14 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus hi_boot_xiffus = "toob-ih." -- .hi-boot reversed. - addModules his@(hi_env, hib_env) nm = fromMaybe his $ - FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm v, hib_env)) + addModules is_dll his@(hi_env, hib_env) nm = fromMaybe his $ + FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm (v, is_dll), hib_env)) (go xiffus rev_nm) `seqMaybe` - FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm v)) + FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm (v,is_dll))) (go hi_boot_version_xiffus rev_nm) `seqMaybe` - FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm v)) + FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm (v,is_dll))) (go hi_boot_xiffus rev_nm) where rev_nm = reverse nm @@ -462,7 +502,7 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do conflict old_path new_path | old_path /= new_path = - pprTrace "Warning: " (text "Identically named interface files present on import path, " $$ + pprTrace "Warning: " (text "Identically named interface files present on the import path, " $$ text (show old_path) <+> text "shadows" $$ text (show new_path) $$ text "on the import path: " <+> @@ -497,8 +537,11 @@ renameSourceCode mod_name name_supply m newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> newMutVarSST ([],[]) `thenSST` \ occs_var -> let - rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var - s_down = SDown emptyRnEnv emptyRdrEnv mod_name (InterfaceMode Compulsory) + rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, + rn_errs = errs_var, rn_occs = occs_var, + rn_mod = mod_name } + s_down = SDown { rn_mode = InterfaceMode Compulsory, + rn_genv = emptyRnEnv, rn_lenv = emptyRdrEnv } in m rn_down s_down `thenSST` \ result -> @@ -508,7 +551,7 @@ renameSourceCode mod_name name_supply m pprTrace "Urk! renameSourceCode found errors" (display errs) #ifdef DEBUG else if not (isEmptyBag warns) then - pprTrace "Urk! renameSourceCode found warnings" (display warns) + pprTrace "Note: renameSourceCode found warnings" (display warns) #endif else id) $ @@ -528,7 +571,8 @@ 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 +mapRn_ :: (a -> RnM s d b) -> [a] -> RnM s d () +mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [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]) @@ -554,6 +598,11 @@ mapRn f (x:xs) mapRn f xs `thenRn` \ rs -> returnRn (r:rs) +mapRn_ f [] = returnRn () +mapRn_ f (x:xs) = + f x `thenRn_` + mapRn_ f xs + foldlRn k z [] = returnRn z foldlRn k z (x:xs) = k z x `thenRn` \ z' -> foldlRn k z' xs @@ -570,8 +619,12 @@ mapAndUnzip3Rn f (x:xs) 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 +mapMaybeRn f [] = returnRn [] +mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> + mapMaybeRn f xs `thenRn` \ rs -> + case maybe_r of + Nothing -> returnRn rs + Just r -> returnRn (r:rs) \end{code} @@ -586,38 +639,38 @@ mapMaybeRn f def (Just v) = f v ================ Errors and warnings ===================== \begin{code} -failWithRn :: a -> ErrMsg -> RnM s d a -failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down +failWithRn :: a -> Message -> RnM s d a +failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` returnSST res where err = addShortErrLocLine loc msg -warnWithRn :: a -> WarnMsg -> RnM s d a -warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down +warnWithRn :: a -> Message -> RnM s d a +warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` returnSST res where warn = addShortWarnLocLine loc msg -addErrRn :: ErrMsg -> RnM s d () +addErrRn :: Message -> RnM s d () addErrRn err = failWithRn () err -checkRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true +checkRn :: Bool -> Message -> RnM s d () -- Check that a condition is true checkRn False err = addErrRn err checkRn True err = returnRn () -warnCheckRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true +warnCheckRn :: Bool -> Message -> RnM s d () -- Check that a condition is true warnCheckRn False err = addWarnRn err warnCheckRn True err = returnRn () -addWarnRn :: WarnMsg -> RnM s d () +addWarnRn :: Message -> RnM s d () addWarnRn warn = warnWithRn () warn checkErrsRn :: RnM s d Bool -- True <=> no errors so far -checkErrsRn (RnDown loc names_var errs_var occs_var) l_down +checkErrsRn (RnDown {rn_errs = errs_var}) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> returnSST (isEmptyBag errs) \end{code} @@ -627,28 +680,28 @@ checkErrsRn (RnDown loc names_var errs_var occs_var) l_down \begin{code} pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a -pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down - = m (RnDown loc' names_var errs_var occs_var) l_down +pushSrcLocRn loc' m down l_down + = m (down {rn_loc = loc'}) l_down getSrcLocRn :: RnM s d SrcLoc -getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down - = returnSST loc +getSrcLocRn down l_down + = returnSST (rn_loc down) \end{code} ================ Name supply ===================== \begin{code} getNameSupplyRn :: RnM s d RnNameSupply -getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down - = readMutVarSST names_var +getNameSupplyRn rn_down l_down + = readMutVarSST (rn_ns rn_down) setNameSupplyRn :: RnNameSupply -> RnM s d () -setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down +setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down = writeMutVarSST names_var names' -- See comments with RnNameSupply above. newInstUniq :: (OccName, OccName) -> RnM s d Int -newInstUniq key (RnDown loc names_var errs_var occs_var) l_down +newInstUniq key (RnDown {rn_ns = names_var}) l_down = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) -> let uniq = case lookupFM mapInst key of @@ -658,6 +711,15 @@ newInstUniq key (RnDown loc names_var errs_var occs_var) l_down in writeMutVarSST names_var (us, mapInst', cache) `thenSST_` returnSST uniq + +getUniqRn :: RnM s d Unique +getUniqRn (RnDown {rn_ns = names_var}) l_down + = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) -> + let + (us1,us') = splitUniqSupply us + in + writeMutVarSST names_var (us', mapInst, cache) `thenSST_` + returnSST (uniqFromSupply us1) \end{code} ================ Occurrences ===================== @@ -687,8 +749,8 @@ but it seems simpler just to do all the compulsory ones first. \begin{code} addOccurrenceName :: Name -> RnMS s Name -- Same name returned as passed -addOccurrenceName name (RnDown loc names_var errs_var occs_var) - (SDown rn_env local_env mod_name mode) +addOccurrenceName name (RnDown {rn_loc = loc, rn_occs = occs_var}) + (SDown {rn_mode = mode}) | isLocallyDefinedName name || not_necessary necessity = returnSST name @@ -707,8 +769,8 @@ addOccurrenceName name (RnDown loc names_var errs_var occs_var) addOccurrenceNames :: [Name] -> RnMS s () -addOccurrenceNames names (RnDown loc names_var errs_var occs_var) - (SDown rn_env local_env mod_name mode) +addOccurrenceNames names (RnDown {rn_loc = loc, rn_occs = occs_var}) + (SDown {rn_mode = mode}) | not_necessary necessity = returnSST () @@ -729,8 +791,8 @@ addOccurrenceNames names (RnDown loc names_var errs_var occs_var) not_necessary Compulsory = False not_necessary Optional = opt_IgnoreIfacePragmas -popOccurrenceName :: RnSMode -> RnM s d (Maybe Occurrence) -popOccurrenceName mode (RnDown loc names_var errs_var occs_var) l_down +popOccurrenceName :: RnMode -> RnM s d (Maybe Occurrence) +popOccurrenceName mode (RnDown {rn_occs = occs_var}) l_down = readMutVarSST occs_var `thenSST` \ occs -> case (mode, occs) of -- Find a compulsory occurrence @@ -755,12 +817,33 @@ popOccurrenceName mode (RnDown loc names_var errs_var occs_var) l_down -- as occurrences. discardOccurrencesRn :: RnM s d a -> RnM s d a -discardOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down +discardOccurrencesRn enclosed_thing rn_down l_down = newMutVarSST ([],[]) `thenSST` \ new_occs_var -> - enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down + enclosed_thing (rn_down {rn_occs = new_occs_var}) l_down \end{code} +================ Module ===================== + +\begin{code} +getModuleRn :: RnM s d Module +getModuleRn (RnDown {rn_mod = mod_name}) l_down + = returnSST mod_name + +setModuleRn :: Module -> RnM s d a -> RnM s 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 s d a -> RnM s d a +setOmitQualFn fn m g_down l_down = m (g_down { rn_omit = fn }) l_down + +getOmitQualFn :: RnM s d (Name -> Bool) +getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down + = returnSST omit_fn +\end{code} + %************************************************************************ %* * \subsection{Plumbing for rename-source part} @@ -771,46 +854,40 @@ discardOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_d \begin{code} getNameEnvs :: RnMS s (GlobalRdrEnv, LocalRdrEnv) -getNameEnvs rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) +getNameEnvs rn_down (SDown {rn_genv = RnEnv global_env fixity_env, rn_lenv = local_env}) = returnSST (global_env, local_env) getLocalNameEnv :: RnMS s LocalRdrEnv -getLocalNameEnv rn_down (SDown rn_env local_env mod_name mode) +getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) = returnSST local_env setLocalNameEnv :: LocalRdrEnv -> 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) +setLocalNameEnv local_env' m rn_down l_down + = m rn_down (l_down {rn_lenv = local_env'}) getFixityEnv :: RnMS s FixityEnv -getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode) +getFixityEnv rn_down (SDown {rn_genv = RnEnv name_env fixity_env}) = returnSST fixity_env extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS s a -> RnMS s a extendFixityEnv fixes enclosed_scope - rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode) + rn_down l_down@(SDown {rn_genv = RnEnv name_env fixity_env}) = let new_fixity_env = extendNameEnv fixity_env fixes in - enclosed_scope rn_down (SDown (RnEnv name_env new_fixity_env) local_env mod_name mode) + enclosed_scope rn_down (l_down {rn_genv = RnEnv name_env new_fixity_env}) \end{code} -================ Module and Mode ===================== - -\begin{code} -getModuleRn :: RnMS s Module -getModuleRn rn_down (SDown rn_env local_env mod_name mode) - = returnSST mod_name -\end{code} +================ Mode ===================== \begin{code} -getModeRn :: RnMS s RnSMode -getModeRn rn_down (SDown rn_env local_env mod_name mode) +getModeRn :: RnMS s RnMode +getModeRn rn_down (SDown {rn_mode = mode}) = returnSST mode -setModeRn :: RnSMode -> RnMS s a -> RnMS s a -setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode) - = thing_inside rn_down (SDown rn_env local_env mod_name new_mode) +setModeRn :: RnMode -> RnMS s a -> RnMS s a +setModeRn new_mode thing_inside rn_down l_down + = thing_inside rn_down (l_down {rn_mode = new_mode}) \end{code} @@ -822,18 +899,44 @@ setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode) \begin{code} getIfacesRn :: RnMG Ifaces -getIfacesRn rn_down (GDown himap hibmap iface_var) +getIfacesRn rn_down (GDown {rn_ifaces = iface_var}) = readMutVarSST iface_var setIfacesRn :: Ifaces -> RnMG () -setIfacesRn ifaces rn_down (GDown himap hibmap iface_var) +setIfacesRn ifaces rn_down (GDown {rn_ifaces = iface_var}) = writeMutVarSST iface_var ifaces -getModuleHiMap :: IfaceFlavour -> RnMG ModuleHiMap -getModuleHiMap as_source rn_down (GDown himap hibmap iface_var) - = case as_source of - HiBootFile -> returnSST hibmap - _ -> returnSST himap +getModuleHiMap :: Bool -> RnM s d ModuleHiMap +getModuleHiMap want_hi_boot (RnDown {rn_hi_map = himap, rn_hiboot_map = hibmap}) _ + | want_hi_boot = returnSST hibmap + | otherwise = returnSST himap +\end{code} + +The interface file format is capable of distinguishing +between normal imports/exports of names from other modules +and 'hi-boot' mentions of names, with the flavour in the +being encoded inside a @Module@. + +@setModuleFlavourRn@ fixes up @Module@ values containing +normal flavours, returning a @Module@ value containing +the attributes of the module that's in scope. The only +attribute at the moment is the DLLness of a module, i.e., +whether the object code for that module resides in a +Win32 DLL or not. + +\begin{code} +setModuleFlavourRn :: Module -> RnM s d Module +setModuleFlavourRn mod + | bootFlavour hif = returnRn mod + | otherwise = + getModuleHiMap (bootFlavour hif) `thenRn` \ himap -> + case (lookupFM himap mod_pstr) of + Nothing -> returnRn mod + Just (_, is_in_a_dll) -> + returnRn (setModuleFlavour (mkDynFlavour is_in_a_dll hif) mod) + where + mod_pstr = moduleString mod + hif = moduleIfaceFlavour mod \end{code}