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