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 RdrHsSyn         ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
  13 import RnHsSyn          ( RenamedHsDecl,
  14                           extractHsTyNames, extractHsCtxtTyNames
  15                         )
  16
  17 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  18 import RnMonad
  19 import RnNames          ( getGlobalNames )
  20 import RnSource         ( rnSourceDecls, rnDecl )
  21 import RnIfaces         ( getImportedInstDecls, importDecl, mkImportInfo,
  22                           getInterfaceExports,
  23                           getImportedRules, getSlurped, removeContext,
  24                           ImportDeclResult(..)
  25                         )
  26 import RnEnv            ( availName, availsToNameSet,
  27                           emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails,
  28                           warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
  29                           lookupOrigNames, lookupGlobalRn,
  30                           FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
  31                         )
  32 import Module           ( Module, ModuleName, WhereFrom(..),
  33                           moduleNameUserString, moduleName,
  34                           lookupModuleEnv
  35                         )
  36 import Name             ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
  37                           nameOccName, nameUnique, nameModule,
  38                           isUserExportedName,
  39                           mkNameEnv, nameEnvElts, extendNameEnv
  40                         )
  41 import OccName          ( occNameFlavour )
  42 import Id               ( idType )
  43 import TyCon            ( isSynTyCon, getSynTyConDefn )
  44 import NameSet
  45 import TysWiredIn       ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
  46 import PrelNames        ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
  47                           ioTyCon_RDR,
  48                           unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
  49                           eqString_RDR
  50                         )
  51 import PrelInfo         ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
  52 import Type             ( namesOfType, funTyCon )
  53 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet )
  54 import Bag              ( isEmptyBag, bagToList )
  55 import FiniteMap        ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
  56                           addToFM_C, elemFM, addToFM
  57                         )
  58 import UniqFM           ( lookupUFM )
  59 import Maybes           ( maybeToBool, catMaybes )
  60 import Outputable
  61 import IO               ( openFile, IOMode(..) )
  62 import HscTypes         ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
  63                           ModIface(..), TyThing(..),
  64                           GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo,
  65                           Provenance(..), ImportReason(..), initialVersionInfo,
  66                           Deprecations(..), lookupDeprec
  67                          )
  68 import List             ( partition, nub )
  69 \end{code}
  70
  71
  72
  73 \begin{code}
  74 renameModule :: DynFlags -> Finder
  75              -> HomeIfaceTable -> HomeSymbolTable
  76              -> PersistentCompilerState
  77              -> Module -> RdrNameHsModule
  78              -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl]))
  79
  80 renameModule dflags finder hit hst old_pcs this_module
  81              this_mod@(HsModule _ _ _ _ _ _ loc)
  82   =     -- Initialise the renamer monad
  83     do {
  84         ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs)
  85            <- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ;
  86
  87         -- Check for warnings
  88         printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ;
  89
  90         -- Dump any debugging output
  91         dump_action ;
  92
  93         -- Return results
  94         if not (isEmptyBag rn_errs_bag) then
  95             return (old_pcs, Nothing)
  96         else
  97             return (new_pcs, maybe_rn_stuff)
  98     }
  99 \end{code}
 100
 101 \begin{code}
 102 rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]), IO ())
 103 rename this_module 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) ->
 114
 115         -- DEAL WITH DEPRECATIONS
 116     rnDeprecs local_gbl_env mod_deprec
 117               [d | DeprecD d <- 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     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     mkImportInfo mod_name imports       `thenRn` \ my_usages ->
 155
 156         -- RETURN THE RENAMED MODULE
 157     getNameSupplyRn                     `thenRn` \ name_supply ->
 158     getIfacesRn                         `thenRn` \ ifaces ->
 159     let
 160         direct_import_mods :: [ModuleName]
 161         direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
 162
 163         -- We record fixities even for things that aren't exported,
 164         -- so that we can change into the context of this moodule easily
 165         fixities = mkNameEnv [ (name, fixity)
 166                              | FixitySig name fixity loc <- nameEnvElts local_fixity_env
 167                              ]
 168
 169
 170         -- Sort the exports to make them easier to compare for versions
 171         my_exports = sortAvails export_avails
 172
 173         mod_iface = ModIface {  mi_module   = this_module,
 174                                 mi_version  = initialVersionInfo,
 175                                 mi_orphan   = any isOrphanDecl rn_local_decls,
 176                                 mi_exports  = my_exports,
 177                                 mi_globals  = gbl_env,
 178                                 mi_usages   = my_usages,
 179                                 mi_fixities = fixities,
 180                                 mi_deprecs  = my_deprecs,
 181                                 mi_decls    = panic "mi_decls"
 182                     }
 183
 184         final_decls = rn_local_decls ++ rn_imp_decls
 185     in
 186
 187         -- REPORT UNUSED NAMES, AND DEBUG DUMP
 188     reportUnusedNames mod_name direct_import_mods
 189                       gbl_env global_avail_env
 190                       export_avails source_fvs
 191                       rn_imp_decls                      `thenRn_`
 192
 193     returnRn (Just (mod_iface, final_decls), dump_action) }
 194 \end{code}
 195
 196 @implicitFVs@ forces the renamer to slurp in some things which aren't
 197 mentioned explicitly, but which might be needed by the type checker.
 198
 199 \begin{code}
 200 implicitFVs mod_name decls
 201   = lookupOrigNames implicit_occs                       `thenRn` \ implicit_names ->
 202     returnRn (mkNameSet (map getName default_tycons)    `plusFV`
 203               implicit_names)
 204   where
 205         -- Add occurrences for Int, and (), because they
 206         -- are the types to which ambigious type variables may be defaulted by
 207         -- the type checker; so they won't always appear explicitly.
 208         -- [The () one is a GHC extension for defaulting CCall results.]
 209         -- ALSO: funTyCon, since it occurs implicitly everywhere!
 210         --       (we don't want to be bothered with making funTyCon a
 211         --        free var at every function application!)
 212         -- Double is dealt with separately in getGates
 213     default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
 214
 215         -- Add occurrences for IO or PrimIO
 216     implicit_main |  mod_name == mAIN_Name
 217                   || mod_name == pREL_MAIN_Name = [ioTyCon_RDR]
 218                   |  otherwise                  = []
 219
 220         -- Now add extra "occurrences" for things that
 221         -- the deriving mechanism, or defaulting, will later need in order to
 222         -- generate code
 223     implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
 224
 225         -- Virtually every program has error messages in it somewhere
 226     string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
 227                    eqString_RDR]
 228
 229     get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _))
 230        = concat (map get_deriv deriv_classes)
 231     get other = []
 232
 233     get_deriv cls = case lookupUFM derivingOccurrences cls of
 234                         Nothing   -> []
 235                         Just occs -> occs
 236 \end{code}
 237
 238 \begin{code}
 239 isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
 240   = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty)))
 241         -- The 'removeContext' is because of
 242         --      instance Foo a => Baz T where ...
 243         -- The decl is an orphan if Baz and T are both not locally defined,
 244         --      even if Foo *is* locally defined
 245
 246 isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _))
 247   = check lhs
 248   where
 249         -- At the moment we just check for common LHS forms
 250         -- Expand as necessary.  Getting it wrong just means
 251         -- more orphans than necessary
 252     check (HsVar v)       = not (isLocallyDefined v)
 253     check (HsApp f a)     = check f && check a
 254     check (HsLit _)       = False
 255     check (HsOverLit _)   = False
 256     check (OpApp l o _ r) = check l && check o && check r
 257     check (NegApp e _)    = check e
 258     check (HsPar e)       = check e
 259     check (SectionL e o)  = check e && check o
 260     check (SectionR o e)  = check e && check o
 261
 262     check other           = True        -- Safe fall through
 263
 264 isOrphanDecl other = False
 265 \end{code}
 266
 267
 268 %*********************************************************
 269 %*                                                       *
 270 \subsection{Slurping declarations}
 271 %*                                                       *
 272 %*********************************************************
 273
 274 \begin{code}
 275 -------------------------------------------------------
 276 slurpImpDecls source_fvs
 277   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
 278
 279         -- The current slurped-set records all local things
 280     getSlurped                                  `thenRn` \ source_binders ->
 281     slurpSourceRefs source_binders source_fvs   `thenRn` \ (decls, needed) ->
 282
 283         -- Then get everything else
 284     closeDecls decls needed                     `thenRn` \ decls1 ->
 285
 286         -- Finally, get any deferred data type decls
 287     slurpDeferredDecls decls1                   `thenRn` \ final_decls ->
 288
 289     returnRn final_decls
 290
 291 -------------------------------------------------------
 292 slurpSourceRefs :: NameSet                      -- Variables defined in source
 293                 -> FreeVars                     -- Variables referenced in source
 294                 -> RnMG ([RenamedHsDecl],
 295                          FreeVars)              -- Un-satisfied needs
 296 -- The declaration (and hence home module) of each gate has
 297 -- already been loaded
 298
 299 slurpSourceRefs source_binders source_fvs
 300   = go_outer []                         -- Accumulating decls
 301              emptyFVs                   -- Unsatisfied needs
 302              emptyFVs                   -- Accumulating gates
 303              (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
 304   where
 305         -- The outer loop repeatedly slurps the decls for the current gates
 306         -- and the instance decls
 307
 308         -- The outer loop is needed because consider
 309         --      instance Foo a => Baz (Maybe a) where ...
 310         -- It may be that @Baz@ and @Maybe@ are used in the source module,
 311         -- but not @Foo@; so we need to chase @Foo@ too.
 312         --
 313         -- We also need to follow superclass refs.  In particular, 'chasing @Foo@' must
 314         -- include actually getting in Foo's class decl
 315         --      class Wib a => Foo a where ..
 316         -- so that its superclasses are discovered.  The point is that Wib is a gate too.
 317         -- We do this for tycons too, so that we look through type synonyms.
 318
 319     go_outer decls fvs all_gates []
 320         = returnRn (decls, fvs)
 321
 322     go_outer decls fvs all_gates refs   -- refs are not necessarily slurped yet
 323         = traceRn (text "go_outer" <+> ppr refs)                `thenRn_`
 324           foldlRn go_inner (decls, fvs, emptyFVs) refs          `thenRn` \ (decls1, fvs1, gates1) ->
 325           getImportedInstDecls (all_gates `plusFV` gates1)      `thenRn` \ inst_decls ->
 326           rnInstDecls decls1 fvs1 gates1 inst_decls             `thenRn` \ (decls2, fvs2, gates2) ->
 327           go_outer decls2 fvs2 (all_gates `plusFV` gates2)
 328                                (nameSetToList (gates2 `minusNameSet` all_gates))
 329                 -- Knock out the all_gates because even if we don't slurp any new
 330                 -- decls we can get some apparently-new gates from wired-in names
 331
 332     go_inner (decls, fvs, gates) wanted_name
 333         = importDecl wanted_name                `thenRn` \ import_result ->
 334           case import_result of
 335             AlreadySlurped -> returnRn (decls, fvs, gates)
 336             WiredIn        -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
 337             Deferred       -> returnRn (decls, fvs, gates `addOneFV` wanted_name)       -- It's a type constructor
 338
 339             HereItIs decl -> rnIfaceDecl decl           `thenRn` \ (new_decl, fvs1) ->
 340                              returnRn (new_decl : decls,
 341                                        fvs1 `plusFV` fvs,
 342                                        gates `plusFV` getGates source_fvs new_decl)
 343
 344 rnInstDecls decls fvs gates []
 345   = returnRn (decls, fvs, gates)
 346 rnInstDecls decls fvs gates (d:ds)
 347   = rnIfaceDecl d               `thenRn` \ (new_decl, fvs1) ->
 348     rnInstDecls (new_decl:decls)
 349                 (fvs1 `plusFV` fvs)
 350                 (gates `plusFV` getInstDeclGates new_decl)
 351                 ds
 352 \end{code}
 353
 354
 355 \begin{code}
 356 -------------------------------------------------------
 357 -- closeDecls keeps going until the free-var set is empty
 358 closeDecls decls needed
 359   | not (isEmptyFVs needed)
 360   = slurpDecls decls needed     `thenRn` \ (decls1, needed1) ->
 361     closeDecls decls1 needed1
 362
 363   | otherwise
 364   = getImportedRules                    `thenRn` \ rule_decls ->
 365     case rule_decls of
 366         []    -> returnRn decls -- No new rules, so we are done
 367         other -> rnIfaceDecls decls emptyFVs rule_decls         `thenRn` \ (decls1, needed1) ->
 368                  closeDecls decls1 needed1
 369
 370
 371 -------------------------------------------------------
 372 -- Augment decls with any decls needed by needed.
 373 -- Return also free vars of the new decls (only)
 374 slurpDecls decls needed
 375   = go decls emptyFVs (nameSetToList needed)
 376   where
 377     go decls fvs []         = returnRn (decls, fvs)
 378     go decls fvs (ref:refs) = slurpDecl decls fvs ref   `thenRn` \ (decls1, fvs1) ->
 379                               go decls1 fvs1 refs
 380
 381 -------------------------------------------------------
 382 slurpDecl decls fvs wanted_name
 383   = importDecl wanted_name              `thenRn` \ import_result ->
 384     case import_result of
 385         -- Found a declaration... rename it
 386         HereItIs decl -> rnIfaceDecl decl               `thenRn` \ (new_decl, fvs1) ->
 387                          returnRn (new_decl:decls, fvs1 `plusFV` fvs)
 388
 389         -- No declaration... (wired in thing, or deferred, or already slurped)
 390         other -> returnRn (decls, fvs)
 391
 392
 393 -------------------------------------------------------
 394 rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
 395              -> [(Module, RdrNameHsDecl)]
 396              -> RnM d ([RenamedHsDecl], FreeVars)
 397 rnIfaceDecls decls fvs []     = returnRn (decls, fvs)
 398 rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d           `thenRn` \ (new_decl, fvs1) ->
 399                                 rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
 400
 401 rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
 402 \end{code}
 403
 404
 405 %*********************************************************
 406 %*                                                       *
 407 \subsection{Deferred declarations}
 408 %*                                                       *
 409 %*********************************************************
 410
 411 The idea of deferred declarations is this.  Suppose we have a function
 412         f :: T -> Int
 413         data T = T1 A | T2 B
 414         data A = A1 X | A2 Y
 415         data B = B1 P | B2 Q
 416 Then we don't want to load T and all its constructors, and all
 417 the types those constructors refer to, and all the types *those*
 418 constructors refer to, and so on.  That might mean loading many more
 419 interface files than is really necessary.  So we 'defer' loading T.
 420
 421 But f might be strict, and the calling convention for evaluating
 422 values of type T depends on how many constructors T has, so
 423 we do need to load T, but not the full details of the type T.
 424 So we load the full decl for T, but only skeleton decls for A and B:
 425         f :: T -> Int
 426         data T = {- 2 constructors -}
 427
 428 Whether all this is worth it is moot.
 429
 430 \begin{code}
 431 slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
 432 slurpDeferredDecls decls = returnRn decls
 433
 434 {-      OMIT FOR NOW
 435 slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
 436 slurpDeferredDecls decls
 437   = getDeferredDecls                                            `thenRn` \ def_decls ->
 438     rnIfaceDecls decls emptyFVs (map stripDecl def_decls)       `thenRn` \ (decls1, fvs) ->
 439     ASSERT( isEmptyFVs fvs )
 440     returnRn decls1
 441
 442 stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
 443   = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc
 444                 name1 name2))
 445         -- Nuke the context and constructors
 446         -- But retain the *number* of constructors!
 447         -- Also the tvs will have kinds on them.
 448 -}
 449 \end{code}
 450
 451
 452 %*********************************************************
 453 %*                                                       *
 454 \subsection{Extracting the `gates'}
 455 %*                                                       *
 456 %*********************************************************
 457
 458 When we import a declaration like
 459 \begin{verbatim}
 460         data T = T1 Wibble | T2 Wobble
 461 \end{verbatim}
 462 we don't want to treat @Wibble@ and @Wobble@ as gates
 463 {\em unless} @T1@, @T2@ respectively are mentioned by the user program.
 464 If only @T@ is mentioned
 465 we want only @T@ to be a gate;
 466 that way we don't suck in useless instance
 467 decls for (say) @Eq Wibble@, when they can't possibly be useful.
 468
 469 @getGates@ takes a newly imported (and renamed) decl, and the free
 470 vars of the source program, and extracts from the decl the gate names.
 471
 472 \begin{code}
 473 getGates source_fvs (SigD (IfaceSig _ ty _ _))
 474   = extractHsTyNames ty
 475
 476 getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ ))
 477   = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
 478                         (hsTyVarNames tvs)
 479      `addOneToNameSet` cls)
 480     `plusFV` maybe_double
 481   where
 482     get (ClassOpSig n _ ty _)
 483         | n `elemNameSet` source_fvs = extractHsTyNames ty
 484         | otherwise                  = emptyFVs
 485
 486         -- If we load any numeric class that doesn't have
 487         -- Int as an instance, add Double to the gates.
 488         -- This takes account of the fact that Double might be needed for
 489         -- defaulting, but we don't want to load Double (and all its baggage)
 490         -- if the more exotic classes aren't used at all.
 491     maybe_double | nameUnique cls `elem` fractionalClassKeys
 492                  = unitFV (getName doubleTyCon)
 493                  | otherwise
 494                  = emptyFVs
 495
 496 getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
 497   = delListFromNameSet (extractHsTyNames ty)
 498                        (hsTyVarNames tvs)
 499         -- A type synonym type constructor isn't a "gate" for instance decls
 500
 501 getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _))
 502   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
 503                        (hsTyVarNames tvs)
 504     `addOneToNameSet` tycon
 505   where
 506     get (ConDecl n _ tvs ctxt details _)
 507         | n `elemNameSet` source_fvs
 508                 -- If the constructor is method, get fvs from all its fields
 509         = delListFromNameSet (get_details details `plusFV`
 510                               extractHsCtxtTyNames ctxt)
 511                              (hsTyVarNames tvs)
 512     get (ConDecl n _ tvs ctxt (RecCon fields) _)
 513                 -- Even if the constructor isn't mentioned, the fields
 514                 -- might be, as selectors.  They can't mention existentially
 515                 -- bound tyvars (typechecker checks for that) so no need for
 516                 -- the deleteListFromNameSet part
 517         = foldr (plusFV . get_field) emptyFVs fields
 518
 519     get other_con = emptyFVs
 520
 521     get_details (VanillaCon tys) = plusFVs (map get_bang tys)
 522     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
 523     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
 524
 525     get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
 526                      | otherwise                         = emptyFVs
 527
 528     get_bang bty = extractHsTyNames (getBangType bty)
 529
 530 getGates source_fvs other_decl = emptyFVs
 531 \end{code}
 532
 533 @getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
 534 rather than a declaration.
 535
 536 \begin{code}
 537 getWiredInGates :: Name -> FreeVars
 538 getWiredInGates name    -- No classes are wired in
 539   = case lookupNameEnv wiredInThingEnv name of
 540         Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))
 541
 542         Just (ATyCon tc)
 543           |  isSynTyCon tc
 544           -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
 545           where
 546              (tyvars,ty)  = getSynTyConDefn tc
 547
 548         other -> unitFV name
 549
 550 getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
 551 \end{code}
 552
 553 \begin{code}
 554 getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
 555 getInstDeclGates other                              = emptyFVs
 556 \end{code}
 557
 558
 559 %*********************************************************
 560 %*                                                       *
 561 \subsection{Fixities}
 562 %*                                                       *
 563 %*********************************************************
 564
 565 \begin{code}
 566 fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
 567 fixitiesFromLocalDecls gbl_env decls
 568   = doptRn Opt_WarnUnusedBinds                            `thenRn` \ warn_unused ->
 569     foldlRn (getFixities warn_unused) emptyNameEnv decls  `thenRn` \ env ->
 570     traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))
 571                                                           `thenRn_`
 572     returnRn env
 573   where
 574     getFixities :: Bool -> LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
 575     getFixities warn_uu acc (FixD fix)
 576       = fix_decl warn_uu acc fix
 577
 578     getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
 579       = foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
 580                 -- Get fixities from class decl sigs too.
 581     getFixities warn_uu acc other_decl
 582       = returnRn acc
 583
 584     fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
 585         =       -- Check for fixity decl for something not declared
 586           pushSrcLocRn loc                      $
 587           lookupGlobalRn gbl_env rdr_name       `thenRn` \  maybe_name ->
 588           case maybe_name of {
 589             Nothing ->  checkRn (not warn_uu) (unusedFixityDecl rdr_name fixity)        `thenRn_`
 590                         returnRn acc ;
 591
 592             Just name ->
 593
 594                 -- Check for duplicate fixity decl
 595           case lookupNameEnv acc name of {
 596             Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
 597                                          `thenRn_` returnRn acc ;
 598
 599             Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
 600           }}
 601 \end{code}
 602
 603
 604 %*********************************************************
 605 %*                                                       *
 606 \subsection{Deprecations}
 607 %*                                                       *
 608 %*********************************************************
 609
 610 For deprecations, all we do is check that the names are in scope.
 611 It's only imported deprecations, dealt with in RnIfaces, that we
 612 gather them together.
 613
 614 \begin{code}
 615 rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
 616            -> [RdrNameDeprecation] -> RnMG Deprecations
 617 rnDeprecs gbl_env Nothing []
 618  = returnRn NoDeprecs
 619
 620 rnDeprecs gbl_env (Just txt) decls
 621  = mapRn (addErrRn . badDeprec) decls   `thenRn_`
 622    returnRn (DeprecAll txt)
 623
 624 rnDeprecs gbl_env Nothing decls
 625   = mapRn rn_deprec decls       `thenRn` \ pairs ->
 626     returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
 627  where
 628    rn_deprec (Deprecation rdr_name txt loc)
 629      = pushSrcLocRn loc                 $
 630        lookupGlobalRn gbl_env rdr_name  `thenRn` \ maybe_name ->
 631        case maybe_name of
 632          Just n  -> returnRn (Just (n,txt))
 633          Nothing -> returnRn Nothing
 634 \end{code}
 635
 636
 637 %*********************************************************
 638 %*                                                       *
 639 \subsection{Unused names}
 640 %*                                                       *
 641 %*********************************************************
 642
 643 \begin{code}
 644 reportUnusedNames :: ModuleName -> [ModuleName]
 645                   -> GlobalRdrEnv -> AvailEnv
 646                   -> Avails -> NameSet -> [RenamedHsDecl]
 647                   -> RnMG ()
 648 reportUnusedNames mod_name direct_import_mods
 649                   gbl_env avail_env
 650                   export_avails mentioned_names
 651                   imported_decls
 652   = warnUnusedModules unused_imp_mods                           `thenRn_`
 653     warnUnusedLocalBinds bad_locals                             `thenRn_`
 654     warnUnusedImports bad_imp_names                             `thenRn_`
 655     printMinimalImports mod_name minimal_imports                `thenRn_`
 656     warnDeprecations really_used_names                          `thenRn_`
 657     returnRn ()
 658
 659   where
 660     used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 661
 662     -- Now, a use of C implies a use of T,
 663     -- if C was brought into scope by T(..) or T(C)
 664     really_used_names = used_names `unionNameSets`
 665       mkNameSet [ parent_name
 666                 | sub_name <- nameSetToList used_names
 667
 668                 -- Usually, every used name will appear in avail_env, but there
 669                 -- is one time when it doesn't: tuples and other built in syntax.  When you
 670                 -- write (a,b) that gives rise to a *use* of "(,)", so that the
 671                 -- instances will get pulled in, but the tycon "(,)" isn't actually
 672                 -- in scope.  Also, (-x) gives rise to an implicit use of 'negate';
 673                 -- similarly,   3.5 gives rise to an implcit use of :%
 674                 -- Hence the silent 'False' in all other cases
 675
 676                 , Just parent_name <- [case lookupNameEnv avail_env sub_name of
 677                                         Just (AvailTC n _) -> Just n
 678                                         other              -> Nothing]
 679             ]
 680
 681     defined_names, defined_and_used, defined_but_not_used :: [(Name,Provenance)]
 682     defined_names                            = concat (rdrEnvElts gbl_env)
 683     (defined_and_used, defined_but_not_used) = partition used defined_names
 684     used (name,_)                            = not (name `elemNameSet` really_used_names)
 685
 686     -- Filter out the ones only defined implicitly
 687     bad_locals :: [Name]
 688     bad_locals     = [n     | (n,LocalDef) <- defined_but_not_used]
 689
 690     bad_imp_names :: [(Name,Provenance)]
 691     bad_imp_names  = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True) _)) <- defined_but_not_used,
 692                               not (module_unused mod)]
 693
 694     -- inst_mods are directly-imported modules that
 695     --  contain instance decl(s) that the renamer decided to suck in
 696     -- It's not necessarily redundant to import such modules.
 697     --
 698     -- NOTE: Consider
 699     --        module This
 700     --          import M ()
 701     --
 702     --   The import M() is not *necessarily* redundant, even if
 703     --   we suck in no instance decls from M (e.g. it contains
 704     --   no instance decls, or This contains no code).  It may be
 705     --   that we import M solely to ensure that M's orphan instance
 706     --   decls (or those in its imports) are visible to people who
 707     --   import This.  Sigh.
 708     --   There's really no good way to detect this, so the error message
 709     --   in RnEnv.warnUnusedModules is weakened instead
 710     inst_mods :: [ModuleName]
 711     inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
 712                  let m = moduleName (nameModule dfun),
 713                  m `elem` direct_import_mods
 714             ]
 715
 716     -- To figure out the minimal set of imports, start with the things
 717     -- that are in scope (i.e. in gbl_env).  Then just combine them
 718     -- into a bunch of avails, so they are properly grouped
 719     minimal_imports :: FiniteMap ModuleName AvailEnv
 720     minimal_imports0 = emptyFM
 721     minimal_imports1 = foldr add_name     minimal_imports0 defined_and_used
 722     minimal_imports  = foldr add_inst_mod minimal_imports1 inst_mods
 723
 724     add_name (n,NonLocalDef (UserImport m _ _) _) acc = addToFM_C plusAvailEnv acc (moduleName (nameModule n))
 725                                                                   (unitAvailEnv (mk_avail n))
 726     add_name (n,other_prov)                       acc = acc
 727
 728     mk_avail n = case lookupNameEnv avail_env n of
 729                 Just (AvailTC m _) | n==m      -> AvailTC n [n]
 730                                    | otherwise -> AvailTC m [n,m]
 731                 Just avail         -> Avail n
 732                 Nothing            -> pprPanic "mk_avail" (ppr n)
 733
 734     add_inst_mod m acc
 735       | m `elemFM` acc = acc    -- We import something already
 736       | otherwise      = addToFM acc m emptyAvailEnv
 737         -- Add an empty collection of imports for a module
 738         -- from which we have sucked only instance decls
 739
 740     -- unused_imp_mods are the directly-imported modules
 741     -- that are not mentioned in minimal_imports
 742     unused_imp_mods = [m | m <- direct_import_mods,
 743                        not (maybeToBool (lookupFM minimal_imports m)),
 744                        m /= pRELUDE_Name]
 745
 746     module_unused :: Module -> Bool
 747     module_unused mod = moduleName mod `elem` unused_imp_mods
 748
 749
 750 warnDeprecations used_names
 751   = doptRn Opt_WarnDeprecations                         `thenRn` \ warn_drs ->
 752     if not warn_drs then returnRn () else
 753
 754     getIfacesRn                                         `thenRn` \ ifaces ->
 755     getHomeIfaceTableRn                                 `thenRn` \ hit ->
 756     let
 757         pit     = iPIT ifaces
 758         deprecs = [ (n,txt)
 759                   | n <- nameSetToList used_names,
 760                     Just txt <- [lookup_deprec hit pit n] ]
 761     in
 762     mapRn_ warnDeprec deprecs
 763
 764   where
 765     lookup_deprec hit pit n
 766         = case lookupModuleEnv hit mod of
 767                 Just iface -> lookupDeprec iface n
 768                 Nothing    -> case lookupModuleEnv pit mod of
 769                                 Just iface -> lookupDeprec iface n
 770                                 Nothing    -> pprPanic "warnDeprecations:" (ppr n)
 771         where
 772           mod = nameModule n
 773
 774 -- ToDo: deal with original imports with 'qualified' and 'as M' clauses
 775 printMinimalImports mod_name imps
 776   = doptRn Opt_D_dump_minimal_imports           `thenRn` \ dump_minimal ->
 777     if not dump_minimal then returnRn () else
 778
 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    = doptRn Opt_D_dump_rn_trace         `thenRn` \ dump_rn_trace ->
 813      doptRn Opt_D_dump_rn_stats         `thenRn` \ dump_rn_stats ->
 814      doptRn Opt_D_dump_rn               `thenRn` \ dump_rn ->
 815      if dump_rn_trace || dump_rn_stats || dump_rn then
 816         getRnStats imp_decls            `thenRn` \ stats_msg ->
 817         returnRn (printErrs stats_msg >>
 818                   dumpIfSet dump_rn "Renamer:"
 819                             (vcat (map ppr (local_decls ++ imp_decls))))
 820      else
 821         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 [() | (_, _, True) <- 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
 913 badDeprec d
 914   = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
 915          nest 4 (ppr d)]
 916 \end{code}
 917
 918
 919 %********************************************************
 920 %*                                                      *
 921 \subsection{Checking usage information}
 922 %*                                                      *
 923 %********************************************************
 924
 925 \begin{code}
 926 {-
 927 checkEarlyExit mod_name
 928   = traceRn (text "Considering whether compilation is required...")     `thenRn_`
 929
 930         -- Read the old interface file, if any, for the module being compiled
 931     findAndReadIface doc_str mod_name False {- Not hi-boot -}   `thenRn` \ maybe_iface ->
 932
 933         -- CHECK WHETHER WE HAVE IT ALREADY
 934     case maybe_iface of
 935         Left err ->     -- Old interface file not found, so we'd better bail out
 936                     traceRn (vcat [ptext SLIT("No old interface file for") <+> ppr mod_name,
 937                                    err])                        `thenRn_`
 938                     returnRn (outOfDate, Nothing)
 939
 940         Right iface
 941           | panic "checkEarlyExit: ???: not opt_SourceUnchanged"
 942           ->    -- Source code changed
 943              traceRn (nest 4 (text "source file changed or recompilation check turned off"))    `thenRn_`
 944              returnRn (False, Just iface)
 945
 946           | otherwise
 947           ->    -- Source code unchanged and no errors yet... carry on
 948              checkModUsage (pi_usages iface)    `thenRn` \ up_to_date ->
 949              returnRn (up_to_date, Just iface)
 950   where
 951         -- Only look in current directory, with suffix .hi
 952     doc_str = sep [ptext SLIT("need usage info from"), ppr mod_name]
 953 \end{code}
 954
 955 \begin{code}
 956 upToDate  = True
 957 outOfDate = False
 958
 959 checkModUsage :: [ImportVersion OccName] -> RnMG Bool
 960 -- Given the usage information extracted from the old
 961 -- M.hi file for the module being compiled, figure out
 962 -- whether M needs to be recompiled.
 963
 964 checkModUsage [] = returnRn upToDate            -- Yes!  Everything is up to date!
 965
 966 checkModUsage ((mod_name, _, _, NothingAtAll) : rest)
 967         -- If CurrentModule.hi contains
 968         --      import Foo :: ;
 969         -- then that simply records that Foo lies below CurrentModule in the
 970         -- hierarchy, but CurrentModule doesn't depend in any way on Foo.
 971         -- In this case we don't even want to open Foo's interface.
 972   = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_`
 973     checkModUsage rest  -- This one's ok, so check the rest
 974
 975 checkModUsage ((mod_name, _, _, whats_imported)  : rest)
 976   = tryLoadInterface doc_str mod_name ImportBySystem    `thenRn` \ (ifaces, maybe_err) ->
 977     case maybe_err of {
 978         Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
 979                                       ppr mod_name]) ;
 980                 -- Couldn't find or parse a module mentioned in the
 981                 -- old interface file.  Don't complain -- it might just be that
 982                 -- the current module doesn't need that import and it's been deleted
 983
 984         Nothing ->
 985     let
 986         (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _)
 987                 = case lookupFM (iImpModInfo ifaces) mod_name of
 988                            Just (_, _, Just stuff) -> stuff
 989
 990         old_mod_vers = case whats_imported of
 991                          Everything v        -> v
 992                          Specifically v _ _ _ -> v
 993                          -- NothingAtAll case dealt with by previous eqn for checkModUsage
 994     in
 995         -- If the module version hasn't changed, just move on
 996     if new_mod_vers == old_mod_vers then
 997         traceRn (sep [ptext SLIT("Module version unchanged:"), ppr mod_name])
 998         `thenRn_` checkModUsage rest
 999     else
