X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=295c15ecd638bc814a343fba9843f9f8ce8c8f67;hb=3721dd37a707d2aacb5cac814410a78096e28a2c;hp=03b2e46baabb74149650051495eb9266f941f94f;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 03b2e46..295c15e 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -22,9 +22,10 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn -import RdrHsSyn ( findSplice, main_RDR_Unqual ) +import RdrHsSyn ( findSplice ) -import PrelNames ( runIOName, rootMainName, mAIN_Name ) +import PrelNames ( runIOName, rootMainName, mAIN_Name, + main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, plusGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) @@ -43,20 +44,20 @@ 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 ) import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet import TyCon ( tyConHasGenerics ) -import SrcLoc ( srcLocSpan, Located(..), noLoc, unLoc ) +import SrcLoc ( srcLocSpan, Located(..), noLoc ) import Outputable import HscTypes ( ModGuts(..), HscEnv(..), GhciMode(..), noDependencies, @@ -93,8 +94,8 @@ import Id ( Id, isImplicitId ) import MkId ( unsafeCoerceId ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import SrcLoc ( interactiveSrcLoc ) -import Var ( setGlobalIdDetails ) +import SrcLoc ( interactiveSrcLoc, unLoc ) +import Var ( globaliseId ) import Name ( nameOccName, nameModuleName ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) @@ -104,12 +105,13 @@ import HscTypes ( InteractiveContext(..), TyThing(..), availNames, icPrintUnqual, ModIface(..), ModDetails(..) ) import BasicTypes ( RecFlag(..), Fixity ) +import Bag ( unitBag ) import Panic ( ghcError, GhcException(..) ) #endif import FastString ( mkFastString ) import Util ( sortLt ) -import Bag ( unionBags, snocBag, unitBag ) +import Bag ( unionBags, snocBag ) import Maybe ( isJust ) \end{code} @@ -162,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.) @@ -175,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 @@ -235,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 ; @@ -461,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 @@ -527,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 ; @@ -806,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) } @@ -931,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