X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=e942eec71b6f476b5852f53d3b7ec68b29e04a2d;hp=fc38fd541a94a945191793725dbbef77fccb63c6;hb=7a59afcebe45ea87c42006873f77eb4600d7316f;hpb=36b27193c994b4a267c8dfdbf833d73b455130aa diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index fc38fd5..e942eec 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -26,7 +26,6 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) import StaticFlags ( opt_PprStyle_Debug ) -import Packages ( checkForPackageConflicts, mkHomeModules ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), LHsBinds, emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, @@ -39,7 +38,7 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) +import TcType ( tidyTopType, tcEqType ) import Inst ( showLIE ) import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) import TcBinds ( tcTopBinds, tcHsBootSigs ) @@ -49,6 +48,7 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcIface ( tcExtCoreBindings, tcHiBootIface ) +import IfaceSyn ( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) @@ -59,23 +59,23 @@ import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprRules, pprCoreBindings ) import CoreSyn ( CoreRule, bindersOfBinds ) -import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv ) +import Module +import UniqFM ( elemUFM, eltsUFM ) import OccName ( mkVarOccFS, plusOccEnv ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, - mkExternalName ) + nameModule, nameOccName, isImplicitName, mkExternalName ) import NameSet -import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind ) +import TyCon ( tyConHasGenerics ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, HscEnv(..), ExternalPackageState(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, - ForeignStubs(NoStubs), TyThing(..), + ForeignStubs(NoStubs), TypeEnv, lookupTypeEnv, hptInstances, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, emptyFixityEnv @@ -99,13 +99,13 @@ import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy, isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) +import TypeRep ( TyThing(..) ) import RnTypes ( rnLHsType ) import Inst ( tcGetInstEnvs ) import InstEnv ( classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) -import LoadIface ( loadSrcInterface, loadSysInterface ) +import LoadIface ( loadSysInterface ) import IfaceEnv ( ifaceExportNames ) -import Module ( moduleSetElts, mkModuleSet ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( setIdType ) import MkId ( unsafeCoerceId ) @@ -114,7 +114,7 @@ import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) import Kind ( Kind ) import Var ( globaliseId ) -import Name ( nameOccName, nameModule, isBuiltInSyntax, isInternalName ) +import Name ( isBuiltInSyntax, isInternalName ) import OccName ( isTcOcc ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, @@ -124,14 +124,14 @@ import HscTypes ( InteractiveContext(..), Dependencies(..) ) import BasicTypes ( Fixity, RecFlag(..) ) import SrcLoc ( unLoc ) +import Data.Maybe ( isNothing ) #endif import FastString ( mkFastString ) -import Maybes ( MaybeErr(..) ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) -import Maybe ( isJust ) +import Data.Maybe ( isJust ) \end{code} @@ -155,9 +155,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - let { this_mod = case maybe_mod of - Nothing -> mAIN -- 'module M where' is omitted - Just (L _ mod) -> mod } ; -- The normal case + let { this_pkg = thisPackage (hsc_dflags hsc_env) ; + this_mod = case maybe_mod of + Nothing -> mAIN -- 'module M where' is omitted + Just (L _ mod) -> mkModule this_pkg mod } ; + -- The normal case initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ @@ -166,16 +168,16 @@ tcRnModule hsc_env hsc_src save_rn_syntax rn_imports <- rnImports import_decls ; (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; - let { dep_mods :: ModuleEnv (Module, IsBootInterface) + let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports -- We want instance declarations from all home-package -- modules below this one, including boot modules, except -- ourselves. The 'except ourselves' is so that we don't -- get the instances from this module's hs-boot file - ; want_instances :: Module -> Bool - ; want_instances mod = mod `elemModuleEnv` dep_mods - && mod /= this_mod + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod ; home_insts = hptInstances hsc_env want_instances } ; @@ -184,8 +186,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- and any other incrementally-performed imports updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - checkConflicts imports this_mod $ do { - -- Update the gbl env updGblEnv ( \ gbl -> gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, @@ -226,7 +226,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- 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 ; + reportDeprecations (hsc_dflags hsc_env) tcg_env ; -- Process the export list rn_exports <- rnExports export_ies ; @@ -254,27 +254,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Dump output and return tcDump final_env ; return final_env - }}}}} - - --- The program is not allowed to contain two modules with the same --- name, and we check for that here. It could happen if the home package --- contains a module that is also present in an external package, for example. -checkConflicts imports this_mod and_then = do - dflags <- getDOpts - let - dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports)) - -- don't forget to include the current module! - - mb_dep_pkgs = checkForPackageConflicts - dflags dep_mods (imp_dep_pkgs imports) - -- - case mb_dep_pkgs of - Failed msg -> - do addErr msg; failM - Succeeded _ -> - updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods }) - and_then + }}}} \end{code} @@ -333,7 +313,6 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_usages = [], -- ToDo: compute usage mg_dir_imps = [], -- ?? mg_deps = noDependencies, -- ?? - mg_home_mods = mkHomeModules [], -- ?? wrong!! mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, @@ -532,24 +511,35 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) checkHiBootIface (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env }) (ModDetails { md_insts = boot_insts, md_types = boot_type_env }) - = do { mapM_ check_one (typeEnvElts boot_type_env) + = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ; + ; mapM_ check_one (typeEnvElts boot_type_env) ; dfun_binds <- mapM check_inst boot_insts ; return (unionManyBags dfun_binds) } where check_one boot_thing | no_check name = return () - | otherwise - = case lookupTypeEnv local_type_env name of - Nothing -> addErrTc (missingBootThing boot_thing) - Just real_thing -> check_thing boot_thing real_thing + | Just real_thing <- lookupTypeEnv local_type_env name + = do { let boot_decl = tyThingToIfaceDecl ext_nm boot_thing + real_decl = tyThingToIfaceDecl ext_nm real_thing + ; checkTc (checkBootDecl boot_decl real_decl) + (bootMisMatch boot_thing boot_decl real_decl) } + -- The easiest way to check compatibility is to convert to + -- iface syntax, where we already have good comparison functions + | otherwise + = addErrTc (missingBootThing boot_thing) where name = getName boot_thing + ext_nm name = ExtPkg (nameModule name) (nameOccName name) + -- Just enough to compare; no versions etc needed + no_check name = isWiredInName name -- No checking for wired-in names. In particular, -- 'error' is handled by a rather gross hack -- (see comments in GHC.Err.hs-boot) || name `elem` dfun_names + || isImplicitName name -- Has a parent, which we'll check + dfun_names = map getName boot_insts check_inst boot_inst @@ -564,35 +554,9 @@ checkHiBootIface local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty ---------------- -check_thing (ATyCon boot_tc) (ATyCon real_tc) - | isSynTyCon boot_tc && isSynTyCon real_tc, - defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2 - = return () - - | tyConKind boot_tc == tyConKind real_tc - = return () - where - (tvs1, defn1) = synTyConDefn boot_tc - (tvs2, defn2) = synTyConDefn boot_tc - -check_thing (AnId boot_id) (AnId real_id) - | idType boot_id `tcEqType` idType real_id - = return () - -check_thing (ADataCon dc1) (ADataCon dc2) - | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2) - = return () - - -- Can't declare a class in a hi-boot file - -check_thing boot_thing real_thing -- Default case; failure - = addErrAt (srcLocSpan (getSrcLoc real_thing)) - (bootMisMatch real_thing) - ----------------- missingBootThing thing = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") -bootMisMatch thing +bootMisMatch thing boot_decl real_decl = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") instMisMatch inst = hang (ppr inst) @@ -1128,17 +1092,13 @@ getModuleExports hsc_env mod tcGetModuleExports :: Module -> TcM NameSet tcGetModuleExports mod = do - iface <- load_iface mod + let doc = ptext SLIT("context for compiling statements") + iface <- initIfaceTcRn $ loadSysInterface doc mod loadOrphanModules (dep_orphs (mi_deps iface)) -- Load any orphan-module interfaces, -- so their instances are visible ifaceExportNames (mi_exports iface) -load_iface mod = loadSrcInterface doc mod False {- Not boot iface -} - where - doc = ptext SLIT("context for compiling statements") - - tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1239,7 +1199,9 @@ plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualif = all ok (nameSetToList (tyClsNamesOfType (idType dfun))) where ok name | isBuiltInSyntax name = True - | isExternalName name = print_unqual (nameModule name) (nameOccName name) + | isExternalName name = + isNothing $ fst print_unqual (nameModule name) + (nameOccName name) | otherwise = True loadUnqualIfaces :: InteractiveContext -> TcM () @@ -1308,7 +1270,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_insts dfun_ids , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports)) + , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc