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