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