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, renameExpr, closeIfaceDecls, checkOldIface ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn
  12 import RdrHsSyn         ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, RdrNameHsExpr,
  13                           RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl
  14                         )
  15 import RnHsSyn          ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
  16                           extractHsTyNames, RenamedHsExpr,
  17                           instDeclFVs, tyClDeclFVs, ruleDeclFVs
  18                         )
  19
  20 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  21 import RnMonad
  22 import RnExpr           ( rnExpr )
  23 import RnNames          ( getGlobalNames, exportsFromAvail )
  24 import RnSource         ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
  25 import RnIfaces         ( slurpImpDecls, mkImportInfo, recordLocalSlurps,
  26                           getInterfaceExports, closeDecls,
  27                           RecompileRequired, outOfDate, recompileRequired
  28                         )
  29 import RnHiFiles        ( readIface, removeContext, loadInterface,
  30                           loadExports, loadFixDecls, loadDeprecs,
  31                           tryLoadInterface )
  32 import RnEnv            ( availsToNameSet, availName, mkIfaceGlobalRdrEnv,
  33                           emptyAvailEnv, unitAvailEnv, availEnvElts,
  34                           plusAvailEnv, groupAvails, warnUnusedImports,
  35                           warnUnusedLocalBinds, warnUnusedModules,
  36                           lookupOrigNames, lookupSrcName,
  37                           newGlobalName, unQualInScope
  38                         )
  39 import Module           ( Module, ModuleName, WhereFrom(..),
  40                           moduleNameUserString, moduleName,
  41                           moduleEnvElts, lookupModuleEnv
  42                         )
  43 import Name             ( Name, NamedThing(..), getSrcLoc,
  44                           nameIsLocalOrFrom, nameOccName, nameModule,
  45                         )
  46 import Name             ( mkNameEnv, nameEnvElts, extendNameEnv )
  47 import RdrName          ( elemRdrEnv, foldRdrEnv, isQual )
  48 import OccName          ( occNameFlavour )
  49 import NameSet
  50 import TysWiredIn       ( unitTyCon, intTyCon, boolTyCon )
  51 import PrelNames        ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
  52                           ioTyCon_RDR, main_RDR_Unqual,
  53                           unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
  54                           eqString_RDR
  55                         )
  56 import PrelInfo         ( derivingOccurrences )
  57 import Type             ( funTyCon )
  58 import ErrUtils         ( dumpIfSet, showPass, printErrorsAndWarnings, errorsFound )
  59 import Bag              ( bagToList )
  60 import FiniteMap        ( FiniteMap, fmToList, emptyFM, lookupFM,
  61                           addToFM_C, elemFM, addToFM
  62                         )
  63 import UniqFM           ( lookupUFM )
  64 import Maybes           ( maybeToBool, catMaybes )
  65 import Outputable
  66 import IO               ( openFile, IOMode(..) )
  67 import HscTypes         ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
  68                           ModIface(..), WhatsImported(..),
  69                           VersionInfo(..), ImportVersion, IsExported,
  70                           IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
  71                           GlobalRdrEnv, pprGlobalRdrEnv,
  72                           AvailEnv, GenAvailInfo(..), AvailInfo, Avails,
  73                           Provenance(..), ImportReason(..), initialVersionInfo,
  74                           Deprecations(..), lookupDeprec, lookupIface
  75                          )
  76 import List             ( partition, nub )
  77 \end{code}
  78
  79
  80
  81
  82 %*********************************************************
  83 %*                                                       *
  84 \subsection{The two main wrappers}
  85 %*                                                       *
  86 %*********************************************************
  87
  88 \begin{code}
  89 renameModule :: DynFlags
  90              -> HomeIfaceTable -> HomeSymbolTable
  91              -> PersistentCompilerState
  92              -> Module -> RdrNameHsModule
  93              -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
  94         -- Nothing => some error occurred in the renamer
  95
  96 renameModule dflags hit hst pcs this_module rdr_module
  97   = renameSource dflags hit hst pcs this_module $
  98     rename this_module rdr_module
  99 \end{code}
 100
 101
 102 \begin{code}
 103 renameExpr :: DynFlags
 104            -> HomeIfaceTable -> HomeSymbolTable
 105            -> PersistentCompilerState
 106            -> Module -> RdrNameHsExpr
 107            -> IO ( PersistentCompilerState,
 108                    Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl]))
 109                  )
 110
 111 renameExpr dflags hit hst pcs this_module expr
 112   = do  { renameSource dflags hit hst pcs this_module $
 113           tryLoadInterface doc (moduleName this_module) ImportByUser
 114                                                 `thenRn` \ (iface, maybe_err) ->
 115           case maybe_err of {
 116             Just msg -> ioToRnM (printErrs alwaysQualify
 117                                  (ptext SLIT("failed to load interface for")
 118                                   <+> quotes (ppr this_module)
 119                                   <>  char ':' <+> msg)) `thenRn_`
 120                         returnRn Nothing;
 121             Nothing ->
 122
 123           let rdr_env      = mi_globals iface
 124               print_unqual = unQualInScope rdr_env
 125           in
 126
 127           initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr)
 128                                                 `thenRn` \ (e,fvs) ->
 129           lookupOrigNames implicit_occs         `thenRn` \ implicit_names ->
 130           slurpImpDecls (fvs `plusFV` implicit_names) `thenRn` \ decls ->
 131           doptRn Opt_D_dump_rn                  `thenRn` \ dump_rn ->
 132           ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e))
 133                                                 `thenRn_`
 134           returnRn (Just (print_unqual, (e, decls)))
 135         }}
 136   where
 137      implicit_occs = string_occs
 138      doc = text "context for compiling expression"
 139 \end{code}
 140
 141
 142 %*********************************************************
 143 %*                                                       *
 144 \subsection{The main function: rename}
 145 %*                                                       *
 146 %*********************************************************
 147
 148 \begin{code}
 149 renameSource :: DynFlags
 150              -> HomeIfaceTable -> HomeSymbolTable
 151              -> PersistentCompilerState
 152              -> Module
 153              -> RnMG (Maybe (PrintUnqualified, r))
 154              -> IO (PersistentCompilerState, Maybe (PrintUnqualified, r))
 155         -- Nothing => some error occurred in the renamer
 156
 157 renameSource dflags hit hst old_pcs this_module thing_inside
 158   = do  { showPass dflags "Renamer"
 159
 160                 -- Initialise the renamer monad
 161         ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside
 162
 163                 -- Print errors from renaming
 164         ;  let print_unqual = case maybe_rn_stuff of
 165                                 Just (unqual, _) -> unqual
 166                                 Nothing          -> alwaysQualify
 167
 168         ;  printErrorsAndWarnings print_unqual msgs ;
 169
 170                 -- Return results.  No harm in updating the PCS
 171         ; if errorsFound msgs then
 172             return (new_pcs, Nothing)
 173           else
 174             return (new_pcs, maybe_rn_stuff)
 175     }
 176 \end{code}
 177
 178 \begin{code}
 179 rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
 180 rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc)
 181   = pushSrcLocRn loc            $
 182
 183         -- FIND THE GLOBAL NAME ENVIRONMENT
 184     getGlobalNames this_module contents         `thenRn` \ (gbl_env, local_gbl_env, all_avails@(_, global_avail_env)) ->
 185
 186         -- Exit if we've found any errors
 187     checkErrsRn                         `thenRn` \ no_errs_so_far ->
 188     if not no_errs_so_far then
 189         -- Found errors already, so exit now
 190         rnDump [] []            `thenRn_`
 191         returnRn Nothing
 192     else
 193
 194         -- PROCESS EXPORT LIST
 195     exportsFromAvail mod_name exports all_avails gbl_env        `thenRn` \ export_avails ->
 196
 197     traceRn (text "Local top-level environment" $$
 198              nest 4 (pprGlobalRdrEnv local_gbl_env))    `thenRn_`
 199
 200         -- DEAL WITH DEPRECATIONS
 201     rnDeprecs local_gbl_env mod_deprec
 202               [d | DeprecD d <- local_decls]            `thenRn` \ my_deprecs ->
 203
 204         -- DEAL WITH LOCAL FIXITIES
 205     fixitiesFromLocalDecls local_gbl_env local_decls    `thenRn` \ local_fixity_env ->
 206
 207         -- RENAME THE SOURCE
 208     rnSourceDecls gbl_env local_fixity_env local_decls  `thenRn` \ (rn_local_decls, source_fvs) ->
 209
 210         -- CHECK THAT main IS DEFINED, IF REQUIRED
 211     checkMain this_module local_gbl_env         `thenRn_`
 212
 213         -- SLURP IN ALL THE NEEDED DECLARATIONS
 214     implicitFVs mod_name rn_local_decls         `thenRn` \ implicit_fvs ->
 215     let
 216         slurp_fvs = implicit_fvs `plusFV` source_fvs
 217                 -- It's important to do the "plus" this way round, so that
 218                 -- when compiling the prelude, locally-defined (), Bool, etc
 219                 -- override the implicit ones.
 220     in
 221     traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs)))   `thenRn_`
 222     slurpImpDecls slurp_fvs             `thenRn` \ rn_imp_decls ->
 223
 224         -- EXIT IF ERRORS FOUND
 225     rnDump rn_imp_decls rn_local_decls          `thenRn_`
 226     checkErrsRn                                 `thenRn` \ no_errs_so_far ->
 227     if not no_errs_so_far then
 228         -- Found errors already, so exit now
 229         returnRn Nothing
 230     else
 231
 232         -- GENERATE THE VERSION/USAGE INFO
 233     mkImportInfo mod_name imports                       `thenRn` \ my_usages ->
 234
 235         -- BUILD THE MODULE INTERFACE
 236     let
 237         -- We record fixities even for things that aren't exported,
 238         -- so that we can change into the context of this moodule easily
 239         fixities = mkNameEnv [ (name, fixity)
 240                              | FixitySig name fixity loc <- nameEnvElts local_fixity_env
 241                              ]
 242
 243         -- Sort the exports to make them easier to compare for versions
 244         my_exports = groupAvails this_module export_avails
 245
 246         final_decls = rn_local_decls ++ rn_imp_decls
 247         is_orphan   = any (isOrphanDecl this_module) rn_local_decls
 248
 249         mod_iface = ModIface {  mi_module   = this_module,
 250                                 mi_version  = initialVersionInfo,
 251                                 mi_usages   = my_usages,
 252                                 mi_boot     = False,
 253                                 mi_orphan   = is_orphan,
 254                                 mi_exports  = my_exports,
 255                                 mi_globals  = gbl_env,
 256                                 mi_fixities = fixities,
 257                                 mi_deprecs  = my_deprecs,
 258                                 mi_decls    = panic "mi_decls"
 259                     }
 260
 261         print_unqualified = unQualInScope gbl_env
 262         is_exported name  = name `elemNameSet` exported_names
 263         exported_names    = availsToNameSet export_avails
 264     in
 265
 266         -- REPORT UNUSED NAMES, AND DEBUG DUMP
 267     reportUnusedNames mod_iface print_unqualified
 268                       imports global_avail_env
 269                       source_fvs export_avails rn_imp_decls     `thenRn_`
 270
 271     returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls)))
 272   where
 273     mod_name = moduleName this_module
 274 \end{code}
 275
 276 Checking that main is defined
 277
 278 \begin{code}
 279 checkMain :: Module -> GlobalRdrEnv -> RnMG ()
 280 checkMain this_mod local_env
 281   | moduleName this_mod == mAIN_Name
 282   = checkRn (main_RDR_Unqual `elemRdrEnv` local_env) noMainErr
 283   | otherwise
 284   = returnRn ()
 285 \end{code}
 286
 287 @implicitFVs@ forces the renamer to slurp in some things which aren't
 288 mentioned explicitly, but which might be needed by the type checker.
 289
 290 \begin{code}
 291 implicitFVs mod_name decls
 292   = lookupOrigNames implicit_occs                       `thenRn` \ implicit_names ->
 293     returnRn (mkNameSet (map getName default_tycons)    `plusFV`
 294               implicit_names)
 295   where
 296         -- Add occurrences for Int, and (), because they
 297         -- are the types to which ambigious type variables may be defaulted by
 298         -- the type checker; so they won't always appear explicitly.
 299         -- [The () one is a GHC extension for defaulting CCall results.]
 300         -- ALSO: funTyCon, since it occurs implicitly everywhere!
 301         --       (we don't want to be bothered with making funTyCon a
 302         --        free var at every function application!)
 303         -- Double is dealt with separately in getGates
 304     default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
 305
 306         -- Add occurrences for IO or PrimIO
 307     implicit_main |  mod_name == mAIN_Name
 308                   || mod_name == pREL_MAIN_Name = [ioTyCon_RDR]
 309                   |  otherwise                  = []
 310
 311         -- Now add extra "occurrences" for things that
 312         -- the deriving mechanism, or defaulting, will later need in order to
 313         -- generate code
 314     implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
 315
 316
 317     get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _))
 318        = concat (map get_deriv deriv_classes)
 319     get other = []
 320
 321     get_deriv cls = case lookupUFM derivingOccurrences cls of
 322                         Nothing   -> []
 323                         Just occs -> occs
 324
 325 -- Virtually every program has error messages in it somewhere
 326 string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR,
 327                unpackCStringUtf8_RDR, eqString_RDR]
 328 \end{code}
 329
 330 \begin{code}
 331 isOrphanDecl this_mod (InstD (InstDecl inst_ty _ _ _ _))
 332   = not (foldNameSet ((||) . nameIsLocalOrFrom this_mod) False
 333                      (extractHsTyNames (removeContext inst_ty)))
 334         -- The 'removeContext' is because of
 335         --      instance Foo a => Baz T where ...
 336         -- The decl is an orphan if Baz and T are both not locally defined,
 337         --      even if Foo *is* locally defined
 338
 339 isOrphanDecl this_mod (RuleD (HsRule _ _ _ lhs _ _))
 340   = check lhs
 341   where
 342         -- At the moment we just check for common LHS forms
 343         -- Expand as necessary.  Getting it wrong just means
 344         -- more orphans than necessary
 345     check (HsVar v)       = not (nameIsLocalOrFrom this_mod v)
 346     check (HsApp f a)     = check f && check a
 347     check (HsLit _)       = False
 348     check (HsOverLit _)   = False
 349     check (OpApp l o _ r) = check l && check o && check r
 350     check (NegApp e _)    = check e
 351     check (HsPar e)       = check e
 352     check (SectionL e o)  = check e && check o
 353     check (SectionR o e)  = check e && check o
 354
 355     check other           = True        -- Safe fall through
 356
 357 isOrphanDecl _ _  = False
 358 \end{code}
 359
 360
 361 %*********************************************************
 362 %*                                                       *
 363 \subsection{Fixities}
 364 %*                                                       *
 365 %*********************************************************
 366
 367 \begin{code}
 368 fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
 369 fixitiesFromLocalDecls gbl_env decls
 370   = foldlRn getFixities emptyNameEnv decls                              `thenRn` \ env ->
 371     traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))    `thenRn_`
 372     returnRn env
 373   where
 374     getFixities :: LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
 375     getFixities acc (FixD fix)
 376       = fix_decl acc fix
 377
 378     getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
 379       = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
 380                 -- Get fixities from class decl sigs too.
 381     getFixities acc other_decl
 382       = returnRn acc
 383
 384     fix_decl acc sig@(FixitySig rdr_name fixity loc)
 385         =       -- Check for fixity decl for something not declared
 386           pushSrcLocRn loc                      $
 387           lookupSrcName gbl_env rdr_name        `thenRn` \ name ->
 388
 389                 -- Check for duplicate fixity decl
 390           case lookupNameEnv acc name of
 391             Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')     `thenRn_`
 392                                          returnRn acc ;
 393
 394             Nothing                   -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
 395 \end{code}
 396
 397
 398 %*********************************************************
 399 %*                                                       *
 400 \subsection{Deprecations}
 401 %*                                                       *
 402 %*********************************************************
 403
 404 For deprecations, all we do is check that the names are in scope.
 405 It's only imported deprecations, dealt with in RnIfaces, that we
 406 gather them together.
 407
 408 \begin{code}
 409 rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
 410            -> [RdrNameDeprecation] -> RnMG Deprecations
 411 rnDeprecs gbl_env Nothing []
 412  = returnRn NoDeprecs
 413
 414 rnDeprecs gbl_env (Just txt) decls
 415  = mapRn (addErrRn . badDeprec) decls   `thenRn_`
 416    returnRn (DeprecAll txt)
 417
 418 rnDeprecs gbl_env Nothing decls
 419   = mapRn rn_deprec decls       `thenRn` \ pairs ->
 420     returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
 421  where
 422    rn_deprec (Deprecation rdr_name txt loc)
 423      = pushSrcLocRn loc                         $
 424        lookupSrcName gbl_env rdr_name           `thenRn` \ name ->
 425        returnRn (Just (name, (name,txt)))
 426 \end{code}
 427
 428
 429 %************************************************************************
 430 %*                                                                      *
 431 \subsection{Grabbing the old interface file and checking versions}
 432 %*                                                                      *
 433 %************************************************************************
 434
 435 \begin{code}
 436 checkOldIface :: DynFlags
 437               -> HomeIfaceTable -> HomeSymbolTable
 438               -> PersistentCompilerState
 439               -> FilePath
 440               -> Bool                   -- Source unchanged
 441               -> Maybe ModIface         -- Old interface from compilation manager, if any
 442               -> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface))
 443                                 -- True <=> errors happened
 444
 445 checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface
 446   = runRn dflags hit hst pcs (panic "Bogus module") $
 447     case maybe_iface of
 448        Just old_iface -> -- Use the one we already have
 449                          setModuleRn (mi_module old_iface) (check_versions old_iface)
 450
 451        Nothing -- try and read it from a file
 452           -> readIface iface_path       `thenRn` \ read_result ->
 453              case read_result of
 454                Left err -> -- Old interface file not found, or garbled; give up
 455                            traceRn (text "Bad old interface file" $$ nest 4 err)        `thenRn_`
 456                            returnRn (outOfDate, Nothing)
 457
 458                Right parsed_iface
 459                       -> setModuleRn (pi_mod parsed_iface) $
 460                          loadOldIface parsed_iface `thenRn` \ m_iface ->
 461                          check_versions m_iface
 462     where
 463        check_versions :: ModIface -> RnMG (RecompileRequired, Maybe ModIface)
 464        check_versions iface
 465           = -- Check versions
 466             recompileRequired iface_path source_unchanged iface
 467                                                         `thenRn` \ recompile ->
 468             returnRn (recompile, Just iface)
 469 \end{code}
 470
 471 I think the following function should now have a more representative name,
 472 but what?
 473
 474 \begin{code}
 475 loadOldIface :: ParsedIface -> RnMG ModIface
 476
 477 loadOldIface parsed_iface
 478   = let iface = parsed_iface
 479         mod = pi_mod iface
 480     in
 481     initIfaceRnMS mod (
 482         loadHomeDecls (pi_decls iface)  `thenRn` \ decls ->
 483         loadHomeRules (pi_rules iface)  `thenRn` \ rules ->
 484         loadHomeInsts (pi_insts iface)  `thenRn` \ insts ->
 485         returnRn (decls, rules, insts)
 486     )
 487         `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) ->
 488
 489     mapRn loadHomeUsage (pi_usages iface)       `thenRn` \ usages ->
 490     loadExports         (pi_exports iface)      `thenRn` \ (export_vers, avails) ->
 491     loadFixDecls mod    (pi_fixity iface)       `thenRn` \ fix_env ->
 492     loadDeprecs mod     (pi_deprecs iface)      `thenRn` \ deprec_env ->
 493     let
 494         version = VersionInfo { vers_module  = pi_vers iface,
 495                                 vers_exports = export_vers,
 496                                 vers_rules   = rule_vers,
 497                                 vers_decls   = decls_vers }
 498
 499         decls = mkIfaceDecls new_decls new_rules new_insts
 500
 501         mod_iface = ModIface { mi_module = mod, mi_version = version,
 502                                mi_exports = avails, mi_usages  = usages,
 503                                mi_boot = False, mi_orphan = pi_orphan iface,
 504                                mi_fixities = fix_env, mi_deprecs = deprec_env,
 505                                mi_decls   = decls,
 506                                mi_globals = mkIfaceGlobalRdrEnv avails
 507                     }
 508     in
 509     returnRn mod_iface
 510 \end{code}
 511
 512 \begin{code}
 513 loadHomeDecls :: [(Version, RdrNameTyClDecl)]
 514               -> RnMS (NameEnv Version, [RenamedTyClDecl])
 515 loadHomeDecls decls = foldlRn loadHomeDecl (emptyNameEnv, []) decls
 516
 517 loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl])
 518              -> (Version, RdrNameTyClDecl)
 519              -> RnMS (NameEnv Version, [RenamedTyClDecl])
 520 loadHomeDecl (version_map, decls) (version, decl)
 521   = rnTyClDecl decl     `thenRn` \ decl' ->
 522     returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls)
 523
 524 ------------------
 525 loadHomeRules :: (Version, [RdrNameRuleDecl])
 526               -> RnMS (Version, [RenamedRuleDecl])
 527 loadHomeRules (version, rules)
 528   = mapRn rnIfaceRuleDecl rules `thenRn` \ rules' ->
 529     returnRn (version, rules')
 530
 531 ------------------
 532 loadHomeInsts :: [RdrNameInstDecl]
 533               -> RnMS [RenamedInstDecl]
 534 loadHomeInsts insts = mapRn rnInstDecl insts
 535
 536 ------------------
 537 loadHomeUsage :: ImportVersion OccName
 538               -> RnMG (ImportVersion Name)
 539 loadHomeUsage (mod_name, orphans, is_boot, whats_imported)
 540   = rn_imps whats_imported      `thenRn` \ whats_imported' ->
 541     returnRn (mod_name, orphans, is_boot, whats_imported')
 542   where
 543     rn_imps NothingAtAll                  = returnRn NothingAtAll
 544     rn_imps (Everything v)                = returnRn (Everything v)
 545     rn_imps (Specifically mv ev items rv) = mapRn rn_imp items  `thenRn` \ items' ->
 546                                             returnRn (Specifically mv ev items' rv)
 547     rn_imp (occ,vers) = newGlobalName mod_name occ      `thenRn` \ name ->
 548                         returnRn (name,vers)
 549 \end{code}
 550
 551
 552
 553 %*********************************************************
 554 %*                                                       *
 555 \subsection{Closing up the interface decls}
 556 %*                                                       *
 557 %*********************************************************
 558
 559 Suppose we discover we don't need to recompile.   Then we start from the
 560 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
 561
 562 \begin{code}
 563 closeIfaceDecls :: DynFlags
 564                 -> HomeIfaceTable -> HomeSymbolTable
 565                 -> PersistentCompilerState
 566                 -> ModIface     -- Get the decls from here
 567                 -> IO (PersistentCompilerState, Bool, [RenamedHsDecl])
 568                                 -- True <=> errors happened
 569 closeIfaceDecls dflags hit hst pcs
 570                 mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls })
 571   = runRn dflags hit hst pcs mod $
 572
 573     let
 574         rule_decls = dcl_rules iface_decls
 575         inst_decls = dcl_insts iface_decls
 576         tycl_decls = dcl_tycl  iface_decls
 577         decls = map RuleD rule_decls ++
 578                 map InstD inst_decls ++
 579                 map TyClD tycl_decls
 580         needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
 581                  unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
 582                  unionManyNameSets (map tyClDeclFVs tycl_decls)
 583         local_names    = foldl add emptyNameSet tycl_decls
 584         add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
 585     in
 586     recordLocalSlurps local_names       `thenRn_`
 587     closeDecls decls needed
 588 \end{code}
 589
 590 %*********************************************************
 591 %*                                                       *
 592 \subsection{Unused names}
 593 %*                                                       *
 594 %*********************************************************
 595
 596 \begin{code}
 597 reportUnusedNames :: ModIface -> PrintUnqualified
 598                   -> [RdrNameImportDecl]
 599                   -> AvailEnv
 600                   -> NameSet            -- Used in this module
 601                   -> Avails             -- Exported by this module
 602                   -> [RenamedHsDecl]
 603                   -> RnMG ()
 604 reportUnusedNames my_mod_iface unqual imports avail_env
 605                   source_fvs export_avails imported_decls
 606   = warnUnusedModules unused_imp_mods                           `thenRn_`
 607     warnUnusedLocalBinds bad_locals                             `thenRn_`
 608     warnUnusedImports bad_imp_names                             `thenRn_`
 609     printMinimalImports this_mod unqual minimal_imports         `thenRn_`
 610     warnDeprecations this_mod export_avails my_deprecs
 611                      really_used_names
 612
 613   where
 614     this_mod   = mi_module my_mod_iface
 615     gbl_env    = mi_globals my_mod_iface
 616     my_deprecs = mi_deprecs my_mod_iface
 617
 618         -- The export_fvs make the exported names look just as if they
 619         -- occurred in the source program.
 620     export_fvs = availsToNameSet export_avails
 621     used_names = source_fvs `plusFV` export_fvs
 622
 623     -- Now, a use of C implies a use of T,
 624     -- if C was brought into scope by T(..) or T(C)
 625     really_used_names = used_names `unionNameSets`
 626       mkNameSet [ parent_name
 627                 | sub_name <- nameSetToList used_names
 628
 629                 -- Usually, every used name will appear in avail_env, but there
 630                 -- is one time when it doesn't: tuples and other built in syntax.  When you
 631                 -- write (a,b) that gives rise to a *use* of "(,)", so that the
 632                 -- instances will get pulled in, but the tycon "(,)" isn't actually
 633                 -- in scope.  Also, (-x) gives rise to an implicit use of 'negate';
 634                 -- similarly,   3.5 gives rise to an implcit use of :%
 635                 -- Hence the silent 'False' in all other cases
 636
 637                 , Just parent_name <- [case lookupNameEnv avail_env sub_name of
 638                                         Just (AvailTC n _) -> Just n
 639                                         other              -> Nothing]
 640             ]
 641
 642         -- Collect the defined names from the in-scope environment
 643         -- Look for the qualified ones only, else get duplicates
 644     defined_names :: [(Name,Provenance)]
 645     defined_names = foldRdrEnv add [] gbl_env
 646     add rdr_name ns acc | isQual rdr_name = ns ++ acc
 647                         | otherwise       = acc
 648
 649     defined_and_used, defined_but_not_used :: [(Name,Provenance)]
 650     (defined_and_used, defined_but_not_used) = partition used defined_names
 651     used (name,_)                            = name `elemNameSet` really_used_names
 652
 653     -- Filter out the ones only defined implicitly
 654     bad_locals :: [Name]
 655     bad_locals     = [n     | (n,LocalDef) <- defined_but_not_used]
 656
 657     bad_imp_names :: [(Name,Provenance)]
 658     bad_imp_names  = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True))) <- defined_but_not_used,
 659                               not (module_unused mod)]
 660
 661     -- inst_mods are directly-imported modules that
 662     --  contain instance decl(s) that the renamer decided to suck in
 663     -- It's not necessarily redundant to import such modules.
 664     --
 665     -- NOTE: Consider
 666     --        module This
 667     --          import M ()
 668     --
 669     --   The import M() is not *necessarily* redundant, even if
 670     --   we suck in no instance decls from M (e.g. it contains
 671     --   no instance decls, or This contains no code).  It may be
 672     --   that we import M solely to ensure that M's orphan instance
 673     --   decls (or those in its imports) are visible to people who
 674     --   import This.  Sigh.
 675     --   There's really no good way to detect this, so the error message
 676     --   in RnEnv.warnUnusedModules is weakened instead
 677     inst_mods :: [ModuleName]
 678     inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
 679                  let m = moduleName (nameModule dfun),
 680                  m `elem` direct_import_mods
 681             ]
 682
 683     -- To figure out the minimal set of imports, start with the things
 684     -- that are in scope (i.e. in gbl_env).  Then just combine them
 685     -- into a bunch of avails, so they are properly grouped
 686     minimal_imports :: FiniteMap ModuleName AvailEnv
 687     minimal_imports0 = emptyFM
 688     minimal_imports1 = foldr add_name     minimal_imports0 defined_and_used
 689     minimal_imports  = foldr add_inst_mod minimal_imports1 inst_mods
 690
 691     add_name (n,NonLocalDef (UserImport m _ _)) acc = addToFM_C plusAvailEnv acc (moduleName (nameModule n))
 692                                                                 (unitAvailEnv (mk_avail n))
 693     add_name (n,other_prov)                     acc = acc
 694
 695     mk_avail n = case lookupNameEnv avail_env n of
 696                 Just (AvailTC m _) | n==m      -> AvailTC n [n]
 697                                    | otherwise -> AvailTC m [n,m]
 698                 Just avail         -> Avail n
 699                 Nothing            -> pprPanic "mk_avail" (ppr n)
 700
 701     add_inst_mod m acc
 702       | m `elemFM` acc = acc    -- We import something already
 703       | otherwise      = addToFM acc m emptyAvailEnv
 704         -- Add an empty collection of imports for a module
 705         -- from which we have sucked only instance decls
 706
 707     direct_import_mods :: [ModuleName]
 708     direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
 709
 710     -- unused_imp_mods are the directly-imported modules
 711     -- that are not mentioned in minimal_imports
 712     unused_imp_mods = [m | m <- direct_import_mods,
 713                        not (maybeToBool (lookupFM minimal_imports m)),
 714                        m /= pRELUDE_Name]
 715
 716     module_unused :: Module -> Bool
 717     module_unused mod = moduleName mod `elem` unused_imp_mods
 718
 719 warnDeprecations this_mod export_avails my_deprecs used_names
 720   = doptRn Opt_WarnDeprecations                         `thenRn` \ warn_drs ->
 721     if not warn_drs then returnRn () else
 722
 723         -- The home modules for things in the export list
 724         -- may not have been loaded yet; do it now, so
 725         -- that we can see their deprecations, if any
 726     mapRn_ load_home export_mods                `thenRn_`
 727
 728     getIfacesRn                                 `thenRn` \ ifaces ->
 729     getHomeIfaceTableRn                         `thenRn` \ hit ->
 730     let
 731         pit     = iPIT ifaces
 732         deprecs = [ (n,txt)
 733                   | n <- nameSetToList used_names,
 734                     Just txt <- [lookup_deprec hit pit n] ]
 735     in
 736     mapRn_ warnDeprec deprecs
 737
 738   where
 739     export_mods = nub [ moduleName (nameModule name)
 740                       | avail <- export_avails,
 741                         let name = availName avail,
 742                         not (nameIsLocalOrFrom this_mod name) ]
 743
 744     load_home m = loadInterface (text "Check deprecations for" <+> ppr m) m ImportBySystem
 745
 746     lookup_deprec hit pit n
 747         | nameIsLocalOrFrom this_mod n
 748         = lookupDeprec my_deprecs n
 749         | otherwise
 750         = case lookupIface hit pit n of
 751                 Just iface -> lookupDeprec (mi_deprecs iface) n
 752                 Nothing    -> pprPanic "warnDeprecations:" (ppr n)
 753
 754 -- ToDo: deal with original imports with 'qualified' and 'as M' clauses
 755 printMinimalImports this_mod unqual imps
 756   = doptRn Opt_D_dump_minimal_imports           `thenRn` \ dump_minimal ->
 757     if not dump_minimal then returnRn () else
 758
 759     mapRn to_ies (fmToList imps)                `thenRn` \ mod_ies ->
 760     ioToRnM (do { h <- openFile filename WriteMode ;
 761                   printForUser h unqual (vcat (map ppr_mod_ie mod_ies))
 762         })                                      `thenRn_`
 763     returnRn ()
 764   where
 765     filename = moduleNameUserString (moduleName this_mod) ++ ".imports"
 766     ppr_mod_ie (mod_name, ies)
 767         | mod_name == pRELUDE_Name
 768         = empty
 769         | otherwise
 770         = ptext SLIT("import") <+> ppr mod_name <>
 771                             parens (fsep (punctuate comma (map ppr ies)))
 772
 773     to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env)      `thenRn` \ ies ->
 774                               returnRn (mod, ies)
 775
 776     to_ie :: AvailInfo -> RnMG (IE Name)
 777     to_ie (Avail n)       = returnRn (IEVar n)
 778     to_ie (AvailTC n [m]) = ASSERT( n==m )
 779                             returnRn (IEThingAbs n)
 780     to_ie (AvailTC n ns)
 781         = getInterfaceExports n_mod ImportBySystem              `thenRn` \ (_, avails_by_module) ->
 782           case [xs | (m,as) <- avails_by_module,
 783                      m == n_mod,
 784                      AvailTC x xs <- as,
 785                      x == n] of
 786               [xs] | all (`elem` ns) xs -> returnRn (IEThingAll n)
 787                    | otherwise          -> returnRn (IEThingWith n (filter (/= n) ns))
 788               other                     -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
 789                                            returnRn (IEVar n)
 790         where
 791           n_mod = moduleName (nameModule n)
 792
 793 rnDump  :: [RenamedHsDecl]      -- Renamed imported decls
 794         -> [RenamedHsDecl]      -- Renamed local decls
 795         -> RnMG ()
 796 rnDump imp_decls local_decls
 797   = doptRn Opt_D_dump_rn_trace  `thenRn` \ dump_rn_trace ->
 798     doptRn Opt_D_dump_rn_stats  `thenRn` \ dump_rn_stats ->
 799     doptRn Opt_D_dump_rn        `thenRn` \ dump_rn ->
 800     getIfacesRn                 `thenRn` \ ifaces ->
 801
 802     ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
 803                             "Renamer statistics"
 804                             (getRnStats imp_decls ifaces) ;
 805
 806                   dumpIfSet dump_rn "Renamer:"
 807                             (vcat (map ppr (local_decls ++ imp_decls)))
 808     })                          `thenRn_`
 809
 810     returnRn ()
 811 \end{code}
 812
 813
 814 %*********************************************************
 815 %*                                                      *
 816 \subsection{Statistics}
 817 %*                                                      *
 818 %*********************************************************
 819
 820 \begin{code}
 821 getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc
 822 getRnStats imported_decls ifaces
 823   = hcat [text "Renamer stats: ", stats]
 824   where
 825     n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)]
 826         -- This is really only right for a one-shot compile
 827
 828     (decls_map, n_decls_slurped) = iDecls ifaces
 829
 830     n_decls_left   = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
 831                         -- Data, newtype, and class decls are in the decls_fm
 832                         -- under multiple names; the tycon/class, and each
 833                         -- constructor/class op too.
 834                         -- The 'True' selects just the 'main' decl
 835                      ]
 836
 837     (insts_left, n_insts_slurped) = iInsts ifaces
 838     n_insts_left  = length (bagToList insts_left)
 839
 840     (rules_left, n_rules_slurped) = iRules ifaces
 841     n_rules_left  = length (bagToList rules_left)
 842
 843     stats = vcat
 844         [int n_mods <+> text "interfaces read",
 845          hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
 846                 int (n_decls_slurped + n_decls_left), text "read"],
 847          hsep [ int n_insts_slurped, text "instance decls imported, out of",
 848                 int (n_insts_slurped + n_insts_left), text "read"],
 849          hsep [ int n_rules_slurped, text "rule decls imported, out of",
 850                 int (n_rules_slurped + n_rules_left), text "read"]
 851         ]
 852 \end{code}
 853
 854
 855 %************************************************************************
 856 %*                                                                      *
 857 \subsection{Errors and warnings}
 858 %*                                                                      *
 859 %************************************************************************
 860
 861 \begin{code}
 862 warnDeprec :: (Name, DeprecTxt) -> RnM d ()
 863 warnDeprec (name, txt)
 864   = pushSrcLocRn (getSrcLoc name)       $
 865     addWarnRn                           $
 866     sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
 867           text "is deprecated:", nest 4 (ppr txt) ]
 868
 869
 870 dupFixityDecl rdr_name loc1 loc2
 871   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 872           ptext SLIT("at ") <+> ppr loc1,
 873           ptext SLIT("and") <+> ppr loc2]
 874
 875 badDeprec d
 876   = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
 877          nest 4 (ppr d)]
 878
 879 noMainErr
 880   = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name),
 881           ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
 882 \end{code}
 883
 884