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