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