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