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