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