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