ghc/compiler/rename/Rename.lhs

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