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 mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [a] -> RnM s d [b]
 575 sequenceRn :: [RnM s d a] -> RnM s d [a]
 576 foldlRn :: (b  -> a -> RnM s d b) -> b -> [a] -> RnM s d b
 577 mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
 578 fixRn    :: (a -> RnM s d a) -> RnM s d a
 579
 580 returnRn v gdown ldown  = returnSST v
 581 thenRn m k gdown ldown  = m gdown ldown `thenSST` \ r -> k r gdown ldown
 582 thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
 583 fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
 584 andRn combiner m1 m2 gdown ldown
 585   = m1 gdown ldown `thenSST` \ res1 ->
 586     m2 gdown ldown `thenSST` \ res2 ->
 587     returnSST (combiner res1 res2)
 588
 589 sequenceRn []     = returnRn []
 590 sequenceRn (m:ms) =  m                  `thenRn` \ r ->
 591                      sequenceRn ms      `thenRn` \ rs ->
 592                      returnRn (r:rs)
 593
 594 mapRn f []     = returnRn []
 595 mapRn f (x:xs)
 596   = f x         `thenRn` \ r ->
 597     mapRn f xs  `thenRn` \ rs ->
 598     returnRn (r:rs)
 599
 600 foldlRn k z [] = returnRn z
 601 foldlRn k z (x:xs) = k z x      `thenRn` \ z' ->
 602                      foldlRn k z' xs
 603
 604 mapAndUnzipRn f [] = returnRn ([],[])
 605 mapAndUnzipRn f (x:xs)
 606   = f x                 `thenRn` \ (r1,  r2)  ->
 607     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 608     returnRn (r1:rs1, r2:rs2)
 609
 610 mapAndUnzip3Rn f [] = returnRn ([],[],[])
 611 mapAndUnzip3Rn f (x:xs)
 612   = f x                 `thenRn` \ (r1,  r2,  r3)  ->
 613     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
 614     returnRn (r1:rs1, r2:rs2, r3:rs3)
 615
 616 mapMaybeRn f []     = returnRn []
 617 mapMaybeRn f (x:xs) = f x               `thenRn` \ maybe_r ->
 618                       mapMaybeRn f xs   `thenRn` \ rs ->
 619                       case maybe_r of
 620                         Nothing -> returnRn rs
 621                         Just r  -> returnRn (r:rs)
 622 \end{code}
 623
 624
 625
 626 %************************************************************************
 627 %*                                                                      *
 628 \subsection{Boring plumbing for common part}
 629 %*                                                                      *
 630 %************************************************************************
 631
 632
 633 ================  Errors and warnings =====================
 634
 635 \begin{code}
 636 failWithRn :: a -> Message -> RnM s d a
 637 failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
 638   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 639     writeMutVarSST errs_var (warns, errs `snocBag` err)         `thenSST_`
 640     returnSST res
 641   where
 642     err = addShortErrLocLine loc msg
 643
 644 warnWithRn :: a -> Message -> RnM s d a
 645 warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
 646   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 647     writeMutVarSST errs_var (warns `snocBag` warn, errs)        `thenSST_`
 648     returnSST res
 649   where
 650     warn = addShortWarnLocLine loc msg
 651
 652 addErrRn :: Message -> RnM s d ()
 653 addErrRn err = failWithRn () err
 654
 655 checkRn :: Bool -> Message -> RnM s d ()        -- Check that a condition is true
 656 checkRn False err = addErrRn err
 657 checkRn True  err = returnRn ()
 658
 659 warnCheckRn :: Bool -> Message -> RnM s d ()    -- Check that a condition is true
 660 warnCheckRn False err = addWarnRn err
 661 warnCheckRn True  err = returnRn ()
 662
 663 addWarnRn :: Message -> RnM s d ()
 664 addWarnRn warn = warnWithRn () warn
 665
 666 checkErrsRn :: RnM s d Bool             -- True <=> no errors so far
 667 checkErrsRn (RnDown {rn_errs = errs_var}) l_down
 668   = readMutVarSST  errs_var                                     `thenSST`  \ (warns,errs) ->
 669     returnSST (isEmptyBag errs)
 670 \end{code}
 671
 672
 673 ================  Source location =====================
 674
 675 \begin{code}
 676 pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
 677 pushSrcLocRn loc' m down l_down
 678   = m (down {rn_loc = loc'}) l_down
 679
 680 getSrcLocRn :: RnM s d SrcLoc
 681 getSrcLocRn down l_down
 682   = returnSST (rn_loc down)
 683 \end{code}
 684
 685 ================  Name supply =====================
 686
 687 \begin{code}
 688 getNameSupplyRn :: RnM s d RnNameSupply
 689 getNameSupplyRn rn_down l_down
 690   = readMutVarSST (rn_ns rn_down)
 691
 692 setNameSupplyRn :: RnNameSupply -> RnM s d ()
 693 setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
 694   = writeMutVarSST names_var names'
 695
 696 -- See comments with RnNameSupply above.
 697 newInstUniq :: (OccName, OccName) -> RnM s d Int
 698 newInstUniq key (RnDown {rn_ns = names_var}) l_down
 699   = readMutVarSST names_var                             `thenSST` \ (us, mapInst, cache) ->
 700     let
 701         uniq = case lookupFM mapInst key of
 702                    Just x  -> x+1
 703                    Nothing -> 0
 704         mapInst' = addToFM mapInst key uniq
 705     in
 706     writeMutVarSST names_var (us, mapInst', cache)      `thenSST_`
 707     returnSST uniq
 708
 709 getUniqRn :: RnM s d Unique
 710 getUniqRn (RnDown {rn_ns = names_var}) l_down
 711  = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
 712    let
 713      (us1,us') = splitUniqSupply us
 714    in
 715    writeMutVarSST names_var (us', mapInst, cache)  `thenSST_`
 716    returnSST (uniqFromSupply us1)
 717 \end{code}
 718
 719 ================  Occurrences =====================
 720
 721 Every time we get an occurrence of a name we put it in one of two lists:
 722         one for "compulsory" occurrences
 723         one for "optional" occurrences
 724
 725 The significance of "compulsory" is
 726         (a) we *must* find the declaration
 727         (b) in the case of type or class names, the name is part of the
 728             source level program, and we must slurp in any instance decls
 729             involving it.
 730
 731 We don't need instance decls "optional" names, because the type inference
 732 process will never come across them.  Optional names are buried inside
 733 type checked (but not renamed) cross-module unfoldings and such.
 734
 735 The pair of lists is held in a mutable variable in RnDown.
 736
 737 The lists are kept separate so that we can process all the compulsory occurrences
 738 before any of the optional ones.  Why?  Because suppose we processed an optional
 739 "g", and slurped an interface decl of g::T->T.  Then we'd rename the type T->T in
 740 optional mode.  But if we later need g compulsorily we'll find that it's already
 741 been slurped and will do nothing.  We could, I suppose, rename it a second time,
 742 but it seems simpler just to do all the compulsory ones first.
 743
 744 \begin{code}
 745 addOccurrenceName :: Name -> RnMS s Name        -- Same name returned as passed
 746 addOccurrenceName name (RnDown {rn_loc = loc, rn_occs = occs_var})
 747                        (SDown {rn_mode = mode})
 748   | isLocallyDefinedName name ||
 749     not_necessary necessity
 750   = returnSST name
 751
 752   | otherwise
 753   = readMutVarSST occs_var                      `thenSST` \ (comp_occs, opt_occs) ->
 754     let
 755         new_occ_pair = case necessity of
 756                          Optional   -> (comp_occs, (name,loc):opt_occs)
 757                          Compulsory -> ((name,loc):comp_occs, opt_occs)
 758     in
 759     writeMutVarSST occs_var new_occ_pair        `thenSST_`
 760     returnSST name
 761   where
 762     necessity = modeToNecessity mode
 763
 764
 765 addOccurrenceNames :: [Name] -> RnMS s ()
 766 addOccurrenceNames names (RnDown {rn_loc = loc, rn_occs = occs_var})
 767                          (SDown {rn_mode = mode})
 768   | not_necessary necessity
 769   = returnSST ()
 770
 771   | otherwise
 772   = readMutVarSST occs_var                      `thenSST` \ (comp_occs, opt_occs) ->
 773     let
 774         new_occ_pair = case necessity of
 775                          Optional   -> (comp_occs, non_local_occs ++ opt_occs)
 776                          Compulsory -> (non_local_occs ++ comp_occs, opt_occs)
 777     in
 778     writeMutVarSST occs_var new_occ_pair
 779   where
 780     non_local_occs = [(name, loc) | name <- names, not (isLocallyDefinedName name)]
 781     necessity = modeToNecessity mode
 782
 783         -- Never look for optional things if we're
 784         -- ignoring optional input interface information
 785 not_necessary Compulsory = False
 786 not_necessary Optional   = opt_IgnoreIfacePragmas
 787
 788 popOccurrenceName :: RnMode -> RnM s d (Maybe Occurrence)
 789 popOccurrenceName mode (RnDown {rn_occs = occs_var}) l_down
 790   = readMutVarSST occs_var                      `thenSST` \ occs ->
 791     case (mode, occs) of
 792                 -- Find a compulsory occurrence
 793         (InterfaceMode Compulsory, (comp:comps, opts))
 794                 -> writeMutVarSST occs_var (comps, opts)        `thenSST_`
 795                    returnSST (Just comp)
 796
 797                 -- Find an optional occurrence
 798                 -- We shouldn't be looking unless we've done all the compulsories
 799         (InterfaceMode Optional, (comps, opt:opts))
 800                 -> ASSERT2( null comps, ppr comps )
 801                    writeMutVarSST occs_var (comps, opts)        `thenSST_`
 802                    returnSST (Just opt)
 803
 804                 -- No suitable occurrence
 805         other -> returnSST Nothing
 806
 807 -- discardOccurrencesRn does the enclosed thing with a *fresh* occurrences
 808 -- variable, and discards the list of occurrences thus found.  It's useful
 809 -- when loading instance decls and specialisation signatures, when we want to
 810 -- know the names of the things in the types, but we don't want to treat them
 811 -- as occurrences.
 812
 813 discardOccurrencesRn :: RnM s d a -> RnM s d a
 814 discardOccurrencesRn enclosed_thing rn_down l_down
 815   = newMutVarSST ([],[])                                                `thenSST` \ new_occs_var ->
 816     enclosed_thing (rn_down {rn_occs = new_occs_var}) l_down
 817 \end{code}
 818
 819
 820 ================  Module =====================
 821
 822 \begin{code}
 823 getModuleRn :: RnM s d Module
 824 getModuleRn (RnDown {rn_mod = mod_name}) l_down
 825   = returnSST mod_name
 826
 827 setModuleRn :: Module -> RnM s d a -> RnM s d a
 828 setModuleRn new_mod enclosed_thing rn_down l_down
 829   = enclosed_thing (rn_down {rn_mod = new_mod}) l_down
 830 \end{code}
 831
 832 \begin{code}
 833 setOmitQualFn :: (Name -> Bool) -> RnM s d a -> RnM s d a
 834 setOmitQualFn fn m g_down l_down = m (g_down { rn_omit = fn }) l_down
 835
 836 getOmitQualFn :: RnM s d (Name -> Bool)
 837 getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down
 838   = returnSST omit_fn
 839 \end{code}
 840
 841 %************************************************************************
 842 %*                                                                      *
 843 \subsection{Plumbing for rename-source part}
 844 %*                                                                      *
 845 %************************************************************************
 846
 847 ================  RnEnv  =====================
 848
 849 \begin{code}
 850 getNameEnvs :: RnMS s (GlobalRdrEnv, LocalRdrEnv)
 851 getNameEnvs rn_down (SDown {rn_genv = RnEnv global_env fixity_env, rn_lenv = local_env})
 852   = returnSST (global_env, local_env)
 853
 854 getLocalNameEnv :: RnMS s LocalRdrEnv
 855 getLocalNameEnv rn_down (SDown {rn_lenv = local_env})
 856   = returnSST local_env
 857
 858 setLocalNameEnv :: LocalRdrEnv -> RnMS s a -> RnMS s a
 859 setLocalNameEnv local_env' m rn_down l_down
 860   = m rn_down (l_down {rn_lenv = local_env'})
 861
 862 getFixityEnv :: RnMS s FixityEnv
 863 getFixityEnv rn_down (SDown {rn_genv = RnEnv name_env fixity_env})
 864   = returnSST fixity_env
 865
 866 extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS s a -> RnMS s a
 867 extendFixityEnv fixes enclosed_scope
 868                 rn_down l_down@(SDown {rn_genv = RnEnv name_env fixity_env})
 869   = let
 870         new_fixity_env = extendNameEnv fixity_env fixes
 871     in
 872     enclosed_scope rn_down (l_down {rn_genv = RnEnv name_env new_fixity_env})
 873 \end{code}
 874
 875 ================  Mode  =====================
 876
 877 \begin{code}
 878 getModeRn :: RnMS s RnMode
 879 getModeRn rn_down (SDown {rn_mode = mode})
 880   = returnSST mode
 881
 882 setModeRn :: RnMode -> RnMS s a -> RnMS s a
 883 setModeRn new_mode thing_inside rn_down l_down
 884   = thing_inside rn_down (l_down {rn_mode = new_mode})
 885 \end{code}
 886
 887
 888 %************************************************************************
 889 %*                                                                      *
 890 \subsection{Plumbing for rename-globals part}
 891 %*                                                                      *
 892 %************************************************************************
 893
 894 \begin{code}
 895 getIfacesRn :: RnMG Ifaces
 896 getIfacesRn rn_down (GDown {rn_ifaces = iface_var})
 897   = readMutVarSST iface_var
 898
 899 setIfacesRn :: Ifaces -> RnMG ()
 900 setIfacesRn ifaces rn_down (GDown {rn_ifaces = iface_var})
 901   = writeMutVarSST iface_var ifaces
 902
 903 getModuleHiMap :: Bool -> RnM s d ModuleHiMap
 904 getModuleHiMap want_hi_boot (RnDown {rn_hi_map = himap, rn_hiboot_map = hibmap}) _
 905   | want_hi_boot = returnSST hibmap
 906   | otherwise    = returnSST himap
 907 \end{code}
 908
 909 The interface file format is capable of distinguishing
 910 between normal imports/exports of names from other modules
 911 and 'hi-boot' mentions of names, with the flavour in the
 912 being encoded inside a @Module@.
 913
 914 @setModuleFlavourRn@ fixes up @Module@ values containing
 915 normal flavours, returning a @Module@ value containing
 916 the attributes of the module that's in scope. The only
 917 attribute at the moment is the DLLness of a module, i.e.,
 918 whether the object code for that module resides in a
 919 Win32 DLL or not.
 920
 921 \begin{code}
 922 setModuleFlavourRn :: Module -> RnM s d Module
 923 setModuleFlavourRn mod
 924   | bootFlavour hif = returnRn mod
 925   | otherwise       =
 926      getModuleHiMap (bootFlavour hif) `thenRn` \ himap ->
 927      case (lookupFM himap mod_pstr) of
 928        Nothing -> returnRn mod
 929        Just (_, is_in_a_dll) ->
 930            returnRn (setModuleFlavour (mkDynFlavour is_in_a_dll hif) mod)
 931     where
 932       mod_pstr = moduleString mod
 933       hif      = moduleIfaceFlavour mod
 934
 935 \end{code}
 936
 937 %************************************************************************
 938 %*                                                                      *
 939 \subsection{HowInScope}
 940 %*                                                                      *
 941 %************************************************************************
 942
 943 \begin{code}
 944 modeToNecessity SourceMode                = Compulsory
 945 modeToNecessity (InterfaceMode necessity) = necessity
 946 \end{code}