[project @ 2004-01-05 12:11:42 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnDriver.lhs

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 7b0a63d..295c15e 100644 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -44,13 +44,13 @@ import TcSimplify   ( tcSimplifyTop )
 import TcTyClsDecls    ( tcTyAndClassDecls )
 import LoadIface       ( loadOrphanModules )
 import RnNames         ( importsFromLocalDecls, rnImports, exportsFromAvail, 
-                         reportUnusedNames )
+                         reportUnusedNames, reportDeprecations )
 import RnEnv           ( lookupSrcOcc_maybe )
 import RnSource                ( rnSrcDecls, rnTyClDecls, checkModDeprec )
 import PprCore         ( pprIdRules, pprCoreBindings )
 import CoreSyn         ( IdCoreRule, bindersOfBinds )
 import ErrUtils                ( mkDumpDoc, showPass )
-import Id              ( mkLocalId, isLocalId, idName, idType, setIdLocalExported )
+import Id              ( mkExportedLocalId, isLocalId, idName, idType )
 import Var             ( Var )
 import Module           ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
 import OccName         ( mkVarOcc )
@@ -95,7 +95,7 @@ import MkId           ( unsafeCoerceId )
 import TysWiredIn      ( mkListTy, unitTy )
 import IdInfo          ( GlobalIdDetails(..) )
 import SrcLoc          ( interactiveSrcLoc, unLoc )
-import Var             ( setGlobalIdDetails )
+import Var             ( globaliseId )
 import Name            ( nameOccName, nameModuleName )
 import NameEnv         ( delListFromNameEnv )
 import PrelNames       ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
@@ -164,9 +164,17 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports
 
        traceRn (text "rn3") ;
 
+               -- Report the use of any deprecated things
+               -- We do this before processsing the export list so
+               -- that we don't bleat about re-exporting a deprecated
+               -- thing (especially via 'module Foo' export item)
+               -- Only uses in the body of the module are complained about
+       reportDeprecations tcg_env ;
+
                -- Process the export list
-       export_avails <- exportsFromAvail (isJust maybe_mod) exports ;
+       exports <- exportsFromAvail (isJust maybe_mod) exports ;
 
+{-     Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
                -- Get any supporting decls for the exports that have not already
                -- been sucked in for the declarations in the body of the module.
                -- (This can happen if something is imported only to be re-exported.)
@@ -177,15 +185,15 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports
                -- We don't need the results, but sucking them in may side-effect
                -- the ExternalPackageState, apart from recording usage
        mappM (tcLookupGlobal . availName) export_avails ;
+-}
 
                -- Check whether the entire module is deprecated
                -- This happens only once per module
        let { mod_deprecs = checkModDeprec mod_deprec } ;
 
                -- Add exports and deprecations to envt
-       let { export_fvs = availsToNameSet export_avails ;
-             final_env  = tcg_env { tcg_exports = export_avails,
-                                    tcg_dus = tcg_dus tcg_env `plusDU` usesOnly export_fvs,
+       let { final_env  = tcg_env { tcg_exports = exports,
+                                    tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
                                     tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` 
                                                   mod_deprecs }
                -- A module deprecation over-rides the earlier ones
@@ -237,8 +245,7 @@ tcRnStmt hsc_env ictxt rdr_stmt
                -- important: otherwise when we come to compile an expression
                -- using these ids later, the byte code generator will consider
                -- the occurrences to be free rather than global.
-       global_ids     = map globaliseId bound_ids ;
-       globaliseId id = setGlobalIdDetails id VanillaGlobal ;
+       global_ids     = map (globaliseId VanillaGlobal) bound_ids ;
     
                -- Update the interactive context
        rn_env   = ic_rn_local_env ictxt ;
@@ -463,7 +470,8 @@ tcRnThing hsc_env ictxt rdr_name
 
 toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
 toIfaceDecl ictxt thing
-  = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing
+  = tyThingToIfaceDecl True {- Discard IdInfo -} (const False) {- Show data cons -} 
+                      ext_nm thing
   where
     unqual = icPrintUnqual ictxt
     ext_nm n | unqual n  = LocalTop (nameOccName n)    -- What a hack
@@ -529,7 +537,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
        -- Wrap up
    let {
        bndrs      = bindersOfBinds core_binds ;
-       my_exports = map (Avail . idName) bndrs ;
+       my_exports = mkNameSet (map idName bndrs) ;
                -- ToDo: export the data types also?
 
        final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
@@ -808,8 +816,7 @@ getModuleExports :: ModuleName -> TcM GlobalRdrEnv
 getModuleExports mod 
   = do { iface <- load_iface mod
        ; avails <- exportsToAvails (mi_exports iface)
-       ; let { gres = [ GRE  { gre_name = name, gre_prov = vanillaProv mod,
-                               gre_deprec = mi_dep_fn iface name }
+       ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
                        | avail <- avails, name <- availNames avail ] }
        ; returnM (mkGlobalRdrEnv gres) }
 
@@ -933,7 +940,7 @@ check_main ghci_mode tcg_env main_mod main_fn
        ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
                             tcInferRho rhs
 
-       ; let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ;
+       ; let { root_main_id = mkExportedLocalId rootMainName ty ;
                main_bind    = noLoc (VarBind root_main_id main_expr) }
 
        ; return (tcg_env { tcg_binds = tcg_binds tcg_env