ghc/compiler/rename/RnMonad.lhs

   1 %\r
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
   3 %\r
   4 \section[RnMonad]{The monad used by the renamer}\r
   5 \r
   6 \begin{code}\r
   7 module RnMonad(\r
   8         module RnMonad,\r
   9         Module,\r
  10         FiniteMap,\r
  11         Bag,\r
  12         Name,\r
  13         RdrNameHsDecl,\r
  14         RdrNameInstDecl,\r
  15         Version,\r
  16         NameSet,\r
  17         OccName,\r
  18         Fixity\r
  19     ) where\r
  20 \r
  21 #include "HsVersions.h"\r
  22 \r
  23 import PrelIOBase       ( fixIO )       -- Should be in GlaExts\r
  24 import IOExts           ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )\r
  25         \r
  26 import HsSyn            \r
  27 import RdrHsSyn\r
  28 import RnHsSyn          ( RenamedFixitySig )\r
  29 import BasicTypes       ( Version )\r
  30 import SrcLoc           ( noSrcLoc )\r
  31 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine,\r
  32                           pprBagOfErrors, ErrMsg, WarnMsg, Message\r
  33                         )\r
  34 import Name             ( Name, OccName, NamedThing(..),\r
  35                           isLocallyDefinedName, nameModule, nameOccName,\r
  36                           decode, mkLocalName\r
  37                         )\r
  38 import Module           ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,\r
  39                           mkModuleHiMaps, moduleName\r
  40                         )\r
  41 import NameSet          \r
  42 import RdrName          ( RdrName, dummyRdrVarName, rdrNameOcc )\r
  43 import CmdLineOpts      ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas )\r
  44 import PrelInfo         ( builtinNames )\r
  45 import TysWiredIn       ( boolTyCon )\r
  46 import SrcLoc           ( SrcLoc, mkGeneratedSrcLoc )\r
  47 import Unique           ( Unique, getUnique, unboundKey )\r
  48 import UniqFM           ( UniqFM )\r
  49 import FiniteMap        ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, \r
  50                           addListToFM_C, addToFM_C, eltsFM, fmToList\r
  51                         )\r
  52 import Bag              ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )\r
  53 import Maybes           ( mapMaybe )\r
  54 import UniqSet\r
  55 import UniqFM\r
  56 import UniqSupply\r
  57 import Util\r
  58 import Outputable\r
  59 \r
  60 infixr 9 `thenRn`, `thenRn_`\r
  61 \end{code}\r
  62 \r
  63 \r
  64 %************************************************************************\r
  65 %*                                                                      *\r
  66 \subsection{Somewhat magical interface to other monads}\r
  67 %*                                                                      *\r
  68 %************************************************************************\r
  69 \r
  70 \begin{code}\r
  71 ioToRnM :: IO r -> RnM d (Either IOError r)\r
  72 ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) \r
  73                             `catch` \r
  74                             (\ err -> return (Left err))\r
  75             \r
  76 traceRn :: SDoc -> RnM d ()\r
  77 traceRn msg | opt_D_dump_rn_trace = putDocRn msg\r
  78             | otherwise           = returnRn ()\r
  79 \r
  80 putDocRn :: SDoc -> RnM d ()\r
  81 putDocRn msg = ioToRnM (printErrs msg)  `thenRn_`\r
  82                returnRn ()\r
  83 \end{code}\r
  84 \r
  85 \r
  86 %************************************************************************\r
  87 %*                                                                      *\r
  88 \subsection{Data types}\r
  89 %*                                                                      *\r
  90 %************************************************************************\r
  91 \r
  92 ===================================================\r
  93                 MONAD TYPES\r
  94 ===================================================\r
  95 \r
  96 \begin{code}\r
  97 type RnM d r = RnDown -> d -> IO r\r
  98 type RnMS r  = RnM SDown r              -- Renaming source\r
  99 type RnMG r  = RnM ()    r              -- Getting global names etc\r
 100 \r
 101         -- Common part\r
 102 data RnDown = RnDown {\r
 103                   rn_mod     :: ModuleName,\r
 104                   rn_loc     :: SrcLoc,\r
 105                   rn_ns      :: IORef RnNameSupply,\r
 106                   rn_errs    :: IORef (Bag WarnMsg, Bag ErrMsg),\r
 107                   rn_ifaces  :: IORef Ifaces,\r
 108                   rn_hi_maps :: (ModuleHiMap,   -- for .hi files\r
 109                                  ModuleHiMap)   -- for .hi-boot files\r
 110                 }\r
 111 \r
 112         -- For renaming source code\r
 113 data SDown = SDown {\r
 114                   rn_mode :: RnMode,\r
 115 \r
 116                   rn_genv :: GlobalRdrEnv,      -- Global envt; the fixity component gets extended\r
 117                                                 --   with local fixity decls\r
 118 \r
 119                   rn_lenv :: LocalRdrEnv,       -- Local name envt\r
 120                                         --   Does *not* includes global name envt; may shadow it\r
 121                                         --   Includes both ordinary variables and type variables;\r
 122                                         --   they are kept distinct because tyvar have a different\r
 123                                         --   occurrence contructor (Name.TvOcc)\r
 124                                         -- We still need the unsullied global name env so that\r
 125                                         --   we can look up record field names\r
 126 \r
 127                   rn_fixenv :: FixityEnv        -- Local fixities\r
 128                                                 -- The global ones are held in the\r
 129                                                 -- rn_ifaces field\r
 130                 }\r
 131 \r
 132 data RnMode     = SourceMode                    -- Renaming source code\r
 133                 | InterfaceMode                 -- Renaming interface declarations.  \r
 134 \end{code}\r
 135 \r
 136 ===================================================\r
 137                 ENVIRONMENTS\r
 138 ===================================================\r
 139 \r
 140 \begin{code}\r
 141 --------------------------------\r
 142 type RdrNameEnv a = FiniteMap RdrName a\r
 143 type GlobalRdrEnv = RdrNameEnv [Name]   -- The list is because there may be name clashes\r
 144                                         -- These only get reported on lookup,\r
 145                                         -- not on construction\r
 146 type LocalRdrEnv  = RdrNameEnv Name\r
 147 \r
 148 emptyRdrEnv  :: RdrNameEnv a\r
 149 lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a\r
 150 addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a\r
 151 extendRdrEnv    :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a\r
 152 \r
 153 emptyRdrEnv  = emptyFM\r
 154 lookupRdrEnv = lookupFM\r
 155 addListToRdrEnv = addListToFM\r
 156 rdrEnvElts      = eltsFM\r
 157 extendRdrEnv    = addToFM\r
 158 rdrEnvToList    = fmToList\r
 159 \r
 160 --------------------------------\r
 161 type NameEnv a = UniqFM a       -- Domain is Name\r
 162 \r
 163 emptyNameEnv   :: NameEnv a\r
 164 nameEnvElts    :: NameEnv a -> [a]\r
 165 addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a\r
 166 addToNameEnv   :: NameEnv a -> Name -> a -> NameEnv a\r
 167 plusNameEnv    :: NameEnv a -> NameEnv a -> NameEnv a\r
 168 extendNameEnv  :: NameEnv a -> [(Name,a)] -> NameEnv a\r
 169 lookupNameEnv  :: NameEnv a -> Name -> Maybe a\r
 170 delFromNameEnv :: NameEnv a -> Name -> NameEnv a\r
 171 elemNameEnv    :: Name -> NameEnv a -> Bool\r
 172 \r
 173 emptyNameEnv   = emptyUFM\r
 174 nameEnvElts    = eltsUFM\r
 175 addToNameEnv_C = addToUFM_C\r
 176 addToNameEnv   = addToUFM\r
 177 plusNameEnv    = plusUFM\r
 178 extendNameEnv  = addListToUFM\r
 179 lookupNameEnv  = lookupUFM\r
 180 delFromNameEnv = delFromUFM\r
 181 elemNameEnv    = elemUFM\r
 182 \r
 183 --------------------------------\r
 184 type FixityEnv = NameEnv RenamedFixitySig\r
 185         -- We keep the whole fixity sig so that we\r
 186         -- can report line-number info when there is a duplicate\r
 187         -- fixity declaration\r
 188 \end{code}\r
 189 \r
 190 \begin{code}\r
 191 --------------------------------\r
 192 type RnNameSupply\r
 193  = ( UniqSupply\r
 194 \r
 195    , FiniteMap (OccName, OccName) Int\r
 196         -- This is used as a name supply for dictionary functions\r
 197         -- From the inst decl we derive a (class, tycon) pair;\r
 198         -- this map then gives a unique int for each inst decl with that\r
 199         -- (class, tycon) pair.  (In Haskell 98 there can only be one,\r
 200         -- but not so in more extended versions.)\r
 201         --      \r
 202         -- We could just use one Int for all the instance decls, but this\r
 203         -- way the uniques change less when you add an instance decl,   \r
 204         -- hence less recompilation\r
 205 \r
 206    , FiniteMap (ModuleName, OccName) Name\r
 207         -- Ensures that one (module,occname) pair gets one unique\r
 208    )\r
 209 \r
 210 \r
 211 --------------------------------\r
 212 data ExportEnv    = ExportEnv Avails Fixities\r
 213 type Avails       = [AvailInfo]\r
 214 type Fixities     = [(Name, Fixity)]\r
 215 \r
 216 type ExportAvails = (FiniteMap ModuleName Avails,       -- Used to figure out "module M" export specifiers\r
 217                                                         -- Includes avails only from *unqualified* imports\r
 218                                                         -- (see 1.4 Report Section 5.1.1)\r
 219 \r
 220                      NameEnv AvailInfo)         -- Used to figure out all other export specifiers.\r
 221                                                 -- Maps a Name to the AvailInfo that contains it\r
 222 \r
 223 \r
 224 data GenAvailInfo name  = Avail name            -- An ordinary identifier\r
 225                         | AvailTC name          -- The name of the type or class\r
 226                                   [name]        -- The available pieces of type/class. NB: If the type or\r
 227                                                 -- class is itself to be in scope, it must be in this list.\r
 228                                                 -- Thus, typically: AvailTC Eq [Eq, ==, /=]\r
 229 type AvailInfo    = GenAvailInfo Name\r
 230 type RdrAvailInfo = GenAvailInfo OccName\r
 231 \end{code}\r
 232 \r
 233 ===================================================\r
 234                 INTERFACE FILE STUFF\r
 235 ===================================================\r
 236 \r
 237 \begin{code}\r
 238 type ExportItem          = (ModuleName, [RdrAvailInfo])\r
 239 type VersionInfo name    = [ImportVersion name]\r
 240 \r
 241 type ImportVersion name  = (ModuleName, Version, WhetherHasOrphans, WhatsImported name)\r
 242 \r
 243 type WhetherHasOrphans   = Bool\r
 244         -- An "orphan" is \r
 245         --      * an instance decl in a module other than the defn module for \r
 246         --              one of the tycons or classes in the instance head\r
 247         --      * a transformation rule in a module other than the one defining\r
 248         --              the function in the head of the rule.\r
 249 \r
 250 data WhatsImported name  = Everything \r
 251                          | Specifically [LocalVersion name]     -- List guaranteed non-empty\r
 252 \r
 253     -- ("M", hif, ver, Everything) means there was a "module M" in \r
 254     -- this module's export list, so we just have to go by M's version, "ver",\r
 255     -- not the list of LocalVersions.\r
 256 \r
 257 \r
 258 type LocalVersion name   = (name, Version)\r
 259 \r
 260 data ParsedIface\r
 261   = ParsedIface {\r
 262       pi_mod       :: Version,                          -- Module version number\r
 263       pi_orphan    :: WhetherHasOrphans,                -- Whether this module has orphans\r
 264       pi_usages    :: [ImportVersion OccName],          -- Usages\r
 265       pi_exports   :: [ExportItem],                     -- Exports\r
 266       pi_decls     :: [(Version, RdrNameHsDecl)],       -- Local definitions\r
 267       pi_insts     :: [RdrNameInstDecl],                -- Local instance declarations\r
 268       pi_rules     :: [RdrNameRuleDecl]                 -- Rules\r
 269     }\r
 270 \r
 271 type InterfaceDetails = (WhetherHasOrphans,\r
 272                          VersionInfo Name,      -- Version information for what this module imports\r
 273                          ExportEnv)             -- What modules this one depends on\r
 274 \r
 275 \r
 276 -- needed by Main to fish out the fixities assoc list.\r
 277 getIfaceFixities :: InterfaceDetails -> Fixities\r
 278 getIfaceFixities (_, _, ExportEnv _ fs) = fs\r
 279 \r
 280 \r
 281 type RdrNamePragma = ()                         -- Fudge for now\r
 282 -------------------\r
 283 \r
 284 data Ifaces = Ifaces {\r
 285                 iImpModInfo :: ImportedModuleInfo,\r
 286                                 -- Modules this one depends on: that is, the union \r
 287                                 -- of the modules its direct imports depend on.\r
 288 \r
 289                 iDecls :: DeclsMap,     -- A single, global map of Names to decls\r
 290 \r
 291                 iFixes :: FixityEnv,    -- A single, global map of Names to fixities\r
 292 \r
 293                 iSlurp :: NameSet,      -- All the names (whether "big" or "small", whether wired-in or not,\r
 294                                         -- whether locally defined or not) that have been slurped in so far.\r
 295 \r
 296                 iVSlurp :: [(Name,Version)],    -- All the (a) non-wired-in (b) "big" (c) non-locally-defined \r
 297                                                 -- names that have been slurped in so far, with their versions. \r
 298                                                 -- This is used to generate the "usage" information for this module.\r
 299                                                 -- Subset of the previous field.\r
 300 \r
 301                 iInsts :: Bag GatedDecl,\r
 302                                 -- The as-yet un-slurped instance decls; this bag is depleted when we\r
 303                                 -- slurp an instance decl so that we don't slurp the same one twice.\r
 304                                 -- Each is 'gated' by the names that must be available before\r
 305                                 -- this instance decl is needed.\r
 306 \r
 307                 iRules :: Bag GatedDecl\r
 308                                 -- Ditto transformation rules\r
 309         }\r
 310 \r
 311 type GatedDecl = (NameSet, (Module, RdrNameHsDecl))\r
 312 \r
 313 type ImportedModuleInfo \r
 314      = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails))\r
 315                 -- Suppose the domain element is module 'A'\r
 316                 --\r
 317                 -- The first Bool is True if A contains \r
 318                 -- 'orphan' rules or instance decls\r
 319 \r
 320                 -- The second Bool is true if the interface file actually\r
 321                 -- read was an .hi-boot file\r
 322 \r
 323                 -- Nothing => A's interface not yet read, but this module has\r
 324                 --            imported a module, B, that itself depends on A\r
 325                 --\r
 326                 -- Just xx => A's interface has been read.  The Module in \r
 327                 --              the Just has the correct Dll flag\r
 328 \r
 329                 -- This set is used to decide whether to look for\r
 330                 -- A.hi or A.hi-boot when importing A.f.\r
 331                 -- Basically, we look for A.hi if A is in the map, and A.hi-boot\r
 332                 -- otherwise\r
 333 \r
 334 type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl))\r
 335                 -- A DeclsMap contains a binding for each Name in the declaration\r
 336                 -- including the constructors of a type decl etc.\r
 337                 -- The Bool is True just for the 'main' Name.\r
 338 \end{code}\r
 339 \r
 340 \r
 341 %************************************************************************\r
 342 %*                                                                      *\r
 343 \subsection{Main monad code}\r
 344 %*                                                                      *\r
 345 %************************************************************************\r
 346 \r
 347 \begin{code}\r
 348 initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc\r
 349        -> RnMG r\r
 350        -> IO (r, Bag ErrMsg, Bag WarnMsg)\r
 351 \r
 352 initRn mod us dirs loc do_rn = do\r
 353   himaps    <- mkModuleHiMaps dirs\r
 354   names_var <- newIORef (us, emptyFM, builtins)\r
 355   errs_var  <- newIORef (emptyBag,emptyBag)\r
 356   iface_var <- newIORef emptyIfaces \r
 357   let\r
 358         rn_down = RnDown { rn_loc = loc, rn_ns = names_var, \r
 359                            rn_errs = errs_var, \r
 360                            rn_hi_maps = himaps, \r
 361                            rn_ifaces = iface_var,\r
 362                            rn_mod = mod }\r
 363 \r
 364         -- do the business\r
 365   res <- do_rn rn_down ()\r
 366 \r
 367         -- grab errors and return\r
 368   (warns, errs) <- readIORef errs_var\r
 369 \r
 370   return (res, errs, warns)\r
 371 \r
 372 \r
 373 initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r\r
 374 initRnMS rn_env fixity_env mode thing_inside rn_down g_down\r
 375   = let\r
 376         s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, \r
 377                          rn_fixenv = fixity_env, rn_mode = mode }\r
 378     in\r
 379     thing_inside rn_down s_down\r
 380 \r
 381 initIfaceRnMS :: Module -> RnMS r -> RnM d r\r
 382 initIfaceRnMS mod thing_inside \r
 383   = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $\r
 384     setModuleRn (moduleName mod) thing_inside\r
 385 \r
 386 emptyIfaces :: Ifaces\r
 387 emptyIfaces = Ifaces { iImpModInfo = emptyFM,\r
 388                        iDecls = emptyNameEnv,\r
 389                        iFixes = emptyNameEnv,\r
 390                        iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),\r
 391                         -- Pretend that the dummy unbound name has already been\r
 392                         -- slurped.  This is what's returned for an out-of-scope name,\r
 393                         -- and we don't want thereby to try to suck it in!\r
 394                        iVSlurp = [],\r
 395                        iInsts = emptyBag,\r
 396                        iRules = emptyBag\r
 397               }\r
 398 \r
 399 -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly\r
 400 -- during compiler debugging.\r
 401 mkUnboundName :: RdrName -> Name\r
 402 mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc\r
 403 \r
 404 isUnboundName :: Name -> Bool\r
 405 isUnboundName name = getUnique name == unboundKey\r
 406 \r
 407 builtins :: FiniteMap (ModuleName,OccName) Name\r
 408 builtins = \r
 409    bagToFM (\r
 410    mapBag (\ name ->  ((moduleName (nameModule name), nameOccName name), name))\r
 411           builtinNames)\r
 412 \end{code}\r
 413 \r
 414 @renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of\r
 415 the main renamer.  Sole examples: derived definitions, which are only generated\r
 416 in the type checker.\r
 417 \r
 418 The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than\r
 419 once you must either split it, or install a fresh unique supply.\r
 420 \r
 421 \begin{code}\r
 422 renameSourceCode :: ModuleName\r
 423                  -> RnNameSupply\r
 424                  -> RnMS r\r
 425                  -> r\r
 426 \r
 427 renameSourceCode mod_name name_supply m\r
 428   = unsafePerformIO (\r
 429         -- It's not really unsafe!  When renaming source code we\r
 430         -- only do any I/O if we need to read in a fixity declaration;\r
 431         -- and that doesn't happen in pragmas etc\r
 432 \r
 433         newIORef name_supply            >>= \ names_var ->\r
 434         newIORef (emptyBag,emptyBag)    >>= \ errs_var ->\r
 435         let\r
 436             rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var,\r
 437                                rn_errs = errs_var,\r
 438                                rn_mod = mod_name }\r
 439             s_down = SDown { rn_mode = InterfaceMode,   -- So that we can refer to PrelBase.True etc\r
 440                              rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,\r
 441                              rn_fixenv = emptyNameEnv }\r
 442         in\r
 443         m rn_down s_down                        >>= \ result ->\r
 444         \r
 445         readIORef errs_var                      >>= \ (warns,errs) ->\r
 446 \r
 447         (if not (isEmptyBag errs) then\r
 448                 pprTrace "Urk! renameSourceCode found errors" (display errs) \r
 449 #ifdef DEBUG\r
 450          else if not (isEmptyBag warns) then\r
 451                 pprTrace "Note: renameSourceCode found warnings" (display warns)\r
 452 #endif\r
 453          else\r
 454                 id) $\r
 455 \r
 456         return result\r
 457     )\r
 458   where\r
 459     display errs = pprBagOfErrors errs\r
 460 \r
 461 {-# INLINE thenRn #-}\r
 462 {-# INLINE thenRn_ #-}\r
 463 {-# INLINE returnRn #-}\r
 464 {-# INLINE andRn #-}\r
 465 \r
 466 returnRn :: a -> RnM d a\r
 467 thenRn   :: RnM d a -> (a -> RnM d b) -> RnM d b\r
 468 thenRn_  :: RnM d a -> RnM d b -> RnM d b\r
 469 andRn    :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a\r
 470 mapRn    :: (a -> RnM d b) -> [a] -> RnM d [b]\r
 471 mapRn_   :: (a -> RnM d b) -> [a] -> RnM d ()\r
 472 mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b]\r
 473 sequenceRn :: [RnM d a] -> RnM d [a]\r
 474 foldlRn :: (b  -> a -> RnM d b) -> b -> [a] -> RnM d b\r
 475 mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c])\r
 476 fixRn    :: (a -> RnM d a) -> RnM d a\r
 477 \r
 478 returnRn v gdown ldown  = return v\r
 479 thenRn m k gdown ldown  = m gdown ldown >>= \ r -> k r gdown ldown\r
 480 thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown\r
 481 fixRn m gdown ldown = fixIO (\r -> m r gdown ldown)\r
 482 andRn combiner m1 m2 gdown ldown\r
 483   = m1 gdown ldown >>= \ res1 ->\r
 484     m2 gdown ldown >>= \ res2 ->\r
 485     return (combiner res1 res2)\r
 486 \r
 487 sequenceRn []     = returnRn []\r
 488 sequenceRn (m:ms) =  m                  `thenRn` \ r ->\r
 489                      sequenceRn ms      `thenRn` \ rs ->\r
 490                      returnRn (r:rs)\r
 491 \r
 492 mapRn f []     = returnRn []\r
 493 mapRn f (x:xs)\r
 494   = f x         `thenRn` \ r ->\r
 495     mapRn f xs  `thenRn` \ rs ->\r
 496     returnRn (r:rs)\r
 497 \r
 498 mapRn_ f []     = returnRn ()\r
 499 mapRn_ f (x:xs) = \r
 500     f x         `thenRn_`\r
 501     mapRn_ f xs\r
 502 \r
 503 foldlRn k z [] = returnRn z\r
 504 foldlRn k z (x:xs) = k z x      `thenRn` \ z' ->\r
 505                      foldlRn k z' xs\r
 506 \r
 507 mapAndUnzipRn f [] = returnRn ([],[])\r
 508 mapAndUnzipRn f (x:xs)\r
 509   = f x                 `thenRn` \ (r1,  r2)  ->\r
 510     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->\r
 511     returnRn (r1:rs1, r2:rs2)\r
 512 \r
 513 mapAndUnzip3Rn f [] = returnRn ([],[],[])\r
 514 mapAndUnzip3Rn f (x:xs)\r
 515   = f x                 `thenRn` \ (r1,  r2,  r3)  ->\r
 516     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->\r
 517     returnRn (r1:rs1, r2:rs2, r3:rs3)\r
 518 \r
 519 mapMaybeRn f []     = returnRn []\r
 520 mapMaybeRn f (x:xs) = f x               `thenRn` \ maybe_r ->\r
 521                       mapMaybeRn f xs   `thenRn` \ rs ->\r
 522                       case maybe_r of\r
 523                         Nothing -> returnRn rs\r
 524                         Just r  -> returnRn (r:rs)\r
 525 \end{code}\r
 526 \r
 527 \r
 528 \r
 529 %************************************************************************\r
 530 %*                                                                      *\r
 531 \subsection{Boring plumbing for common part}\r
 532 %*                                                                      *\r
 533 %************************************************************************\r
 534 \r
 535 \r
 536 ================  Errors and warnings =====================\r
 537 \r
 538 \begin{code}\r
 539 failWithRn :: a -> Message -> RnM d a\r
 540 failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down\r
 541   = readIORef  errs_var                                         >>=  \ (warns,errs) ->\r
 542     writeIORef errs_var (warns, errs `snocBag` err)             >> \r
 543     return res\r
 544   where\r
 545     err = addShortErrLocLine loc msg\r
 546 \r
 547 warnWithRn :: a -> Message -> RnM d a\r
 548 warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down\r
 549   = readIORef  errs_var                                         >>=  \ (warns,errs) ->\r
 550     writeIORef errs_var (warns `snocBag` warn, errs)    >> \r
 551     return res\r
 552   where\r
 553     warn = addShortWarnLocLine loc msg\r
 554 \r
 555 addErrRn :: Message -> RnM d ()\r
 556 addErrRn err = failWithRn () err\r
 557 \r
 558 checkRn :: Bool -> Message -> RnM d ()  -- Check that a condition is true\r
 559 checkRn False err = addErrRn err\r
 560 checkRn True  err = returnRn ()\r
 561 \r
 562 warnCheckRn :: Bool -> Message -> RnM d ()      -- Check that a condition is true\r
 563 warnCheckRn False err = addWarnRn err\r
 564 warnCheckRn True  err = returnRn ()\r
 565 \r
 566 addWarnRn :: Message -> RnM d ()\r
 567 addWarnRn warn = warnWithRn () warn\r
 568 \r
 569 checkErrsRn :: RnM d Bool               -- True <=> no errors so far\r
 570 checkErrsRn (RnDown {rn_errs = errs_var}) l_down\r
 571   = readIORef  errs_var                                         >>=  \ (warns,errs) ->\r
 572     return (isEmptyBag errs)\r
 573 \end{code}\r
 574 \r
 575 \r
 576 ================  Source location =====================\r
 577 \r
 578 \begin{code}\r
 579 pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a\r
 580 pushSrcLocRn loc' m down l_down\r
 581   = m (down {rn_loc = loc'}) l_down\r
 582 \r
 583 getSrcLocRn :: RnM d SrcLoc\r
 584 getSrcLocRn down l_down\r
 585   = return (rn_loc down)\r
 586 \end{code}\r
 587 \r
 588 ================  Name supply =====================\r
 589 \r
 590 \begin{code}\r
 591 getNameSupplyRn :: RnM d RnNameSupply\r
 592 getNameSupplyRn rn_down l_down\r
 593   = readIORef (rn_ns rn_down)\r
 594 \r
 595 setNameSupplyRn :: RnNameSupply -> RnM d ()\r
 596 setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down\r
 597   = writeIORef names_var names'\r
 598 \r
 599 -- See comments with RnNameSupply above.\r
 600 newInstUniq :: (OccName, OccName) -> RnM d Int\r
 601 newInstUniq key (RnDown {rn_ns = names_var}) l_down\r
 602   = readIORef names_var                         >>= \ (us, mapInst, cache) ->\r
 603     let\r
 604         uniq = case lookupFM mapInst key of\r
 605                    Just x  -> x+1\r
 606                    Nothing -> 0\r
 607         mapInst' = addToFM mapInst key uniq\r
 608     in\r
 609     writeIORef names_var (us, mapInst', cache)  >>\r
 610     return uniq\r
 611 \r
 612 getUniqRn :: RnM d Unique\r
 613 getUniqRn (RnDown {rn_ns = names_var}) l_down\r
 614  = readIORef names_var >>= \ (us, mapInst, cache) ->\r
 615    let\r
 616      (us1,us') = splitUniqSupply us\r
 617    in\r
 618    writeIORef names_var (us', mapInst, cache)  >>\r
 619    return (uniqFromSupply us1)\r
 620 \end{code}\r
 621 \r
 622 ================  Module =====================\r
 623 \r
 624 \begin{code}\r
 625 getModuleRn :: RnM d ModuleName\r
 626 getModuleRn (RnDown {rn_mod = mod_name}) l_down\r
 627   = return mod_name\r
 628 \r
 629 setModuleRn :: ModuleName -> RnM d a -> RnM d a\r
 630 setModuleRn new_mod enclosed_thing rn_down l_down\r
 631   = enclosed_thing (rn_down {rn_mod = new_mod}) l_down\r
 632 \end{code}\r
 633 \r
 634 \r
 635 %************************************************************************\r
 636 %*                                                                      *\r
 637 \subsection{Plumbing for rename-source part}\r
 638 %*                                                                      *\r
 639 %************************************************************************\r
 640 \r
 641 ================  RnEnv  =====================\r
 642 \r
 643 \begin{code}\r
 644 getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv)\r
 645 getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env})\r
 646   = return (global_env, local_env)\r
 647 \r
 648 getLocalNameEnv :: RnMS LocalRdrEnv\r
 649 getLocalNameEnv rn_down (SDown {rn_lenv = local_env})\r
 650   = return local_env\r
 651 \r
 652 setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a\r
 653 setLocalNameEnv local_env' m rn_down l_down\r
 654   = m rn_down (l_down {rn_lenv = local_env'})\r
 655 \r
 656 getFixityEnv :: RnMS FixityEnv\r
 657 getFixityEnv rn_down (SDown {rn_fixenv = fixity_env})\r
 658   = return fixity_env\r
 659 \r
 660 extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a\r
 661 extendFixityEnv fixes enclosed_scope\r
 662                 rn_down l_down@(SDown {rn_fixenv = fixity_env})\r
 663   = let\r
 664         new_fixity_env = extendNameEnv fixity_env fixes\r
 665     in\r
 666     enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env})\r
 667 \end{code}\r
 668 \r
 669 ================  Mode  =====================\r
 670 \r
 671 \begin{code}\r
 672 getModeRn :: RnMS RnMode\r
 673 getModeRn rn_down (SDown {rn_mode = mode})\r
 674   = return mode\r
 675 \r
 676 setModeRn :: RnMode -> RnMS a -> RnMS a\r
 677 setModeRn new_mode thing_inside rn_down l_down\r
 678   = thing_inside rn_down (l_down {rn_mode = new_mode})\r
 679 \end{code}\r
 680 \r
 681 \r
 682 %************************************************************************\r
 683 %*                                                                      *\r
 684 \subsection{Plumbing for rename-globals part}\r
 685 %*                                                                      *\r
 686 %************************************************************************\r
 687 \r
 688 \begin{code}\r
 689 getIfacesRn :: RnM d Ifaces\r
 690 getIfacesRn (RnDown {rn_ifaces = iface_var}) _\r
 691   = readIORef iface_var\r
 692 \r
 693 setIfacesRn :: Ifaces -> RnM d ()\r
 694 setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _\r
 695   = writeIORef iface_var ifaces\r
 696 \r
 697 getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap)\r
 698 getHiMaps (RnDown {rn_hi_maps = himaps}) _ \r
 699   = return himaps\r
 700 \end{code}\r