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