ghc/compiler/rename/Rename.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1998
   3 %
   4 \section[Rename]{Renaming and dependency analysis passes}
   5
   6 \begin{code}
   7 module Rename ( renameModule ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn
  12 import HsPragmas        ( DataPragmas(..) )
  13 import RdrHsSyn         ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
  14 import RnHsSyn          ( RenamedHsModule, RenamedHsDecl,
  15                           extractHsTyNames, extractHsCtxtTyNames
  16                         )
  17
  18 import CmdLineOpts      ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports,
  19                           opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations,
  20                           opt_WarnUnusedBinds
  21                         )
  22 import RnMonad
  23 import RnNames          ( getGlobalNames )
  24 import RnSource         ( rnSourceDecls, rnDecl )
  25 import RnIfaces         ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports,
  26                           getImportedRules, getSlurped, removeContext,
  27                           loadBuiltinRules, getDeferredDecls, ImportDeclResult(..)
  28                         )
  29 import RnEnv            ( availName, availsToNameSet,
  30                           emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv,
  31                           warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
  32                           lookupOrigNames, unknownNameErr,
  33                           FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
  34                         )
  35 import Module           ( Module, ModuleName, WhereFrom(..),
  36                           moduleNameUserString, mkSearchPath, moduleName, mkThisModule
  37                         )
  38 import Name             ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
  39                           nameOccName, nameUnique, nameModule, maybeUserImportedFrom,
  40                           isUserImportedExplicitlyName, isUserImportedName,
  41                           maybeWiredInTyConName, maybeWiredInIdName,
  42                           isUserExportedName, toRdrName,
  43                           nameEnvElts, extendNameEnv
  44                         )
  45 import OccName          ( occNameFlavour, isValOcc )
  46 import Id               ( idType )
  47 import TyCon            ( isSynTyCon, getSynTyConDefn )
  48 import NameSet
  49 import TysWiredIn       ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
  50 import PrelRules        ( builtinRules )
  51 import PrelNames        ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
  52                           ioTyCon_RDR,
  53                           unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
  54                           eqString_RDR
  55                         )
  56 import PrelInfo         ( fractionalClassKeys, derivingOccurrences )
  57 import Type             ( namesOfType, funTyCon )
  58 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet, ghcExit )
  59 import BasicTypes       ( Version, initialVersion )
  60 import Bag              ( isEmptyBag, bagToList )
  61 import FiniteMap        ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
  62                           addToFM_C, elemFM, addToFM
  63                         )
  64 import UniqSupply       ( UniqSupply )
  65 import UniqFM           ( lookupUFM )
  66 import SrcLoc           ( noSrcLoc )
  67 import Maybes           ( maybeToBool, expectJust )
  68 import Outputable
  69 import IO               ( openFile, IOMode(..) )
  70 \end{code}
  71
  72
  73
  74 \begin{code}
  75 type RenameResult = ( Module            -- This module
  76                     , RenamedHsModule   -- Renamed module
  77                     , Maybe ParsedIface -- The existing interface file, if any
  78                     , ParsedIface       -- The new interface
  79                     , RnNameSupply      -- Final env; for renaming derivings
  80                     , FixityEnv         -- The fixity environment; for derivings
  81                     , [Module])         -- Imported modules
  82
  83 renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult)
  84 renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc)
  85   =     -- Initialise the renamer monad
  86     do {
  87         ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag)
  88            <- initRn (mkThisModule mod_name) us
  89                      (mkSearchPath opt_HiMap) loc
  90                      (rename this_mod) ;
  91
  92         -- Check for warnings
  93         printErrorsAndWarnings rn_errs_bag rn_warns_bag ;
  94
  95         -- Dump any debugging output
  96         dump_action ;
  97
  98         -- Return results
  99         if not (isEmptyBag rn_errs_bag) then
 100             do { ghcExit 1 ; return Nothing }
 101         else
 102             return maybe_rn_stuff
 103     }
 104 \end{code}
 105
 106 \begin{code}
 107 rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ())
 108 rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
 109   =     -- FIND THE GLOBAL NAME ENVIRONMENT
 110     getGlobalNames this_mod                     `thenRn` \ maybe_stuff ->
 111
 112         -- CHECK FOR EARLY EXIT
 113     case maybe_stuff of {
 114         Nothing ->      -- Everything is up to date; no need to recompile further
 115                 rnDump [] []            `thenRn` \ dump_action ->
 116                 returnRn (Nothing, dump_action) ;
 117
 118         Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface) ->
 119
 120         -- DEAL WITH DEPRECATIONS
 121     rnDeprecs local_gbl_env mod_deprec local_decls      `thenRn` \ my_deprecs ->
 122
 123         -- DEAL WITH LOCAL FIXITIES
 124     fixitiesFromLocalDecls local_gbl_env local_decls    `thenRn` \ local_fixity_env ->
 125
 126         -- RENAME THE SOURCE
 127     initRnMS gbl_env local_fixity_env SourceMode (
 128         rnSourceDecls local_decls
 129     )                                   `thenRn` \ (rn_local_decls, source_fvs) ->
 130
 131         -- SLURP IN ALL THE NEEDED DECLARATIONS
 132     implicitFVs mod_name rn_local_decls         `thenRn` \ implicit_fvs ->
 133     let
 134                 -- The export_fvs make the exported names look just as if they
 135                 -- occurred in the source program.  For the reasoning, see the
 136                 -- comments with RnIfaces.getImportVersions.
 137                 -- We only need the 'parent name' of the avail;
 138                 -- that's enough to suck in the declaration.
 139         export_fvs      = mkNameSet (map availName export_avails)
 140         real_source_fvs = source_fvs `plusFV` export_fvs
 141
 142         slurp_fvs       = implicit_fvs `plusFV` real_source_fvs
 143                 -- It's important to do the "plus" this way round, so that
 144                 -- when compiling the prelude, locally-defined (), Bool, etc
 145                 -- override the implicit ones.
 146     in
 147     loadBuiltinRules builtinRules       `thenRn_`
 148     slurpImpDecls slurp_fvs             `thenRn` \ rn_imp_decls ->
 149
 150         -- EXIT IF ERRORS FOUND
 151     rnDump rn_imp_decls rn_local_decls          `thenRn` \ dump_action ->
 152     checkErrsRn                                 `thenRn` \ no_errs_so_far ->
 153     if not no_errs_so_far then
 154         -- Found errors already, so exit now
 155         returnRn (Nothing, dump_action)
 156     else
 157
 158         -- GENERATE THE VERSION/USAGE INFO
 159     mkImportExportInfo mod_name export_avails exports   `thenRn` \ (my_exports, my_usages) ->
 160
 161         -- RETURN THE RENAMED MODULE
 162     getNameSupplyRn                     `thenRn` \ name_supply ->
 163     getIfacesRn                         `thenRn` \ ifaces ->
 164     let
 165         direct_import_mods :: [Module]
 166         direct_import_mods = [m | (_, _, Just (m, _, _, _, imp, _))
 167                                   <- eltsFM (iImpModInfo ifaces), user_import imp]
 168
 169                 -- *don't* just pick the forward edges.  It's entirely possible
 170                 -- that a module is only reachable via back edges.
 171         user_import ImportByUser = True
 172         user_import ImportByUserSource = True
 173         user_import _ = False
 174
 175         this_module        = mkThisModule mod_name
 176
 177         -- Export only those fixities that are for names that are
 178         --      (a) defined in this module
 179         --      (b) exported
 180         exported_fixities
 181           = [ FixitySig (toRdrName name) fixity loc
 182             | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
 183               isUserExportedName name
 184             ]
 185
 186         new_iface = ParsedIface { pi_mod     = this_module
 187                                 , pi_vers    = initialVersion
 188                                 , pi_orphan  = any isOrphanDecl rn_local_decls
 189                                 , pi_exports = my_exports
 190                                 , pi_usages  = my_usages
 191                                 , pi_fixity  = (initialVersion, exported_fixities)
 192                                 , pi_deprecs = my_deprecs
 193                                         -- These ones get filled in later
 194                                 , pi_insts = [], pi_decls = []
 195                                 , pi_rules = (initialVersion, [])
 196                         }
 197
 198         renamed_module = HsModule mod_name vers
 199                                   trashed_exports trashed_imports
 200                                   (rn_local_decls ++ rn_imp_decls)
 201                                   mod_deprec
 202                                   loc
 203
 204         result = (this_module,   renamed_module,
 205                   old_iface,   new_iface,
 206                   name_supply, local_fixity_env,
 207                   direct_import_mods)
 208     in
 209
 210         -- REPORT UNUSED NAMES, AND DEBUG DUMP
 211     reportUnusedNames mod_name direct_import_mods
 212                       gbl_env global_avail_env
 213                       export_avails source_fvs
 214                       rn_imp_decls                      `thenRn_`
 215
 216     returnRn (Just result, dump_action) }
 217   where
 218     trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
 219     trashed_imports  = {-trace "rnSource:trashed_imports"-} []
 220 \end{code}
 221
 222 @implicitFVs@ forces the renamer to slurp in some things which aren't
 223 mentioned explicitly, but which might be needed by the type checker.
 224
 225 \begin{code}
 226 implicitFVs mod_name decls
 227   = lookupOrigNames implicit_occs                       `thenRn` \ implicit_names ->
 228     returnRn (mkNameSet (map getName default_tycons)    `plusFV`
 229               implicit_names)
 230   where
 231         -- Add occurrences for Int, and (), because they
 232         -- are the types to which ambigious type variables may be defaulted by
 233         -- the type checker; so they won't always appear explicitly.
 234         -- [The () one is a GHC extension for defaulting CCall results.]
 235         -- ALSO: funTyCon, since it occurs implicitly everywhere!
 236         --       (we don't want to be bothered with making funTyCon a
 237         --        free var at every function application!)
 238         -- Double is dealt with separately in getGates
 239     default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
 240
 241         -- Add occurrences for IO or PrimIO
 242     implicit_main |  mod_name == mAIN_Name
 243                   || mod_name == pREL_MAIN_Name = [ioTyCon_RDR]
 244                   |  otherwise                  = []
 245
 246         -- Now add extra "occurrences" for things that
 247         -- the deriving mechanism, or defaulting, will later need in order to
 248         -- generate code
 249     implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
 250
 251         -- Virtually every program has error messages in it somewhere
 252     string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
 253                    eqString_RDR]
 254
 255     get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _))
 256        = concat (map get_deriv deriv_classes)
 257     get other = []
 258
 259     get_deriv cls = case lookupUFM derivingOccurrences cls of
 260                         Nothing   -> []
 261                         Just occs -> occs
 262 \end{code}
 263
 264 \begin{code}
 265 isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
 266   = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty)))
 267         -- The 'removeContext' is because of
 268         --      instance Foo a => Baz T where ...
 269         -- The decl is an orphan if Baz and T are both not locally defined,
 270         --      even if Foo *is* locally defined
 271
 272 isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _))
 273   = check lhs
 274   where
 275         -- At the moment we just check for common LHS forms
 276         -- Expand as necessary.  Getting it wrong just means
 277         -- more orphans than necessary
 278     check (HsVar v)       = not (isLocallyDefined v)
 279     check (HsApp f a)     = check f && check a
 280     check (HsLit _)       = False
 281     check (HsOverLit _)   = False
 282     check (OpApp l o _ r) = check l && check o && check r
 283     check (NegApp e _)    = check e
 284     check (HsPar e)       = check e
 285     check (SectionL e o)  = check e && check o
 286     check (SectionR o e)  = check e && check o
 287
 288     check other           = True        -- Safe fall through
 289
 290 isOrphanDecl other = False
 291 \end{code}
 292
 293
 294 \begin{code}
 295 dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
 296   = pushSrcLocRn locn1  $
 297     addErrRn msg
 298   where
 299     msg = hang (ptext SLIT("Multiple default declarations"))
 300                4  (vcat (map pp dup_things))
 301     pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
 302 \end{code}
 303
 304
 305 %*********************************************************
 306 %*                                                       *
 307 \subsection{Slurping declarations}
 308 %*                                                       *
 309 %*********************************************************
 310
 311 \begin{code}
 312 -------------------------------------------------------
 313 slurpImpDecls source_fvs
 314   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
 315
 316         -- The current slurped-set records all local things
 317     getSlurped                                  `thenRn` \ source_binders ->
 318     slurpSourceRefs source_binders source_fvs   `thenRn` \ (decls, needed) ->
 319
 320         -- Then get everything else
 321     closeDecls decls needed                     `thenRn` \ decls1 ->
 322
 323         -- Finally, get any deferred data type decls
 324     slurpDeferredDecls decls1                   `thenRn` \ final_decls ->
 325
 326     returnRn final_decls
 327
 328 -------------------------------------------------------
 329 slurpSourceRefs :: NameSet                      -- Variables defined in source
 330                 -> FreeVars                     -- Variables referenced in source
 331                 -> RnMG ([RenamedHsDecl],
 332                          FreeVars)              -- Un-satisfied needs
 333 -- The declaration (and hence home module) of each gate has
 334 -- already been loaded
 335
 336 slurpSourceRefs source_binders source_fvs
 337   = go_outer []                         -- Accumulating decls
 338              emptyFVs                   -- Unsatisfied needs
 339              emptyFVs                   -- Accumulating gates
 340              (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
 341   where
 342         -- The outer loop repeatedly slurps the decls for the current gates
 343         -- and the instance decls
 344
 345         -- The outer loop is needed because consider
 346         --      instance Foo a => Baz (Maybe a) where ...
 347         -- It may be that @Baz@ and @Maybe@ are used in the source module,
 348         -- but not @Foo@; so we need to chase @Foo@ too.
 349         --
 350         -- We also need to follow superclass refs.  In particular, 'chasing @Foo@' must
 351         -- include actually getting in Foo's class decl
 352         --      class Wib a => Foo a where ..
 353         -- so that its superclasses are discovered.  The point is that Wib is a gate too.
 354         -- We do this for tycons too, so that we look through type synonyms.
 355
 356     go_outer decls fvs all_gates []
 357         = returnRn (decls, fvs)
 358
 359     go_outer decls fvs all_gates refs   -- refs are not necessarily slurped yet
 360         = traceRn (text "go_outer" <+> ppr refs)                `thenRn_`
 361           foldlRn go_inner (decls, fvs, emptyFVs) refs          `thenRn` \ (decls1, fvs1, gates1) ->
 362           getImportedInstDecls (all_gates `plusFV` gates1)      `thenRn` \ inst_decls ->
 363           rnInstDecls decls1 fvs1 gates1 inst_decls             `thenRn` \ (decls2, fvs2, gates2) ->
 364           go_outer decls2 fvs2 (all_gates `plusFV` gates2)
 365                                (nameSetToList (gates2 `minusNameSet` all_gates))
 366                 -- Knock out the all_gates because even if we don't slurp any new
 367                 -- decls we can get some apparently-new gates from wired-in names
 368
 369     go_inner (decls, fvs, gates) wanted_name
 370         = importDecl wanted_name                `thenRn` \ import_result ->
 371           case import_result of
 372             AlreadySlurped -> returnRn (decls, fvs, gates)
 373             WiredIn        -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
 374             Deferred       -> returnRn (decls, fvs, gates `addOneFV` wanted_name)       -- It's a type constructor
 375
 376             HereItIs decl -> rnIfaceDecl decl           `thenRn` \ (new_decl, fvs1) ->
 377                              returnRn (new_decl : decls,
 378                                        fvs1 `plusFV` fvs,
 379                                        gates `plusFV` getGates source_fvs new_decl)
 380
 381 rnInstDecls decls fvs gates []
 382   = returnRn (decls, fvs, gates)
 383 rnInstDecls decls fvs gates (d:ds)
 384   = rnIfaceDecl d               `thenRn` \ (new_decl, fvs1) ->
 385     rnInstDecls (new_decl:decls)
 386                 (fvs1 `plusFV` fvs)
 387                 (gates `plusFV` getInstDeclGates new_decl)
 388                 ds
 389 \end{code}
 390
 391
 392 \begin{code}
 393 -------------------------------------------------------
 394 -- closeDecls keeps going until the free-var set is empty
 395 closeDecls decls needed
 396   | not (isEmptyFVs needed)
 397   = slurpDecls decls needed     `thenRn` \ (decls1, needed1) ->
 398     closeDecls decls1 needed1
 399
 400   | otherwise
 401   = getImportedRules                    `thenRn` \ rule_decls ->
 402     case rule_decls of
 403         []    -> returnRn decls -- No new rules, so we are done
 404         other -> rnIfaceDecls decls emptyFVs rule_decls         `thenRn` \ (decls1, needed1) ->
 405                  closeDecls decls1 needed1
 406
 407
 408 -------------------------------------------------------
 409 -- Augment decls with any decls needed by needed.
 410 -- Return also free vars of the new decls (only)
 411 slurpDecls decls needed
 412   = go decls emptyFVs (nameSetToList needed)
 413   where
 414     go decls fvs []         = returnRn (decls, fvs)
 415     go decls fvs (ref:refs) = slurpDecl decls fvs ref   `thenRn` \ (decls1, fvs1) ->
 416                               go decls1 fvs1 refs
 417
 418 -------------------------------------------------------
 419 slurpDecl decls fvs wanted_name
 420   = importDecl wanted_name              `thenRn` \ import_result ->
 421     case import_result of
 422         -- Found a declaration... rename it
 423         HereItIs decl -> rnIfaceDecl decl               `thenRn` \ (new_decl, fvs1) ->
 424                          returnRn (new_decl:decls, fvs1 `plusFV` fvs)
 425
 426         -- No declaration... (wired in thing, or deferred, or already slurped)
 427         other -> returnRn (decls, fvs)
 428
 429
 430 -------------------------------------------------------
 431 rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
 432              -> [(Module, RdrNameHsDecl)]
 433              -> RnM d ([RenamedHsDecl], FreeVars)
 434 rnIfaceDecls decls fvs []     = returnRn (decls, fvs)
 435 rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d           `thenRn` \ (new_decl, fvs1) ->
 436                                 rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
 437
 438 rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
 439 \end{code}
 440
 441
 442 %*********************************************************
 443 %*                                                       *
 444 \subsection{Deferred declarations}
 445 %*                                                       *
 446 %*********************************************************
 447
 448 The idea of deferred declarations is this.  Suppose we have a function
 449         f :: T -> Int
 450         data T = T1 A | T2 B
 451         data A = A1 X | A2 Y
 452         data B = B1 P | B2 Q
 453 Then we don't want to load T and all its constructors, and all
 454 the types those constructors refer to, and all the types *those*
 455 constructors refer to, and so on.  That might mean loading many more
 456 interface files than is really necessary.  So we 'defer' loading T.
 457
 458 But f might be strict, and the calling convention for evaluating
 459 values of type T depends on how many constructors T has, so
 460 we do need to load T, but not the full details of the type T.
 461 So we load the full decl for T, but only skeleton decls for A and B:
 462         f :: T -> Int
 463         data T = {- 2 constructors -}
 464
 465 Whether all this is worth it is moot.
 466
 467 \begin{code}
 468 slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
 469 slurpDeferredDecls decls
 470   = getDeferredDecls                                            `thenRn` \ def_decls ->
 471     rnIfaceDecls decls emptyFVs (map stripDecl def_decls)       `thenRn` \ (decls1, fvs) ->
 472     ASSERT( isEmptyFVs fvs )
 473     returnRn decls1
 474
 475 stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2))
 476   = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc
 477                 name1 name2))
 478         -- Nuke the context and constructors
 479         -- But retain the *number* of constructors!
 480         -- Also the tvs will have kinds on them.
 481 \end{code}
 482
 483
 484 %*********************************************************
 485 %*                                                       *
 486 \subsection{Extracting the `gates'}
 487 %*                                                       *
 488 %*********************************************************
 489
 490 When we import a declaration like
 491 \begin{verbatim}
 492         data T = T1 Wibble | T2 Wobble
 493 \end{verbatim}
 494 we don't want to treat @Wibble@ and @Wobble@ as gates
 495 {\em unless} @T1@, @T2@ respectively are mentioned by the user program.
 496 If only @T@ is mentioned
 497 we want only @T@ to be a gate;
 498 that way we don't suck in useless instance
 499 decls for (say) @Eq Wibble@, when they can't possibly be useful.
 500
 501 @getGates@ takes a newly imported (and renamed) decl, and the free
 502 vars of the source program, and extracts from the decl the gate names.
 503
 504 \begin{code}
 505 getGates source_fvs (SigD (IfaceSig _ ty _ _))
 506   = extractHsTyNames ty
 507
 508 getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ ))
 509   = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
 510                         (hsTyVarNames tvs)
 511      `addOneToNameSet` cls)
 512     `plusFV` maybe_double
 513   where
 514     get (ClassOpSig n _ ty _)
 515         | n `elemNameSet` source_fvs = extractHsTyNames ty
 516         | otherwise                  = emptyFVs
 517
 518         -- If we load any numeric class that doesn't have
 519         -- Int as an instance, add Double to the gates.
 520         -- This takes account of the fact that Double might be needed for
 521         -- defaulting, but we don't want to load Double (and all its baggage)
 522         -- if the more exotic classes aren't used at all.
 523     maybe_double | nameUnique cls `elem` fractionalClassKeys
 524                  = unitFV (getName doubleTyCon)
 525                  | otherwise
 526                  = emptyFVs
 527
 528 getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
 529   = delListFromNameSet (extractHsTyNames ty)
 530                        (hsTyVarNames tvs)
 531         -- A type synonym type constructor isn't a "gate" for instance decls
 532
 533 getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _))
 534   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
 535                        (hsTyVarNames tvs)
 536     `addOneToNameSet` tycon
 537   where
 538     get (ConDecl n _ tvs ctxt details _)
 539         | n `elemNameSet` source_fvs
 540                 -- If the constructor is method, get fvs from all its fields
 541         = delListFromNameSet (get_details details `plusFV`
 542                               extractHsCtxtTyNames ctxt)
 543                              (hsTyVarNames tvs)
 544     get (ConDecl n _ tvs ctxt (RecCon fields) _)
 545                 -- Even if the constructor isn't mentioned, the fields
 546                 -- might be, as selectors.  They can't mention existentially
 547                 -- bound tyvars (typechecker checks for that) so no need for
 548                 -- the deleteListFromNameSet part
 549         = foldr (plusFV . get_field) emptyFVs fields
 550
 551     get other_con = emptyFVs
 552
 553     get_details (VanillaCon tys) = plusFVs (map get_bang tys)
 554     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
 555     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
 556
 557     get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
 558                      | otherwise                         = emptyFVs
 559
 560     get_bang bty = extractHsTyNames (getBangType bty)
 561
 562 getGates source_fvs other_decl = emptyFVs
 563 \end{code}
 564
 565 @getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
 566 rather than a declaration.
 567
 568 \begin{code}
 569 getWiredInGates :: Name -> FreeVars
 570 getWiredInGates name    -- No classes are wired in
 571   | is_id                = getWiredInGates_s (namesOfType (idType the_id))
 572   | isSynTyCon the_tycon = getWiredInGates_s
 573          (delListFromNameSet (namesOfType ty) (map getName tyvars))
 574   | otherwise            = unitFV name
 575   where
 576     maybe_wired_in_id    = maybeWiredInIdName name
 577     is_id                = maybeToBool maybe_wired_in_id
 578     maybe_wired_in_tycon = maybeWiredInTyConName name
 579     Just the_id          = maybe_wired_in_id
 580     Just the_tycon       = maybe_wired_in_tycon
 581     (tyvars,ty)          = getSynTyConDefn the_tycon
 582
 583 getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
 584 \end{code}
 585
 586 \begin{code}
 587 getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
 588 getInstDeclGates other                              = emptyFVs
 589 \end{code}
 590
 591
 592 %*********************************************************
 593 %*                                                       *
 594 \subsection{Fixities}
 595 %*                                                       *
 596 %*********************************************************
 597
 598 \begin{code}
 599 fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
 600 fixitiesFromLocalDecls gbl_env decls
 601   = foldlRn getFixities emptyNameEnv decls                              `thenRn` \ env ->
 602     traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))    `thenRn_`
 603     returnRn env
 604   where
 605     getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
 606     getFixities acc (FixD fix)
 607       = fix_decl acc fix
 608
 609     getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ ))
 610       = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
 611                 -- Get fixities from class decl sigs too.
 612     getFixities acc other_decl
 613       = returnRn acc
 614
 615     fix_decl acc sig@(FixitySig rdr_name fixity loc)
 616         =       -- Check for fixity decl for something not declared
 617           case lookupRdrEnv gbl_env rdr_name of {
 618             Nothing | opt_WarnUnusedBinds
 619                     -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
 620                        `thenRn_` returnRn acc
 621                     | otherwise -> returnRn acc ;
 622
 623             Just (name:_) ->
 624
 625                 -- Check for duplicate fixity decl
 626           case lookupNameEnv acc name of {
 627             Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
 628                                          `thenRn_` returnRn acc ;
 629
 630             Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
 631           }}
 632 \end{code}
 633
 634
 635 %*********************************************************
 636 %*                                                       *
 637 \subsection{Deprecations}
 638 %*                                                       *
 639 %*********************************************************
 640
 641 For deprecations, all we do is check that the names are in scope.
 642 It's only imported deprecations, dealt with in RnIfaces, that we
 643 gather them together.
 644
 645 \begin{code}
 646 rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
 647            -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation]
 648 rnDeprecs gbl_env mod_deprec decls
 649  = mapRn rn_deprec deprecs      `thenRn_`
 650    returnRn (extra_deprec ++ deprecs)
 651  where
 652    deprecs = [d | DeprecD d <- decls]
 653    extra_deprec = case mod_deprec of
 654                    Nothing  -> []
 655                    Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc]
 656
 657    rn_deprec (Deprecation ie txt loc)
 658      = pushSrcLocRn loc         $
 659        mapRn check (ieNames ie)
 660
 661    check n = case lookupRdrEnv gbl_env n of
 662                 Nothing -> addErrRn (unknownNameErr n)
 663                 Just _  -> returnRn ()
 664 \end{code}
 665
 666
 667 %*********************************************************
 668 %*                                                       *
 669 \subsection{Unused names}
 670 %*                                                       *
 671 %*********************************************************
 672
 673 \begin{code}
 674 reportUnusedNames :: ModuleName -> [Module]
 675                   -> GlobalRdrEnv -> AvailEnv
 676                   -> Avails -> NameSet -> [RenamedHsDecl]
 677                   -> RnMG ()
 678 reportUnusedNames mod_name direct_import_mods
 679                   gbl_env avail_env
 680                   export_avails mentioned_names
 681                   imported_decls
 682   = let
 683         used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 684
 685         -- Now, a use of C implies a use of T,
 686         -- if C was brought into scope by T(..) or T(C)
 687         really_used_names = used_names `unionNameSets`
 688           mkNameSet [ availName parent_avail
 689                     | sub_name <- nameSetToList used_names
 690                     , isValOcc (getOccName sub_name)
 691
 692                         -- Usually, every used name will appear in avail_env, but there
 693                         -- is one time when it doesn't: tuples and other built in syntax.  When you
 694                         -- write (a,b) that gives rise to a *use* of "(,)", so that the
 695                         -- instances will get pulled in, but the tycon "(,)" isn't actually
 696                         -- in scope.  Hence the isValOcc filter.
 697                         --
 698                         -- Also, (-x) gives rise to an implicit use of 'negate'; similarly,
 699                         --   3.5 gives rise to an implcit use of :%
 700                         -- hence the isUserImportedName filter on the warning
 701
 702                     , let parent_avail
 703                             = case lookupNameEnv avail_env sub_name of
 704                                 Just avail -> avail
 705                                 Nothing -> WARN( isUserImportedName sub_name,
 706                                                  text "reportUnusedName: not in avail_env" <+>
 707                                                         ppr sub_name )
 708                                            Avail sub_name
 709
 710                     , case parent_avail of { AvailTC _ _ -> True; other -> False }
 711                     ]
 712
 713         defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
 714         defined_but_not_used =
 715            nameSetToList (defined_names `minusNameSet` really_used_names)
 716
 717         -- Filter out the ones only defined implicitly
 718         bad_locals     = [n | n <- defined_but_not_used, isLocallyDefined             n]
 719         bad_imp_names  = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n,
 720                                                          not (module_unused n)]
 721
 722         deprec_used deprec_env = [ (n,txt)
 723                                  | n <- nameSetToList mentioned_names,
 724                                    not (isLocallyDefined n),
 725                                    Just txt <- [lookupNameEnv deprec_env n] ]
 726
 727         -- inst_mods are directly-imported modules that
 728         --      contain instance decl(s) that the renamer decided to suck in
 729         -- It's not necessarily redundant to import such modules.
 730         --
 731         -- NOTE: Consider
 732         --            module This
 733         --              import M ()
 734         --
 735         --       The import M() is not *necessarily* redundant, even if
 736         --       we suck in no instance decls from M (e.g. it contains
 737         --       no instance decls, or This contains no code).  It may be
 738         --       that we import M solely to ensure that M's orphan instance
 739         --       decls (or those in its imports) are visible to people who
 740         --       import This.  Sigh.
 741         --       There's really no good way to detect this, so the error message
 742         --       in RnEnv.warnUnusedModules is weakened instead
 743         inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
 744                          let m = nameModule dfun,
 745                          m `elem` direct_import_mods
 746                     ]
 747
 748         minimal_imports :: FiniteMap Module AvailEnv
 749         minimal_imports0 = emptyFM
 750         minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names
 751         minimal_imports  = foldr   add_inst_mod minimal_imports1 inst_mods
 752
 753         add_name n acc = case maybeUserImportedFrom n of
 754                            Nothing -> acc
 755                            Just m  -> addToFM_C plusAvailEnv acc m
 756                                                 (unitAvailEnv (mk_avail n))
 757         add_inst_mod m acc
 758           | m `elemFM` acc = acc        -- We import something already
 759           | otherwise      = addToFM acc m emptyAvailEnv
 760                 -- Add an empty collection of imports for a module
 761                 -- from which we have sucked only instance decls
 762
 763         mk_avail n = case lookupNameEnv avail_env n of
 764                         Just (AvailTC m _) | n==m      -> AvailTC n [n]
 765                                            | otherwise -> AvailTC m [n,m]
 766                         Just avail         -> Avail n
 767                         Nothing            -> pprPanic "mk_avail" (ppr n)
 768
 769         -- unused_imp_mods are the directly-imported modules
 770         -- that are not mentioned in minimal_imports
 771         unused_imp_mods = [m | m <- direct_import_mods,
 772                                not (maybeToBool (lookupFM minimal_imports m)),
 773                                moduleName m /= pRELUDE_Name]
 774
 775         module_unused :: Name -> Bool
 776         -- Name is imported from a module that's completely unused,
 777         -- so don't report stuff about the name (the module covers it)
 778         module_unused n = expectJust "module_unused" (maybeUserImportedFrom n)
 779                           `elem` unused_imp_mods
 780                                 -- module_unused is only called if it's user-imported
 781     in
 782     warnUnusedModules unused_imp_mods                           `thenRn_`
 783     warnUnusedLocalBinds bad_locals                             `thenRn_`
 784     warnUnusedImports bad_imp_names                             `thenRn_`
 785     printMinimalImports mod_name minimal_imports                `thenRn_`
 786     getIfacesRn                                                 `thenRn` \ ifaces ->
 787     (if opt_WarnDeprecations
 788         then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
 789         else returnRn ())
 790
 791 -- ToDo: deal with original imports with 'qualified' and 'as M' clauses
 792 printMinimalImports mod_name imps
 793   | not opt_D_dump_minimal_imports
 794   = returnRn ()
 795   | otherwise
 796   = mapRn to_ies (fmToList imps)                `thenRn` \ mod_ies ->
 797     ioToRnM (do { h <- openFile filename WriteMode ;
 798                   printForUser h (vcat (map ppr_mod_ie mod_ies))
 799         })                                      `thenRn_`
 800     returnRn ()
 801   where
 802     filename = moduleNameUserString mod_name ++ ".imports"
 803     ppr_mod_ie (mod_name, ies)
 804         | mod_name == pRELUDE_Name
 805         = empty
 806         | otherwise
 807         = ptext SLIT("import") <+> ppr mod_name <>
 808                             parens (fsep (punctuate comma (map ppr ies)))
 809
 810     to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env)      `thenRn` \ ies ->
 811                               returnRn (moduleName mod, ies)
 812
 813     to_ie :: AvailInfo -> RnMG (IE Name)
 814     to_ie (Avail n)       = returnRn (IEVar n)
 815     to_ie (AvailTC n [m]) = ASSERT( n==m )
 816                             returnRn (IEThingAbs n)
 817     to_ie (AvailTC n ns)  = getInterfaceExports (moduleName (nameModule n))
 818                                                 ImportBySystem          `thenRn` \ (_, avails) ->
 819                             case [ms | AvailTC m ms <- avails, m == n] of
 820                               [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
 821                                    | otherwise          -> returnRn (IEThingWith n (filter (/= n) ns))
 822                               other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
 823                                        returnRn (IEVar n)
 824
 825 rnDump  :: [RenamedHsDecl]      -- Renamed imported decls
 826         -> [RenamedHsDecl]      -- Renamed local decls
 827         -> RnMG (IO ())
 828 rnDump imp_decls local_decls
 829         | opt_D_dump_rn_trace ||
 830           opt_D_dump_rn_stats ||
 831           opt_D_dump_rn
 832         = getRnStats imp_decls          `thenRn` \ stats_msg ->
 833
 834           returnRn (printErrs stats_msg >>
 835                     dumpIfSet opt_D_dump_rn "Renamer:"
 836                               (vcat (map ppr (local_decls ++ imp_decls))))
 837
 838         | otherwise = returnRn (return ())
 839 \end{code}
 840
 841
 842 %*********************************************************
 843 %*                                                      *
 844 \subsection{Statistics}
 845 %*                                                      *
 846 %*********************************************************
 847
 848 \begin{code}
 849 getRnStats :: [RenamedHsDecl] -> RnMG SDoc
 850 getRnStats imported_decls
 851   = getIfacesRn                 `thenRn` \ ifaces ->
 852     let
 853         n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)]
 854
 855         decls_read     = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
 856                                 -- Data, newtype, and class decls are in the decls_fm
 857                                 -- under multiple names; the tycon/class, and each
 858                                 -- constructor/class op too.
 859                                 -- The 'True' selects just the 'main' decl
 860                                  not (isLocallyDefined (availName avail))
 861                              ]
 862
 863         (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd,     _) = count_decls decls_read
 864         (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
 865
 866         unslurped_insts       = iInsts ifaces
 867         inst_decls_unslurped  = length (bagToList unslurped_insts)
 868         inst_decls_read       = id_sp + inst_decls_unslurped
 869
 870         stats = vcat
 871                 [int n_mods <+> text "interfaces read",
 872                  hsep [ int cd_sp, text "class decls imported, out of",
 873                         int cd_rd, text "read"],
 874                  hsep [ int dd_sp, text "data decls imported, out of",
 875                         int dd_rd, text "read"],
 876                  hsep [ int nd_sp, text "newtype decls imported, out of",
 877                         int nd_rd, text "read"],
 878                  hsep [int sd_sp, text "type synonym decls imported, out of",
 879                         int sd_rd, text "read"],
 880                  hsep [int vd_sp, text "value signatures imported, out of",
 881                         int vd_rd, text "read"],
 882                  hsep [int id_sp, text "instance decls imported, out of",
 883                         int inst_decls_read, text "read"],
 884                  text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
 885                                            [d | TyClD d <- imported_decls, isClassDecl d]),
 886                  text "cls dcls read"  <+> fsep (map (ppr . tyClDeclName)
 887                                            [d | TyClD d <- decls_read, isClassDecl d])]
 888     in
 889     returnRn (hcat [text "Renamer stats: ", stats])
 890
 891 count_decls decls
 892   = (class_decls,
 893      data_decls,
 894      newtype_decls,
 895      syn_decls,
 896      val_decls,
 897      inst_decls)
 898   where
 899     tycl_decls = [d | TyClD d <- decls]
 900     (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
 901
 902     val_decls     = length [() | SigD _   <- decls]
 903     inst_decls    = length [() | InstD _  <- decls]
 904 \end{code}
 905
 906
 907 %************************************************************************
 908 %*                                                                      *
 909 \subsection{Errors and warnings}
 910 %*                                                                      *
 911 %************************************************************************
 912
 913 \begin{code}
 914 warnDeprec :: (Name, DeprecTxt) -> RnM d ()
 915 warnDeprec (name, txt)
 916   = pushSrcLocRn (getSrcLoc name)       $
 917     addWarnRn                           $
 918     sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
 919           text "is deprecated:", nest 4 (ppr txt) ]
 920
 921
 922 unusedFixityDecl rdr_name fixity
 923   = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
 924
 925 dupFixityDecl rdr_name loc1 loc2
 926   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 927           ptext SLIT("at ") <+> ppr loc1,
 928           ptext SLIT("and") <+> ppr loc2]
 929 \end{code}