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 import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST )
32 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
33 pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
35 import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet,
37 modAndOcc, NamedThing(..)
39 import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
40 import PrelInfo ( builtinNames )
41 import TyCon ( TyCon {- instance NamedThing -} )
42 import TysWiredIn ( boolTyCon )
44 import PprStyle ( PprStyle(..) )
45 import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
46 import Unique ( Unique )
47 import FiniteMap ( FiniteMap, emptyFM, bagToFM )
48 import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
52 infixr 9 `thenRn`, `thenRn_`
56 %************************************************************************
58 \subsection{Somewhat magical interface to other monads}
60 %************************************************************************
63 #if __GLASGOW_HASKELL__ >= 200
64 # define REAL_WORLD RealWorld
66 # define REAL_WORLD _RealWorld
71 sstToIO :: SST REAL_WORLD r -> IO r
73 = sstToST sst `thenStrictlyST` \ r ->
74 returnStrictlyST (Right r)
76 ioToRnMG :: IO r -> RnMG (Either IOError13 r)
77 ioToRnMG io rn_down g_down = stToSST io
79 traceRn :: Pretty -> RnMG ()
80 traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >>
81 hPutStr stderr "\n") `thenRn_`
83 | otherwise = returnRn ()
87 %************************************************************************
89 \subsection{Data types}
91 %************************************************************************
93 ===================================================
95 ===================================================
98 type RnM s d r = RnDown s -> d -> SST s r
99 type RnMS s r = RnM s (SDown s) r -- Renaming source
100 type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc
101 type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this
104 data RnDown s = RnDown
106 (MutableVar s RnNameSupply)
107 (MutableVar s (Bag Warning, Bag Error))
108 (MutableVar s [(Name,Necessity)]) -- Occurrences
110 data Necessity = Compulsory | Optional -- We *must* find definitions for
111 -- compulsory occurrences; we *may* find them
112 -- for optional ones.
114 -- For getting global names
119 -- For renaming source code
122 NameEnv -- Local name envt (includes global name envt,
123 -- but may shadow it)
128 data RnSMode = SourceMode
131 type SearchPath = [String] -- List of directories to seach for interface files
132 type FreeVars = NameSet
135 ===================================================
137 ===================================================
140 type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
141 -- Ensures that one (m,n) pair gets one unique
142 -- The Int is used to give a number to each instance declaration;
143 -- it's really a separate name supply.
145 data RnEnv = RnEnv NameEnv FixityEnv
146 emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
148 type NameEnv = FiniteMap RdrName Name
149 emptyNameEnv = emptyFM
151 type FixityEnv = FiniteMap RdrName (Fixity, Provenance)
152 emptyFixityEnv = emptyFM
153 -- It's possible to have a different fixity for B.op than for op:
155 -- module A( op ) where module B where
156 -- import qualified B( op ) infixr 2 op
157 -- infixl 9 `op` op = ...
158 -- op a b = a `B.op` b
160 data ExportEnv = ExportEnv Avails Fixities
161 type Avails = [AvailInfo]
162 type Fixities = [(OccName, (Fixity, Provenance))]
163 -- Can contain duplicates, if one module defines the same fixity,
164 -- or the same type/class/id, more than once. Hence a boring old list.
165 -- This allows us to report duplicates in just one place, namely plusRnEnv.
167 type ModuleAvails = FiniteMap Module Avails
169 data AvailInfo = NotAvailable
170 | Avail Name -- An ordinary identifier
171 | AvailTC Name -- The name of the type or class
172 [Name] -- The available pieces of type/class. NB: If the type or
173 -- class is itself to be in scope, it must be in this list.
174 -- Thus, typically: Avail Eq [Eq, ==, /=]
177 ===================================================
179 ===================================================
182 type ExportItem = (Module, [(OccName, [OccName])])
183 type VersionInfo name = [ImportVersion name]
184 type ImportVersion name = (Module, Version, [LocalVersion name])
185 type LocalVersion name = (name, Version)
189 Module -- Module name
190 Version -- Module version number
191 [ImportVersion OccName] -- Usages
192 [ExportItem] -- Exports
193 [Module] -- Special instance modules
194 [(OccName,Fixity)] -- Fixities
195 [(Version, RdrNameHsDecl)] -- Local definitions
196 [RdrNameInstDecl] -- Local instance declarations
198 type InterfaceDetails = (VersionInfo Name, -- Version information
199 ExportEnv, -- What this module exports
200 [Module]) -- Instance modules
202 type RdrNamePragma = () -- Fudge for now
206 Module -- Name of this module
207 (FiniteMap Module Version)
208 (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
211 NameSet -- All the names (whether "big" or "small", whether wired-in or not,
212 -- whether locally defined or not) that have been slurped in so far.
214 [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
215 -- have been slurped in so far, with their versions. Subset of
216 -- the previous field. This is used to generate the "usage" information
219 (Bag IfaceInst) -- Un-slurped instance decls; this bag is depleted when we
220 -- slurp an instance decl so that we don't slurp the same one twice.
222 [Module] -- Set of modules with "special" instance declarations
223 -- Excludes this module
225 type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
226 type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
227 [Name]) -- "Gate" names. Slurp this instance decl when this
228 -- list becomes empty. It's depleted whenever we
229 -- slurp another type or class decl.
233 %************************************************************************
235 \subsection{Main monad code}
237 %************************************************************************
240 initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
242 -> IO (r, Bag Error, Bag Warning)
244 initRn mod us dirs loc do_rn
246 newMutVarSST (us, 1, builtins) `thenSST` \ names_var ->
247 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
248 newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
249 newMutVarSST initOccs `thenSST` \ occs_var ->
251 rn_down = RnDown loc names_var errs_var occs_var
252 g_down = GDown dirs iface_var
255 do_rn rn_down g_down `thenSST` \ res ->
257 -- grab errors and return
258 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
259 returnSST (res, errs, warns)
262 initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
263 initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
265 s_down = SDown rn_env name_env mod_name mode
270 emptyIfaces :: Module -> Ifaces
271 emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag []
273 builtins :: FiniteMap (Module,OccName) Name
274 builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
276 -- Initial value for the occurrence pool.
277 initOccs :: [(Name,Necessity)]
278 initOccs = [(getName boolTyCon, Compulsory)]
279 -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
280 -- rather implausible that not one will be used in the module.
281 -- We could add some other common types, notably lists, but the general idea is
282 -- to do as much as possible explicitly.
288 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
289 the main renamer. Examples: pragmas (which we don't want to rename unless
290 we actually explore them); and derived definitions, which are only generated
293 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
294 once you must either split it, or install a fresh unique supply.
297 renameSourceCode :: Module
302 -- Alas, we can't use the real runST, with the desired signature:
303 -- renameSourceCode :: RnNameSupply -> RnMS s r -> r
304 -- because we can't manufacture "new versions of runST".
306 renameSourceCode mod_name name_supply m
308 newMutVarSST name_supply `thenSST` \ names_var ->
309 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
310 newMutVarSST [] `thenSST` \ occs_var ->
312 rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
313 s_down = SDown emptyRnEnv emptyNameEnv mod_name InterfaceMode
315 m rn_down s_down `thenSST` \ result ->
317 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
319 (if not (isEmptyBag errs) then
320 trace ("Urk! renameSourceCode found errors" ++ display errs)
321 else if not (isEmptyBag warns) then
322 trace ("Urk! renameSourceCode found warnings" ++ display warns)
329 display errs = ppShow 80 (pprBagOfErrors PprDebug errs)
331 {-# INLINE thenRn #-}
332 {-# INLINE thenRn_ #-}
333 {-# INLINE returnRn #-}
336 returnRn :: a -> RnM s d a
337 thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
338 thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b
339 andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
340 mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b]
341 sequenceRn :: [RnM s d a] -> RnM s d [a]
342 foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b
343 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
344 fixRn :: (a -> RnM s d a) -> RnM s d a
346 returnRn v gdown ldown = returnSST v
347 thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown
348 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
349 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
350 andRn combiner m1 m2 gdown ldown
351 = m1 gdown ldown `thenSST` \ res1 ->
352 m2 gdown ldown `thenSST` \ res2 ->
353 returnSST (combiner res1 res2)
355 sequenceRn [] = returnRn []
356 sequenceRn (m:ms) = m `thenRn` \ r ->
357 sequenceRn ms `thenRn` \ rs ->
360 mapRn f [] = returnRn []
362 = f x `thenRn` \ r ->
363 mapRn f xs `thenRn` \ rs ->
366 foldlRn k z [] = returnRn z
367 foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
370 mapAndUnzipRn f [] = returnRn ([],[])
371 mapAndUnzipRn f (x:xs)
372 = f x `thenRn` \ (r1, r2) ->
373 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
374 returnRn (r1:rs1, r2:rs2)
376 mapAndUnzip3Rn f [] = returnRn ([],[],[])
377 mapAndUnzip3Rn f (x:xs)
378 = f x `thenRn` \ (r1, r2, r3) ->
379 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
380 returnRn (r1:rs1, r2:rs2, r3:rs3)
385 %************************************************************************
387 \subsection{Boring plumbing for common part}
389 %************************************************************************
392 ================ Errors and warnings =====================
395 failWithRn :: a -> Error -> RnM s d a
396 failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
397 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
398 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
401 err = addShortErrLocLine loc msg
403 warnWithRn :: a -> Warning -> RnM s d a
404 warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
405 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
406 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
409 warn = addShortWarnLocLine loc msg
411 addErrRn :: Error -> RnM s d ()
412 addErrRn err = failWithRn () err
414 checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true
415 checkRn False err = addErrRn err
416 checkRn True err = returnRn ()
418 addWarnRn :: Warning -> RnM s d ()
419 addWarnRn warn = warnWithRn () warn
421 checkErrsRn :: RnM s d Bool -- True <=> no errors so far
422 checkErrsRn (RnDown loc names_var errs_var occs_var) l_down
423 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
424 returnSST (isEmptyBag errs)
428 ================ Source location =====================
431 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
432 pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
433 = m (RnDown loc' names_var errs_var occs_var) l_down
435 getSrcLocRn :: RnM s d SrcLoc
436 getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
440 ================ Name supply =====================
443 getNameSupplyRn :: RnM s d RnNameSupply
444 getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
445 = readMutVarSST names_var
447 setNameSupplyRn :: RnNameSupply -> RnM s d ()
448 setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
449 = writeMutVarSST names_var names'
451 -- The "instance-decl unique supply", inst, is just an integer that's used to
452 -- give a unique number for each instance declaration.
453 newInstUniq :: RnM s d Int
454 newInstUniq (RnDown loc names_var errs_var occs_var) l_down
455 = readMutVarSST names_var `thenSST` \ (us, inst, cache) ->
456 writeMutVarSST names_var (us, inst+1, cache) `thenSST_`
460 ================ Occurrences =====================
463 addOccurrenceName :: Necessity -> Name -> RnM s d Name -- Same name returned as passed
464 addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
465 | isLocallyDefinedName name ||
466 not_necessary necessity
470 = readMutVarSST occs_var `thenSST` \ occs ->
471 writeMutVarSST occs_var ((name,necessity) : occs) `thenSST_`
474 not_necessary Compulsory = False
475 not_necessary Optional = opt_IgnoreIfacePragmas
476 -- Never look for optional things if we're
477 -- ignoring optional input interface information
479 addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
480 addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
481 = readMutVarSST occs_var `thenSST` \ occs ->
482 writeMutVarSST occs_var ([(name,necessity) | name <- names, not (isLocallyDefinedName name)] ++ occs)
484 popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
485 popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
486 = readMutVarSST occs_var `thenSST` \ occs ->
488 [] -> returnSST Nothing
489 (occ:occs) -> writeMutVarSST occs_var occs `thenSST_`
492 -- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
493 -- variable, and returns the list of occurrences thus found. It's useful
494 -- when loading instance decls and specialisation signatures, when we want to
495 -- know the names of the things in the types, but we don't want to treat them
498 findOccurrencesRn :: RnM s d a -> RnM s d [Name]
499 findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
500 = newMutVarSST [] `thenSST` \ new_occs_var ->
501 enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_`
502 readMutVarSST new_occs_var `thenSST` \ occs ->
503 returnSST (map fst occs)
507 %************************************************************************
509 \subsection{Plumbing for rename-source part}
511 %************************************************************************
513 ================ RnEnv =====================
516 getGlobalNameEnv :: RnMS s NameEnv
517 getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
518 = returnSST global_env
520 getNameEnv :: RnMS s NameEnv
521 getNameEnv rn_down (SDown rn_env local_env mod_name mode)
522 = returnSST local_env
524 setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
525 setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
526 = m rn_down (SDown rn_env local_env' mod_name mode)
528 getFixityEnv :: RnMS s FixityEnv
529 getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
530 = returnSST fixity_env
533 ================ Module and Mode =====================
536 getModuleRn :: RnMS s Module
537 getModuleRn rn_down (SDown rn_env local_env mod_name mode)
542 getModeRn :: RnMS s RnSMode
543 getModeRn rn_down (SDown rn_env local_env mod_name mode)
548 %************************************************************************
550 \subsection{Plumbing for rename-globals part}
552 %************************************************************************
555 getIfacesRn :: RnMG Ifaces
556 getIfacesRn rn_down (GDown dirs iface_var)
557 = readMutVarSST iface_var
559 setIfacesRn :: Ifaces -> RnMG ()
560 setIfacesRn ifaces rn_down (GDown dirs iface_var)
561 = writeMutVarSST iface_var ifaces
563 getSearchPathRn :: RnMG SearchPath
564 getSearchPathRn rn_down (GDown dirs iface_var)