ghc/compiler/rename/RnMonad.lhs

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