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