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 PrelInfo         ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
  52                           ioTyCon_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
  53                           fractionalClassKeys, derivingOccurrences
  54                         )
  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 (OpApp l o _ r) = check l && check o && check r
 279     check (NegApp e _)    = check e
 280     check (HsPar e)       = check e
 281     check (SectionL e o)  = check e && check o
 282     check (SectionR o e)  = check e && check o
 283
 284     check other           = True        -- Safe fall through
 285
 286 isOrphanDecl other = False
 287 \end{code}
 288
 289
 290 \begin{code}
 291 dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
 292   = pushSrcLocRn locn1  $
 293     addErrRn msg
 294   where
 295     msg = hang (ptext SLIT("Multiple default declarations"))
 296                4  (vcat (map pp dup_things))
 297     pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
 298 \end{code}
 299
 300
 301 %*********************************************************
 302 %*                                                       *
 303 \subsection{Slurping declarations}
 304 %*                                                       *
 305 %*********************************************************
 306
 307 \begin{code}
 308 -------------------------------------------------------
 309 slurpImpDecls source_fvs
 310   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
 311
 312         -- The current slurped-set records all local things
 313     getSlurped                                  `thenRn` \ source_binders ->
 314     slurpSourceRefs source_binders source_fvs   `thenRn` \ (decls, needed) ->
 315
 316         -- Then get everything else
 317     closeDecls decls needed                     `thenRn` \ decls1 ->
 318
 319         -- Finally, get any deferred data type decls
 320     slurpDeferredDecls decls1                   `thenRn` \ final_decls ->
 321
 322     returnRn final_decls
 323
 324 -------------------------------------------------------
 325 slurpSourceRefs :: NameSet                      -- Variables defined in source
 326                 -> FreeVars                     -- Variables referenced in source
 327                 -> RnMG ([RenamedHsDecl],
 328                          FreeVars)              -- Un-satisfied needs
 329 -- The declaration (and hence home module) of each gate has
 330 -- already been loaded
 331
 332 slurpSourceRefs source_binders source_fvs
 333   = go_outer []                         -- Accumulating decls
 334              emptyFVs                   -- Unsatisfied needs
 335              emptyFVs                   -- Accumulating gates
 336              (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
 337   where
 338         -- The outer loop repeatedly slurps the decls for the current gates
 339         -- and the instance decls
 340
 341         -- The outer loop is needed because consider
 342         --      instance Foo a => Baz (Maybe a) where ...
 343         -- It may be that @Baz@ and @Maybe@ are used in the source module,
 344         -- but not @Foo@; so we need to chase @Foo@ too.
 345         --
 346         -- We also need to follow superclass refs.  In particular, 'chasing @Foo@' must
 347         -- include actually getting in Foo's class decl
 348         --      class Wib a => Foo a where ..
 349         -- so that its superclasses are discovered.  The point is that Wib is a gate too.
 350         -- We do this for tycons too, so that we look through type synonyms.
 351
 352     go_outer decls fvs all_gates []
 353         = returnRn (decls, fvs)
 354
 355     go_outer decls fvs all_gates refs   -- refs are not necessarily slurped yet
 356         = traceRn (text "go_outer" <+> ppr refs)                `thenRn_`
 357           foldlRn go_inner (decls, fvs, emptyFVs) refs          `thenRn` \ (decls1, fvs1, gates1) ->
 358           getImportedInstDecls (all_gates `plusFV` gates1)      `thenRn` \ inst_decls ->
 359           rnInstDecls decls1 fvs1 gates1 inst_decls             `thenRn` \ (decls2, fvs2, gates2) ->
 360           go_outer decls2 fvs2 (all_gates `plusFV` gates2)
 361                                (nameSetToList (gates2 `minusNameSet` all_gates))
 362                 -- Knock out the all_gates because even if we don't slurp any new
 363                 -- decls we can get some apparently-new gates from wired-in names
 364
 365     go_inner (decls, fvs, gates) wanted_name
 366         = importDecl wanted_name                `thenRn` \ import_result ->
 367           case import_result of
 368             AlreadySlurped -> returnRn (decls, fvs, gates)
 369             WiredIn        -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
 370             Deferred       -> returnRn (decls, fvs, gates `addOneFV` wanted_name)       -- It's a type constructor
 371
 372             HereItIs decl -> rnIfaceDecl decl           `thenRn` \ (new_decl, fvs1) ->
 373                              returnRn (new_decl : decls,
 374                                        fvs1 `plusFV` fvs,
 375                                        gates `plusFV` getGates source_fvs new_decl)
 376
 377 rnInstDecls decls fvs gates []
 378   = returnRn (decls, fvs, gates)
 379 rnInstDecls decls fvs gates (d:ds)
 380   = rnIfaceDecl d               `thenRn` \ (new_decl, fvs1) ->
 381     rnInstDecls (new_decl:decls)
 382                 (fvs1 `plusFV` fvs)
 383                 (gates `plusFV` getInstDeclGates new_decl)
 384                 ds
 385 \end{code}
 386
 387
 388 \begin{code}
 389 -------------------------------------------------------
 390 -- closeDecls keeps going until the free-var set is empty
 391 closeDecls decls needed
 392   | not (isEmptyFVs needed)
 393   = slurpDecls decls needed     `thenRn` \ (decls1, needed1) ->
 394     closeDecls decls1 needed1
 395
 396   | otherwise
 397   = getImportedRules                    `thenRn` \ rule_decls ->
 398     case rule_decls of
 399         []    -> returnRn decls -- No new rules, so we are done
 400         other -> rnIfaceDecls decls emptyFVs rule_decls         `thenRn` \ (decls1, needed1) ->
 401                  closeDecls decls1 needed1
 402
 403
 404 -------------------------------------------------------
 405 -- Augment decls with any decls needed by needed.
 406 -- Return also free vars of the new decls (only)
 407 slurpDecls decls needed
 408   = go decls emptyFVs (nameSetToList needed)
 409   where
 410     go decls fvs []         = returnRn (decls, fvs)
 411     go decls fvs (ref:refs) = slurpDecl decls fvs ref   `thenRn` \ (decls1, fvs1) ->
 412                               go decls1 fvs1 refs
 413
 414 -------------------------------------------------------
 415 slurpDecl decls fvs wanted_name
 416   = importDecl wanted_name              `thenRn` \ import_result ->
 417     case import_result of
 418         -- Found a declaration... rename it
 419         HereItIs decl -> rnIfaceDecl decl               `thenRn` \ (new_decl, fvs1) ->
 420                          returnRn (new_decl:decls, fvs1 `plusFV` fvs)
 421
 422         -- No declaration... (wired in thing, or deferred, or already slurped)
 423         other -> returnRn (decls, fvs)
 424
 425
 426 -------------------------------------------------------
 427 rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
 428              -> [(Module, RdrNameHsDecl)]
 429              -> RnM d ([RenamedHsDecl], FreeVars)
 430 rnIfaceDecls decls fvs []     = returnRn (decls, fvs)
 431 rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d           `thenRn` \ (new_decl, fvs1) ->
 432                                 rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
 433
 434 rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
 435 \end{code}
 436
 437
 438 %*********************************************************
 439 %*                                                       *
 440 \subsection{Deferred declarations}
 441 %*                                                       *
 442 %*********************************************************
 443
 444 The idea of deferred declarations is this.  Suppose we have a function
 445         f :: T -> Int
 446         data T = T1 A | T2 B
 447         data A = A1 X | A2 Y
 448         data B = B1 P | B2 Q
 449 Then we don't want to load T and all its constructors, and all
 450 the types those constructors refer to, and all the types *those*
 451 constructors refer to, and so on.  That might mean loading many more
 452 interface files than is really necessary.  So we 'defer' loading T.
 453
 454 But f might be strict, and the calling convention for evaluating
 455 values of type T depends on how many constructors T has, so
 456 we do need to load T, but not the full details of the type T.
 457 So we load the full decl for T, but only skeleton decls for A and B:
 458         f :: T -> Int
 459         data T = {- 2 constructors -}
 460
 461 Whether all this is worth it is moot.
 462
 463 \begin{code}
 464 slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
 465 slurpDeferredDecls decls
 466   = getDeferredDecls                                            `thenRn` \ def_decls ->
 467     rnIfaceDecls decls emptyFVs (map stripDecl def_decls)       `thenRn` \ (decls1, fvs) ->
 468     ASSERT( isEmptyFVs fvs )
 469     returnRn decls1
 470
 471 stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc))
 472   = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc))
 473         -- Nuke the context and constructors
 474         -- But retain the *number* of constructors!
 475         -- Also the tvs will have kinds on them.
 476 \end{code}
 477
 478
 479 %*********************************************************
 480 %*                                                       *
 481 \subsection{Extracting the `gates'}
 482 %*                                                       *
 483 %*********************************************************
 484
 485 When we import a declaration like
 486 \begin{verbatim}
 487         data T = T1 Wibble | T2 Wobble
 488 \end{verbatim}
 489 we don't want to treat @Wibble@ and @Wobble@ as gates
 490 {\em unless} @T1@, @T2@ respectively are mentioned by the user program.
 491 If only @T@ is mentioned
 492 we want only @T@ to be a gate;
 493 that way we don't suck in useless instance
 494 decls for (say) @Eq Wibble@, when they can't possibly be useful.
 495
 496 @getGates@ takes a newly imported (and renamed) decl, and the free
 497 vars of the source program, and extracts from the decl the gate names.
 498
 499 \begin{code}
 500 getGates source_fvs (SigD (IfaceSig _ ty _ _))
 501   = extractHsTyNames ty
 502
 503 getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
 504   = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
 505                         (hsTyVarNames tvs)
 506      `addOneToNameSet` cls)
 507     `plusFV` maybe_double
 508   where
 509     get (ClassOpSig n _ ty _)
 510         | n `elemNameSet` source_fvs = extractHsTyNames ty
 511         | otherwise                  = emptyFVs
 512
 513         -- If we load any numeric class that doesn't have
 514         -- Int as an instance, add Double to the gates.
 515         -- This takes account of the fact that Double might be needed for
 516         -- defaulting, but we don't want to load Double (and all its baggage)
 517         -- if the more exotic classes aren't used at all.
 518     maybe_double | nameUnique cls `elem` fractionalClassKeys
 519                  = unitFV (getName doubleTyCon)
 520                  | otherwise
 521                  = emptyFVs
 522
 523 getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
 524   = delListFromNameSet (extractHsTyNames ty)
 525                        (hsTyVarNames tvs)
 526         -- A type synonym type constructor isn't a "gate" for instance decls
 527
 528 getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
 529   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
 530                        (hsTyVarNames tvs)
 531     `addOneToNameSet` tycon
 532   where
 533     get (ConDecl n _ tvs ctxt details _)
 534         | n `elemNameSet` source_fvs
 535                 -- If the constructor is method, get fvs from all its fields
 536         = delListFromNameSet (get_details details `plusFV`
 537                               extractHsCtxtTyNames ctxt)
 538                              (hsTyVarNames tvs)
 539     get (ConDecl n _ tvs ctxt (RecCon fields) _)
 540                 -- Even if the constructor isn't mentioned, the fields
 541                 -- might be, as selectors.  They can't mention existentially
 542                 -- bound tyvars (typechecker checks for that) so no need for
 543                 -- the deleteListFromNameSet part
 544         = foldr (plusFV . get_field) emptyFVs fields
 545
 546     get other_con = emptyFVs
 547
 548     get_details (VanillaCon tys) = plusFVs (map get_bang tys)
 549     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
 550     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
 551     get_details (NewCon t _)     = extractHsTyNames t
 552
 553     get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
 554                      | otherwise                         = emptyFVs
 555
 556     get_bang bty = extractHsTyNames (getBangType bty)
 557
 558 getGates source_fvs other_decl = emptyFVs
 559 \end{code}
 560
 561 @getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
 562 rather than a declaration.
 563
 564 \begin{code}
 565 getWiredInGates :: Name -> FreeVars
 566 getWiredInGates name    -- No classes are wired in
 567   | is_id                = getWiredInGates_s (namesOfType (idType the_id))
 568   | isSynTyCon the_tycon = getWiredInGates_s
 569          (delListFromNameSet (namesOfType ty) (map getName tyvars))
 570   | otherwise            = unitFV name
 571   where
 572     maybe_wired_in_id    = maybeWiredInIdName name
 573     is_id                = maybeToBool maybe_wired_in_id
 574     maybe_wired_in_tycon = maybeWiredInTyConName name
 575     Just the_id          = maybe_wired_in_id
 576     Just the_tycon       = maybe_wired_in_tycon
 577     (tyvars,ty)          = getSynTyConDefn the_tycon
 578
 579 getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
 580 \end{code}
 581
 582 \begin{code}
 583 getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
 584 getInstDeclGates other                              = emptyFVs
 585 \end{code}
 586
 587
 588 %*********************************************************
 589 %*                                                       *
 590 \subsection{Fixities}
 591 %*                                                       *
 592 %*********************************************************
 593
 594 \begin{code}
 595 fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
 596 fixitiesFromLocalDecls gbl_env decls
 597   = foldlRn getFixities emptyNameEnv decls                              `thenRn` \ env ->
 598     traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))    `thenRn_`
 599     returnRn env
 600   where
 601     getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
 602     getFixities acc (FixD fix)
 603       = fix_decl acc fix
 604
 605     getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
 606       = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
 607                 -- Get fixities from class decl sigs too.
 608     getFixities acc other_decl
 609       = returnRn acc
 610
 611     fix_decl acc sig@(FixitySig rdr_name fixity loc)
 612         =       -- Check for fixity decl for something not declared
 613           case lookupRdrEnv gbl_env rdr_name of {
 614             Nothing | opt_WarnUnusedBinds
 615                     -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
 616                        `thenRn_` returnRn acc
 617                     | otherwise -> returnRn acc ;
 618
 619             Just (name:_) ->
 620
 621                 -- Check for duplicate fixity decl
 622           case lookupNameEnv acc name of {
 623             Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
 624                                          `thenRn_` returnRn acc ;
 625
 626             Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
 627           }}
 628 \end{code}
 629
 630
 631 %*********************************************************
 632 %*                                                       *
 633 \subsection{Deprecations}
 634 %*                                                       *
 635 %*********************************************************
 636
 637 For deprecations, all we do is check that the names are in scope.
 638 It's only imported deprecations, dealt with in RnIfaces, that we
 639 gather them together.
 640
 641 \begin{code}
 642 rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
 643            -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation]
 644 rnDeprecs gbl_env mod_deprec decls
 645  = mapRn rn_deprec deprecs      `thenRn_`
 646    returnRn (extra_deprec ++ deprecs)
 647  where
 648    deprecs = [d | DeprecD d <- decls]
 649    extra_deprec = case mod_deprec of
 650                    Nothing  -> []
 651                    Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc]
 652
 653    rn_deprec (Deprecation ie txt loc)
 654      = pushSrcLocRn loc         $
 655        mapRn check (ieNames ie)
 656
 657    check n = case lookupRdrEnv gbl_env n of
 658                 Nothing -> addErrRn (unknownNameErr n)
 659                 Just _  -> returnRn ()
 660 \end{code}
 661
 662
 663 %*********************************************************
 664 %*                                                       *
 665 \subsection{Unused names}
 666 %*                                                       *
 667 %*********************************************************
 668
 669 \begin{code}
 670 reportUnusedNames :: ModuleName -> [Module]
 671                   -> GlobalRdrEnv -> AvailEnv
 672                   -> Avails -> NameSet -> [RenamedHsDecl]
 673                   -> RnMG ()
 674 reportUnusedNames mod_name direct_import_mods
 675                   gbl_env avail_env
 676                   export_avails mentioned_names
 677                   imported_decls
 678   = let
 679         used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 680
 681         -- Now, a use of C implies a use of T,
 682         -- if C was brought into scope by T(..) or T(C)
 683         really_used_names = used_names `unionNameSets`
 684           mkNameSet [ availName parent_avail
 685                     | sub_name <- nameSetToList used_names
 686                     , isValOcc (getOccName sub_name)
 687
 688                         -- Usually, every used name will appear in avail_env, but there
 689                         -- is one time when it doesn't: tuples and other built in syntax.  When you
 690                         -- write (a,b) that gives rise to a *use* of "(,)", so that the
 691                         -- instances will get pulled in, but the tycon "(,)" isn't actually
 692                         -- in scope.  Hence the isValOcc filter.
 693                         --
 694                         -- Also, (-x) gives rise to an implicit use of 'negate'; similarly,
 695                         --   3.5 gives rise to an implcit use of :%
 696                         -- hence the isUserImportedName filter on the warning
 697
 698                     , let parent_avail
 699                             = case lookupNameEnv avail_env sub_name of
 700                                 Just avail -> avail
 701                                 Nothing -> WARN( isUserImportedName sub_name,
 702                                                  text "reportUnusedName: not in avail_env" <+>
 703                                                         ppr sub_name )
 704                                            Avail sub_name
 705
 706                     , case parent_avail of { AvailTC _ _ -> True; other -> False }
 707                     ]
 708
 709         defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
 710         defined_but_not_used =
 711            nameSetToList (defined_names `minusNameSet` really_used_names)
 712
 713         -- Filter out the ones only defined implicitly
 714         bad_locals     = [n | n <- defined_but_not_used, isLocallyDefined             n]
 715         bad_imp_names  = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n,
 716                                                          not (module_unused n)]
 717
 718         deprec_used deprec_env = [ (n,txt)
 719                                  | n <- nameSetToList mentioned_names,
 720                                    not (isLocallyDefined n),
 721                                    Just txt <- [lookupNameEnv deprec_env n] ]
 722
 723         -- inst_mods are directly-imported modules that
 724         --      contain instance decl(s) that the renamer decided to suck in
 725         -- It's not necessarily redundant to import such modules.
 726         --
 727         -- NOTE: Consider
 728         --            module This
 729         --              import M ()
 730         --
 731         --       The import M() is not *necessarily* redundant, even if
 732         --       we suck in no instance decls from M (e.g. it contains
 733         --       no instance decls, or This contains no code).  It may be
 734         --       that we import M solely to ensure that M's orphan instance
 735         --       decls (or those in its imports) are visible to people who
 736         --       import This.  Sigh.
 737         --       There's really no good way to detect this, so the error message
 738         --       in RnEnv.warnUnusedModules is weakened instead
 739         inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
 740                          let m = nameModule dfun,
 741                          m `elem` direct_import_mods
 742                     ]
 743
 744         minimal_imports :: FiniteMap Module AvailEnv
 745         minimal_imports0 = emptyFM
 746         minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names
 747         minimal_imports  = foldr   add_inst_mod minimal_imports1 inst_mods
 748
 749         add_name n acc = case maybeUserImportedFrom n of
 750                            Nothing -> acc
 751                            Just m  -> addToFM_C plusAvailEnv acc m
 752                                                 (unitAvailEnv (mk_avail n))
 753         add_inst_mod m acc
 754           | m `elemFM` acc = acc        -- We import something already
 755           | otherwise      = addToFM acc m emptyAvailEnv
 756                 -- Add an empty collection of imports for a module
 757                 -- from which we have sucked only instance decls
 758
 759         mk_avail n = case lookupNameEnv avail_env n of
 760                         Just (AvailTC m _) | n==m      -> AvailTC n [n]
 761                                            | otherwise -> AvailTC m [n,m]
 762                         Just avail         -> Avail n
 763                         Nothing            -> pprPanic "mk_avail" (ppr n)
 764
 765         -- unused_imp_mods are the directly-imported modules
 766         -- that are not mentioned in minimal_imports
 767         unused_imp_mods = [m | m <- direct_import_mods,
 768                                not (maybeToBool (lookupFM minimal_imports m)),
 769                                moduleName m /= pRELUDE_Name]
 770
 771         module_unused :: Name -> Bool
 772         -- Name is imported from a module that's completely unused,
 773         -- so don't report stuff about the name (the module covers it)
 774         module_unused n = expectJust "module_unused" (maybeUserImportedFrom n)
 775                           `elem` unused_imp_mods
 776                                 -- module_unused is only called if it's user-imported
 777     in
 778     warnUnusedModules unused_imp_mods                           `thenRn_`
 779     warnUnusedLocalBinds bad_locals                             `thenRn_`
 780     warnUnusedImports bad_imp_names                             `thenRn_`
 781     printMinimalImports mod_name minimal_imports                `thenRn_`
 782     getIfacesRn                                                 `thenRn` \ ifaces ->
 783     (if opt_WarnDeprecations
 784         then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
 785         else returnRn ())
 786
 787 -- ToDo: deal with original imports with 'qualified' and 'as M' clauses
 788 printMinimalImports mod_name imps
 789   | not opt_D_dump_minimal_imports
 790   = returnRn ()
 791   | otherwise
 792   = mapRn to_ies (fmToList imps)                `thenRn` \ mod_ies ->
 793     ioToRnM (do { h <- openFile filename WriteMode ;
 794                   printForUser h (vcat (map ppr_mod_ie mod_ies))
 795         })                                      `thenRn_`
 796     returnRn ()
 797   where
 798     filename = moduleNameUserString mod_name ++ ".imports"
 799     ppr_mod_ie (mod_name, ies)
 800         | mod_name == pRELUDE_Name
 801         = empty
 802         | otherwise
 803         = ptext SLIT("import") <+> ppr mod_name <>
 804                             parens (fsep (punctuate comma (map ppr ies)))
 805
 806     to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env)      `thenRn` \ ies ->
 807                               returnRn (moduleName mod, ies)
 808
 809     to_ie :: AvailInfo -> RnMG (IE Name)
 810     to_ie (Avail n)       = returnRn (IEVar n)
 811     to_ie (AvailTC n [m]) = ASSERT( n==m )
 812                             returnRn (IEThingAbs n)
 813     to_ie (AvailTC n ns)  = getInterfaceExports (moduleName (nameModule n))
 814                                                 ImportBySystem          `thenRn` \ (_, avails) ->
 815                             case [ms | AvailTC m ms <- avails, m == n] of
 816                               [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
 817                                    | otherwise          -> returnRn (IEThingWith n (filter (/= n) ns))
 818                               other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
 819                                        returnRn (IEVar n)
 820
 821 rnDump  :: [RenamedHsDecl]      -- Renamed imported decls
 822         -> [RenamedHsDecl]      -- Renamed local decls
 823         -> RnMG (IO ())
 824 rnDump imp_decls local_decls
 825         | opt_D_dump_rn_trace ||
 826           opt_D_dump_rn_stats ||
 827           opt_D_dump_rn
 828         = getRnStats imp_decls          `thenRn` \ stats_msg ->
 829
 830           returnRn (printErrs stats_msg >>
 831                     dumpIfSet opt_D_dump_rn "Renamer:"
 832                               (vcat (map ppr (local_decls ++ imp_decls))))
 833
 834         | otherwise = returnRn (return ())
 835 \end{code}
 836
 837
 838 %*********************************************************
 839 %*                                                      *
 840 \subsection{Statistics}
 841 %*                                                      *
 842 %*********************************************************
 843
 844 \begin{code}
 845 getRnStats :: [RenamedHsDecl] -> RnMG SDoc
 846 getRnStats imported_decls
 847   = getIfacesRn                 `thenRn` \ ifaces ->
 848     let
 849         n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)]
 850
 851         decls_read     = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
 852                                 -- Data, newtype, and class decls are in the decls_fm
 853                                 -- under multiple names; the tycon/class, and each
 854                                 -- constructor/class op too.
 855                                 -- The 'True' selects just the 'main' decl
 856                                  not (isLocallyDefined (availName avail))
 857                              ]
 858
 859         (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd,     _) = count_decls decls_read
 860         (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
 861
 862         unslurped_insts       = iInsts ifaces
 863         inst_decls_unslurped  = length (bagToList unslurped_insts)
 864         inst_decls_read       = id_sp + inst_decls_unslurped
 865
 866         stats = vcat
 867                 [int n_mods <+> text "interfaces read",
 868                  hsep [ int cd_sp, text "class decls imported, out of",
 869                         int cd_rd, text "read"],
 870                  hsep [ int dd_sp, text "data decls imported, out of",
 871                         int dd_rd, text "read"],
 872                  hsep [ int nd_sp, text "newtype decls imported, out of",
 873                         int nd_rd, text "read"],
 874                  hsep [int sd_sp, text "type synonym decls imported, out of",
 875                         int sd_rd, text "read"],
 876                  hsep [int vd_sp, text "value signatures imported, out of",
 877                         int vd_rd, text "read"],
 878                  hsep [int id_sp, text "instance decls imported, out of",
 879                         int inst_decls_read, text "read"],
 880                  text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
 881                                            [d | TyClD d <- imported_decls, isClassDecl d]),
 882                  text "cls dcls read"  <+> fsep (map (ppr . tyClDeclName)
 883                                            [d | TyClD d <- decls_read, isClassDecl d])]
 884     in
 885     returnRn (hcat [text "Renamer stats: ", stats])
 886
 887 count_decls decls
 888   = (class_decls,
 889      data_decls,
 890      newtype_decls,
 891      syn_decls,
 892      val_decls,
 893      inst_decls)
 894   where
 895     tycl_decls = [d | TyClD d <- decls]
 896     (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
 897
 898     val_decls     = length [() | SigD _   <- decls]
 899     inst_decls    = length [() | InstD _  <- decls]
 900 \end{code}
 901
 902
 903 %************************************************************************
 904 %*                                                                      *
 905 \subsection{Errors and warnings}
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 \begin{code}
 910 warnDeprec :: (Name, DeprecTxt) -> RnM d ()
 911 warnDeprec (name, txt)
 912   = pushSrcLocRn (getSrcLoc name)       $
 913     addWarnRn                           $
 914     sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
 915           text "is deprecated:", nest 4 (ppr txt) ]
 916
 917
 918 unusedFixityDecl rdr_name fixity
 919   = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
 920
 921 dupFixityDecl rdr_name loc1 loc2
 922   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 923           ptext SLIT("at ") <+> ppr loc1,
 924           ptext SLIT("and") <+> ppr loc2]
 925 \end{code}