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