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 RdrHsSyn         ( RdrNameHsModule )
  13 import RnHsSyn          ( RenamedHsModule, RenamedHsDecl,
  14                           extractHsTyNames, extractHsCtxtTyNames
  15                         )
  16
  17 import CmdLineOpts      ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports,
  18                           opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations
  19                         )
  20 import RnMonad
  21 import RnNames          ( getGlobalNames )
  22 import RnSource         ( rnSourceDecls, rnDecl )
  23 import RnIfaces         ( getImportedInstDecls, importDecl, getImportVersions, getInterfaceExports,
  24                           getImportedRules, loadHomeInterface, getSlurped, removeContext
  25                         )
  26 import RnEnv            ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv,
  27                           warnUnusedImports, warnUnusedLocalBinds, lookupImplicitOccRn, pprAvail,
  28                           FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
  29                         )
  30 import Module           ( Module, ModuleName, WhereFrom(..),
  31                           moduleNameUserString, mkSearchPath, moduleName, mkThisModule
  32                         )
  33 import Name             ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
  34                           nameOccName, nameUnique, nameModule, maybeUserImportedFrom,
  35                           isUserImportedExplicitlyName, isUserImportedName,
  36                           maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
  37                         )
  38 import OccName          ( occNameFlavour, isValOcc )
  39 import Id               ( idType )
  40 import TyCon            ( isSynTyCon, getSynTyConDefn )
  41 import NameSet
  42 import PrelMods         ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name )
  43 import TysWiredIn       ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
  44 import PrelInfo         ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences )
  45 import Type             ( namesOfType, funTyCon )
  46 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet, ghcExit )
  47 import BasicTypes       ( NewOrData(..) )
  48 import Bag              ( isEmptyBag, bagToList )
  49 import FiniteMap        ( FiniteMap, eltsFM, fmToList, emptyFM, addToFM_C )
  50 import UniqSupply       ( UniqSupply )
  51 import UniqFM           ( lookupUFM )
  52 import Maybes           ( maybeToBool )
  53 import Outputable
  54 import IO               ( openFile, IOMode(..) )
  55 \end{code}
  56
  57
  58
  59 \begin{code}
  60 renameModule :: UniqSupply
  61              -> RdrNameHsModule
  62              -> IO (Maybe
  63                       ( Module
  64                       , RenamedHsModule   -- Output, after renaming
  65                       , InterfaceDetails  -- Interface; for interface file generation
  66                       , RnNameSupply      -- Final env; for renaming derivings
  67                       , [ModuleName]      -- Imported modules; for profiling
  68                       ))
  69
  70 renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc)
  71   =     -- Initialise the renamer monad
  72     initRn mod_name us (mkSearchPath opt_HiMap) loc
  73            (rename this_mod)                            >>=
  74         \ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) ->
  75
  76         -- Check for warnings
  77     printErrorsAndWarnings rn_errs_bag rn_warns_bag     >>
  78
  79         -- Dump any debugging output
  80     dump_action                                         >>
  81
  82         -- Return results
  83     if not (isEmptyBag rn_errs_bag) then
  84             ghcExit 1 >> return Nothing
  85     else
  86             return maybe_rn_stuff
  87 \end{code}
  88
  89
  90 \begin{code}
  91 rename :: RdrNameHsModule
  92        -> RnMG (Maybe (Module, RenamedHsModule, InterfaceDetails, RnNameSupply, [ModuleName]), IO ())
  93 rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc)
  94   =     -- FIND THE GLOBAL NAME ENVIRONMENT
  95     getGlobalNames this_mod                     `thenRn` \ maybe_stuff ->
  96
  97         -- CHECK FOR EARLY EXIT
  98     if not (maybeToBool maybe_stuff) then
  99         -- Everything is up to date; no need to recompile further
 100         rnDump [] []            `thenRn` \ dump_action ->
 101         returnRn (Nothing, dump_action)
 102     else
 103     let
 104         Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
 105         ExportEnv export_avails _ _ = export_env
 106     in
 107
 108         -- RENAME THE SOURCE
 109     initRnMS gbl_env fixity_env SourceMode (
 110         rnSourceDecls local_decls
 111     )                                   `thenRn` \ (rn_local_decls, source_fvs) ->
 112
 113         -- SLURP IN ALL THE NEEDED DECLARATIONS
 114     implicitFVs mod_name rn_local_decls         `thenRn` \ implicit_fvs ->
 115     let
 116         real_source_fvs = implicit_fvs `plusFV` source_fvs `plusFV` export_fvs
 117                 -- It's important to do the "plus" this way round, so that
 118                 -- when compiling the prelude, locally-defined (), Bool, etc
 119                 -- override the implicit ones.
 120
 121                 -- The export_fvs make the exported names look just as if they
 122                 -- occurred in the source program.  For the reasoning, see the
 123                 -- comments with RnIfaces.getImportVersions
 124         export_fvs = mkNameSet (map availName export_avails)
 125     in
 126     slurpImpDecls real_source_fvs       `thenRn` \ rn_imp_decls ->
 127     let
 128         rn_all_decls       = rn_local_decls ++ rn_imp_decls
 129
 130         -- COLLECT ALL DEPRECATIONS
 131         deprec_sigs = [ ds | ValD bnds <- rn_local_decls, ds <- collectDeprecs bnds ]
 132         deprecs = case mod_deprec of
 133            Nothing -> deprec_sigs
 134            Just txt -> Deprecation (IEModuleContents undefined) txt : deprec_sigs
 135     in
 136
 137         -- EXIT IF ERRORS FOUND
 138     checkErrsRn                                 `thenRn` \ no_errs_so_far ->
 139     if not no_errs_so_far then
 140         -- Found errors already, so exit now
 141         rnDump rn_imp_decls rn_all_decls        `thenRn` \ dump_action ->
 142         returnRn (Nothing, dump_action)
 143     else
 144
 145         -- GENERATE THE VERSION/USAGE INFO
 146     getImportVersions mod_name export_env       `thenRn` \ my_usages ->
 147     getNameSupplyRn                             `thenRn` \ name_supply ->
 148
 149         -- REPORT UNUSED NAMES
 150     reportUnusedNames mod_name gbl_env global_avail_env
 151                       export_env
 152                       source_fvs                        `thenRn_`
 153
 154         -- RETURN THE RENAMED MODULE
 155     let
 156         has_orphans        = any isOrphanDecl rn_local_decls
 157         direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
 158         renamed_module = HsModule mod_name vers
 159                                   trashed_exports trashed_imports
 160                                   rn_all_decls
 161                                   mod_deprec
 162                                   loc
 163     in
 164     rnDump rn_imp_decls rn_all_decls            `thenRn` \ dump_action ->
 165     returnRn (Just (mkThisModule mod_name,
 166                     renamed_module,
 167                     (InterfaceDetails has_orphans my_usages export_env deprecs),
 168                     name_supply,
 169                     direct_import_mods), dump_action)
 170   where
 171     trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
 172     trashed_imports  = {-trace "rnSource:trashed_imports"-} []
 173
 174     collectDeprecs EmptyBinds = []
 175     collectDeprecs (ThenBinds x y) = collectDeprecs x ++ collectDeprecs y
 176     collectDeprecs (MonoBind _ sigs _) = [ d | DeprecSig d _ <- sigs ]
 177 \end{code}
 178
 179 @implicitFVs@ forces the renamer to slurp in some things which aren't
 180 mentioned explicitly, but which might be needed by the type checker.
 181
 182 \begin{code}
 183 implicitFVs mod_name decls
 184   = mapRn lookupImplicitOccRn implicit_occs     `thenRn` \ implicit_names ->
 185     returnRn (implicit_main                             `plusFV`
 186               mkNameSet (map getName default_tycons)    `plusFV`
 187               mkNameSet thinAirIdNames                  `plusFV`
 188               mkNameSet implicit_names)
 189   where
 190         -- Add occurrences for Int, and (), because they
 191         -- are the types to which ambigious type variables may be defaulted by
 192         -- the type checker; so they won't always appear explicitly.
 193         -- [The () one is a GHC extension for defaulting CCall results.]
 194         -- ALSO: funTyCon, since it occurs implicitly everywhere!
 195         --       (we don't want to be bothered with making funTyCon a
 196         --        free var at every function application!)
 197         -- Double is dealt with separately in getGates
 198     default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
 199
 200         -- Add occurrences for IO or PrimIO
 201     implicit_main |  mod_name == mAIN_Name
 202                   || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME
 203                   |  otherwise                  = emptyFVs
 204
 205         -- Now add extra "occurrences" for things that
 206         -- the deriving mechanism, or defaulting, will later need in order to
 207         -- generate code
 208     implicit_occs = foldr ((++) . get) [] decls
 209
 210     get (TyClD (TyData _ _ _ _ _ (Just deriv_classes) _ _))
 211        = concat (map get_deriv deriv_classes)
 212     get other = []
 213
 214     get_deriv cls = case lookupUFM derivingOccurrences cls of
 215                         Nothing   -> []
 216                         Just occs -> occs
 217 \end{code}
 218
 219 \begin{code}
 220 isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
 221   = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty)))
 222         -- The 'removeContext' is because of
 223         --      instance Foo a => Baz T where ...
 224         -- The decl is an orphan if Baz and T are both not locally defined,
 225         --      even if Foo *is* locally defined
 226
 227 isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _))
 228   = check lhs
 229   where
 230         -- At the moment we just check for common LHS forms
 231         -- Expand as necessary.  Getting it wrong just means
 232         -- more orphans than necessary
 233     check (HsVar v)       = not (isLocallyDefined v)
 234     check (HsApp f a)     = check f && check a
 235     check (HsLit _)       = False
 236     check (OpApp l o _ r) = check l && check o && check r
 237     check (NegApp e _)    = check e
 238     check (HsPar e)       = check e
 239     check (SectionL e o)  = check e && check o
 240     check (SectionR o e)  = check e && check o
 241
 242     check other           = True        -- Safe fall through
 243
 244 isOrphanDecl other = False
 245 \end{code}
 246
 247
 248 \begin{code}
 249 dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
 250   = pushSrcLocRn locn1  $
 251     addErrRn msg
 252   where
 253     msg = hang (ptext SLIT("Multiple default declarations"))
 254                4  (vcat (map pp dup_things))
 255     pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
 256 \end{code}
 257
 258
 259 %*********************************************************
 260 %*                                                       *
 261 \subsection{Slurping declarations}
 262 %*                                                       *
 263 %*********************************************************
 264
 265 \begin{code}
 266 -------------------------------------------------------
 267 slurpImpDecls source_fvs
 268   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
 269
 270         -- The current slurped-set records all local things
 271     getSlurped                                  `thenRn` \ source_binders ->
 272     slurpSourceRefs source_binders source_fvs   `thenRn` \ (decls, needed) ->
 273
 274         -- And finally get everything else
 275     closeDecls decls needed
 276
 277 -------------------------------------------------------
 278 slurpSourceRefs :: NameSet                      -- Variables defined in source
 279                 -> FreeVars                     -- Variables referenced in source
 280                 -> RnMG ([RenamedHsDecl],
 281                          FreeVars)              -- Un-satisfied needs
 282 -- The declaration (and hence home module) of each gate has
 283 -- already been loaded
 284
 285 slurpSourceRefs source_binders source_fvs
 286   = go_outer []                         -- Accumulating decls
 287              emptyFVs                   -- Unsatisfied needs
 288              emptyFVs                   -- Accumulating gates
 289              (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
 290   where
 291         -- The outer loop repeatedly slurps the decls for the current gates
 292         -- and the instance decls
 293
 294         -- The outer loop is needed because consider
 295         --      instance Foo a => Baz (Maybe a) where ...
 296         -- It may be that @Baz@ and @Maybe@ are used in the source module,
 297         -- but not @Foo@; so we need to chase @Foo@ too.
 298         --
 299         -- We also need to follow superclass refs.  In particular, 'chasing @Foo@' must
 300         -- include actually getting in Foo's class decl
 301         --      class Wib a => Foo a where ..
 302         -- so that its superclasses are discovered.  The point is that Wib is a gate too.
 303         -- We do this for tycons too, so that we look through type synonyms.
 304
 305     go_outer decls fvs all_gates []
 306         = returnRn (decls, fvs)
 307
 308     go_outer decls fvs all_gates refs   -- refs are not necessarily slurped yet
 309         = traceRn (text "go_outer" <+> ppr refs)                `thenRn_`
 310           go_inner decls fvs emptyFVs refs                      `thenRn` \ (decls1, fvs1, gates1) ->
 311           getImportedInstDecls (all_gates `plusFV` gates1)      `thenRn` \ inst_decls ->
 312           rnInstDecls decls1 fvs1 gates1 inst_decls             `thenRn` \ (decls2, fvs2, gates2) ->
 313           go_outer decls2 fvs2 (all_gates `plusFV` gates2)
 314                                (nameSetToList (gates2 `minusNameSet` all_gates))
 315                 -- Knock out the all_gates because even if we don't slurp any new
 316                 -- decls we can get some apparently-new gates from wired-in names
 317
 318     go_inner decls fvs gates []
 319         = returnRn (decls, fvs, gates)
 320
 321     go_inner decls fvs gates (wanted_name:refs)
 322         | isWiredInName wanted_name
 323         = load_home wanted_name         `thenRn_`
 324           go_inner decls fvs (gates `plusFV` getWiredInGates wanted_name) refs
 325
 326         | otherwise
 327         = importDecl wanted_name                `thenRn` \ maybe_decl ->
 328           case maybe_decl of
 329             Nothing   -> go_inner decls fvs gates refs  -- No declaration... (already slurped, or local)
 330             Just decl -> rnIfaceDecl decl               `thenRn` \ (new_decl, fvs1) ->
 331                          go_inner (new_decl : decls)
 332                                   (fvs1 `plusFV` fvs)
 333                                   (gates `plusFV` getGates source_fvs new_decl)
 334                                   refs
 335
 336         -- When we find a wired-in name we must load its
 337         -- home module so that we find any instance decls therein
 338     load_home name
 339         | name `elemNameSet` source_binders = returnRn ()
 340                 -- When compiling the prelude, a wired-in thing may
 341                 -- be defined in this module, in which case we don't
 342                 -- want to load its home module!
 343                 -- Using 'isLocallyDefined' doesn't work because some of
 344                 -- the free variables returned are simply 'listTyCon_Name',
 345                 -- with a system provenance.  We could look them up every time
 346                 -- but that seems a waste.
 347         | otherwise                           = loadHomeInterface doc name      `thenRn_`
 348                                                 returnRn ()
 349         where
 350           doc = ptext SLIT("need home module for wired in thing") <+> ppr name
 351
 352 rnInstDecls decls fvs gates []
 353   = returnRn (decls, fvs, gates)
 354 rnInstDecls decls fvs gates (d:ds)
 355   = rnIfaceDecl d               `thenRn` \ (new_decl, fvs1) ->
 356     rnInstDecls (new_decl:decls)
 357                 (fvs1 `plusFV` fvs)
 358                 (gates `plusFV` getInstDeclGates new_decl)
 359                 ds
 360 \end{code}
 361
 362
 363 \begin{code}
 364 -------------------------------------------------------
 365 -- closeDecls keeps going until the free-var set is empty
 366 closeDecls decls needed
 367   | not (isEmptyFVs needed)
 368   = slurpDecls decls needed     `thenRn` \ (decls1, needed1) ->
 369     closeDecls decls1 needed1
 370
 371   | otherwise
 372   = getImportedRules                    `thenRn` \ rule_decls ->
 373     case rule_decls of
 374         []    -> returnRn decls -- No new rules, so we are done
 375         other -> rnIfaceDecls decls emptyFVs rule_decls         `thenRn` \ (decls1, needed1) ->
 376                  closeDecls decls1 needed1
 377
 378
 379 -------------------------------------------------------
 380 rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
 381              -> [(Module, RdrNameHsDecl)]
 382              -> RnM d ([RenamedHsDecl], FreeVars)
 383 rnIfaceDecls decls fvs []     = returnRn (decls, fvs)
 384 rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d           `thenRn` \ (new_decl, fvs1) ->
 385                                 rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
 386
 387 rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
 388
 389
 390 -------------------------------------------------------
 391 -- Augment decls with any decls needed by needed.
 392 -- Return also free vars of the new decls (only)
 393 slurpDecls decls needed
 394   = go decls emptyFVs (nameSetToList needed)
 395   where
 396     go decls fvs []         = returnRn (decls, fvs)
 397     go decls fvs (ref:refs) = slurpDecl decls fvs ref   `thenRn` \ (decls1, fvs1) ->
 398                               go decls1 fvs1 refs
 399
 400 -------------------------------------------------------
 401 slurpDecl decls fvs wanted_name
 402   = importDecl wanted_name              `thenRn` \ maybe_decl ->
 403     case maybe_decl of
 404         -- No declaration... (wired in thing)
 405         Nothing -> returnRn (decls, fvs)
 406
 407         -- Found a declaration... rename it
 408         Just decl -> rnIfaceDecl decl           `thenRn` \ (new_decl, fvs1) ->
 409                      returnRn (new_decl:decls, fvs1 `plusFV` fvs)
 410 \end{code}
 411
 412
 413 %*********************************************************
 414 %*                                                       *
 415 \subsection{Extracting the `gates'}
 416 %*                                                       *
 417 %*********************************************************
 418
 419 When we import a declaration like
 420 \begin{verbatim}
 421         data T = T1 Wibble | T2 Wobble
 422 \end{verbatim}
 423 we don't want to treat @Wibble@ and @Wobble@ as gates
 424 {\em unless} @T1@, @T2@ respectively are mentioned by the user program.
 425 If only @T@ is mentioned
 426 we want only @T@ to be a gate;
 427 that way we don't suck in useless instance
 428 decls for (say) @Eq Wibble@, when they can't possibly be useful.
 429
 430 @getGates@ takes a newly imported (and renamed) decl, and the free
 431 vars of the source program, and extracts from the decl the gate names.
 432
 433 \begin{code}
 434 getGates source_fvs (SigD (IfaceSig _ ty _ _))
 435   = extractHsTyNames ty
 436
 437 getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
 438   = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
 439                        (map getTyVarName tvs)
 440      `addOneToNameSet` cls)
 441     `plusFV` maybe_double
 442   where
 443     get (ClassOpSig n _ _ ty _)
 444         | n `elemNameSet` source_fvs = extractHsTyNames ty
 445         | otherwise                  = emptyFVs
 446
 447         -- If we load any numeric class that doesn't have
 448         -- Int as an instance, add Double to the gates.
 449         -- This takes account of the fact that Double might be needed for
 450         -- defaulting, but we don't want to load Double (and all its baggage)
 451         -- if the more exotic classes aren't used at all.
 452     maybe_double | nameUnique cls `elem` fractionalClassKeys
 453                  = unitFV (getName doubleTyCon)
 454                  | otherwise
 455                  = emptyFVs
 456
 457 getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
 458   = delListFromNameSet (extractHsTyNames ty)
 459                        (map getTyVarName tvs)
 460         -- A type synonym type constructor isn't a "gate" for instance decls
 461
 462 getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _))
 463   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
 464                        (map getTyVarName tvs)
 465     `addOneToNameSet` tycon
 466   where
 467     get (ConDecl n _ tvs ctxt details _)
 468         | n `elemNameSet` source_fvs
 469                 -- If the constructor is method, get fvs from all its fields
 470         = delListFromNameSet (get_details details `plusFV`
 471                               extractHsCtxtTyNames ctxt)
 472                              (map getTyVarName tvs)
 473     get (ConDecl n _ tvs ctxt (RecCon fields) _)
 474                 -- Even if the constructor isn't mentioned, the fields
 475                 -- might be, as selectors.  They can't mention existentially
 476                 -- bound tyvars (typechecker checks for that) so no need for
 477                 -- the deleteListFromNameSet part
 478         = foldr (plusFV . get_field) emptyFVs fields
 479
 480     get other_con = emptyFVs
 481
 482     get_details (VanillaCon tys) = plusFVs (map get_bang tys)
 483     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
 484     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
 485     get_details (NewCon t _)     = extractHsTyNames t
 486
 487     get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
 488                      | otherwise                         = emptyFVs
 489
 490     get_bang (Banged   t) = extractHsTyNames t
 491     get_bang (Unbanged t) = extractHsTyNames t
 492     get_bang (Unpacked t) = extractHsTyNames t
 493
 494 getGates source_fvs other_decl = emptyFVs
 495 \end{code}
 496
 497 @getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
 498 rather than a declaration.
 499
 500 \begin{code}
 501 getWiredInGates :: Name -> FreeVars
 502 getWiredInGates name    -- No classes are wired in
 503   | is_id                = getWiredInGates_s (namesOfType (idType the_id))
 504   | isSynTyCon the_tycon = getWiredInGates_s
 505          (delListFromNameSet (namesOfType ty) (map getName tyvars))
 506   | otherwise            = unitFV name
 507   where
 508     maybe_wired_in_id    = maybeWiredInIdName name
 509     is_id                = maybeToBool maybe_wired_in_id
 510     maybe_wired_in_tycon = maybeWiredInTyConName name
 511     Just the_id          = maybe_wired_in_id
 512     Just the_tycon       = maybe_wired_in_tycon
 513     (tyvars,ty)          = getSynTyConDefn the_tycon
 514
 515 getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
 516 \end{code}
 517
 518 \begin{code}
 519 getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
 520 getInstDeclGates other                              = emptyFVs
 521 \end{code}
 522
 523
 524 %*********************************************************
 525 %*                                                       *
 526 \subsection{Unused names}
 527 %*                                                       *
 528 %*********************************************************
 529
 530 \begin{code}
 531 reportUnusedNames :: ModuleName -> GlobalRdrEnv -> AvailEnv -> ExportEnv -> NameSet -> RnMG ()
 532 reportUnusedNames mod_name gbl_env avail_env (ExportEnv export_avails _ _) mentioned_names
 533   = let
 534         used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 535
 536         -- Now, a use of C implies a use of T,
 537         -- if C was brought into scope by T(..) or T(C)
 538         really_used_names = used_names `unionNameSets`
 539           mkNameSet [ availName parent_avail
 540                     | sub_name <- nameSetToList used_names
 541                     , isValOcc (getOccName sub_name)
 542
 543                         -- Usually, every used name will appear in avail_env, but there
 544                         -- is one time when it doesn't: tuples and other built in syntax.  When you
 545                         -- write (a,b) that gives rise to a *use* of "(,)", so that the
 546                         -- instances will get pulled in, but the tycon "(,)" isn't actually
 547                         -- in scope.  Hence the isValOcc filter.
 548                         --
 549                         -- Also, (-x) gives rise to an implicit use of 'negate'; similarly,
 550                         --   3.5 gives rise to an implcit use of :%
 551                         -- hence the isUserImportedName filter on the warning
 552
 553                     , let parent_avail
 554                             = case lookupNameEnv avail_env sub_name of
 555                                 Just avail -> avail
 556                                 Nothing -> WARN( isUserImportedName sub_name,
 557                                                  text "reportUnusedName: not in avail_env" <+> ppr sub_name )
 558                                            Avail sub_name
 559
 560                     , case parent_avail of { AvailTC _ _ -> True; other -> False }
 561                     ]
 562
 563         defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
 564         defined_but_not_used =
 565            nameSetToList (defined_names `minusNameSet` really_used_names)
 566
 567         -- Filter out the ones only defined implicitly
 568         bad_locals = [n | n <- defined_but_not_used, isLocallyDefined             n]
 569         bad_imps   = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n]
 570
 571         deprec_used deprec_env = [ (n,txt)
 572                                  | n <- nameSetToList mentioned_names,
 573                                    not (isLocallyDefined n),
 574                                    Just txt <- [lookupNameEnv deprec_env n] ]
 575
 576         minimal_imports :: FiniteMap Module AvailEnv
 577         minimal_imports = foldNameSet add emptyFM really_used_names
 578         add n acc = case maybeUserImportedFrom n of
 579                         Nothing -> acc
 580                         Just m  -> addToFM_C plusAvailEnv acc m
 581                                              (unitAvailEnv (mk_avail n))
 582         mk_avail n = case lookupNameEnv avail_env n of
 583                         Just (AvailTC m _) | n==m      -> AvailTC n [n]
 584                                            | otherwise -> AvailTC m [n,m]
 585                         Just avail         -> Avail n
 586                         Nothing            -> pprPanic "mk_avail" (ppr n)
 587     in
 588     warnUnusedLocalBinds bad_locals                             `thenRn_`
 589     warnUnusedImports bad_imps                                  `thenRn_`
 590     printMinimalImports mod_name minimal_imports                `thenRn_`
 591     getIfacesRn                                                 `thenRn` \ ifaces ->
 592     (if opt_WarnDeprecations
 593         then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
 594         else returnRn ())
 595
 596 -- ToDo: deal with original imports with 'qualified' and 'as M' clauses
 597 printMinimalImports mod_name imps
 598   | not opt_D_dump_minimal_imports
 599   = returnRn ()
 600   | otherwise
 601   = mapRn to_ies (fmToList imps)                `thenRn` \ mod_ies ->
 602     ioToRnM (do { h <- openFile filename WriteMode ;
 603                   printForUser h (vcat (map ppr_mod_ie mod_ies))
 604         })                                      `thenRn_`
 605     returnRn ()
 606   where
 607     filename = moduleNameUserString mod_name ++ ".imports"
 608     ppr_mod_ie (mod_name, ies)
 609         | mod_name == pRELUDE_Name
 610         = empty
 611         | otherwise
 612         = ptext SLIT("import") <+> ppr mod_name <>
 613                             parens (fsep (punctuate comma (map ppr ies)))
 614
 615     to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env)      `thenRn` \ ies ->
 616                               returnRn (moduleName mod, ies)
 617
 618     to_ie :: AvailInfo -> RnMG (IE Name)
 619     to_ie (Avail n)       = returnRn (IEVar n)
 620     to_ie (AvailTC n [m]) = ASSERT( n==m )
 621                             returnRn (IEThingAbs n)
 622     to_ie (AvailTC n ns)  = getInterfaceExports (moduleName (nameModule n))
 623                                                 ImportBySystem          `thenRn` \ (_, avails) ->
 624                             case [ms | AvailTC m ms <- avails, m == n] of
 625                               [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
 626                                    | otherwise          -> returnRn (IEThingWith n (filter (/= n) ns))
 627                               other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
 628                                        returnRn (IEVar n)
 629
 630 warnDeprec :: (Name, DeprecTxt) -> RnM d ()
 631 warnDeprec (name, txt)
 632   = pushSrcLocRn (getSrcLoc name)       $
 633     addWarnRn                           $
 634     sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
 635           text "is deprecated:", nest 4 (ppr txt) ]
 636
 637
 638 rnDump  :: [RenamedHsDecl]      -- Renamed imported decls
 639         -> [RenamedHsDecl]      -- Renamed local decls
 640         -> RnMG (IO ())
 641 rnDump imp_decls decls
 642         | opt_D_dump_rn_trace ||
 643           opt_D_dump_rn_stats ||
 644           opt_D_dump_rn
 645         = getRnStats imp_decls          `thenRn` \ stats_msg ->
 646
 647           returnRn (printErrs stats_msg >>
 648                     dumpIfSet opt_D_dump_rn "Renamer:" (vcat (map ppr decls)))
 649
 650         | otherwise = returnRn (return ())
 651 \end{code}
 652
 653
 654 %*********************************************************
 655 %*                                                      *
 656 \subsection{Statistics}
 657 %*                                                      *
 658 %*********************************************************
 659
 660 \begin{code}
 661 getRnStats :: [RenamedHsDecl] -> RnMG SDoc
 662 getRnStats imported_decls
 663   = getIfacesRn                 `thenRn` \ ifaces ->
 664     let
 665         n_mods = length [() | (_, _, _, Just _) <- eltsFM (iImpModInfo ifaces)]
 666
 667         decls_read     = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
 668                                 -- Data, newtype, and class decls are in the decls_fm
 669                                 -- under multiple names; the tycon/class, and each
 670                                 -- constructor/class op too.
 671                                 -- The 'True' selects just the 'main' decl
 672                                  not (isLocallyDefined (availName avail))
 673                              ]
 674
 675         (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd,     _) = count_decls decls_read
 676         (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
 677
 678         unslurped_insts       = iInsts ifaces
 679         inst_decls_unslurped  = length (bagToList unslurped_insts)
 680         inst_decls_read       = id_sp + inst_decls_unslurped
 681
 682         stats = vcat
 683                 [int n_mods <+> text "interfaces read",
 684                  hsep [ int cd_sp, text "class decls imported, out of",
 685                         int cd_rd, text "read"],
 686                  hsep [ int dd_sp, text "data decls imported, out of",
 687                         int dd_rd, text "read"],
 688                  hsep [ int nd_sp, text "newtype decls imported, out of",
 689                         int nd_rd, text "read"],
 690                  hsep [int sd_sp, text "type synonym decls imported, out of",
 691                         int sd_rd, text "read"],
 692                  hsep [int vd_sp, text "value signatures imported, out of",
 693                         int vd_rd, text "read"],
 694                  hsep [int id_sp, text "instance decls imported, out of",
 695                         int inst_decls_read, text "read"],
 696                  text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
 697                                            [d | TyClD d <- imported_decls, isClassDecl d]),
 698                  text "cls dcls read"  <+> fsep (map (ppr . tyClDeclName)
 699                                            [d | TyClD d <- decls_read, isClassDecl d])]
 700     in
 701     returnRn (hcat [text "Renamer stats: ", stats])
 702
 703 count_decls decls
 704   = (class_decls,
 705      data_decls,
 706      newtype_decls,
 707      syn_decls,
 708      val_decls,
 709      inst_decls)
 710   where
 711     tycl_decls = [d | TyClD d <- decls]
 712     (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
 713
 714     val_decls     = length [() | SigD _   <- decls]
 715     inst_decls    = length [() | InstD _  <- decls]
 716 \end{code}
 717