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