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