ghc/compiler/rename/RnMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
   3 %
   4 \section[RnMonad]{The monad used by the renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnMonad(
  10         EXP_MODULE(RnMonad),
  11          -- close it up (partly done to allow unfoldings)
  12         EXP_MODULE(SST),
  13         SYN_IE(Module),
  14         FiniteMap,
  15         Bag,
  16         Name,
  17         SYN_IE(RdrNameHsDecl),
  18         SYN_IE(RdrNameInstDecl),
  19         SYN_IE(Version),
  20         SYN_IE(NameSet),
  21         OccName,
  22         Fixity
  23     ) where
  24
  25 IMP_Ubiq(){-uitous-}
  26
  27 import SST
  28 #if __GLASGOW_HASKELL__ <= 201
  29 import PreludeGlaST     ( SYN_IE(ST), thenStrictlyST, returnStrictlyST )
  30 #define MkIO
  31 #else
  32 import GlaExts
  33 import IO
  34 import ST
  35 import IOBase
  36 # if __GLASGOW_HASKELL__ >= 209
  37 import STBase (ST(..), STret(..) )
  38 # endif
  39 #define IOError13 IOError
  40 #define MkIO IO
  41 #endif
  42
  43 import HsSyn
  44 import RdrHsSyn
  45 import BasicTypes       ( SYN_IE(Version), NewOrData )
  46 import ErrUtils         ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
  47                           pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
  48                         )
  49 import Name             ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet,
  50                           isLocallyDefinedName,
  51                           modAndOcc, NamedThing(..)
  52                         )
  53 import CmdLineOpts      ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
  54 import PrelInfo         ( builtinNames )
  55 import TyCon            ( TyCon {- instance NamedThing -} )
  56 import TysWiredIn       ( boolTyCon )
  57 import Pretty
  58 import Outputable       ( PprStyle(..), printErrs )
  59 import SrcLoc           ( SrcLoc, mkGeneratedSrcLoc )
  60 import Unique           ( Unique )
  61 import UniqFM           ( UniqFM )
  62 import FiniteMap        ( FiniteMap, emptyFM, bagToFM )
  63 import Bag              ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
  64 import UniqSet
  65 import Util
  66 #if __GLASGOW_HASKELL__ >= 202
  67 import UniqSupply
  68 #endif
  69
  70 infixr 9 `thenRn`, `thenRn_`
  71 \end{code}
  72
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection{Somewhat magical interface to other monads}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 \begin{code}
  81 #if __GLASGOW_HASKELL__ >= 200
  82 # define REAL_WORLD RealWorld
  83 #else
  84 # define REAL_WORLD _RealWorld
  85 #endif
  86 \end{code}
  87
  88 \begin{code}
  89 sstToIO :: SST REAL_WORLD r -> IO r
  90 #if __GLASGOW_HASKELL__ < 209
  91 sstToIO sst =
  92     MkIO (
  93     sstToST sst         `thenStrictlyST` \ r ->
  94     returnStrictlyST (Right r))
  95 #else
  96 sstToIO sst =
  97     IO (\ s ->
  98       let (ST st_act) = sstToST sst in
  99       case st_act s of
 100        STret s' v -> IOok s' v)
 101 #endif
 102
 103 ioToRnMG :: IO r -> RnMG (Either IOError13 r)
 104 #if __GLASGOW_HASKELL__ < 209
 105 ioToRnMG (MkIO io) rn_down g_down = stToSST io
 106 #else
 107 ioToRnMG (IO io) rn_down g_down
 108   = stToSST (ST io')
 109     where
 110      io' st =
 111       case io st of
 112        IOok   st' v -> STret st' (Right v)
 113        IOfail st' e -> STret st' (Left e)
 114 #endif
 115
 116 traceRn :: Doc -> RnMG ()
 117 traceRn msg | opt_D_show_rn_trace = putDocRn msg
 118             | otherwise           = returnRn ()
 119
 120 putDocRn :: Doc -> RnMG ()
 121 putDocRn msg = ioToRnMG (printErrs msg) `thenRn_`
 122                returnRn ()
 123 \end{code}
 124
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection{Data types}
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 ===================================================
 133                 MONAD TYPES
 134 ===================================================
 135
 136 \begin{code}
 137 type RnM s d r = RnDown s -> d -> SST s r
 138 type RnMS s r   = RnM s          (SDown s) r            -- Renaming source
 139 type RnMG r     = RnM REAL_WORLD GDown     r            -- Getting global names etc
 140 type MutVar a  = MutableVar REAL_WORLD a                -- ToDo: there ought to be a standard defn of this
 141
 142         -- Common part
 143 data RnDown s = RnDown
 144                   SrcLoc
 145                   (MutableVar s RnNameSupply)
 146                   (MutableVar s (Bag Warning, Bag Error))
 147                   (MutableVar s ([Name],[Name]))        -- Occurrences: compulsory and optional resp
 148
 149 data Necessity = Compulsory | Optional          -- We *must* find definitions for
 150                                                 -- compulsory occurrences; we *may* find them
 151                                                 -- for optional ones.
 152
 153         -- For getting global names
 154 data GDown = GDown
 155                 SearchPath
 156                 (MutVar Ifaces)
 157
 158         -- For renaming source code
 159 data SDown s = SDown
 160                   RnEnv                 -- Global envt
 161                   NameEnv               -- Local name envt (includes global name envt,
 162                                         -- but may shadow it)
 163                   Module
 164                   RnSMode
 165
 166
 167 data RnSMode    = SourceMode                    -- Renaming source code
 168                 | InterfaceMode Necessity       -- Renaming interface declarations.  The "necessity"
 169                                                 -- flag says free variables *must* be found and slurped
 170                                                 -- or whether they need not be.  For value signatures of
 171                                                 -- things that are themselves compulsorily imported
 172                                                 -- we arrange that the type signature is read in compulsory mode,
 173                                                 -- but the pragmas in optional mode.
 174
 175 type SearchPath = [(String,String)]     -- List of (directory,suffix) pairs to search
 176                                         -- for interface files.
 177 type FreeVars   = NameSet
 178 \end{code}
 179
 180 ===================================================
 181                 ENVIRONMENTS
 182 ===================================================
 183
 184 \begin{code}
 185 type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
 186         -- Ensures that one (m,n) pair gets one unique
 187         -- The Int is used to give a number to each instance declaration;
 188         -- it's really a separate name supply.
 189
 190 data RnEnv      = RnEnv NameEnv FixityEnv
 191 emptyRnEnv      = RnEnv emptyNameEnv emptyFixityEnv
 192
 193 type NameEnv    = FiniteMap RdrName Name
 194 emptyNameEnv    = emptyFM
 195
 196 type FixityEnv          = FiniteMap RdrName (Fixity, Provenance)
 197 emptyFixityEnv          = emptyFM
 198         -- It's possible to have a different fixity for B.op than for op:
 199         --
 200         --      module A( op ) where            module B where
 201         --      import qualified B( op )        infixr 2 op
 202         --      infixl 9 `op`                   op = ...
 203         --      op a b = a `B.op` b
 204
 205 data ExportEnv          = ExportEnv Avails Fixities
 206 type Avails             = [AvailInfo]
 207 type Fixities           = [(OccName, (Fixity, Provenance))]
 208         -- Can contain duplicates, if one module defines the same fixity,
 209         -- or the same type/class/id, more than once.   Hence a boring old list.
 210         -- This allows us to report duplicates in just one place, namely plusRnEnv.
 211
 212 type ExportAvails       = (FiniteMap Module Avails,     -- Used to figure out "module M" export specifiers
 213                                                         -- Includes avails only from *unqualified* imports
 214                                                         -- (see 1.4 Report Section 5.1.1)
 215
 216                            UniqFM AvailInfo)            -- Used to figure out all other export specifiers.
 217                                                         -- Maps a Name to the AvailInfo that contains it
 218                                                         -- NB: Contain bindings for class ops but
 219                                                         -- not constructors (see defn of availEntityNames)
 220
 221
 222 data GenAvailInfo name  = NotAvailable
 223                         | Avail name            -- An ordinary identifier
 224                         | AvailTC name          -- The name of the type or class
 225                                   [name]        -- The available pieces of type/class. NB: If the type or
 226                                                 -- class is itself to be in scope, it must be in this list.
 227                                                 -- Thus, typically: AvailTC Eq [Eq, ==, /=]
 228 type AvailInfo    = GenAvailInfo Name
 229 type RdrAvailInfo = GenAvailInfo OccName
 230 \end{code}
 231
 232 ===================================================
 233                 INTERFACE FILE STUFF
 234 ===================================================
 235
 236 \begin{code}
 237 type ExportItem          = (Module, IfaceFlavour, [RdrAvailInfo])
 238 type VersionInfo name    = [ImportVersion name]
 239 type ImportVersion name  = (Module, IfaceFlavour, Version, [LocalVersion name])
 240 type LocalVersion name   = (name, Version)
 241
 242 data ParsedIface
 243   = ParsedIface
 244       Module                    -- Module name
 245       Version                   -- Module version number
 246       [ImportVersion OccName]           -- Usages
 247       [ExportItem]                      -- Exports
 248       [Module]                          -- Special instance modules
 249       [(OccName,Fixity)]                -- Fixities
 250       [(Version, RdrNameHsDecl)]        -- Local definitions
 251       [RdrNameInstDecl]                 -- Local instance declarations
 252
 253 type InterfaceDetails = (VersionInfo Name,      -- Version information
 254                          ExportEnv,             -- What this module exports
 255                          [Module])              -- Instance modules
 256
 257 type RdrNamePragma = ()                         -- Fudge for now
 258 -------------------
 259
 260 data Ifaces = Ifaces
 261                 Module                                          -- Name of this module
 262                 (FiniteMap Module (IfaceFlavour,                -- Exports
 263                                    Version,
 264                                    Avails,
 265                                    [(OccName,Fixity)]))
 266                 DeclsMap
 267
 268                 NameSet                 -- All the names (whether "big" or "small", whether wired-in or not,
 269                                         -- whether locally defined or not) that have been slurped in so far.
 270
 271                 [(Name,Version)]        -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
 272                                         -- have been slurped in so far, with their versions.
 273                                         -- This is used to generate the "usage" information for this module.
 274                                         -- Subset of the previous field.
 275
 276                 (Bag IfaceInst, NameSet) -- The as-yet un-slurped instance decls; this bag is depleted when we
 277                                          -- slurp an instance decl so that we don't slurp the same one twice.
 278                                          -- Together with them is the set of tycons/classes that may allow
 279                                          -- the instance decls in.
 280
 281                 (FiniteMap Name RdrNameTyDecl)
 282                                         -- Deferred data type declarations; each has the following properties
 283                                         --      * it's a data type decl
 284                                         --      * its TyCon is needed
 285                                         --      * the decl may or may not have been slurped, depending on whether any
 286                                         --        of the constrs are needed.
 287
 288                 [Module]                -- Set of modules with "special" instance declarations
 289                                         -- Excludes this module
 290
 291
 292 type DeclsMap    = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
 293 type IfaceInst   = ((Module, RdrNameInstDecl),  -- Instance decl
 294                     [Name])                     -- "Gate" names.  Slurp this instance decl when this
 295                                                 -- list becomes empty.  It's depleted whenever we
 296                                                 -- slurp another type or class decl.
 297 \end{code}
 298
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection{Main monad code}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 \begin{code}
 307 initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
 308        -> RnMG r
 309        -> IO (r, Bag Error, Bag Warning)
 310
 311 initRn mod us dirs loc do_rn
 312   = sstToIO $
 313     newMutVarSST (us, 1, builtins)      `thenSST` \ names_var ->
 314     newMutVarSST (emptyBag,emptyBag)    `thenSST` \ errs_var ->
 315     newMutVarSST (emptyIfaces mod)      `thenSST` \ iface_var ->
 316     newMutVarSST initOccs               `thenSST` \ occs_var ->
 317     let
 318         rn_down = RnDown loc names_var errs_var occs_var
 319         g_down  = GDown dirs iface_var
 320     in
 321         -- do the buisness
 322     do_rn rn_down g_down                `thenSST` \ res ->
 323
 324         -- grab errors and return
 325     readMutVarSST errs_var                      `thenSST` \ (warns,errs) ->
 326     returnSST (res, errs, warns)
 327
 328
 329 initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
 330 initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
 331   = let
 332         s_down = SDown rn_env name_env mod_name mode
 333     in
 334     m rn_down s_down
 335
 336
 337 emptyIfaces :: Module -> Ifaces
 338 emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
 339
 340 builtins :: FiniteMap (Module,OccName) Name
 341 builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
 342
 343         -- Initial value for the occurrence pool.
 344 initOccs :: ([Name],[Name])     -- Compulsory and optional respectively
 345 initOccs = ([getName boolTyCon], [])
 346         -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
 347         -- rather implausible that not one will be used in the module.
 348         -- We could add some other common types, notably lists, but the general idea is
 349         -- to do as much as possible explicitly.
 350 \end{code}
 351
 352 \end{code}
 353
 354
 355 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
 356 the main renamer.  Examples: pragmas (which we don't want to rename unless
 357 we actually explore them); and derived definitions, which are only generated
 358 in the type checker.
 359
 360 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
 361 once you must either split it, or install a fresh unique supply.
 362
 363 \begin{code}
 364 renameSourceCode :: Module
 365                  -> RnNameSupply
 366                  -> RnMS REAL_WORLD r
 367                  -> r
 368
 369 -- Alas, we can't use the real runST, with the desired signature:
 370 --      renameSourceCode :: RnNameSupply -> RnMS s r -> r
 371 -- because we can't manufacture "new versions of runST".
 372
 373 renameSourceCode mod_name name_supply m
 374   = runSST (
 375         newMutVarSST name_supply                `thenSST` \ names_var ->
 376         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ errs_var ->
 377         newMutVarSST ([],[])                    `thenSST` \ occs_var ->
 378         let
 379             rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
 380             s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory)
 381         in
 382         m rn_down s_down                        `thenSST` \ result ->
 383
 384         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 385
 386         (if not (isEmptyBag errs) then
 387                 trace ("Urk! renameSourceCode found errors" ++ display errs)
 388          else if not (isEmptyBag warns) then
 389                 trace ("Urk! renameSourceCode found warnings" ++ display warns)
 390          else
 391                 id) $
 392
 393         returnSST result
 394     )
 395   where
 396     display errs = show (pprBagOfErrors PprDebug errs)
 397
 398 {-# INLINE thenRn #-}
 399 {-# INLINE thenRn_ #-}
 400 {-# INLINE returnRn #-}
 401 {-# INLINE andRn #-}
 402
 403 returnRn :: a -> RnM s d a
 404 thenRn   :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
 405 thenRn_  :: RnM s d a -> RnM s d b -> RnM s d b
 406 andRn    :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
 407 mapRn    :: (a -> RnM s d b) -> [a] -> RnM s d [b]
 408 sequenceRn :: [RnM s d a] -> RnM s d [a]
 409 foldlRn :: (b  -> a -> RnM s d b) -> b -> [a] -> RnM s d b
 410 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
 411 fixRn    :: (a -> RnM s d a) -> RnM s d a
 412
 413 returnRn v gdown ldown  = returnSST v
 414 thenRn m k gdown ldown  = m gdown ldown `thenSST` \ r -> k r gdown ldown
 415 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
 416 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
 417 andRn combiner m1 m2 gdown ldown
 418   = m1 gdown ldown `thenSST` \ res1 ->
 419     m2 gdown ldown `thenSST` \ res2 ->
 420     returnSST (combiner res1 res2)
 421
 422 sequenceRn []     = returnRn []
 423 sequenceRn (m:ms) =  m                  `thenRn` \ r ->
 424                      sequenceRn ms      `thenRn` \ rs ->
 425                      returnRn (r:rs)
 426
 427 mapRn f []     = returnRn []
 428 mapRn f (x:xs)
 429   = f x         `thenRn` \ r ->
 430     mapRn f xs  `thenRn` \ rs ->
 431     returnRn (r:rs)
 432
 433 foldlRn k z [] = returnRn z
 434 foldlRn k z (x:xs) = k z x      `thenRn` \ z' ->
 435                      foldlRn k z' xs
 436
 437 mapAndUnzipRn f [] = returnRn ([],[])
 438 mapAndUnzipRn f (x:xs)
 439   = f x                 `thenRn` \ (r1,  r2)  ->
 440     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 441     returnRn (r1:rs1, r2:rs2)
 442
 443 mapAndUnzip3Rn f [] = returnRn ([],[],[])
 444 mapAndUnzip3Rn f (x:xs)
 445   = f x                 `thenRn` \ (r1,  r2,  r3)  ->
 446     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
 447     returnRn (r1:rs1, r2:rs2, r3:rs3)
 448 \end{code}
 449
 450
 451
 452 %************************************************************************
 453 %*                                                                      *
 454 \subsection{Boring plumbing for common part}
 455 %*                                                                      *
 456 %************************************************************************
 457
 458
 459 ================  Errors and warnings =====================
 460
 461 \begin{code}
 462 failWithRn :: a -> Error -> RnM s d a
 463 failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
 464   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 465     writeMutVarSST errs_var (warns, errs `snocBag` err)         `thenSST_`
 466     returnSST res
 467   where
 468     err = addShortErrLocLine loc msg
 469
 470 warnWithRn :: a -> Warning -> RnM s d a
 471 warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
 472   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 473     writeMutVarSST errs_var (warns `snocBag` warn, errs)        `thenSST_`
 474     returnSST res
 475   where
 476     warn = addShortWarnLocLine loc msg
 477
 478 addErrRn :: Error -> RnM s d ()
 479 addErrRn err = failWithRn () err
 480
 481 checkRn :: Bool -> Error -> RnM s d ()  -- Check that a condition is true
 482 checkRn False err  = addErrRn err
 483 checkRn True err = returnRn ()
 484
 485 addWarnRn :: Warning -> RnM s d ()
 486 addWarnRn warn = warnWithRn () warn
 487
 488 checkErrsRn :: RnM s d Bool             -- True <=> no errors so far
 489 checkErrsRn  (RnDown loc names_var errs_var occs_var) l_down
 490   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 491     returnSST (isEmptyBag errs)
 492 \end{code}
 493
 494
 495 ================  Source location =====================
 496
 497 \begin{code}
 498 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
 499 pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
 500   = m (RnDown loc' names_var errs_var occs_var) l_down
 501
 502 getSrcLocRn :: RnM s d SrcLoc
 503 getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
 504   = returnSST loc
 505 \end{code}
 506
 507 ================  Name supply =====================
 508
 509 \begin{code}
 510 getNameSupplyRn :: RnM s d RnNameSupply
 511 getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
 512   = readMutVarSST names_var
 513
 514 setNameSupplyRn :: RnNameSupply -> RnM s d ()
 515 setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
 516   = writeMutVarSST names_var names'
 517
 518 -- The "instance-decl unique supply", inst, is just an integer that's used to
 519 -- give a unique number for each instance declaration.
 520 newInstUniq :: RnM s d Int
 521 newInstUniq (RnDown loc names_var errs_var occs_var) l_down
 522   = readMutVarSST names_var                             `thenSST` \ (us, inst, cache) ->
 523     writeMutVarSST names_var (us, inst+1, cache)        `thenSST_`
 524     returnSST inst
 525 \end{code}
 526
 527 ================  Occurrences =====================
 528
 529 Every time we get an occurrence of a name we put it in one of two lists:
 530         one for "compulsory" occurrences
 531         one for "optional" occurrences
 532
 533 The significance of "compulsory" is
 534         (a) we *must* find the declaration
 535         (b) in the case of type or class names, the name is part of the
 536             source level program, and we must slurp in any instance decls
 537             involving it.
 538
 539 We don't need instance decls "optional" names, because the type inference
 540 process will never come across them.  Optional names are buried inside
 541 type checked (but not renamed) cross-module unfoldings and such.
 542
 543 The pair of lists is held in a mutable variable in RnDown.
 544
 545 The lists are kept separate so that we can process all the compulsory occurrences
 546 before any of the optional ones.  Why?  Because suppose we processed an optional
 547 "g", and slurped an interface decl of g::T->T.  Then we'd rename the type T->T in
 548 optional mode.  But if we later need g compulsorily we'll find that it's already
 549 been slurped and will do nothing.  We could, I suppose, rename it a second time,
 550 but it seems simpler just to do all the compulsory ones first.
 551
 552 \begin{code}
 553 addOccurrenceName :: Name -> RnMS s Name        -- Same name returned as passed
 554 addOccurrenceName name (RnDown loc names_var errs_var occs_var)
 555                        (SDown rn_env local_env mod_name mode)
 556   | isLocallyDefinedName name ||
 557     not_necessary necessity
 558   = returnSST name
 559
 560   | otherwise
 561   = readMutVarSST occs_var                      `thenSST` \ (comp_occs, opt_occs) ->
 562     let
 563         new_occ_pair = case necessity of
 564                          Optional   -> (comp_occs, name:opt_occs)
 565                          Compulsory -> (name:comp_occs, opt_occs)
 566     in
 567     writeMutVarSST occs_var new_occ_pair        `thenSST_`
 568     returnSST name
 569   where
 570     necessity = case mode of
 571                   SourceMode              -> Compulsory
 572                   InterfaceMode necessity -> necessity
 573
 574
 575 addOccurrenceNames :: [Name] -> RnMS s ()
 576 addOccurrenceNames names (RnDown loc names_var errs_var occs_var)
 577                          (SDown rn_env local_env mod_name mode)
 578   | not_necessary necessity
 579   = returnSST ()
 580
 581   | otherwise
 582   = readMutVarSST occs_var                      `thenSST` \ (comp_occs, opt_occs) ->
 583     let
 584         new_occ_pair = case necessity of
 585                          Optional   -> (comp_occs, non_local_names ++ opt_occs)
 586                          Compulsory -> (non_local_names ++ comp_occs, opt_occs)
 587     in
 588     writeMutVarSST occs_var new_occ_pair
 589   where
 590     non_local_names = filter (not . isLocallyDefinedName) names
 591     necessity = case mode of
 592                   SourceMode              -> Compulsory
 593                   InterfaceMode necessity -> necessity
 594
 595         -- Never look for optional things if we're
 596         -- ignoring optional input interface information
 597 not_necessary Compulsory = False
 598 not_necessary Optional   = opt_IgnoreIfacePragmas
 599
 600 popOccurrenceName :: Necessity -> RnM s d (Maybe Name)
 601 popOccurrenceName necessity (RnDown loc names_var errs_var occs_var) l_down
 602   = readMutVarSST occs_var                      `thenSST` \ occs ->
 603     case (necessity, occs) of
 604                 -- Find a compulsory occurrence
 605         (Compulsory, (comp:comps, opts)) -> writeMutVarSST occs_var (comps, opts)       `thenSST_`
 606                                             returnSST (Just comp)
 607
 608                 -- Find an optional occurrence
 609                 -- We shouldn't be looking unless we've done all the compulsories
 610         (Optional, (comps, opt:opts)) -> ASSERT( null comps )
 611                                          writeMutVarSST occs_var (comps, opts)  `thenSST_`
 612                                          returnSST (Just opt)
 613
 614                 -- No suitable occurrence
 615         other -> returnSST Nothing
 616
 617 -- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
 618 -- variable, and returns the list of occurrences thus found.  It's useful
 619 -- when loading instance decls and specialisation signatures, when we want to
 620 -- know the names of the things in the types, but we don't want to treat them
 621 -- as occurrences.
 622
 623 findOccurrencesRn :: RnM s d a -> RnM s d [Name]
 624 findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
 625   = newMutVarSST ([],[])                                                `thenSST` \ new_occs_var ->
 626     enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down  `thenSST_`
 627     readMutVarSST new_occs_var                                          `thenSST` \ (occs,_) ->
 628     returnSST occs
 629 \end{code}
 630
 631
 632 %************************************************************************
 633 %*                                                                      *
 634 \subsection{Plumbing for rename-source part}
 635 %*                                                                      *
 636 %************************************************************************
 637
 638 ================  RnEnv  =====================
 639
 640 \begin{code}
 641 getGlobalNameEnv :: RnMS s NameEnv
 642 getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
 643   = returnSST global_env
 644
 645 getNameEnv :: RnMS s NameEnv
 646 getNameEnv rn_down (SDown rn_env local_env mod_name mode)
 647   = returnSST local_env
 648
 649 setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
 650 setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
 651   = m rn_down (SDown rn_env local_env' mod_name mode)
 652
 653 getFixityEnv :: RnMS s FixityEnv
 654 getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
 655   = returnSST fixity_env
 656 \end{code}
 657
 658 ================  Module and Mode =====================
 659
 660 \begin{code}
 661 getModuleRn :: RnMS s Module
 662 getModuleRn rn_down (SDown rn_env local_env mod_name mode)
 663   = returnSST mod_name
 664 \end{code}
 665
 666 \begin{code}
 667 getModeRn :: RnMS s RnSMode
 668 getModeRn rn_down (SDown rn_env local_env mod_name mode)
 669   = returnSST mode
 670
 671 setModeRn :: RnSMode -> RnMS s a -> RnMS s a
 672 setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode)
 673   = thing_inside rn_down (SDown rn_env local_env mod_name new_mode)
 674 \end{code}
 675
 676
 677 %************************************************************************
 678 %*                                                                      *
 679 \subsection{Plumbing for rename-globals part}
 680 %*                                                                      *
 681 %************************************************************************
 682
 683 \begin{code}
 684 getIfacesRn :: RnMG Ifaces
 685 getIfacesRn rn_down (GDown dirs iface_var)
 686   = readMutVarSST iface_var
 687
 688 setIfacesRn :: Ifaces -> RnMG ()
 689 setIfacesRn ifaces rn_down (GDown dirs iface_var)
 690   = writeMutVarSST iface_var ifaces
 691
 692 getSearchPathRn :: RnMG SearchPath
 693 getSearchPathRn rn_down (GDown dirs iface_var)
 694   = returnSST dirs
 695 \end{code}