ghc/compiler/rename/Rename.lhs

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