2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnMonad]{The monad used by the renamer}
21 #include "HsVersions.h"
24 import GlaExts ( RealWorld, stToIO )
25 import List ( intersperse )
29 import RnHsSyn ( RenamedFixitySig )
30 import BasicTypes ( Version )
31 import SrcLoc ( noSrcLoc )
32 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
33 pprBagOfErrors, ErrMsg, WarnMsg, Message
35 import Name ( Name, OccName, NamedThing(..),
36 isLocallyDefinedName, nameModule, nameOccName,
39 import Module ( Module, IfaceFlavour, setModuleFlavour, mkSysModuleFS,
40 bootFlavour, moduleString, moduleIfaceFlavour, mkDynFlavour
43 import RdrName ( RdrName )
44 import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas,
45 opt_WarnHiShadows, opt_Static
47 import PrelInfo ( builtinNames )
48 import TysWiredIn ( boolTyCon )
49 import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
50 import Unique ( Unique )
51 import UniqFM ( UniqFM )
52 import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM,
53 addListToFM_C, addToFM_C, eltsFM
55 import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
56 import Maybes ( seqMaybe, mapMaybe )
62 import DirUtils ( getDirectoryContents )
63 import Directory ( doesFileExist )
64 import IO ( hPutStrLn, stderr, isDoesNotExistError )
65 import Monad ( foldM )
66 import Maybe ( fromMaybe )
67 import Constants ( interfaceFileFormatVersion )
69 infixr 9 `thenRn`, `thenRn_`
73 %************************************************************************
75 \subsection{Somewhat magical interface to other monads}
77 %************************************************************************
80 sstToIO :: SST RealWorld r -> IO r
81 sstToIO sst = stToIO (sstToST sst)
83 ioToRnMG :: IO r -> RnMG (Either IOError r)
84 ioToRnMG io rn_down g_down = ioToSST io
86 traceRn :: SDoc -> RnMG ()
87 traceRn msg | opt_D_show_rn_trace = putDocRn msg
88 | otherwise = returnRn ()
90 putDocRn :: SDoc -> RnMG ()
91 putDocRn msg = ioToRnMG (printErrs msg) `thenRn_`
96 %************************************************************************
98 \subsection{Data types}
100 %************************************************************************
102 ===================================================
104 ===================================================
107 type RnM s d r = RnDown s -> d -> SST s r
108 type RnMS s r = RnM s (SDown s) r -- Renaming source
109 type RnMG r = RnM RealWorld GDown r -- Getting global names etc
110 type SSTRWRef a = SSTRef RealWorld a -- ToDo: there ought to be a standard defn of this
113 data RnDown s = RnDown {
115 rn_omit :: Name -> Bool, -- True <=> omit qualifier when printing
116 rn_ns :: SSTRef s RnNameSupply,
117 rn_errs :: SSTRef s (Bag WarnMsg, Bag ErrMsg),
118 rn_occs :: SSTRef s ([Occurrence],[Occurrence]), -- Occurrences: compulsory and optional resp
119 rn_hi_map :: ModuleHiMap, -- for .hi files
120 rn_hiboot_map :: ModuleHiMap, -- for .hi-boot files
124 type Occurrence = (Name, SrcLoc) -- The srcloc is the occurrence site
126 data Necessity = Compulsory | Optional -- We *must* find definitions for
127 -- compulsory occurrences; we *may* find them
128 -- for optional ones.
130 -- For getting global names
132 rn_ifaces :: SSTRWRef Ifaces
135 -- For renaming source code
136 data SDown s = SDown {
138 rn_genv :: RnEnv, -- Global envt; the fixity component gets extended
139 -- with local fixity decls
140 rn_lenv :: LocalRdrEnv -- Local name envt
141 -- Does *not* includes global name envt; may shadow it
142 -- Includes both ordinary variables and type variables;
143 -- they are kept distinct because tyvar have a different
144 -- occurrence contructor (Name.TvOcc)
145 -- We still need the unsullied global name env so that
146 -- we can look up record field names
149 data RnMode = SourceMode -- Renaming source code
150 | InterfaceMode -- Renaming interface declarations.
151 Necessity -- The "necessity"
152 -- flag says free variables *must* be found and slurped
153 -- or whether they need not be. For value signatures of
154 -- things that are themselves compulsorily imported
155 -- we arrange that the type signature is read
156 -- in compulsory mode,
157 -- but the pragmas in optional mode.
159 type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
160 -- for interface files.
162 type ModuleHiMap = FiniteMap String (String, Bool)
163 -- mapping from module name to the file path of its corresponding
167 ===================================================
169 ===================================================
172 --------------------------------
173 type RdrNameEnv a = FiniteMap RdrName a
174 type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes
175 -- These only get reported on lookup,
176 -- not on construction
177 type LocalRdrEnv = RdrNameEnv Name
179 emptyRdrEnv :: RdrNameEnv a
180 lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a
181 addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a
183 emptyRdrEnv = emptyFM
184 lookupRdrEnv = lookupFM
185 addListToRdrEnv = addListToFM
188 --------------------------------
189 type NameEnv a = UniqFM a -- Domain is Name
191 emptyNameEnv :: NameEnv a
192 nameEnvElts :: NameEnv a -> [a]
193 addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
194 addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a
195 plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
196 extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
197 lookupNameEnv :: NameEnv a -> Name -> Maybe a
198 delFromNameEnv :: NameEnv a -> Name -> NameEnv a
199 elemNameEnv :: Name -> NameEnv a -> Bool
201 emptyNameEnv = emptyUFM
202 nameEnvElts = eltsUFM
203 addToNameEnv_C = addToUFM_C
204 addToNameEnv = addToUFM
205 plusNameEnv = plusUFM
206 extendNameEnv = addListToUFM
207 lookupNameEnv = lookupUFM
208 delFromNameEnv = delFromUFM
209 elemNameEnv = elemUFM
211 --------------------------------
212 type FixityEnv = NameEnv RenamedFixitySig
214 --------------------------------
215 data RnEnv = RnEnv GlobalRdrEnv FixityEnv
216 emptyRnEnv = RnEnv emptyRdrEnv emptyNameEnv
220 --------------------------------
224 , FiniteMap (OccName, OccName) Int
225 -- This is used as a name supply for dictionary functions
226 -- From the inst decl we derive a (class, tycon) pair;
227 -- this map then gives a unique int for each inst decl with that
228 -- (class, tycon) pair. (In Haskell 98 there can only be one,
229 -- but not so in more extended versions.)
231 -- We could just use one Int for all the instance decls, but this
232 -- way the uniques change less when you add an instance decl,
233 -- hence less recompilation
235 , FiniteMap (Module,OccName) Name
236 -- Ensures that one (module,occname) pair gets one unique
240 --------------------------------
241 data ExportEnv = ExportEnv Avails Fixities
242 type Avails = [AvailInfo]
243 type Fixities = [(Name, Fixity)]
245 type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers
246 -- Includes avails only from *unqualified* imports
247 -- (see 1.4 Report Section 5.1.1)
249 NameEnv AvailInfo) -- Used to figure out all other export specifiers.
250 -- Maps a Name to the AvailInfo that contains it
253 data GenAvailInfo name = Avail name -- An ordinary identifier
254 | AvailTC name -- The name of the type or class
255 [name] -- The available pieces of type/class. NB: If the type or
256 -- class is itself to be in scope, it must be in this list.
257 -- Thus, typically: AvailTC Eq [Eq, ==, /=]
258 type AvailInfo = GenAvailInfo Name
259 type RdrAvailInfo = GenAvailInfo OccName
262 ===================================================
264 ===================================================
267 type ExportItem = (Module, [RdrAvailInfo])
268 type VersionInfo name = [ImportVersion name]
270 type ImportVersion name = (Module, Version, WhatsImported name)
271 data WhatsImported name = Everything
272 | Specifically [LocalVersion name] -- List guaranteed non-empty
274 -- ("M", hif, ver, Everything) means there was a "module M" in
275 -- this module's export list, so we just have to go by M's version, "ver",
276 -- not the list of LocalVersions.
279 type LocalVersion name = (name, Version)
283 Version -- Module version number
284 [ImportVersion OccName] -- Usages
285 [ExportItem] -- Exports
286 [Module] -- Special instance modules
287 [(Version, RdrNameHsDecl)] -- Local definitions
288 [RdrNameInstDecl] -- Local instance declarations
290 type InterfaceDetails = (VersionInfo Name, -- Version information for what this module imports
291 ExportEnv, -- What this module exports
292 [Module]) -- Instance modules
295 -- needed by Main to fish out the fixities assoc list.
296 getIfaceFixities :: InterfaceDetails -> Fixities
297 getIfaceFixities (_, ExportEnv _ fs, _) = fs
300 type RdrNamePragma = () -- Fudge for now
303 data Ifaces = Ifaces {
304 iMod :: Module, -- Name of the module being compiled
306 iModMap :: FiniteMap Module (IfaceFlavour, -- Exports
310 iDecls :: DeclsMap, -- A single, global map of Names to decls
312 iFixes :: FixityEnv, -- A single, global map of Names to fixities
314 iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not,
315 -- whether locally defined or not) that have been slurped in so far.
317 iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
318 -- have been slurped in so far, with their versions.
319 -- This is used to generate the "usage" information for this module.
320 -- Subset of the previous field.
322 iDefInsts :: (Bag IfaceInst, NameSet),
323 -- The as-yet un-slurped instance decls; this bag is depleted when we
324 -- slurp an instance decl so that we don't slurp the same one twice.
325 -- Together with them is the set of tycons/classes that may allow
326 -- the instance decls in.
328 iDefData :: NameEnv (Module, RdrNameTyClDecl),
329 -- Deferred data type declarations; each has the following properties
330 -- * it's a data type decl
331 -- * its TyCon is needed
332 -- * the decl may or may not have been slurped, depending on whether any
333 -- of the constrs are needed.
335 iInstMods :: [Module] -- Set of modules with "special" instance declarations
336 -- Excludes this module
340 type DeclsMap = NameEnv (Version, AvailInfo, RdrNameHsDecl, Bool)
341 -- A DeclsMap contains a binding for each Name in the declaration
342 -- including the constructors of a type decl etc.
343 -- The Bool is True just for the 'main' Name.
345 type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
346 NameSet) -- "Gate" names. Slurp this instance decl when this
347 -- set becomes empty. It's depleted whenever we
348 -- slurp another type or class decl.
352 %************************************************************************
354 \subsection{Main monad code}
356 %************************************************************************
359 initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
361 -> IO (r, Bag ErrMsg, Bag WarnMsg)
363 initRn mod us dirs loc do_rn = do
364 names_var <- sstToIO (newMutVarSST (us, emptyFM, builtins))
365 errs_var <- sstToIO (newMutVarSST (emptyBag,emptyBag))
366 iface_var <- sstToIO (newMutVarSST (emptyIfaces mod))
367 occs_var <- sstToIO (newMutVarSST initOccs)
368 (himap, hibmap) <- mkModuleHiMaps dirs
370 rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var,
371 rn_errs = errs_var, rn_occs = occs_var,
372 rn_hi_map = himap, rn_hiboot_map = hibmap,
374 g_down = GDown {rn_ifaces = iface_var }
377 res <- sstToIO (do_rn rn_down g_down)
379 -- grab errors and return
380 (warns, errs) <- sstToIO (readMutVarSST errs_var)
381 return (res, errs, warns)
384 initRnMS :: RnEnv -> RnMode -> RnMS RealWorld r -> RnMG r
385 initRnMS rn_env mode m rn_down g_down
387 s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, rn_mode = mode }
392 emptyIfaces :: Module -> Ifaces
393 emptyIfaces mod = Ifaces { iMod = mod,
395 iDecls = emptyNameEnv,
396 iFixes = emptyNameEnv,
397 iSlurp = emptyNameSet,
399 iDefInsts = (emptyBag, emptyNameSet),
400 iDefData = emptyNameEnv,
404 builtins :: FiniteMap (Module,OccName) Name
406 mapBag (\ name -> ((nameModule name, nameOccName name), name))
409 -- Initial value for the occurrence pool.
410 initOccs :: ([Occurrence],[Occurrence]) -- Compulsory and optional respectively
411 initOccs = ([(getName boolTyCon, noSrcLoc)], [])
412 -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
413 -- rather implausible that not one will be used in the module.
414 -- We could add some other common types, notably lists, but the general idea is
415 -- to do as much as possible explicitly.
418 We (allege) that it is quicker to build up a mapping from module names
419 to the paths to their corresponding interface files once, than to search
420 along the import part every time we slurp in a new module (which we
424 mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap)
425 mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs
429 {- a pseudo file which signals that the interface files
430 contained in a particular directory have got their
431 corresponding object codes stashed away in a DLL
433 This stuff is only needed to deal with Win32 DLLs,
434 and conceivably we conditionally compile in support
435 for handling it. (ToDo?)
437 dir_contain_dll_his = "dLL_ifs.hi"
439 getAllFilesMatching :: SearchPath
440 -> (ModuleHiMap, ModuleHiMap)
441 -> (FilePath, String)
442 -> IO (ModuleHiMap, ModuleHiMap)
443 getAllFilesMatching dirs hims (dir_path, suffix) = ( do
444 -- fpaths entries do not have dir_path prepended
445 fpaths <- getDirectoryContents dir_path
447 (if opt_Static || dir_path == "." then
450 doesFileExist (dir_path ++ '/': dir_contain_dll_his))
451 (\ _ {-don't care-} -> return False)
452 return (foldl (addModules is_dyns) hims fpaths)
457 ("Import path element `" ++ dir_path ++
458 if (isDoesNotExistError err) then
459 "' does not exist, ignoring."
461 "' couldn't read, ignoring.")
466 xiffus = reverse dotted_suffix
474 hi_boot_version_xiffus =
475 reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus
476 hi_boot_xiffus = "toob-ih." -- .hi-boot reversed.
478 addModules is_dll his@(hi_env, hib_env) nm = fromMaybe his $
479 FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm (v, is_dll), hib_env))
480 (go xiffus rev_nm) `seqMaybe`
482 FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm (v,is_dll)))
483 (go hi_boot_version_xiffus rev_nm) `seqMaybe`
485 FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm (v,is_dll)))
486 (go hi_boot_xiffus rev_nm)
490 go [] xs = Just (reverse xs, dir_path ++'/':nm)
494 | otherwise = Nothing
497 | opt_WarnHiShadows = conflict
498 | otherwise = stickWithOld
500 stickWithOld old new = old
501 overrideNew old new = new
503 conflict old_path new_path
504 | old_path /= new_path =
505 pprTrace "Warning: " (text "Identically named interface files present on the import path, " $$
506 text (show old_path) <+> text "shadows" $$
507 text (show new_path) $$
508 text "on the import path: " <+>
509 text (concat (intersperse ":" (map fst dirs))))
511 | otherwise = old_path -- don't warn about innocous shadowings.
516 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
517 the main renamer. Examples: pragmas (which we don't want to rename unless
518 we actually explore them); and derived definitions, which are only generated
521 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
522 once you must either split it, or install a fresh unique supply.
525 renameSourceCode :: Module
530 -- Alas, we can't use the real runST, with the desired signature:
531 -- renameSourceCode :: RnNameSupply -> RnMS s r -> r
532 -- because we can't manufacture "new versions of runST".
534 renameSourceCode mod_name name_supply m
536 newMutVarSST name_supply `thenSST` \ names_var ->
537 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
538 newMutVarSST ([],[]) `thenSST` \ occs_var ->
540 rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var,
541 rn_errs = errs_var, rn_occs = occs_var,
543 s_down = SDown { rn_mode = InterfaceMode Compulsory,
544 rn_genv = emptyRnEnv, rn_lenv = emptyRdrEnv }
546 m rn_down s_down `thenSST` \ result ->
548 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
550 (if not (isEmptyBag errs) then
551 pprTrace "Urk! renameSourceCode found errors" (display errs)
553 else if not (isEmptyBag warns) then
554 pprTrace "Note: renameSourceCode found warnings" (display warns)
562 display errs = pprBagOfErrors errs
564 {-# INLINE thenRn #-}
565 {-# INLINE thenRn_ #-}
566 {-# INLINE returnRn #-}
569 returnRn :: a -> RnM s d a
570 thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
571 thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b
572 andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
573 mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b]
574 mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [a] -> RnM s d [b]
575 sequenceRn :: [RnM s d a] -> RnM s d [a]
576 foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b
577 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
578 fixRn :: (a -> RnM s d a) -> RnM s d a
580 returnRn v gdown ldown = returnSST v
581 thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown
582 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
583 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
584 andRn combiner m1 m2 gdown ldown
585 = m1 gdown ldown `thenSST` \ res1 ->
586 m2 gdown ldown `thenSST` \ res2 ->
587 returnSST (combiner res1 res2)
589 sequenceRn [] = returnRn []
590 sequenceRn (m:ms) = m `thenRn` \ r ->
591 sequenceRn ms `thenRn` \ rs ->
594 mapRn f [] = returnRn []
596 = f x `thenRn` \ r ->
597 mapRn f xs `thenRn` \ rs ->
600 foldlRn k z [] = returnRn z
601 foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
604 mapAndUnzipRn f [] = returnRn ([],[])
605 mapAndUnzipRn f (x:xs)
606 = f x `thenRn` \ (r1, r2) ->
607 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
608 returnRn (r1:rs1, r2:rs2)
610 mapAndUnzip3Rn f [] = returnRn ([],[],[])
611 mapAndUnzip3Rn f (x:xs)
612 = f x `thenRn` \ (r1, r2, r3) ->
613 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
614 returnRn (r1:rs1, r2:rs2, r3:rs3)
616 mapMaybeRn f [] = returnRn []
617 mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r ->
618 mapMaybeRn f xs `thenRn` \ rs ->
620 Nothing -> returnRn rs
621 Just r -> returnRn (r:rs)
626 %************************************************************************
628 \subsection{Boring plumbing for common part}
630 %************************************************************************
633 ================ Errors and warnings =====================
636 failWithRn :: a -> Message -> RnM s d a
637 failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
638 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
639 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
642 err = addShortErrLocLine loc msg
644 warnWithRn :: a -> Message -> RnM s d a
645 warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
646 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
647 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
650 warn = addShortWarnLocLine loc msg
652 addErrRn :: Message -> RnM s d ()
653 addErrRn err = failWithRn () err
655 checkRn :: Bool -> Message -> RnM s d () -- Check that a condition is true
656 checkRn False err = addErrRn err
657 checkRn True err = returnRn ()
659 warnCheckRn :: Bool -> Message -> RnM s d () -- Check that a condition is true
660 warnCheckRn False err = addWarnRn err
661 warnCheckRn True err = returnRn ()
663 addWarnRn :: Message -> RnM s d ()
664 addWarnRn warn = warnWithRn () warn
666 checkErrsRn :: RnM s d Bool -- True <=> no errors so far
667 checkErrsRn (RnDown {rn_errs = errs_var}) l_down
668 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
669 returnSST (isEmptyBag errs)
673 ================ Source location =====================
676 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
677 pushSrcLocRn loc' m down l_down
678 = m (down {rn_loc = loc'}) l_down
680 getSrcLocRn :: RnM s d SrcLoc
681 getSrcLocRn down l_down
682 = returnSST (rn_loc down)
685 ================ Name supply =====================
688 getNameSupplyRn :: RnM s d RnNameSupply
689 getNameSupplyRn rn_down l_down
690 = readMutVarSST (rn_ns rn_down)
692 setNameSupplyRn :: RnNameSupply -> RnM s d ()
693 setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
694 = writeMutVarSST names_var names'
696 -- See comments with RnNameSupply above.
697 newInstUniq :: (OccName, OccName) -> RnM s d Int
698 newInstUniq key (RnDown {rn_ns = names_var}) l_down
699 = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
701 uniq = case lookupFM mapInst key of
704 mapInst' = addToFM mapInst key uniq
706 writeMutVarSST names_var (us, mapInst', cache) `thenSST_`
710 ================ Occurrences =====================
712 Every time we get an occurrence of a name we put it in one of two lists:
713 one for "compulsory" occurrences
714 one for "optional" occurrences
716 The significance of "compulsory" is
717 (a) we *must* find the declaration
718 (b) in the case of type or class names, the name is part of the
719 source level program, and we must slurp in any instance decls
722 We don't need instance decls "optional" names, because the type inference
723 process will never come across them. Optional names are buried inside
724 type checked (but not renamed) cross-module unfoldings and such.
726 The pair of lists is held in a mutable variable in RnDown.
728 The lists are kept separate so that we can process all the compulsory occurrences
729 before any of the optional ones. Why? Because suppose we processed an optional
730 "g", and slurped an interface decl of g::T->T. Then we'd rename the type T->T in
731 optional mode. But if we later need g compulsorily we'll find that it's already
732 been slurped and will do nothing. We could, I suppose, rename it a second time,
733 but it seems simpler just to do all the compulsory ones first.
736 addOccurrenceName :: Name -> RnMS s Name -- Same name returned as passed
737 addOccurrenceName name (RnDown {rn_loc = loc, rn_occs = occs_var})
738 (SDown {rn_mode = mode})
739 | isLocallyDefinedName name ||
740 not_necessary necessity
744 = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) ->
746 new_occ_pair = case necessity of
747 Optional -> (comp_occs, (name,loc):opt_occs)
748 Compulsory -> ((name,loc):comp_occs, opt_occs)
750 writeMutVarSST occs_var new_occ_pair `thenSST_`
753 necessity = modeToNecessity mode
756 addOccurrenceNames :: [Name] -> RnMS s ()
757 addOccurrenceNames names (RnDown {rn_loc = loc, rn_occs = occs_var})
758 (SDown {rn_mode = mode})
759 | not_necessary necessity
763 = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) ->
765 new_occ_pair = case necessity of
766 Optional -> (comp_occs, non_local_occs ++ opt_occs)
767 Compulsory -> (non_local_occs ++ comp_occs, opt_occs)
769 writeMutVarSST occs_var new_occ_pair
771 non_local_occs = [(name, loc) | name <- names, not (isLocallyDefinedName name)]
772 necessity = modeToNecessity mode
774 -- Never look for optional things if we're
775 -- ignoring optional input interface information
776 not_necessary Compulsory = False
777 not_necessary Optional = opt_IgnoreIfacePragmas
779 popOccurrenceName :: RnMode -> RnM s d (Maybe Occurrence)
780 popOccurrenceName mode (RnDown {rn_occs = occs_var}) l_down
781 = readMutVarSST occs_var `thenSST` \ occs ->
783 -- Find a compulsory occurrence
784 (InterfaceMode Compulsory, (comp:comps, opts))
785 -> writeMutVarSST occs_var (comps, opts) `thenSST_`
786 returnSST (Just comp)
788 -- Find an optional occurrence
789 -- We shouldn't be looking unless we've done all the compulsories
790 (InterfaceMode Optional, (comps, opt:opts))
791 -> ASSERT2( null comps, ppr comps )
792 writeMutVarSST occs_var (comps, opts) `thenSST_`
795 -- No suitable occurrence
796 other -> returnSST Nothing
798 -- discardOccurrencesRn does the enclosed thing with a *fresh* occurrences
799 -- variable, and discards the list of occurrences thus found. It's useful
800 -- when loading instance decls and specialisation signatures, when we want to
801 -- know the names of the things in the types, but we don't want to treat them
804 discardOccurrencesRn :: RnM s d a -> RnM s d a
805 discardOccurrencesRn enclosed_thing rn_down l_down
806 = newMutVarSST ([],[]) `thenSST` \ new_occs_var ->
807 enclosed_thing (rn_down {rn_occs = new_occs_var}) l_down
811 ================ Module =====================
814 getModuleRn :: RnM s d Module
815 getModuleRn (RnDown {rn_mod = mod_name}) l_down
818 setModuleRn :: Module -> RnM s d a -> RnM s d a
819 setModuleRn new_mod enclosed_thing rn_down l_down
820 = enclosed_thing (rn_down {rn_mod = new_mod}) l_down
824 setOmitQualFn :: (Name -> Bool) -> RnM s d a -> RnM s d a
825 setOmitQualFn fn m g_down l_down = m (g_down { rn_omit = fn }) l_down
827 getOmitQualFn :: RnM s d (Name -> Bool)
828 getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down
832 %************************************************************************
834 \subsection{Plumbing for rename-source part}
836 %************************************************************************
838 ================ RnEnv =====================
841 getNameEnvs :: RnMS s (GlobalRdrEnv, LocalRdrEnv)
842 getNameEnvs rn_down (SDown {rn_genv = RnEnv global_env fixity_env, rn_lenv = local_env})
843 = returnSST (global_env, local_env)
845 getLocalNameEnv :: RnMS s LocalRdrEnv
846 getLocalNameEnv rn_down (SDown {rn_lenv = local_env})
847 = returnSST local_env
849 setLocalNameEnv :: LocalRdrEnv -> RnMS s a -> RnMS s a
850 setLocalNameEnv local_env' m rn_down l_down
851 = m rn_down (l_down {rn_lenv = local_env'})
853 getFixityEnv :: RnMS s FixityEnv
854 getFixityEnv rn_down (SDown {rn_genv = RnEnv name_env fixity_env})
855 = returnSST fixity_env
857 extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS s a -> RnMS s a
858 extendFixityEnv fixes enclosed_scope
859 rn_down l_down@(SDown {rn_genv = RnEnv name_env fixity_env})
861 new_fixity_env = extendNameEnv fixity_env fixes
863 enclosed_scope rn_down (l_down {rn_genv = RnEnv name_env new_fixity_env})
866 ================ Mode =====================
869 getModeRn :: RnMS s RnMode
870 getModeRn rn_down (SDown {rn_mode = mode})
873 setModeRn :: RnMode -> RnMS s a -> RnMS s a
874 setModeRn new_mode thing_inside rn_down l_down
875 = thing_inside rn_down (l_down {rn_mode = new_mode})
879 %************************************************************************
881 \subsection{Plumbing for rename-globals part}
883 %************************************************************************
886 getIfacesRn :: RnMG Ifaces
887 getIfacesRn rn_down (GDown {rn_ifaces = iface_var})
888 = readMutVarSST iface_var
890 setIfacesRn :: Ifaces -> RnMG ()
891 setIfacesRn ifaces rn_down (GDown {rn_ifaces = iface_var})
892 = writeMutVarSST iface_var ifaces
894 getModuleHiMap :: Bool -> RnM s d ModuleHiMap
895 getModuleHiMap want_hi_boot (RnDown {rn_hi_map = himap, rn_hiboot_map = hibmap}) _
896 | want_hi_boot = returnSST hibmap
897 | otherwise = returnSST himap
900 The interface file format is capable of distinguishing
901 between normal imports/exports of names from other modules
902 and 'hi-boot' mentions of names, with the flavour in the
903 being encoded inside a @Module@.
905 @setModuleFlavourRn@ fixes up @Module@ values containing
906 normal flavours, checking to see whether
909 setModuleFlavourRn :: Module -> RnM s d Module
910 setModuleFlavourRn mod
911 | bootFlavour hif = returnRn mod
913 getModuleHiMap (bootFlavour hif) `thenRn` \ himap ->
914 let mod_pstr = moduleString mod in
915 case (lookupFM himap mod_pstr) of
916 Nothing -> returnRn mod
917 Just (_,is_in_a_dll) ->
918 returnRn (setModuleFlavour (mkDynFlavour is_in_a_dll hif) mod)
920 hif = moduleIfaceFlavour mod
924 %************************************************************************
926 \subsection{HowInScope}
928 %************************************************************************
931 modeToNecessity SourceMode = Compulsory
932 modeToNecessity (InterfaceMode necessity) = necessity