2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnMonad]{The monad used by the renamer}
7 #include "HsVersions.h"
17 import PreludeGlaST ( SYN_IE(ST), thenST, returnST )
21 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
22 pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
24 import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet),
25 modAndOcc, NamedThing(..)
27 import CmdLineOpts ( opt_D_show_rn_trace )
28 import PrelInfo ( builtinNames )
29 import TyCon ( TyCon {- instance NamedThing -} )
30 import TysWiredIn ( boolTyCon )
32 import PprStyle ( PprStyle(..) )
33 import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
34 import Unique ( Unique )
35 import FiniteMap ( FiniteMap, emptyFM, bagToFM )
36 import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
40 infixr 9 `thenRn`, `thenRn_`
44 %************************************************************************
46 \subsection{Somewhat magical interface to other monads}
48 %************************************************************************
51 #if __GLASGOW_HASKELL__ >= 200
52 # define REAL_WORLD RealWorld
54 # define REAL_WORLD _RealWorld
59 sstToIO :: SST REAL_WORLD r -> IO r
61 = sstToST sst `thenST` \ r ->
64 ioToRnMG :: IO r -> RnMG (Either IOError13 r)
65 ioToRnMG io rn_down g_down = stToSST io
67 traceRn :: Pretty -> RnMG ()
68 traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >>
69 hPutStr stderr "\n") `thenRn_`
71 | otherwise = returnRn ()
75 %************************************************************************
77 \subsection{Data types}
79 %************************************************************************
81 ===================================================
83 ===================================================
86 type RnM s d r = RnDown s -> d -> SST s r
87 type RnMS s r = RnM s (SDown s) r -- Renaming source
88 type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc
89 type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this
92 data RnDown s = RnDown
94 (MutableVar s RnNameSupply)
95 (MutableVar s (Bag Warning, Bag Error))
96 (MutableVar s [(Name,Necessity)]) -- Occurrences
98 data Necessity = Compulsory | Optional -- We *must* find definitions for
99 -- compulsory occurrences; we *may* find them
100 -- for optional ones.
102 -- For getting global names
107 -- For renaming source code
114 data RnSMode = SourceMode
117 type SearchPath = [String] -- List of directories to seach for interface files
118 type FreeVars = NameSet
121 ===================================================
123 ===================================================
126 type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
127 -- Ensures that one (m,n) pair gets one unique
128 -- The Int is used to give a number to each instance declaration;
129 -- it's really a separate name supply.
131 data RnEnv = RnEnv NameEnv FixityEnv
132 emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
134 type NameEnv = FiniteMap RdrName Name
135 emptyNameEnv = emptyFM
137 type FixityEnv = FiniteMap RdrName (Fixity, Provenance)
138 emptyFixityEnv = emptyFM
139 -- It's possible to have a different fixity for B.op than for op:
141 -- module A( op ) where module B where
142 -- import qualified B( op ) infixr 2 op
143 -- infixl 9 `op` op = ...
144 -- op a b = a `B.op` b
146 data ExportEnv = ExportEnv Avails Fixities
147 type Avails = [AvailInfo]
148 type Fixities = [(OccName, (Fixity, Provenance))]
149 -- Can contain duplicates, if one module defines the same fixity,
150 -- or the same type/class/id, more than once. Hence a boring old list.
151 -- This allows us to report duplicates in just one place, namely plusRnEnv.
153 type ModuleAvails = FiniteMap Module Avails
155 data AvailInfo = NotAvailable | Avail Name [Name]
158 ===================================================
160 ===================================================
163 type ExportItem = (Module, [(OccName, [OccName])])
164 type VersionInfo name = [ImportVersion name]
165 type ImportVersion name = (Module, Version, [LocalVersion name])
166 type LocalVersion name = (name, Version)
170 Module -- Module name
171 Version -- Module version number
172 [ImportVersion OccName] -- Usages
173 [ExportItem] -- Exports
174 [Module] -- Special instance modules
175 [(OccName,Fixity)] -- Fixities
176 [(Version, RdrNameHsDecl)] -- Local definitions
177 [RdrNameInstDecl] -- Local instance declarations
179 type InterfaceDetails = (VersionInfo Name, -- Version information
180 ExportEnv, -- What this module exports
181 [Module]) -- Instance modules
183 type RdrNamePragma = () -- Fudge for now
187 Module -- Name of this module
188 (FiniteMap Module Version)
189 (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
193 [Module] -- Set of modules with "special" instance declarations
194 -- Excludes this module
196 type DeclsMap = FiniteMap Name (AvailInfo, RdrNameHsDecl)
197 type VersionMap = FiniteMap Name Version
198 type IfaceInst = ([Name], Module, RdrNameInstDecl) -- The Names are those tycons and
199 -- classes mentioned by the instance type
203 %************************************************************************
205 \subsection{Main monad code}
207 %************************************************************************
210 initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
212 -> IO (r, Bag Error, Bag Warning)
214 initRn mod us dirs loc do_rn
216 newMutVarSST (us, 1, builtins) `thenSST` \ names_var ->
217 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
218 newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
219 newMutVarSST initOccs `thenSST` \ occs_var ->
221 rn_down = RnDown loc names_var errs_var occs_var
222 g_down = GDown dirs iface_var
225 do_rn rn_down g_down `thenSST` \ res ->
227 -- grab errors and return
228 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
229 returnSST (res, errs, warns)
232 initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
233 initRnMS env mod_name mode m rn_down g_down
235 s_down = SDown env mod_name mode
240 emptyIfaces :: Module -> Ifaces
241 emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyFM emptyBag []
243 builtins :: FiniteMap (Module,OccName) Name
244 builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
246 -- Initial value for the occurrence pool.
247 initOccs :: [(Name,Necessity)]
248 initOccs = [(getName boolTyCon, Compulsory)]
249 -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
250 -- rather implausible that not one will be used in the module.
251 -- We could add some other common types, notably lists, but the general idea is
252 -- to do as much as possible explicitly.
258 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
259 the main renamer. Examples: pragmas (which we don't want to rename unless
260 we actually explore them); and derived definitions, which are only generated
263 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
264 once you must either split it, or install a fresh unique supply.
267 renameSourceCode :: Module
272 -- Alas, we can't use the real runST, with the desired signature:
273 -- renameSourceCode :: RnNameSupply -> RnMS s r -> r
274 -- because we can't manufacture "new versions of runST".
276 renameSourceCode mod_name name_supply m
278 newMutVarSST name_supply `thenSST` \ names_var ->
279 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
280 newMutVarSST [] `thenSST` \ occs_var ->
282 rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
283 s_down = SDown emptyRnEnv mod_name InterfaceMode
285 m rn_down s_down `thenSST` \ result ->
287 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
289 (if not (isEmptyBag errs) then
290 trace ("Urk! renameSourceCode found errors" ++ display errs)
291 else if not (isEmptyBag warns) then
292 trace ("Urk! renameSourceCode found warnings" ++ display warns)
299 display errs = ppShow 80 (pprBagOfErrors PprDebug errs)
301 {-# INLINE thenRn #-}
302 {-# INLINE thenRn_ #-}
303 {-# INLINE returnRn #-}
306 returnRn :: a -> RnM s d a
307 thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
308 thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b
309 andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
310 mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b]
311 sequenceRn :: [RnM s d a] -> RnM s d [a]
312 foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b
313 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
314 fixRn :: (a -> RnM s d a) -> RnM s d a
316 returnRn v gdown ldown = returnSST v
317 thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown
318 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
319 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
320 andRn combiner m1 m2 gdown ldown
321 = m1 gdown ldown `thenSST` \ res1 ->
322 m2 gdown ldown `thenSST` \ res2 ->
323 returnSST (combiner res1 res2)
325 sequenceRn [] = returnRn []
326 sequenceRn (m:ms) = m `thenRn` \ r ->
327 sequenceRn ms `thenRn` \ rs ->
330 mapRn f [] = returnRn []
332 = f x `thenRn` \ r ->
333 mapRn f xs `thenRn` \ rs ->
336 foldlRn k z [] = returnRn z
337 foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
340 mapAndUnzipRn f [] = returnRn ([],[])
341 mapAndUnzipRn f (x:xs)
342 = f x `thenRn` \ (r1, r2) ->
343 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
344 returnRn (r1:rs1, r2:rs2)
346 mapAndUnzip3Rn f [] = returnRn ([],[],[])
347 mapAndUnzip3Rn f (x:xs)
348 = f x `thenRn` \ (r1, r2, r3) ->
349 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
350 returnRn (r1:rs1, r2:rs2, r3:rs3)
355 %************************************************************************
357 \subsection{Boring plumbing for common part}
359 %************************************************************************
362 ================ Errors and warnings =====================
365 failWithRn :: a -> Error -> RnM s d a
366 failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
367 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
368 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
371 err = addShortErrLocLine loc msg
373 warnWithRn :: a -> Warning -> RnM s d a
374 warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
375 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
376 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
379 warn = addShortWarnLocLine loc msg
381 addErrRn :: Error -> RnM s d ()
382 addErrRn err = failWithRn () err
384 checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true
385 checkRn False err = addErrRn err
386 checkRn True err = returnRn ()
388 addWarnRn :: Warning -> RnM s d ()
389 addWarnRn warn = warnWithRn () warn
391 checkErrsRn :: RnM s d Bool -- True <=> no errors so far
392 checkErrsRn (RnDown loc names_var errs_var occs_var) l_down
393 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
394 returnSST (isEmptyBag errs)
398 ================ Source location =====================
401 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
402 pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
403 = m (RnDown loc' names_var errs_var occs_var) l_down
405 getSrcLocRn :: RnM s d SrcLoc
406 getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
410 ================ Name supply =====================
413 getNameSupplyRn :: RnM s d RnNameSupply
414 getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
415 = readMutVarSST names_var
417 setNameSupplyRn :: RnNameSupply -> RnM s d ()
418 setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
419 = writeMutVarSST names_var names'
422 ================ Occurrences =====================
425 addOccurrenceName :: Necessity -> Name -> RnM s d ()
426 addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
427 = readMutVarSST occs_var `thenSST` \ occs ->
428 writeMutVarSST occs_var ((name,necessity) : occs)
430 addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
431 addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
432 = readMutVarSST occs_var `thenSST` \ occs ->
433 writeMutVarSST occs_var ([(name,necessity) | name <- names] ++ occs)
435 popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
436 popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
437 = readMutVarSST occs_var `thenSST` \ occs ->
439 [] -> returnSST Nothing
440 (occ:occs) -> writeMutVarSST occs_var occs `thenSST_`
443 -- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
444 -- variable, and returns the list of occurrences thus found. It's useful
445 -- when loading instance decls and specialisation signatures, when we want to
446 -- know the names of the things in the types, but we don't want to treat them
449 findOccurrencesRn :: RnM s d a -> RnM s d [Name]
450 findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
451 = newMutVarSST [] `thenSST` \ new_occs_var ->
452 enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_`
453 readMutVarSST new_occs_var `thenSST` \ occs ->
454 returnSST (map fst occs)
458 %************************************************************************
460 \subsection{Plumbing for rename-source part}
462 %************************************************************************
464 ================ RnEnv =====================
467 getNameEnv :: RnMS s NameEnv
468 getNameEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
471 setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
472 setNameEnv name_env' m rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
473 = m rn_down (SDown (RnEnv name_env' fixity_env) mod_name mode)
475 getFixityEnv :: RnMS s FixityEnv
476 getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
477 = returnSST fixity_env
479 setRnEnv :: RnEnv -> RnMS s a -> RnMS s a
480 setRnEnv rn_env' m rn_down (SDown rn_env mod_name mode)
481 = m rn_down (SDown rn_env' mod_name mode)
484 ================ Module and Mode =====================
487 getModuleRn :: RnMS s Module
488 getModuleRn rn_down (SDown rn_env mod_name mode)
493 getModeRn :: RnMS s RnSMode
494 getModeRn rn_down (SDown rn_env mod_name mode)
499 %************************************************************************
501 \subsection{Plumbing for rename-globals part}
503 %************************************************************************
506 getIfacesRn :: RnMG Ifaces
507 getIfacesRn rn_down (GDown dirs iface_var)
508 = readMutVarSST iface_var
510 setIfacesRn :: Ifaces -> RnMG ()
511 setIfacesRn ifaces rn_down (GDown dirs iface_var)
512 = writeMutVarSST iface_var ifaces
514 getSearchPathRn :: RnMG SearchPath
515 getSearchPathRn rn_down (GDown dirs iface_var)