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