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