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