2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
4 \section[RnMonad]{The monad used by the renamer}
7 #include "HsVersions.h"
11 -- close it up (partly done to allow unfoldings)
17 SYN_IE(RdrNameHsDecl),
18 SYN_IE(RdrNameInstDecl),
28 #if __GLASGOW_HASKELL__ <= 201
29 import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST )
36 #define IOError13 IOError
42 import BasicTypes ( SYN_IE(Version), NewOrData )
43 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
44 pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
46 import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet,
48 modAndOcc, NamedThing(..)
50 import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
51 import PrelInfo ( builtinNames )
52 import TyCon ( TyCon {- instance NamedThing -} )
53 import TysWiredIn ( boolTyCon )
55 import Outputable ( PprStyle(..) )
56 import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
57 import Unique ( Unique )
58 import UniqFM ( UniqFM )
59 import FiniteMap ( FiniteMap, emptyFM, bagToFM )
60 import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
63 #if __GLASGOW_HASKELL__ >= 202
67 infixr 9 `thenRn`, `thenRn_`
71 %************************************************************************
73 \subsection{Somewhat magical interface to other monads}
75 %************************************************************************
78 #if __GLASGOW_HASKELL__ >= 200
79 # define REAL_WORLD RealWorld
81 # define REAL_WORLD _RealWorld
86 sstToIO :: SST REAL_WORLD r -> IO r
89 sstToST sst `thenStrictlyST` \ r ->
90 returnStrictlyST (Right r))
92 ioToRnMG :: IO r -> RnMG (Either IOError13 r)
93 ioToRnMG (MkIO io) rn_down g_down = stToSST io
95 traceRn :: Doc -> RnMG ()
96 traceRn msg | opt_D_show_rn_trace = putDocRn msg
97 | otherwise = returnRn ()
99 putDocRn :: Doc -> RnMG ()
100 putDocRn msg = ioToRnMG (hPutStr stderr (show msg) >>
101 hPutStr stderr "\n") `thenRn_`
106 %************************************************************************
108 \subsection{Data types}
110 %************************************************************************
112 ===================================================
114 ===================================================
117 type RnM s d r = RnDown s -> d -> SST s r
118 type RnMS s r = RnM s (SDown s) r -- Renaming source
119 type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc
120 type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this
123 data RnDown s = RnDown
125 (MutableVar s RnNameSupply)
126 (MutableVar s (Bag Warning, Bag Error))
127 (MutableVar s ([Name],[Name])) -- Occurrences: compulsory and optional resp
129 data Necessity = Compulsory | Optional -- We *must* find definitions for
130 -- compulsory occurrences; we *may* find them
131 -- for optional ones.
133 -- For getting global names
138 -- For renaming source code
141 NameEnv -- Local name envt (includes global name envt,
142 -- but may shadow it)
147 data RnSMode = SourceMode -- Renaming source code
148 | InterfaceMode Necessity -- Renaming interface declarations. The "necessity"
149 -- flag says free variables *must* be found and slurped
150 -- or whether they need not be. For value signatures of
151 -- things that are themselves compulsorily imported
152 -- we arrange that the type signature is read in compulsory mode,
153 -- but the pragmas in optional mode.
155 type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
156 -- for interface files.
157 type FreeVars = NameSet
160 ===================================================
162 ===================================================
165 type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
166 -- Ensures that one (m,n) pair gets one unique
167 -- The Int is used to give a number to each instance declaration;
168 -- it's really a separate name supply.
170 data RnEnv = RnEnv NameEnv FixityEnv
171 emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
173 type NameEnv = FiniteMap RdrName Name
174 emptyNameEnv = emptyFM
176 type FixityEnv = FiniteMap RdrName (Fixity, Provenance)
177 emptyFixityEnv = emptyFM
178 -- It's possible to have a different fixity for B.op than for op:
180 -- module A( op ) where module B where
181 -- import qualified B( op ) infixr 2 op
182 -- infixl 9 `op` op = ...
183 -- op a b = a `B.op` b
185 data ExportEnv = ExportEnv Avails Fixities
186 type Avails = [AvailInfo]
187 type Fixities = [(OccName, (Fixity, Provenance))]
188 -- Can contain duplicates, if one module defines the same fixity,
189 -- or the same type/class/id, more than once. Hence a boring old list.
190 -- This allows us to report duplicates in just one place, namely plusRnEnv.
192 type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers
193 -- Includes avails only from *unqualified* imports
194 -- (see 1.4 Report Section 5.1.1)
196 UniqFM AvailInfo) -- Used to figure out all other export specifiers.
197 -- Maps a Name to the AvailInfo that contains it
198 -- NB: Contain bindings for class ops but
199 -- not constructors (see defn of availEntityNames)
202 data GenAvailInfo name = NotAvailable
203 | Avail name -- An ordinary identifier
204 | AvailTC name -- The name of the type or class
205 [name] -- The available pieces of type/class. NB: If the type or
206 -- class is itself to be in scope, it must be in this list.
207 -- Thus, typically: AvailTC Eq [Eq, ==, /=]
208 type AvailInfo = GenAvailInfo Name
209 type RdrAvailInfo = GenAvailInfo OccName
212 ===================================================
214 ===================================================
217 type ExportItem = (Module, IfaceFlavour, [RdrAvailInfo])
218 type VersionInfo name = [ImportVersion name]
219 type ImportVersion name = (Module, IfaceFlavour, Version, [LocalVersion name])
220 type LocalVersion name = (name, Version)
224 Module -- Module name
225 Version -- Module version number
226 [ImportVersion OccName] -- Usages
227 [ExportItem] -- Exports
228 [Module] -- Special instance modules
229 [(OccName,Fixity)] -- Fixities
230 [(Version, RdrNameHsDecl)] -- Local definitions
231 [RdrNameInstDecl] -- Local instance declarations
233 type InterfaceDetails = (VersionInfo Name, -- Version information
234 ExportEnv, -- What this module exports
235 [Module]) -- Instance modules
237 type RdrNamePragma = () -- Fudge for now
241 Module -- Name of this module
242 (FiniteMap Module (IfaceFlavour, -- Exports
248 NameSet -- All the names (whether "big" or "small", whether wired-in or not,
249 -- whether locally defined or not) that have been slurped in so far.
251 [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
252 -- have been slurped in so far, with their versions.
253 -- This is used to generate the "usage" information for this module.
254 -- Subset of the previous field.
256 (Bag IfaceInst, NameSet) -- The as-yet un-slurped instance decls; this bag is depleted when we
257 -- slurp an instance decl so that we don't slurp the same one twice.
258 -- Together with them is the set of tycons/classes that may allow
259 -- the instance decls in.
261 (FiniteMap Name RdrNameTyDecl)
262 -- Deferred data type declarations; each has the following properties
263 -- * it's a data type decl
264 -- * its TyCon is needed
265 -- * the decl may or may not have been slurped, depending on whether any
266 -- of the constrs are needed.
268 [Module] -- Set of modules with "special" instance declarations
269 -- Excludes this module
272 type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
273 type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
274 [Name]) -- "Gate" names. Slurp this instance decl when this
275 -- list becomes empty. It's depleted whenever we
276 -- slurp another type or class decl.
280 %************************************************************************
282 \subsection{Main monad code}
284 %************************************************************************
287 initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
289 -> IO (r, Bag Error, Bag Warning)
291 initRn mod us dirs loc do_rn
293 newMutVarSST (us, 1, builtins) `thenSST` \ names_var ->
294 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
295 newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
296 newMutVarSST initOccs `thenSST` \ occs_var ->
298 rn_down = RnDown loc names_var errs_var occs_var
299 g_down = GDown dirs iface_var
302 do_rn rn_down g_down `thenSST` \ res ->
304 -- grab errors and return
305 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
306 returnSST (res, errs, warns)
309 initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
310 initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
312 s_down = SDown rn_env name_env mod_name mode
317 emptyIfaces :: Module -> Ifaces
318 emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
320 builtins :: FiniteMap (Module,OccName) Name
321 builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
323 -- Initial value for the occurrence pool.
324 initOccs :: ([Name],[Name]) -- Compulsory and optional respectively
325 initOccs = ([getName boolTyCon], [])
326 -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
327 -- rather implausible that not one will be used in the module.
328 -- We could add some other common types, notably lists, but the general idea is
329 -- to do as much as possible explicitly.
335 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
336 the main renamer. Examples: pragmas (which we don't want to rename unless
337 we actually explore them); and derived definitions, which are only generated
340 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
341 once you must either split it, or install a fresh unique supply.
344 renameSourceCode :: Module
349 -- Alas, we can't use the real runST, with the desired signature:
350 -- renameSourceCode :: RnNameSupply -> RnMS s r -> r
351 -- because we can't manufacture "new versions of runST".
353 renameSourceCode mod_name name_supply m
355 newMutVarSST name_supply `thenSST` \ names_var ->
356 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
357 newMutVarSST ([],[]) `thenSST` \ occs_var ->
359 rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
360 s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory)
362 m rn_down s_down `thenSST` \ result ->
364 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
366 (if not (isEmptyBag errs) then
367 trace ("Urk! renameSourceCode found errors" ++ display errs)
368 else if not (isEmptyBag warns) then
369 trace ("Urk! renameSourceCode found warnings" ++ display warns)
376 display errs = show (pprBagOfErrors PprDebug errs)
378 {-# INLINE thenRn #-}
379 {-# INLINE thenRn_ #-}
380 {-# INLINE returnRn #-}
383 returnRn :: a -> RnM s d a
384 thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
385 thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b
386 andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
387 mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b]
388 sequenceRn :: [RnM s d a] -> RnM s d [a]
389 foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b
390 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
391 fixRn :: (a -> RnM s d a) -> RnM s d a
393 returnRn v gdown ldown = returnSST v
394 thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown
395 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
396 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
397 andRn combiner m1 m2 gdown ldown
398 = m1 gdown ldown `thenSST` \ res1 ->
399 m2 gdown ldown `thenSST` \ res2 ->
400 returnSST (combiner res1 res2)
402 sequenceRn [] = returnRn []
403 sequenceRn (m:ms) = m `thenRn` \ r ->
404 sequenceRn ms `thenRn` \ rs ->
407 mapRn f [] = returnRn []
409 = f x `thenRn` \ r ->
410 mapRn f xs `thenRn` \ rs ->
413 foldlRn k z [] = returnRn z
414 foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
417 mapAndUnzipRn f [] = returnRn ([],[])
418 mapAndUnzipRn f (x:xs)
419 = f x `thenRn` \ (r1, r2) ->
420 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
421 returnRn (r1:rs1, r2:rs2)
423 mapAndUnzip3Rn f [] = returnRn ([],[],[])
424 mapAndUnzip3Rn f (x:xs)
425 = f x `thenRn` \ (r1, r2, r3) ->
426 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
427 returnRn (r1:rs1, r2:rs2, r3:rs3)
432 %************************************************************************
434 \subsection{Boring plumbing for common part}
436 %************************************************************************
439 ================ Errors and warnings =====================
442 failWithRn :: a -> Error -> RnM s d a
443 failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
444 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
445 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
448 err = addShortErrLocLine loc msg
450 warnWithRn :: a -> Warning -> RnM s d a
451 warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
452 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
453 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
456 warn = addShortWarnLocLine loc msg
458 addErrRn :: Error -> RnM s d ()
459 addErrRn err = failWithRn () err
461 checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true
462 checkRn False err = addErrRn err
463 checkRn True err = returnRn ()
465 addWarnRn :: Warning -> RnM s d ()
466 addWarnRn warn = warnWithRn () warn
468 checkErrsRn :: RnM s d Bool -- True <=> no errors so far
469 checkErrsRn (RnDown loc names_var errs_var occs_var) l_down
470 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
471 returnSST (isEmptyBag errs)
475 ================ Source location =====================
478 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
479 pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
480 = m (RnDown loc' names_var errs_var occs_var) l_down
482 getSrcLocRn :: RnM s d SrcLoc
483 getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
487 ================ Name supply =====================
490 getNameSupplyRn :: RnM s d RnNameSupply
491 getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
492 = readMutVarSST names_var
494 setNameSupplyRn :: RnNameSupply -> RnM s d ()
495 setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
496 = writeMutVarSST names_var names'
498 -- The "instance-decl unique supply", inst, is just an integer that's used to
499 -- give a unique number for each instance declaration.
500 newInstUniq :: RnM s d Int
501 newInstUniq (RnDown loc names_var errs_var occs_var) l_down
502 = readMutVarSST names_var `thenSST` \ (us, inst, cache) ->
503 writeMutVarSST names_var (us, inst+1, cache) `thenSST_`
507 ================ Occurrences =====================
509 Every time we get an occurrence of a name we put it in one of two lists:
510 one for "compulsory" occurrences
511 one for "optional" occurrences
513 The significance of "compulsory" is
514 (a) we *must* find the declaration
515 (b) in the case of type or class names, the name is part of the
516 source level program, and we must slurp in any instance decls
519 We don't need instance decls "optional" names, because the type inference
520 process will never come across them. Optional names are buried inside
521 type checked (but not renamed) cross-module unfoldings and such.
523 The pair of lists is held in a mutable variable in RnDown.
525 The lists are kept separate so that we can process all the compulsory occurrences
526 before any of the optional ones. Why? Because suppose we processed an optional
527 "g", and slurped an interface decl of g::T->T. Then we'd rename the type T->T in
528 optional mode. But if we later need g compulsorily we'll find that it's already
529 been slurped and will do nothing. We could, I suppose, rename it a second time,
530 but it seems simpler just to do all the compulsory ones first.
533 addOccurrenceName :: Name -> RnMS s Name -- Same name returned as passed
534 addOccurrenceName name (RnDown loc names_var errs_var occs_var)
535 (SDown rn_env local_env mod_name mode)
536 | isLocallyDefinedName name ||
537 not_necessary necessity
541 = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) ->
543 new_occ_pair = case necessity of
544 Optional -> (comp_occs, name:opt_occs)
545 Compulsory -> (name:comp_occs, opt_occs)
547 writeMutVarSST occs_var new_occ_pair `thenSST_`
550 necessity = case mode of
551 SourceMode -> Compulsory
552 InterfaceMode necessity -> necessity
555 addOccurrenceNames :: [Name] -> RnMS s ()
556 addOccurrenceNames names (RnDown loc names_var errs_var occs_var)
557 (SDown rn_env local_env mod_name mode)
558 | not_necessary necessity
562 = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) ->
564 new_occ_pair = case necessity of
565 Optional -> (comp_occs, non_local_names ++ opt_occs)
566 Compulsory -> (non_local_names ++ comp_occs, opt_occs)
568 writeMutVarSST occs_var new_occ_pair
570 non_local_names = filter (not . isLocallyDefinedName) names
571 necessity = case mode of
572 SourceMode -> Compulsory
573 InterfaceMode necessity -> necessity
575 -- Never look for optional things if we're
576 -- ignoring optional input interface information
577 not_necessary Compulsory = False
578 not_necessary Optional = opt_IgnoreIfacePragmas
580 popOccurrenceName :: Necessity -> RnM s d (Maybe Name)
581 popOccurrenceName necessity (RnDown loc names_var errs_var occs_var) l_down
582 = readMutVarSST occs_var `thenSST` \ occs ->
583 case (necessity, occs) of
584 -- Find a compulsory occurrence
585 (Compulsory, (comp:comps, opts)) -> writeMutVarSST occs_var (comps, opts) `thenSST_`
586 returnSST (Just comp)
588 -- Find an optional occurrence
589 -- We shouldn't be looking unless we've done all the compulsories
590 (Optional, (comps, opt:opts)) -> ASSERT( null comps )
591 writeMutVarSST occs_var (comps, opts) `thenSST_`
594 -- No suitable occurrence
595 other -> returnSST Nothing
597 -- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
598 -- variable, and returns the list of occurrences thus found. It's useful
599 -- when loading instance decls and specialisation signatures, when we want to
600 -- know the names of the things in the types, but we don't want to treat them
603 findOccurrencesRn :: RnM s d a -> RnM s d [Name]
604 findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
605 = newMutVarSST ([],[]) `thenSST` \ new_occs_var ->
606 enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_`
607 readMutVarSST new_occs_var `thenSST` \ (occs,_) ->
612 %************************************************************************
614 \subsection{Plumbing for rename-source part}
616 %************************************************************************
618 ================ RnEnv =====================
621 getGlobalNameEnv :: RnMS s NameEnv
622 getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
623 = returnSST global_env
625 getNameEnv :: RnMS s NameEnv
626 getNameEnv rn_down (SDown rn_env local_env mod_name mode)
627 = returnSST local_env
629 setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
630 setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
631 = m rn_down (SDown rn_env local_env' mod_name mode)
633 getFixityEnv :: RnMS s FixityEnv
634 getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
635 = returnSST fixity_env
638 ================ Module and Mode =====================
641 getModuleRn :: RnMS s Module
642 getModuleRn rn_down (SDown rn_env local_env mod_name mode)
647 getModeRn :: RnMS s RnSMode
648 getModeRn rn_down (SDown rn_env local_env mod_name mode)
651 setModeRn :: RnSMode -> RnMS s a -> RnMS s a
652 setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode)
653 = thing_inside rn_down (SDown rn_env local_env mod_name new_mode)
657 %************************************************************************
659 \subsection{Plumbing for rename-globals part}
661 %************************************************************************
664 getIfacesRn :: RnMG Ifaces
665 getIfacesRn rn_down (GDown dirs iface_var)
666 = readMutVarSST iface_var
668 setIfacesRn :: Ifaces -> RnMG ()
669 setIfacesRn ifaces rn_down (GDown dirs iface_var)
670 = writeMutVarSST iface_var ifaces
672 getSearchPathRn :: RnMG SearchPath
673 getSearchPathRn rn_down (GDown dirs iface_var)