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