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