ghc/compiler/rename/Rename.lhs

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