1000     traceRn (sep [ptext SLIT("Module version has changed:"), ppr mod_name])
1001     `thenRn_`
1002         -- Module version changed, so check entities inside
1003
1004         -- If the usage info wants to say "I imported everything from this module"
1005         --     it does so by making whats_imported equal to Everything
1006         -- In that case, we must recompile
1007     case whats_imported of {    -- NothingAtAll dealt with earlier
1008
1009       Everything _
1010         -> out_of_date (ptext SLIT("...and I needed the whole module")) ;
1011
1012       Specifically _ old_fix_vers old_rule_vers old_local_vers ->
1013
1014     if old_fix_vers /= new_fix_vers then
1015         out_of_date (ptext SLIT("Fixities changed"))
1016     else if old_rule_vers /= new_rule_vers then
1017         out_of_date (ptext SLIT("Rules changed"))
1018     else
1019         -- Non-empty usage list, so check item by item
1020     checkEntityUsage mod_name (iDecls ifaces) old_local_vers    `thenRn` \ up_to_date ->
1021     if up_to_date then
1022         traceRn (ptext SLIT("...but the bits I use haven't."))  `thenRn_`
1023         checkModUsage rest      -- This one's ok, so check the rest
1024     else
1025         returnRn outOfDate      -- This one failed, so just bail out now
1026     }}
1027   where
1028     doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
1029
1030
1031 checkEntityUsage mod decls []
1032   = returnRn upToDate   -- Yes!  All up to date!
1033
1034 checkEntityUsage mod decls ((occ_name,old_vers) : rest)
1035   = newGlobalName mod occ_name  `thenRn` \ name ->
1036     case lookupNameEnv decls name of
1037
1038         Nothing       ->        -- We used it before, but it ain't there now
1039                           out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
1040
1041         Just (new_vers,_,_,_)   -- It's there, but is it up to date?
1042                 | new_vers == old_vers
1043                         -- Up to date, so check the rest
1044                 -> checkEntityUsage mod decls rest
1045
1046                 | otherwise
1047                         -- Out of date, so bale out
1048                 -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
1049
1050 out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate
1051 -}
1052 \end{code}
1053
1054