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 ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
43 pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
45 import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet,
47 modAndOcc, NamedThing(..)
49 import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
50 import PrelInfo ( builtinNames )
51 import TyCon ( TyCon {- instance NamedThing -} )
52 import TysWiredIn ( boolTyCon )
54 import PprStyle ( PprStyle(..) )
55 import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
56 import Unique ( Unique )
57 import FiniteMap ( FiniteMap, emptyFM, bagToFM )
58 import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
61 #if __GLASGOW_HASKELL__ >= 202
65 infixr 9 `thenRn`, `thenRn_`
69 %************************************************************************
71 \subsection{Somewhat magical interface to other monads}
73 %************************************************************************
76 #if __GLASGOW_HASKELL__ >= 200
77 # define REAL_WORLD RealWorld
79 # define REAL_WORLD _RealWorld
84 sstToIO :: SST REAL_WORLD r -> IO r
87 sstToST sst `thenStrictlyST` \ r ->
88 returnStrictlyST (Right r))
90 ioToRnMG :: IO r -> RnMG (Either IOError13 r)
91 ioToRnMG (MkIO io) rn_down g_down = stToSST io
93 traceRn :: Doc -> RnMG ()
94 traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (show msg) >>
95 hPutStr stderr "\n") `thenRn_`
97 | otherwise = returnRn ()
101 %************************************************************************
103 \subsection{Data types}
105 %************************************************************************
107 ===================================================
109 ===================================================
112 type RnM s d r = RnDown s -> d -> SST s r
113 type RnMS s r = RnM s (SDown s) r -- Renaming source
114 type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc
115 type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this
118 data RnDown s = RnDown
120 (MutableVar s RnNameSupply)
121 (MutableVar s (Bag Warning, Bag Error))
122 (MutableVar s [(Name,Necessity)]) -- Occurrences
124 data Necessity = Compulsory | Optional -- We *must* find definitions for
125 -- compulsory occurrences; we *may* find them
126 -- for optional ones.
128 -- For getting global names
133 -- For renaming source code
136 NameEnv -- Local name envt (includes global name envt,
137 -- but may shadow it)
142 data RnSMode = SourceMode
145 type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
146 -- for interface files.
147 type FreeVars = NameSet
150 ===================================================
152 ===================================================
155 type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
156 -- Ensures that one (m,n) pair gets one unique
157 -- The Int is used to give a number to each instance declaration;
158 -- it's really a separate name supply.
160 data RnEnv = RnEnv NameEnv FixityEnv
161 emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
163 type NameEnv = FiniteMap RdrName Name
164 emptyNameEnv = emptyFM
166 type FixityEnv = FiniteMap RdrName (Fixity, Provenance)
167 emptyFixityEnv = emptyFM
168 -- It's possible to have a different fixity for B.op than for op:
170 -- module A( op ) where module B where
171 -- import qualified B( op ) infixr 2 op
172 -- infixl 9 `op` op = ...
173 -- op a b = a `B.op` b
175 data ExportEnv = ExportEnv Avails Fixities
176 type Avails = [AvailInfo]
177 type Fixities = [(OccName, (Fixity, Provenance))]
178 -- Can contain duplicates, if one module defines the same fixity,
179 -- or the same type/class/id, more than once. Hence a boring old list.
180 -- This allows us to report duplicates in just one place, namely plusRnEnv.
182 type ModuleAvails = FiniteMap Module Avails
184 data AvailInfo = NotAvailable
185 | Avail Name -- An ordinary identifier
186 | AvailTC Name -- The name of the type or class
187 [Name] -- The available pieces of type/class. NB: If the type or
188 -- class is itself to be in scope, it must be in this list.
189 -- Thus, typically: AvailTC Eq [Eq, ==, /=]
192 ===================================================
194 ===================================================
197 type ExportItem = (Module, [(OccName, [OccName])])
198 type VersionInfo name = [ImportVersion name]
199 type ImportVersion name = (Module, Version, [LocalVersion name])
200 type LocalVersion name = (name, Version)
204 Module -- Module name
205 Version -- Module version number
206 [ImportVersion OccName] -- Usages
207 [ExportItem] -- Exports
208 [Module] -- Special instance modules
209 [(OccName,Fixity)] -- Fixities
210 [(Version, RdrNameHsDecl)] -- Local definitions
211 [RdrNameInstDecl] -- Local instance declarations
213 type InterfaceDetails = (VersionInfo Name, -- Version information
214 ExportEnv, -- What this module exports
215 [Module]) -- Instance modules
217 type RdrNamePragma = () -- Fudge for now
221 Module -- Name of this module
222 (FiniteMap Module Version)
223 (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
226 NameSet -- All the names (whether "big" or "small", whether wired-in or not,
227 -- whether locally defined or not) that have been slurped in so far.
229 [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
230 -- have been slurped in so far, with their versions.
231 -- This is used to generate the "usage" information for this module.
232 -- Subset of the previous field.
234 (Bag IfaceInst) -- The as-yet un-slurped instance decls; this bag is depleted when we
235 -- slurp an instance decl so that we don't slurp the same one twice.
237 (FiniteMap Name RdrNameTyDecl)
238 -- Deferred data type declarations; each has the following properties
239 -- * it's a data type decl
240 -- * its TyCon is needed
241 -- * the decl may or may not have been slurped, depending on whether any
242 -- of the constrs are needed.
244 [Module] -- Set of modules with "special" instance declarations
245 -- Excludes this module
248 type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
249 type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
250 [Name]) -- "Gate" names. Slurp this instance decl when this
251 -- list becomes empty. It's depleted whenever we
252 -- slurp another type or class decl.
256 %************************************************************************
258 \subsection{Main monad code}
260 %************************************************************************
263 initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
265 -> IO (r, Bag Error, Bag Warning)
267 initRn mod us dirs loc do_rn
269 newMutVarSST (us, 1, builtins) `thenSST` \ names_var ->
270 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
271 newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
272 newMutVarSST initOccs `thenSST` \ occs_var ->
274 rn_down = RnDown loc names_var errs_var occs_var
275 g_down = GDown dirs iface_var
278 do_rn rn_down g_down `thenSST` \ res ->
280 -- grab errors and return
281 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
282 returnSST (res, errs, warns)
285 initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
286 initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
288 s_down = SDown rn_env name_env mod_name mode
293 emptyIfaces :: Module -> Ifaces
294 emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag emptyFM []
296 builtins :: FiniteMap (Module,OccName) Name
297 builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
299 -- Initial value for the occurrence pool.
300 initOccs :: [(Name,Necessity)]
301 initOccs = [(getName boolTyCon, Compulsory)]
302 -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
303 -- rather implausible that not one will be used in the module.
304 -- We could add some other common types, notably lists, but the general idea is
305 -- to do as much as possible explicitly.
311 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
312 the main renamer. Examples: pragmas (which we don't want to rename unless
313 we actually explore them); and derived definitions, which are only generated
316 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
317 once you must either split it, or install a fresh unique supply.
320 renameSourceCode :: Module
325 -- Alas, we can't use the real runST, with the desired signature:
326 -- renameSourceCode :: RnNameSupply -> RnMS s r -> r
327 -- because we can't manufacture "new versions of runST".
329 renameSourceCode mod_name name_supply m
331 newMutVarSST name_supply `thenSST` \ names_var ->
332 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
333 newMutVarSST [] `thenSST` \ occs_var ->
335 rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
336 s_down = SDown emptyRnEnv emptyNameEnv mod_name InterfaceMode
338 m rn_down s_down `thenSST` \ result ->
340 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
342 (if not (isEmptyBag errs) then
343 trace ("Urk! renameSourceCode found errors" ++ display errs)
344 else if not (isEmptyBag warns) then
345 trace ("Urk! renameSourceCode found warnings" ++ display warns)
352 display errs = show (pprBagOfErrors PprDebug errs)
354 {-# INLINE thenRn #-}
355 {-# INLINE thenRn_ #-}
356 {-# INLINE returnRn #-}
359 returnRn :: a -> RnM s d a
360 thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
361 thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b
362 andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
363 mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b]
364 sequenceRn :: [RnM s d a] -> RnM s d [a]
365 foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b
366 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
367 fixRn :: (a -> RnM s d a) -> RnM s d a
369 returnRn v gdown ldown = returnSST v
370 thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown
371 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
372 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
373 andRn combiner m1 m2 gdown ldown
374 = m1 gdown ldown `thenSST` \ res1 ->
375 m2 gdown ldown `thenSST` \ res2 ->
376 returnSST (combiner res1 res2)
378 sequenceRn [] = returnRn []
379 sequenceRn (m:ms) = m `thenRn` \ r ->
380 sequenceRn ms `thenRn` \ rs ->
383 mapRn f [] = returnRn []
385 = f x `thenRn` \ r ->
386 mapRn f xs `thenRn` \ rs ->
389 foldlRn k z [] = returnRn z
390 foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
393 mapAndUnzipRn f [] = returnRn ([],[])
394 mapAndUnzipRn f (x:xs)
395 = f x `thenRn` \ (r1, r2) ->
396 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
397 returnRn (r1:rs1, r2:rs2)
399 mapAndUnzip3Rn f [] = returnRn ([],[],[])
400 mapAndUnzip3Rn f (x:xs)
401 = f x `thenRn` \ (r1, r2, r3) ->
402 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
403 returnRn (r1:rs1, r2:rs2, r3:rs3)
408 %************************************************************************
410 \subsection{Boring plumbing for common part}
412 %************************************************************************
415 ================ Errors and warnings =====================
418 failWithRn :: a -> Error -> RnM s d a
419 failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
420 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
421 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
424 err = addShortErrLocLine loc msg
426 warnWithRn :: a -> Warning -> RnM s d a
427 warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
428 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
429 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
432 warn = addShortWarnLocLine loc msg
434 addErrRn :: Error -> RnM s d ()
435 addErrRn err = failWithRn () err
437 checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true
438 checkRn False err = addErrRn err
439 checkRn True err = returnRn ()
441 addWarnRn :: Warning -> RnM s d ()
442 addWarnRn warn = warnWithRn () warn
444 checkErrsRn :: RnM s d Bool -- True <=> no errors so far
445 checkErrsRn (RnDown loc names_var errs_var occs_var) l_down
446 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
447 returnSST (isEmptyBag errs)
451 ================ Source location =====================
454 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
455 pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
456 = m (RnDown loc' names_var errs_var occs_var) l_down
458 getSrcLocRn :: RnM s d SrcLoc
459 getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
463 ================ Name supply =====================
466 getNameSupplyRn :: RnM s d RnNameSupply
467 getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
468 = readMutVarSST names_var
470 setNameSupplyRn :: RnNameSupply -> RnM s d ()
471 setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
472 = writeMutVarSST names_var names'
474 -- The "instance-decl unique supply", inst, is just an integer that's used to
475 -- give a unique number for each instance declaration.
476 newInstUniq :: RnM s d Int
477 newInstUniq (RnDown loc names_var errs_var occs_var) l_down
478 = readMutVarSST names_var `thenSST` \ (us, inst, cache) ->
479 writeMutVarSST names_var (us, inst+1, cache) `thenSST_`
483 ================ Occurrences =====================
486 addOccurrenceName :: Necessity -> Name -> RnM s d Name -- Same name returned as passed
487 addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
488 | isLocallyDefinedName name ||
489 not_necessary necessity
493 = readMutVarSST occs_var `thenSST` \ occs ->
494 writeMutVarSST occs_var ((name,necessity) : occs) `thenSST_`
497 not_necessary Compulsory = False
498 not_necessary Optional = opt_IgnoreIfacePragmas
499 -- Never look for optional things if we're
500 -- ignoring optional input interface information
502 addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
503 addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
504 = readMutVarSST occs_var `thenSST` \ occs ->
505 writeMutVarSST occs_var ([(name,necessity) | name <- names, not (isLocallyDefinedName name)] ++ occs)
507 popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
508 popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
509 = readMutVarSST occs_var `thenSST` \ occs ->
511 [] -> returnSST Nothing
512 (occ:occs) -> writeMutVarSST occs_var occs `thenSST_`
515 -- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
516 -- variable, and returns the list of occurrences thus found. It's useful
517 -- when loading instance decls and specialisation signatures, when we want to
518 -- know the names of the things in the types, but we don't want to treat them
521 findOccurrencesRn :: RnM s d a -> RnM s d [Name]
522 findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
523 = newMutVarSST [] `thenSST` \ new_occs_var ->
524 enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_`
525 readMutVarSST new_occs_var `thenSST` \ occs ->
526 returnSST (map fst occs)
530 %************************************************************************
532 \subsection{Plumbing for rename-source part}
534 %************************************************************************
536 ================ RnEnv =====================
539 getGlobalNameEnv :: RnMS s NameEnv
540 getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
541 = returnSST global_env
543 getNameEnv :: RnMS s NameEnv
544 getNameEnv rn_down (SDown rn_env local_env mod_name mode)
545 = returnSST local_env
547 setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
548 setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
549 = m rn_down (SDown rn_env local_env' mod_name mode)
551 getFixityEnv :: RnMS s FixityEnv
552 getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
553 = returnSST fixity_env
556 ================ Module and Mode =====================
559 getModuleRn :: RnMS s Module
560 getModuleRn rn_down (SDown rn_env local_env mod_name mode)
565 getModeRn :: RnMS s RnSMode
566 getModeRn rn_down (SDown rn_env local_env mod_name mode)
571 %************************************************************************
573 \subsection{Plumbing for rename-globals part}
575 %************************************************************************
578 getIfacesRn :: RnMG Ifaces
579 getIfacesRn rn_down (GDown dirs iface_var)
580 = readMutVarSST iface_var
582 setIfacesRn :: Ifaces -> RnMG ()
583 setIfacesRn ifaces rn_down (GDown dirs iface_var)
584 = writeMutVarSST iface_var ifaces
586 getSearchPathRn :: RnMG SearchPath
587 getSearchPathRn rn_down (GDown dirs iface_var)