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
  10         module RdrName,         -- Re-exports
  11         module Name,            -- from these two
  12
  13         Module,
  14         FiniteMap,
  15         Bag,
  16         RdrNameHsDecl,
  17         RdrNameInstDecl,
  18         Version,
  19         NameSet,
  20         OccName,
  21         Fixity
  22     ) where
  23
  24 #include "HsVersions.h"
  25
  26 import HsSyn
  27 import RdrHsSyn
  28 import RnHsSyn          ( RenamedFixitySig )
  29 import HscTypes         ( AvailEnv, emptyAvailEnv, lookupType,
  30                           NameSupply(..),
  31                           ImportedModuleInfo, WhetherHasOrphans, ImportVersion,
  32                           PersistentRenamerState(..),  RdrExportItem,
  33                           DeclsMap, IfaceInsts, IfaceRules,
  34                           HomeSymbolTable, TyThing,
  35                           PersistentCompilerState(..), GlobalRdrEnv,
  36                           LocalRdrEnv,
  37                           HomeIfaceTable, PackageIfaceTable )
  38 import BasicTypes       ( Version, defaultFixity,
  39                           Fixity(..), FixityDirection(..) )
  40 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine,
  41                           Message, Messages, errorsFound, warningsFound,
  42                           printErrorsAndWarnings
  43                         )
  44 import RdrName          ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
  45                           RdrNameEnv, emptyRdrEnv, extendRdrEnv,
  46                           addListToRdrEnv, rdrEnvToList, rdrEnvElts
  47                         )
  48 import Id               ( idName )
  49 import MkId             ( seqId )
  50 import Name             ( Name, OccName, NamedThing(..),
  51                           nameOccName, nameRdrName,
  52                           decode, mkLocalName, mkKnownKeyGlobal
  53                         )
  54 import NameEnv          ( NameEnv, lookupNameEnv, emptyNameEnv,
  55                           extendNameEnvList )
  56 import Module           ( Module, ModuleName, ModuleSet, emptyModuleSet,
  57                           PackageName, preludePackage )
  58 import PrelInfo         ( ghcPrimExports,
  59                           cCallableClassDecl, cReturnableClassDecl, assertDecl )
  60 import PrelNames        ( mkUnboundName, gHC_PRIM_Name )
  61 import NameSet
  62 import CmdLineOpts      ( DynFlags, DynFlag(..), dopt )
  63 import SrcLoc           ( SrcLoc, generatedSrcLoc, noSrcLoc )
  64 import Unique           ( Unique )
  65 import FiniteMap        ( FiniteMap )
  66 import Maybes           ( seqMaybe )
  67 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag )
  68 import UniqSupply
  69 import Outputable
  70
  71 import IOExts           ( IORef, newIORef, readIORef, writeIORef,
  72                           fixIO, unsafePerformIO )
  73 import IO               ( hPutStr, stderr )
  74
  75 infixr 9 `thenRn`, `thenRn_`
  76 \end{code}
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection{Somewhat magical interface to other monads}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 ioToRnM :: IO r -> RnM d (Either IOError r)
  87 ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok))
  88                             `catch`
  89                             (\ err -> return (Left err))
  90
  91 ioToRnM_no_fail :: IO r -> RnM d r
  92 ioToRnM_no_fail io rn_down g_down
  93    = (io >>= \ ok -> return ok)
  94      `catch`
  95      (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!")
  96
  97 traceRn :: SDoc -> RnM d ()
  98 traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg)
  99
 100 traceHiDiffsRn :: SDoc -> RnM d ()
 101 traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg)
 102
 103 putDocRn :: SDoc -> RnM d ()
 104 putDocRn msg = ioToRnM (printErrs alwaysQualify msg)    `thenRn_`
 105                returnRn ()
 106 \end{code}
 107
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection{Data types}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 %===================================================
 116 \subsubsection{         MONAD TYPES}
 117 %===================================================
 118
 119 \begin{code}
 120 type RnM d r = RnDown -> d -> IO r
 121 type RnMS r  = RnM SDown r              -- Renaming source
 122 type RnMG r  = RnM ()    r              -- Getting global names etc
 123
 124         -- Common part
 125 data RnDown
 126   = RnDown {
 127         rn_mod     :: Module,           -- This module
 128         rn_loc     :: SrcLoc,           -- Current locn
 129
 130         rn_dflags  :: DynFlags,
 131
 132         rn_hit     :: HomeIfaceTable,
 133         rn_done    :: Name -> Maybe TyThing,    -- Tells what things (both in the
 134                                                 -- home package and other packages)
 135                                                 -- were already available (i.e. in
 136                                                 -- the relevant SymbolTable) before
 137                                                 -- compiling this module
 138                         -- The Name passed to rn_done is guaranteed to be a Global,
 139                         -- so it has a Module, so it can be looked up
 140
 141         rn_errs    :: IORef Messages,
 142         rn_ns      :: IORef NameSupply,
 143         rn_ifaces  :: IORef Ifaces
 144     }
 145
 146         -- For renaming source code
 147 data SDown = SDown {
 148                   rn_mode :: RnMode,
 149
 150                   rn_genv :: GlobalRdrEnv,      -- Top level environment
 151
 152                   rn_avails :: AvailEnv,
 153                         -- Top level AvailEnv; contains all the things that
 154                         -- are nameable in the top-level scope, regardless of
 155                         -- *how* they can be named (qualified, unqualified...)
 156                         -- It is used only to map a Class to its class ops, and
 157                         -- hence to resolve the binders in an instance decl
 158
 159                   rn_lenv :: LocalRdrEnv,       -- Local name envt
 160                         --   Does *not* include global name envt; may shadow it
 161                         --   Includes both ordinary variables and type variables;
 162                         --   they are kept distinct because tyvar have a different
 163                         --   occurrence contructor (Name.TvOcc)
 164                         -- We still need the unsullied global name env so that
 165                         --   we can look up record field names
 166
 167                   rn_fixenv :: LocalFixityEnv   -- Local fixities (for non-top-level
 168                                                 -- declarations)
 169                         -- The global fixities are held in the
 170                         -- HIT or PIT.  Why?  See the comments
 171                         -- with RnIfaces.lookupLocalFixity
 172                 }
 173
 174 data RnMode     = SourceMode            -- Renaming source code
 175                 | InterfaceMode         -- Renaming interface declarations.
 176                 | CmdLineMode           -- Renaming a command-line expression
 177
 178 isInterfaceMode InterfaceMode = True
 179 isInterfaceMode _ = False
 180
 181 isCmdLineMode CmdLineMode = True
 182 isCmdLineMode _ = False
 183 \end{code}
 184
 185 %===================================================
 186 \subsubsection{         ENVIRONMENTS}
 187 %===================================================
 188
 189 \begin{code}
 190 --------------------------------
 191 type LocalFixityEnv = NameEnv RenamedFixitySig
 192         -- We keep the whole fixity sig so that we
 193         -- can report line-number info when there is a duplicate
 194         -- fixity declaration
 195
 196 emptyLocalFixityEnv :: LocalFixityEnv
 197 emptyLocalFixityEnv = emptyNameEnv
 198
 199 lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
 200 lookupLocalFixity env name
 201   = case lookupNameEnv env name of
 202         Just (FixitySig _ fix _) -> fix
 203         Nothing                  -> defaultFixity
 204 \end{code}
 205
 206 %************************************************************************
 207 %*                                                                      *
 208 \subsection{Interface file stuff}
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 \begin{code}
 213 type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)])
 214         -- Nothing        => NoDeprecs
 215         -- Just (Left t)  => DeprecAll
 216         -- Just (Right p) => DeprecSome
 217
 218 data ParsedIface
 219   = ParsedIface {
 220       pi_mod       :: ModuleName,
 221       pi_pkg       :: PackageName,
 222       pi_vers      :: Version,                          -- Module version number
 223       pi_orphan    :: WhetherHasOrphans,                -- Whether this module has orphans
 224       pi_usages    :: [ImportVersion OccName],          -- Usages
 225       pi_exports   :: (Version, [RdrExportItem]),       -- Exports
 226       pi_decls     :: [(Version, RdrNameTyClDecl)],     -- Local definitions
 227       pi_fixity    :: [(RdrName,Fixity)],               -- Local fixity declarations,
 228       pi_insts     :: [RdrNameInstDecl],                -- Local instance declarations
 229       pi_rules     :: (Version, [RdrNameRuleDecl]),     -- Rules, with their version
 230       pi_deprecs   :: IfaceDeprecs                      -- Deprecations
 231     }
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsection{Wired-in interfaces}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 \begin{code}
 241 ghcPrimIface :: ParsedIface
 242 ghcPrimIface = ParsedIface {
 243       pi_mod     = gHC_PRIM_Name,
 244       pi_pkg     = preludePackage,
 245       pi_vers    = 1,
 246       pi_orphan  = False,
 247       pi_usages  = [],
 248       pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]),
 249       pi_decls   = [(1,cCallableClassDecl),
 250                     (1,cReturnableClassDecl),
 251                     (1,assertDecl)],
 252       pi_fixity  = [(nameRdrName (idName seqId), Fixity 0 InfixR)],
 253                 -- seq is infixr 0
 254       pi_insts   = [],
 255       pi_rules   = (1,[]),
 256       pi_deprecs = Nothing
 257  }
 258 \end{code}
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsection{The renamer state}
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 data Ifaces = Ifaces {
 268     -- PERSISTENT FIELDS
 269         iPIT :: PackageIfaceTable,
 270                 -- The ModuleIFaces for modules in other packages
 271                 -- whose interfaces we have opened
 272                 -- The declarations in these interface files are held in
 273                 -- iDecls, iInsts, iRules (below), not in the mi_decls fields
 274                 -- of the iPIT.  What _is_ in the iPIT is:
 275                 --      * The Module
 276                 --      * Version info
 277                 --      * Its exports
 278                 --      * Fixities
 279                 --      * Deprecations
 280                 -- The iPIT field is initialised from the compiler's persistent
 281                 -- package symbol table, and the renamer incrementally adds
 282                 -- to it.
 283
 284         iImpModInfo :: ImportedModuleInfo,
 285                         -- Modules that we know something about, because they are mentioned
 286                         -- in interface files, BUT which we have not loaded yet.
 287                         -- No module is both in here and in the PIT
 288
 289         iDecls :: DeclsMap,
 290                 -- A single, global map of Names to unslurped decls
 291
 292         iInsts :: IfaceInsts,
 293                 -- The as-yet un-slurped instance decls; this bag is depleted when we
 294                 -- slurp an instance decl so that we don't slurp the same one twice.
 295                 -- Each is 'gated' by the names that must be available before
 296                 -- this instance decl is needed.
 297
 298         iRules :: IfaceRules,
 299                 -- Similar to instance decls, only for rules
 300
 301     -- EPHEMERAL FIELDS
 302     -- These fields persist during the compilation of a single module only
 303         iSlurp :: NameSet,
 304                 -- All the names (whether "big" or "small", whether wired-in or not,
 305                 -- whether locally defined or not) that have been slurped in so far.
 306                 --
 307                 -- It's used for two things:
 308                 --      a) To record what we've already slurped, so
 309                 --         we can no-op if we try to slurp it again
 310                 --      b) As the 'gates' for importing rules.  We import a rule
 311                 --         if all its LHS free vars have been slurped
 312
 313         iVSlurp :: (ModuleSet, NameSet)
 314                 -- The Names are all the (a) non-wired-in
 315                 --                       (b) "big"
 316                 --                       (c) non-locally-defined
 317                 --                       (d) home-package
 318                 -- names that have been slurped in so far, with their versions.
 319                 -- This is used to generate the "usage" information for this module.
 320                 -- Subset of the previous field.
 321                 --
 322                 -- The module set is the non-home-package modules from which we have
 323                 -- slurped at least one name.
 324                 -- It's worth keeping separately, because there's no very easy
 325                 -- way to distinguish the "big" names from the "non-big" ones.
 326                 -- But this is a decision we might want to revisit.
 327     }
 328 \end{code}
 329
 330
 331 %************************************************************************
 332 %*                                                                      *
 333 \subsection{Main monad code}
 334 %*                                                                      *
 335 %************************************************************************
 336
 337 \begin{code}
 338 runRn dflags hit hst pcs mod do_rn
 339   = do { (pcs, msgs, r) <- initRn dflags hit hst pcs mod do_rn ;
 340          printErrorsAndWarnings alwaysQualify msgs ;
 341          return (pcs, errorsFound msgs, r)
 342     }
 343
 344 initRn :: DynFlags
 345        -> HomeIfaceTable -> HomeSymbolTable
 346        -> PersistentCompilerState
 347        -> Module
 348        -> RnMG t
 349        -> IO (PersistentCompilerState, Messages, t)
 350
 351 initRn dflags hit hst pcs mod do_rn
 352   = do
 353         let prs = pcs_PRS pcs
 354         let pte = pcs_PTE pcs
 355         let ifaces = Ifaces { iPIT   = pcs_PIT pcs,
 356                               iDecls = prsDecls prs,
 357                               iInsts = prsInsts prs,
 358                               iRules = prsRules prs,
 359
 360                               iImpModInfo = prsImpMods prs,
 361                               iSlurp      = unitNameSet (mkUnboundName dummyRdrVarName),
 362                                 -- Pretend that the dummy unbound name has already been
 363                                 -- slurped.  This is what's returned for an out-of-scope name,
 364                                 -- and we don't want thereby to try to suck it in!
 365                               iVSlurp = (emptyModuleSet, emptyNameSet)
 366                       }
 367         names_var <- newIORef (prsOrig prs)
 368         errs_var  <- newIORef (emptyBag,emptyBag)
 369         iface_var <- newIORef ifaces
 370         let rn_down = RnDown { rn_mod = mod,
 371                                rn_loc = noSrcLoc,
 372
 373                                rn_dflags = dflags,
 374                                rn_hit    = hit,
 375                                rn_done   = lookupType hst pte,
 376
 377                                rn_ns     = names_var,
 378                                rn_errs   = errs_var,
 379                                rn_ifaces = iface_var,
 380                              }
 381
 382         -- do the business
 383         res <- do_rn rn_down ()
 384
 385         -- Grab state and record it
 386         (warns, errs)   <- readIORef errs_var
 387         new_ifaces      <- readIORef iface_var
 388         new_orig        <- readIORef names_var
 389         let new_prs = prs { prsOrig    = new_orig,
 390                             prsImpMods = iImpModInfo new_ifaces,
 391                             prsDecls   = iDecls new_ifaces,
 392                             prsInsts   = iInsts new_ifaces,
 393                             prsRules   = iRules new_ifaces }
 394         let new_pcs = pcs { pcs_PIT = iPIT new_ifaces,
 395                             pcs_PRS = new_prs }
 396
 397         return (new_pcs, (warns, errs), res)
 398
 399 initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
 400          -> RnMS a -> RnM d a
 401
 402 initRnMS rn_env avails local_env fixity_env mode thing_inside rn_down g_down
 403         -- The fixity_env appears in both the rn_fixenv field
 404         -- and in the HIT.  See comments with RnHiFiles.lookupFixityRn
 405   = let
 406         s_down = SDown { rn_genv = rn_env, rn_avails = avails,
 407                          rn_lenv = local_env, rn_fixenv = fixity_env,
 408                          rn_mode = mode }
 409     in
 410     thing_inside rn_down s_down
 411
 412 initIfaceRnMS :: Module -> RnMS r -> RnM d r
 413 initIfaceRnMS mod thing_inside
 414   = initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv
 415              emptyLocalFixityEnv InterfaceMode
 416              (setModuleRn mod thing_inside)
 417 \end{code}
 418
 419 @renameDerivedCode@ is used to rename stuff ``out-of-line'';
 420 that is, not as part of the main renamer.
 421 Sole examples: derived definitions,
 422 which are only generated in the type checker.
 423
 424 The @NameSupply@ includes a @UniqueSupply@, so if you call it more than
 425 once you must either split it, or install a fresh unique supply.
 426
 427 \begin{code}
 428 renameDerivedCode :: DynFlags
 429                   -> Module
 430                   -> PersistentRenamerState
 431                   -> RnMS r
 432                   -> r
 433
 434 renameDerivedCode dflags mod prs thing_inside
 435   = unsafePerformIO $
 436         -- It's not really unsafe!  When renaming source code we
 437         -- only do any I/O if we need to read in a fixity declaration;
 438         -- and that doesn't happen in pragmas etc
 439
 440     do  { us <- mkSplitUniqSupply 'r'
 441         ; names_var <- newIORef ((prsOrig prs) { nsUniqs = us })
 442         ; errs_var <- newIORef (emptyBag,emptyBag)
 443
 444         ; let rn_down = RnDown { rn_dflags = dflags,
 445                                  rn_loc    = generatedSrcLoc, rn_ns = names_var,
 446                                  rn_errs   = errs_var,
 447                                  rn_mod    = mod,
 448                                  rn_done   = bogus "rn_done",
 449                                  rn_hit    = bogus "rn_hit",
 450                                  rn_ifaces = bogus "rn_ifaces"
 451                                }
 452         ; let s_down = SDown { rn_mode = InterfaceMode,
 453                                -- So that we can refer to PrelBase.True etc
 454                                rn_avails = emptyAvailEnv,
 455                                rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
 456                                rn_fixenv = emptyLocalFixityEnv }
 457
 458         ; result <- thing_inside rn_down s_down
 459         ; messages <- readIORef errs_var
 460
 461         ; if bad messages then
 462                 do { hPutStr stderr "Urk!  renameDerivedCode found errors or warnings"
 463                    ; printErrorsAndWarnings alwaysQualify messages
 464                    }
 465            else
 466                 return()
 467
 468         ; return result
 469         }
 470   where
 471 #ifdef DEBUG
 472     bad messages = errorsFound messages || warningsFound messages
 473 #else
 474     bad messages = errorsFound messages
 475 #endif
 476
 477 bogus s = panic ("rnameSourceCode: " ++ s)  -- Used for unused record fields
 478
 479 {-# INLINE thenRn #-}
 480 {-# INLINE thenRn_ #-}
 481 {-# INLINE returnRn #-}
 482 {-# INLINE andRn #-}
 483
 484 returnRn :: a -> RnM d a
 485 thenRn   :: RnM d a -> (a -> RnM d b) -> RnM d b
 486 thenRn_  :: RnM d a -> RnM d b -> RnM d b
 487 andRn    :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a
 488 mapRn    :: (a -> RnM d b) -> [a] -> RnM d [b]
 489 mapRn_   :: (a -> RnM d b) -> [a] -> RnM d ()
 490 mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b]
 491 flatMapRn  :: (a -> RnM d [b])       -> [a] -> RnM d [b]
 492 sequenceRn  :: [RnM d a] -> RnM d [a]
 493 sequenceRn_ :: [RnM d a] -> RnM d ()
 494 foldlRn :: (b  -> a -> RnM d b) -> b -> [a] -> RnM d b
 495 mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c])
 496 fixRn    :: (a -> RnM d a) -> RnM d a
 497
 498 returnRn v gdown ldown  = return v
 499 thenRn m k gdown ldown  = m gdown ldown >>= \ r -> k r gdown ldown
 500 thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown
 501 fixRn m gdown ldown = fixIO (\r -> m r gdown ldown)
 502 andRn combiner m1 m2 gdown ldown
 503   = m1 gdown ldown >>= \ res1 ->
 504     m2 gdown ldown >>= \ res2 ->
 505     return (combiner res1 res2)
 506
 507 sequenceRn []     = returnRn []
 508 sequenceRn (m:ms) =  m                  `thenRn` \ r ->
 509                      sequenceRn ms      `thenRn` \ rs ->
 510                      returnRn (r:rs)
 511
 512 sequenceRn_ []     = returnRn ()
 513 sequenceRn_ (m:ms) = m `thenRn_` sequenceRn_ ms
 514
 515 mapRn f []     = returnRn []
 516 mapRn f (x:xs)
 517   = f x         `thenRn` \ r ->
 518     mapRn f xs  `thenRn` \ rs ->
 519     returnRn (r:rs)
 520
 521 mapRn_ f []     = returnRn ()
 522 mapRn_ f (x:xs) =
 523     f x         `thenRn_`
 524     mapRn_ f xs
 525
 526 foldlRn k z [] = returnRn z
 527 foldlRn k z (x:xs) = k z x      `thenRn` \ z' ->
 528                      foldlRn k z' xs
 529
 530 mapAndUnzipRn f [] = returnRn ([],[])
 531 mapAndUnzipRn f (x:xs)
 532   = f x                 `thenRn` \ (r1,  r2)  ->
 533     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 534     returnRn (r1:rs1, r2:rs2)
 535
 536 mapAndUnzip3Rn f [] = returnRn ([],[],[])
 537 mapAndUnzip3Rn f (x:xs)
 538   = f x                 `thenRn` \ (r1,  r2,  r3)  ->
 539     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
 540     returnRn (r1:rs1, r2:rs2, r3:rs3)
 541
 542 mapMaybeRn f []     = returnRn []
 543 mapMaybeRn f (x:xs) = f x               `thenRn` \ maybe_r ->
 544                       mapMaybeRn f xs   `thenRn` \ rs ->
 545                       case maybe_r of
 546                         Nothing -> returnRn rs
 547                         Just r  -> returnRn (r:rs)
 548
 549 flatMapRn f []     = returnRn []
 550 flatMapRn f (x:xs) = f x                `thenRn` \ r ->
 551                      flatMapRn f xs     `thenRn` \ rs ->
 552                      returnRn (r ++ rs)
 553 \end{code}
 554
 555
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsection{Boring plumbing for common part}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563
 564 %================
 565 \subsubsection{  Errors and warnings}
 566 %=====================
 567
 568 \begin{code}
 569 failWithRn :: a -> Message -> RnM d a
 570 failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
 571   = readIORef  errs_var                                         >>=  \ (warns,errs) ->
 572     writeIORef errs_var (warns, errs `snocBag` err)             >>
 573     return res
 574   where
 575     err = addShortErrLocLine loc msg
 576
 577 warnWithRn :: a -> Message -> RnM d a
 578 warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
 579   = readIORef  errs_var                                         >>=  \ (warns,errs) ->
 580     writeIORef errs_var (warns `snocBag` warn, errs)    >>
 581     return res
 582   where
 583     warn = addShortWarnLocLine loc msg
 584
 585 tryRn :: RnM d a -> RnM d (Either Messages a)
 586 tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down
 587   = do current_msgs <- readIORef errs_var
 588        writeIORef errs_var (emptyBag,emptyBag)
 589        a <- try_this down l_down
 590        (warns, errs) <- readIORef errs_var
 591        writeIORef errs_var current_msgs
 592        if (isEmptyBag errs)
 593           then return (Right a)
 594           else return (Left (warns,errs))
 595
 596 setErrsRn :: Messages -> RnM d ()
 597 setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down
 598   = do writeIORef errs_var msgs; return ()
 599
 600 addErrRn :: Message -> RnM d ()
 601 addErrRn err = failWithRn () err
 602
 603 checkRn :: Bool -> Message -> RnM d ()  -- Check that a condition is true
 604 checkRn False err = addErrRn err
 605 checkRn True  err = returnRn ()
 606
 607 warnCheckRn :: Bool -> Message -> RnM d ()      -- Check that a condition is true
 608 warnCheckRn False err = addWarnRn err
 609 warnCheckRn True  err = returnRn ()
 610
 611 addWarnRn :: Message -> RnM d ()
 612 addWarnRn warn = warnWithRn () warn
 613
 614 checkErrsRn :: RnM d Bool               -- True <=> no errors so far
 615 checkErrsRn (RnDown {rn_errs = errs_var}) l_down
 616   = readIORef  errs_var                                         >>=  \ (warns,errs) ->
 617     return (isEmptyBag errs)
 618
 619 doptRn :: DynFlag -> RnM d Bool
 620 doptRn dflag (RnDown { rn_dflags = dflags}) l_down
 621    = return (dopt dflag dflags)
 622
 623 ifOptRn :: DynFlag -> RnM d a -> RnM d ()
 624 ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down
 625   | dopt dflag dflags = thing_inside down l_down >> return ()
 626   | otherwise         = return ()
 627
 628 getDOptsRn :: RnM d DynFlags
 629 getDOptsRn (RnDown { rn_dflags = dflags}) l_down
 630    = return dflags
 631 \end{code}
 632
 633
 634 %================
 635 \subsubsection{Source location}
 636 %=====================
 637
 638 \begin{code}
 639 pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a
 640 pushSrcLocRn loc' m down l_down
 641   = m (down {rn_loc = loc'}) l_down
 642
 643 getSrcLocRn :: RnM d SrcLoc
 644 getSrcLocRn down l_down
 645   = return (rn_loc down)
 646 \end{code}
 647
 648 %================
 649 \subsubsection{The finder and home symbol table}
 650 %=====================
 651
 652 \begin{code}
 653 getHomeIfaceTableRn :: RnM d HomeIfaceTable
 654 getHomeIfaceTableRn down l_down = return (rn_hit down)
 655
 656 getTypeEnvRn :: RnM d (Name -> Maybe TyThing)
 657 getTypeEnvRn down l_down = return (rn_done down)
 658
 659 extendTypeEnvRn :: NameEnv TyThing -> RnM d a -> RnM d a
 660 extendTypeEnvRn env inside down l_down
 661   = inside down{rn_done=new_rn_done} l_down
 662   where new_rn_done = \nm -> lookupNameEnv env nm `seqMaybe` rn_done down nm
 663 \end{code}
 664
 665 %================
 666 \subsubsection{Name supply}
 667 %=====================
 668
 669 \begin{code}
 670 getNameSupplyRn :: RnM d NameSupply
 671 getNameSupplyRn rn_down l_down
 672   = readIORef (rn_ns rn_down)
 673
 674 setNameSupplyRn :: NameSupply -> RnM d ()
 675 setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
 676   = writeIORef names_var names'
 677
 678 getUniqRn :: RnM d Unique
 679 getUniqRn (RnDown {rn_ns = names_var}) l_down
 680  = readIORef names_var >>= \ ns ->
 681    let
 682      (us1,us') = splitUniqSupply (nsUniqs ns)
 683    in
 684    writeIORef names_var (ns {nsUniqs = us'})    >>
 685    return (uniqFromSupply us1)
 686 \end{code}
 687
 688 %================
 689 \subsubsection{  Module}
 690 %=====================
 691
 692 \begin{code}
 693 getModuleRn :: RnM d Module
 694 getModuleRn (RnDown {rn_mod = mod}) l_down
 695   = return mod
 696
 697 setModuleRn :: Module -> RnM d a -> RnM d a
 698 setModuleRn new_mod enclosed_thing rn_down l_down
 699   = enclosed_thing (rn_down {rn_mod = new_mod}) l_down
 700 \end{code}
 701
 702
 703 %************************************************************************
 704 %*                                                                      *
 705 \subsection{Plumbing for rename-source part}
 706 %*                                                                      *
 707 %************************************************************************
 708
 709 %================
 710 \subsubsection{  RnEnv}
 711 %=====================
 712
 713 \begin{code}
 714 getLocalNameEnv :: RnMS LocalRdrEnv
 715 getLocalNameEnv rn_down (SDown {rn_lenv = local_env})
 716   = return local_env
 717
 718 getGlobalNameEnv :: RnMS GlobalRdrEnv
 719 getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
 720   = return global_env
 721
 722 getGlobalAvails :: RnMS AvailEnv
 723 getGlobalAvails  rn_down (SDown {rn_avails = avails})
 724   = return avails
 725
 726 setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
 727 setLocalNameEnv local_env' m rn_down l_down
 728   = m rn_down (l_down {rn_lenv = local_env'})
 729
 730 getFixityEnv :: RnMS LocalFixityEnv
 731 getFixityEnv rn_down (SDown {rn_fixenv = fixity_env})
 732   = return fixity_env
 733
 734 extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
 735 extendFixityEnv fixes enclosed_scope
 736                 rn_down l_down@(SDown {rn_fixenv = fixity_env})
 737   = let
 738         new_fixity_env = extendNameEnvList fixity_env fixes
 739     in
 740     enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env})
 741 \end{code}
 742
 743 %================
 744 \subsubsection{  Mode}
 745 %=====================
 746
 747 \begin{code}
 748 getModeRn :: RnMS RnMode
 749 getModeRn rn_down (SDown {rn_mode = mode})
 750   = return mode
 751
 752 setModeRn :: RnMode -> RnMS a -> RnMS a
 753 setModeRn new_mode thing_inside rn_down l_down
 754   = thing_inside rn_down (l_down {rn_mode = new_mode})
 755 \end{code}
 756
 757
 758 %************************************************************************
 759 %*                                                                      *
 760 \subsection{Plumbing for rename-globals part}
 761 %*                                                                      *
 762 %************************************************************************
 763
 764 \begin{code}
 765 getIfacesRn :: RnM d Ifaces
 766 getIfacesRn (RnDown {rn_ifaces = iface_var}) _
 767   = readIORef iface_var
 768
 769 setIfacesRn :: Ifaces -> RnM d ()
 770 setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _
 771   = writeIORef iface_var ifaces
 772 \end{code}