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