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 mapMaybeRn :: (a -> RnM s d b) -> b -> Maybe a -> RnM s d b
 409 sequenceRn :: [RnM s d a] -> RnM s d [a]
 410 foldlRn :: (b  -> a -> RnM s d b) -> b -> [a] -> RnM s d b
 411 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
 412 fixRn    :: (a -> RnM s d a) -> RnM s d a
 413
 414 returnRn v gdown ldown  = returnSST v
 415 thenRn m k gdown ldown  = m gdown ldown `thenSST` \ r -> k r gdown ldown
 416 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
 417 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
 418 andRn combiner m1 m2 gdown ldown
 419   = m1 gdown ldown `thenSST` \ res1 ->
 420     m2 gdown ldown `thenSST` \ res2 ->
 421     returnSST (combiner res1 res2)
 422
 423 sequenceRn []     = returnRn []
 424 sequenceRn (m:ms) =  m                  `thenRn` \ r ->
 425                      sequenceRn ms      `thenRn` \ rs ->
 426                      returnRn (r:rs)
 427
 428 mapRn f []     = returnRn []
 429 mapRn f (x:xs)
 430   = f x         `thenRn` \ r ->
 431     mapRn f xs  `thenRn` \ rs ->
 432     returnRn (r:rs)
 433
 434 foldlRn k z [] = returnRn z
 435 foldlRn k z (x:xs) = k z x      `thenRn` \ z' ->
 436                      foldlRn k z' xs
 437
 438 mapAndUnzipRn f [] = returnRn ([],[])
 439 mapAndUnzipRn f (x:xs)
 440   = f x                 `thenRn` \ (r1,  r2)  ->
 441     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 442     returnRn (r1:rs1, r2:rs2)
 443
 444 mapAndUnzip3Rn f [] = returnRn ([],[],[])
 445 mapAndUnzip3Rn f (x:xs)
 446   = f x                 `thenRn` \ (r1,  r2,  r3)  ->
 447     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
 448     returnRn (r1:rs1, r2:rs2, r3:rs3)
 449
 450 mapMaybeRn f def Nothing  = returnRn def
 451 mapMaybeRn f def (Just v) = f v
 452 \end{code}
 453
 454
 455
 456 %************************************************************************
 457 %*                                                                      *
 458 \subsection{Boring plumbing for common part}
 459 %*                                                                      *
 460 %************************************************************************
 461
 462
 463 ================  Errors and warnings =====================
 464
 465 \begin{code}
 466 failWithRn :: a -> Error -> RnM s d a
 467 failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
 468   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 469     writeMutVarSST errs_var (warns, errs `snocBag` err)         `thenSST_`
 470     returnSST res
 471   where
 472     err = addShortErrLocLine loc msg
 473
 474 warnWithRn :: a -> Warning -> RnM s d a
 475 warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
 476   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 477     writeMutVarSST errs_var (warns `snocBag` warn, errs)        `thenSST_`
 478     returnSST res
 479   where
 480     warn = addShortWarnLocLine loc msg
 481
 482 addErrRn :: Error -> RnM s d ()
 483 addErrRn err = failWithRn () err
 484
 485 checkRn :: Bool -> Error -> RnM s d ()  -- Check that a condition is true
 486 checkRn False err  = addErrRn err
 487 checkRn True err = returnRn ()
 488
 489 addWarnRn :: Warning -> RnM s d ()
 490 addWarnRn warn = warnWithRn () warn
 491
 492 checkErrsRn :: RnM s d Bool             -- True <=> no errors so far
 493 checkErrsRn  (RnDown loc names_var errs_var occs_var) l_down
 494   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 495     returnSST (isEmptyBag errs)
 496 \end{code}
 497
 498
 499 ================  Source location =====================
 500
 501 \begin{code}
 502 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
 503 pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
 504   = m (RnDown loc' names_var errs_var occs_var) l_down
 505
 506 getSrcLocRn :: RnM s d SrcLoc
 507 getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
 508   = returnSST loc
 509 \end{code}
 510
 511 ================  Name supply =====================
 512
 513 \begin{code}
 514 getNameSupplyRn :: RnM s d RnNameSupply
 515 getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
 516   = readMutVarSST names_var
 517
 518 setNameSupplyRn :: RnNameSupply -> RnM s d ()
 519 setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
 520   = writeMutVarSST names_var names'
 521
 522 -- The "instance-decl unique supply", inst, is just an integer that's used to
 523 -- give a unique number for each instance declaration.
 524 newInstUniq :: RnM s d Int
 525 newInstUniq (RnDown loc names_var errs_var occs_var) l_down
 526   = readMutVarSST names_var                             `thenSST` \ (us, inst, cache) ->
 527     writeMutVarSST names_var (us, inst+1, cache)        `thenSST_`
 528     returnSST inst
 529 \end{code}
 530
 531 ================  Occurrences =====================
 532
 533 Every time we get an occurrence of a name we put it in one of two lists:
 534         one for "compulsory" occurrences
 535         one for "optional" occurrences
 536
 537 The significance of "compulsory" is
 538         (a) we *must* find the declaration
 539         (b) in the case of type or class names, the name is part of the
 540             source level program, and we must slurp in any instance decls
 541             involving it.
 542
 543 We don't need instance decls "optional" names, because the type inference
 544 process will never come across them.  Optional names are buried inside
 545 type checked (but not renamed) cross-module unfoldings and such.
 546
 547 The pair of lists is held in a mutable variable in RnDown.
 548
 549 The lists are kept separate so that we can process all the compulsory occurrences
 550 before any of the optional ones.  Why?  Because suppose we processed an optional
 551 "g", and slurped an interface decl of g::T->T.  Then we'd rename the type T->T in
 552 optional mode.  But if we later need g compulsorily we'll find that it's already
 553 been slurped and will do nothing.  We could, I suppose, rename it a second time,
 554 but it seems simpler just to do all the compulsory ones first.
 555
 556 \begin{code}
 557 addOccurrenceName :: Name -> RnMS s Name        -- Same name returned as passed
 558 addOccurrenceName name (RnDown loc names_var errs_var occs_var)
 559                        (SDown rn_env local_env mod_name mode)
 560   | isLocallyDefinedName name ||
 561     not_necessary necessity
 562   = returnSST name
 563
 564   | otherwise
 565   = readMutVarSST occs_var                      `thenSST` \ (comp_occs, opt_occs) ->
 566     let
 567         new_occ_pair = case necessity of
 568                          Optional   -> (comp_occs, name:opt_occs)
 569                          Compulsory -> (name:comp_occs, opt_occs)
 570     in
 571     writeMutVarSST occs_var new_occ_pair        `thenSST_`
 572     returnSST name
 573   where
 574     necessity = case mode of
 575                   SourceMode              -> Compulsory
 576                   InterfaceMode necessity -> necessity
 577
 578
 579 addOccurrenceNames :: [Name] -> RnMS s ()
 580 addOccurrenceNames names (RnDown loc names_var errs_var occs_var)
 581                          (SDown rn_env local_env mod_name mode)
 582   | not_necessary necessity
 583   = returnSST ()
 584
 585   | otherwise
 586   = readMutVarSST occs_var                      `thenSST` \ (comp_occs, opt_occs) ->
 587     let
 588         new_occ_pair = case necessity of
 589                          Optional   -> (comp_occs, non_local_names ++ opt_occs)
 590                          Compulsory -> (non_local_names ++ comp_occs, opt_occs)
 591     in
 592     writeMutVarSST occs_var new_occ_pair
 593   where
 594     non_local_names = filter (not . isLocallyDefinedName) names
 595     necessity = case mode of
 596                   SourceMode              -> Compulsory
 597                   InterfaceMode necessity -> necessity
 598
 599         -- Never look for optional things if we're
 600         -- ignoring optional input interface information
 601 not_necessary Compulsory = False
 602 not_necessary Optional   = opt_IgnoreIfacePragmas
 603
 604 popOccurrenceName :: Necessity -> RnM s d (Maybe Name)
 605 popOccurrenceName necessity (RnDown loc names_var errs_var occs_var) l_down
 606   = readMutVarSST occs_var                      `thenSST` \ occs ->
 607     case (necessity, occs) of
 608                 -- Find a compulsory occurrence
 609         (Compulsory, (comp:comps, opts)) -> writeMutVarSST occs_var (comps, opts)       `thenSST_`
 610                                             returnSST (Just comp)
 611
 612                 -- Find an optional occurrence
 613                 -- We shouldn't be looking unless we've done all the compulsories
 614         (Optional, (comps, opt:opts)) -> ASSERT( null comps )
 615                                          writeMutVarSST occs_var (comps, opts)  `thenSST_`
 616                                          returnSST (Just opt)
 617
 618                 -- No suitable occurrence
 619         other -> returnSST Nothing
 620
 621 -- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
 622 -- variable, and returns the list of occurrences thus found.  It's useful
 623 -- when loading instance decls and specialisation signatures, when we want to
 624 -- know the names of the things in the types, but we don't want to treat them
 625 -- as occurrences.
 626
 627 findOccurrencesRn :: RnM s d a -> RnM s d [Name]
 628 findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
 629   = newMutVarSST ([],[])                                                `thenSST` \ new_occs_var ->
 630     enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down  `thenSST_`
 631     readMutVarSST new_occs_var                                          `thenSST` \ (occs,_) ->
 632     returnSST occs
 633 \end{code}
 634
 635
 636 %************************************************************************
 637 %*                                                                      *
 638 \subsection{Plumbing for rename-source part}
 639 %*                                                                      *
 640 %************************************************************************
 641
 642 ================  RnEnv  =====================
 643
 644 \begin{code}
 645 getGlobalNameEnv :: RnMS s NameEnv
 646 getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
 647   = returnSST global_env
 648
 649 getNameEnv :: RnMS s NameEnv
 650 getNameEnv rn_down (SDown rn_env local_env mod_name mode)
 651   = returnSST local_env
 652
 653 setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
 654 setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
 655   = m rn_down (SDown rn_env local_env' mod_name mode)
 656
 657 getFixityEnv :: RnMS s FixityEnv
 658 getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
 659   = returnSST fixity_env
 660 \end{code}
 661
 662 ================  Module and Mode =====================
 663
 664 \begin{code}
 665 getModuleRn :: RnMS s Module
 666 getModuleRn rn_down (SDown rn_env local_env mod_name mode)
 667   = returnSST mod_name
 668 \end{code}
 669
 670 \begin{code}
 671 getModeRn :: RnMS s RnSMode
 672 getModeRn rn_down (SDown rn_env local_env mod_name mode)
 673   = returnSST mode
 674
 675 setModeRn :: RnSMode -> RnMS s a -> RnMS s a
 676 setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode)
 677   = thing_inside rn_down (SDown rn_env local_env mod_name new_mode)
 678 \end{code}
 679
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection{Plumbing for rename-globals part}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 \begin{code}
 688 getIfacesRn :: RnMG Ifaces
 689 getIfacesRn rn_down (GDown dirs iface_var)
 690   = readMutVarSST iface_var
 691
 692 setIfacesRn :: Ifaces -> RnMG ()
 693 setIfacesRn ifaces rn_down (GDown dirs iface_var)
 694   = writeMutVarSST iface_var ifaces
 695
 696 getSearchPathRn :: RnMG SearchPath
 697 getSearchPathRn rn_down (GDown dirs iface_var)
 698   = returnSST dirs
 699 \end{code}