From 88f315a135bd00d2efa00d991bb9487929562d91 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 31 Oct 2000 08:08:39 +0000 Subject: [PATCH] [project @ 2000-10-31 08:08:38 by simonpj] More tidying up; esp of isLocallyDefined --- ghc/compiler/Makefile | 6 ++- ghc/compiler/basicTypes/Name.lhs | 30 ++++++++--- ghc/compiler/main/HscTypes.lhs | 25 +++++---- ghc/compiler/main/MkIface.lhs | 26 ++++----- ghc/compiler/rename/Rename.lhs | 63 +++++++++++----------- ghc/compiler/rename/RnEnv.lhs | 2 +- ghc/compiler/rename/RnHiFiles.lhs | 44 +++++++++++----- ghc/compiler/rename/RnIfaces.lhs | 37 ++++--------- ghc/compiler/rename/RnMonad.lhs | 16 +++--- ghc/compiler/rename/RnSource.lhs | 2 +- ghc/compiler/typecheck/TcClassDcl.lhs | 17 +++--- ghc/compiler/typecheck/TcDeriv.lhs | 42 ++++++--------- ghc/compiler/typecheck/TcEnv.lhs | 26 ++++----- ghc/compiler/typecheck/TcInstDcls.lhs | 93 ++++++++++++++------------------- ghc/compiler/typecheck/TcModule.lhs | 28 ++++------ ghc/compiler/typecheck/TcTyDecls.lhs | 21 ++++---- 16 files changed, 231 insertions(+), 247 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 413f59e..896a431 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.103 2000/10/30 11:18:14 sewardj Exp $ +# $Id: Makefile,v 1.104 2000/10/31 08:08:38 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -366,7 +366,9 @@ parser/Parser.hs : parser/Parser.y #----------------------------------------------------------------------------- # Linking -SRC_LD_OPTS += -no-link-chk -ldl +SRC_LD_OPTS += -no-link-chk +# REMOVED SLPJ +# -ldl ifneq "$(GhcWithHscBuiltViaC)" "YES" ifeq "$(GhcReportCompiles)" "YES" diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index a11b797..eb66139 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -21,7 +21,7 @@ module Name ( toRdrName, hashName, isUserExportedName, - nameSrcLoc, isLocallyDefinedName, isDllName, + nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, isTyVarName, @@ -36,7 +36,8 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, isLocallyDefined, getOccString, toRdrName + getSrcLoc, isLocallyDefined, getOccString, toRdrName, + isFrom, isLocalOrFrom ) where #include "HsVersions.h" @@ -121,7 +122,9 @@ nameModule_maybe name = Nothing \end{code} \begin{code} -isLocallyDefinedName :: Name -> Bool +nameIsLocallyDefined :: Name -> Bool +nameIsFrom :: Module -> Name -> Bool +nameIsLocalOrFrom :: Module -> Name -> Bool isUserExportedName :: Name -> Bool isLocalName :: Name -> Bool -- Not globals isGlobalName :: Name -> Bool @@ -133,14 +136,23 @@ isGlobalName other = False isLocalName name = not (isGlobalName name) -isLocallyDefinedName name = isLocalName name +nameIsLocallyDefined name = isLocalName name + +nameIsLocalOrFrom from (Name {n_sort = Global mod}) = mod == from +nameIsLocalOrFrom from other = True + +nameIsFrom from (Name {n_sort = Global mod}) = mod == from +nameIsFrom from other = pprPanic "nameIsFrom" (ppr other) -- Global names are by definition those that are visible -- outside the module, *as seen by the linker*. Externally visible --- does not mean visible at the source level (that's isExported). +-- does not mean visible at the source level (that's isUserExported). isExternallyVisibleName name = isGlobalName name +-- Constructors, selectors and suchlike Globals, and are all exported +-- Other Local things may or may not be exported isUserExportedName (Name { n_sort = Exported }) = True +isUserExportedName (Name { n_sort = Global _ }) = True isUserExportedName other = False isSystemName (Name {n_sort = System}) = True @@ -354,7 +366,7 @@ ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n) isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? isDllName nm = not opt_Static && - not (isLocallyDefinedName nm) && -- isLocallyDefinedName test needed 'cos + not (nameIsLocallyDefined nm) && -- isLocallyDefinedName test needed 'cos not (isModuleInThisPackage (nameModule nm)) -- nameModule won't work on local names @@ -494,11 +506,15 @@ getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String toRdrName :: NamedThing a => a -> RdrName +isFrom :: NamedThing a => Module -> a -> Bool +isLocalOrFrom :: NamedThing a => Module -> a -> Bool getSrcLoc = nameSrcLoc . getName -isLocallyDefined = isLocallyDefinedName . getName +isLocallyDefined = nameIsLocallyDefined . getName getOccString = occNameString . getOccName toRdrName = ifaceNameRdrName . getName +isFrom mod x = nameIsFrom mod (getName x) +isLocalOrFrom mod x = nameIsLocalOrFrom mod ( getName x) \end{code} \begin{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index ab77b47..ccfddd5 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -10,7 +10,7 @@ module HscTypes ( ModDetails(..), ModIface(..), HomeSymbolTable, PackageTypeEnv, HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, - lookupTable, lookupTableByModName, + lookupIface, lookupIfaceByModName, emptyModIface, IfaceDecls(..), @@ -47,8 +47,9 @@ module HscTypes ( import RdrName ( RdrNameEnv, emptyRdrEnv ) import Name ( Name, NameEnv, NamedThing, emptyNameEnv, extendNameEnv, - lookupNameEnv, emptyNameEnv, getName, nameModule, - nameSrcLoc, nameEnvElts ) + lookupNameEnv, emptyNameEnv, nameEnvElts, + isLocallyDefined, getName, nameModule, + nameSrcLoc ) import NameSet ( NameSet ) import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, @@ -200,16 +201,19 @@ emptyIfaceTable = emptyUFM Simple lookups in the symbol table. \begin{code} -lookupTable :: ModuleEnv a -> ModuleEnv a -> Name -> Maybe a --- We often have two Symbol- or IfaceTables, and want to do a lookup -lookupTable ht pt name - = lookupModuleEnv ht mod `seqMaybe` lookupModuleEnv pt mod +lookupIface :: HomeIfaceTable -> PackageIfaceTable + -> Module -> Name -- The module is to use for locally-defined names + -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIface hit pit this_mod name + | isLocallyDefined name = lookupModuleEnv hit this_mod + | otherwise = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod where mod = nameModule name -lookupTableByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a +lookupIfaceByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a -- We often have two Symbol- or IfaceTables, and want to do a lookup -lookupTableByModName ht pt mod +lookupIfaceByModName ht pt mod = lookupModuleEnvByName ht mod `seqMaybe` lookupModuleEnvByName pt mod \end{code} @@ -260,7 +264,8 @@ extendTypeEnvList env things \begin{code} lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing lookupType hst pte name - = case lookupModuleEnv hst (nameModule name) of + = ASSERT2( not (isLocallyDefined name), ppr name ) + case lookupModuleEnv hst (nameModule name) of Just details -> lookupNameEnv (md_types details) name Nothing -> lookupNameEnv pte name \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index c837f4c..8eec30d 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -128,9 +128,6 @@ completeIface :: Maybe ModIface -- The old interface, if we have it -- NB: 'Nothing' means that even the usages havn't changed, so there's no -- need to write a new interface file. But even if the usages have -- changed, the module version may not have. - -- - -- The IO in the type is solely for debug output - -- In particular, dumping a record of what has changed completeIface maybe_old_iface new_iface mod_details = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls }) where @@ -628,14 +625,13 @@ pprIface iface , vcat (map pprExport (mi_exports iface)) , vcat (map pprUsage (mi_usages iface)) - , pprIfaceDecls (vers_decls version_info) - (mi_fixities iface) - (mi_decls iface) - + , pprFixities (mi_fixities iface) (dcl_tycl decls) + , pprIfaceDecls (vers_decls version_info) decls , pprDeprecs (mi_deprecs iface) ] where version_info = mi_version iface + decls = mi_decls iface exp_vers = vers_exports version_info rule_vers = vers_rules version_info @@ -696,27 +692,27 @@ pprUsage (m, has_orphans, is_boot, whats_imported) \end{code} \begin{code} -pprIfaceDecls version_map fixity_map decls +pprIfaceDecls version_map decls = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls] , vcat (map ppr_decl (dcl_tycl decls)) , pprRules (dcl_rules decls) ] where - ppr_decl d = (ppr_vers d <+> ppr d <> semi) $$ ppr_fixes d + ppr_decl d = ppr_vers d <+> ppr d <> semi -- Print the version for the decl ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of Nothing -> empty Just v -> int v - - -- Print fixities relevant to the decl - ppr_fixes d = vcat [ ppr fix <+> ppr n <> semi - | (n,_) <- tyClDeclNames d, - Just fix <- [lookupNameEnv fixity_map n] - ] \end{code} \begin{code} +pprFixities fixity_map decls + = hsep [ ppr fix <+> ppr n + | d <- decls, + (n,_) <- tyClDeclNames d, + Just fix <- [lookupNameEnv fixity_map n]] <> semi + pprRules [] = empty pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")] diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 88beb68..c3a1e32 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -36,7 +36,8 @@ import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, mkModuleInThisPackage, mkModuleName, moduleEnvElts ) -import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, +import Name ( Name, NamedThing(..), getSrcLoc, + nameIsLocalOrFrom, nameOccName, nameModule, mkNameEnv, nameEnvElts, extendNameEnv ) @@ -65,7 +66,7 @@ import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, VersionInfo(..), ImportVersion, IfaceDecls(..), GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, Provenance(..), ImportReason(..), initialVersionInfo, - Deprecations(..), lookupDeprec, lookupTable + Deprecations(..), lookupDeprec, lookupIface ) import List ( partition, nub ) \end{code} @@ -159,11 +160,9 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) else -- GENERATE THE VERSION/USAGE INFO - mkImportInfo mod_name imports `thenRn` \ my_usages -> + mkImportInfo mod_name imports `thenRn` \ my_usages -> - -- RETURN THE RENAMED MODULE - getNameSupplyRn `thenRn` \ name_supply -> - getIfacesRn `thenRn` \ ifaces -> + -- BUILD THE MODULE INTERFACE let -- We record fixities even for things that aren't exported, -- so that we can change into the context of this moodule easily @@ -171,23 +170,23 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) | FixitySig name fixity loc <- nameEnvElts local_fixity_env ] - -- Sort the exports to make them easier to compare for versions my_exports = groupAvails this_module export_avails + final_decls = rn_local_decls ++ rn_imp_decls + is_orphan = any (isOrphanDecl this_module) rn_local_decls + mod_iface = ModIface { mi_module = this_module, mi_version = initialVersionInfo, + mi_usages = my_usages, mi_boot = False, - mi_orphan = any isOrphanDecl rn_local_decls, + mi_orphan = is_orphan, mi_exports = my_exports, mi_globals = gbl_env, - mi_usages = my_usages, mi_fixities = fixities, mi_deprecs = my_deprecs, mi_decls = panic "mi_decls" } - - final_decls = rn_local_decls ++ rn_imp_decls in -- REPORT UNUSED NAMES, AND DEBUG DUMP @@ -253,20 +252,21 @@ implicitFVs mod_name decls \end{code} \begin{code} -isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) - = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty))) +isOrphanDecl this_mod (InstD (InstDecl inst_ty _ _ _ _)) + = not (foldNameSet ((||) . nameIsLocalOrFrom this_mod) False + (extractHsTyNames (removeContext inst_ty))) -- The 'removeContext' is because of -- instance Foo a => Baz T where ... -- The decl is an orphan if Baz and T are both not locally defined, -- even if Foo *is* locally defined -isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _)) +isOrphanDecl this_mod (RuleD (HsRule _ _ _ lhs _ _)) = check lhs where -- At the moment we just check for common LHS forms -- Expand as necessary. Getting it wrong just means -- more orphans than necessary - check (HsVar v) = not (isLocallyDefined v) + check (HsVar v) = not (nameIsLocalOrFrom this_mod v) check (HsApp f a) = check f && check a check (HsLit _) = False check (HsOverLit _) = False @@ -278,7 +278,7 @@ isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _)) check other = True -- Safe fall through -isOrphanDecl other = False +isOrphanDecl _ _ = False \end{code} @@ -540,12 +540,14 @@ reportUnusedNames my_mod_iface imports avail_env = warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports my_mod_iface minimal_imports `thenRn_` - warnDeprecations my_mod_iface really_used_names `thenRn_` + printMinimalImports this_mod minimal_imports `thenRn_` + warnDeprecations this_mod my_deprecs really_used_names `thenRn_` returnRn () where + this_mod = mi_module my_mod_iface gbl_env = mi_globals my_mod_iface + my_deprecs = mi_deprecs my_mod_iface -- Now, a use of C implies a use of T, -- if C was brought into scope by T(..) or T(C) @@ -638,7 +640,7 @@ reportUnusedNames my_mod_iface imports avail_env module_unused mod = moduleName mod `elem` unused_imp_mods -warnDeprecations my_mod_iface used_names +warnDeprecations this_mod my_deprecs used_names = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> if not warn_drs then returnRn () else @@ -653,15 +655,16 @@ warnDeprecations my_mod_iface used_names mapRn_ warnDeprec deprecs where - my_deprecs = mi_deprecs my_mod_iface - lookup_deprec hit pit n - | isLocallyDefined n = lookupDeprec my_deprecs n - | otherwise = case lookupTable hit pit n of - Just iface -> lookupDeprec (mi_deprecs iface) n - Nothing -> pprPanic "warnDeprecations:" (ppr n) + lookup_deprec hit pit n + | nameIsLocalOrFrom this_mod n + = lookupDeprec my_deprecs n + | otherwise + = case lookupIface hit pit this_mod n of + Just iface -> lookupDeprec (mi_deprecs iface) n + Nothing -> pprPanic "warnDeprecations:" (ppr n) -- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports my_mod_iface imps +printMinimalImports this_mod imps = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> if not dump_minimal then returnRn () else @@ -671,8 +674,7 @@ printMinimalImports my_mod_iface imps }) `thenRn_` returnRn () where - filename = moduleNameUserString (moduleName (mi_module my_mod_iface)) - ++ ".imports" + filename = moduleNameUserString (moduleName this_mod) ++ ".imports" ppr_mod_ie (mod_name, ies) | mod_name == pRELUDE_Name = empty @@ -706,7 +708,7 @@ rnDump :: [RenamedHsDecl] -- Renamed imported decls rnDump imp_decls local_decls = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> - doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> + doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> getIfacesRn `thenRn` \ ifaces -> ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn) @@ -735,12 +737,11 @@ getRnStats imported_decls ifaces n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)] -- This is really only right for a one-shot compile - decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), + decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces) -- Data, newtype, and class decls are in the decls_fm -- under multiple names; the tycon/class, and each -- constructor/class op too. -- The 'True' selects just the 'main' decl - not (isLocallyDefined (availName avail)) ] (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 023e10c..97f505e 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -663,7 +663,7 @@ groupAvails this_mod avails ] where groupFM :: FiniteMap FastString Avails - -- Deliberatey use the FastString so we + -- Deliberately use the FastString so we -- get a canonical ordering groupFM = foldl add emptyFM avails diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 2fa3bdd..ca381a3 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -21,7 +21,7 @@ import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas ) import HscTypes ( ModuleLocation(..), ModIface(..), emptyModIface, VersionInfo(..), - lookupTableByModName, + lookupIfaceByModName, ImportVersion, WhetherHasOrphans, IsBootInterface, DeclsMap, GatedDecl, IfaceInsts, IfaceRules, AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) @@ -40,7 +40,7 @@ import RnMonad import ParseIface ( parseIface, IfaceStuff(..) ) import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocallyDefined, + nameModule, isLocalName, nameIsLocalOrFrom, NamedThing(..), mkNameEnv, extendNameEnv ) @@ -76,7 +76,8 @@ import Monad ( when ) \begin{code} loadHomeInterface :: SDoc -> Name -> RnM d ModIface loadHomeInterface doc_str name - = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem + = ASSERT2( not (isLocalName name), ppr name <+> parens doc_str ) + loadInterface doc_str (moduleName (nameModule name)) ImportBySystem loadOrphanModules :: [ModuleName] -> RnM d () loadOrphanModules mods @@ -110,7 +111,7 @@ tryLoadInterface doc_str mod_name from getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) -> -- CHECK WHETHER WE HAVE IT ALREADY - case lookupTableByModName hit pit mod_name of { + case lookupIfaceByModName hit pit mod_name of { Just iface -> returnRn (iface, Nothing) ; -- Already loaded Nothing -> @@ -191,7 +192,7 @@ tryLoadInterface doc_str mod_name from ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map other -> mod_map mod_map2 = delFromFM mod_map1 mod_name - is_loaded m = maybeToBool (lookupTableByModName hit pit m) + is_loaded m = maybeToBool (lookupIfaceByModName hit pit m) -- Now add info about this module to the PIT has_orphans = pi_orphan iface @@ -553,16 +554,32 @@ readIface tr file_path %* * %********************************************************* -This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface +@lookupFixityRn@ has to be in RnIfaces (or RnHiFiles) because +it calls @loadHomeInterface@. + +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the HIT or PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with RnNames.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment \begin{code} lookupFixityRn :: Name -> RnMS Fixity lookupFixityRn name - | isLocallyDefined name - = getFixityEnv `thenRn` \ local_fix_env -> - returnRn (lookupLocalFixity local_fix_env name) + = getModuleRn `thenRn` \ this_mod -> + if nameIsLocalOrFrom this_mod name + then -- It's defined in this module + getFixityEnv `thenRn` \ local_fix_env -> + returnRn (lookupLocalFixity local_fix_env name) - | otherwise -- Imported + else -- It's imported -- For imported names, we have to get their fixities by doing a loadHomeInterface, -- and consulting the Ifaces that comes back from that, because the interface -- file for the Name might not have been loaded yet. Why not? Suppose you import module A, @@ -570,11 +587,10 @@ lookupFixityRn name -- right away (after all, it's possible that nothing from B will be used). -- When we come across a use of 'f', we need to know its fixity, and it's then, -- and only then, that we load B.hi. That is what's happening here. - = getHomeIfaceTableRn `thenRn` \ hit -> - loadHomeInterface doc name `thenRn` \ iface -> - returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) + loadHomeInterface doc name `thenRn` \ iface -> + returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) where - doc = ptext SLIT("Checking fixity for") <+> ppr name + doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 81c9ab9..8d371ce 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -36,7 +36,7 @@ import Id ( idType ) import Type ( namesOfType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocallyDefined, nameUnique, + nameModule, isLocalName, nameUnique, NamedThing(..), elemNameEnv ) @@ -458,15 +458,14 @@ getSlurped recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = (imp_mods, imp_names) }) avail - = let - new_slurped_names = addAvailToNameSet slurped_names avail - new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names name) - | otherwise = (extendModuleSet imp_mods mod, imp_names) - where - mod = nameModule name - name = availName avail - in + = ASSERT2( not (isLocalName (availName avail)), pprAvail avail ) ifaces { iSlurp = new_slurped_names, iVSlurp = new_vslurp } + where + main_name = availName avail + mod = nameModule main_name + new_slurped_names = addAvailToNameSet slurped_names avail + new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name) + | otherwise = (extendModuleSet imp_mods mod, imp_names) recordLocalSlurps local_avails = getIfacesRn `thenRn` \ ifaces -> @@ -647,7 +646,7 @@ data ImportDeclResult importDecl name = -- Check if it was loaded before beginning this module - if isLocallyDefined name then + if isLocalName name then returnRn AlreadySlurped else checkAlreadyAvailable name `thenRn` \ done -> @@ -661,13 +660,6 @@ importDecl name returnRn AlreadySlurped else - -- Don't slurp in decls from this module's own interface file - -- (Indeed, this shouldn't happen.) - if isLocallyDefined name then - addWarnRn (importDeclWarn name) `thenRn_` - returnRn AlreadySlurped - else - -- When we find a wired-in name we must load its home -- module so that we find any instance decls lurking therein if name `elemNameEnv` wiredInThingEnv then @@ -798,9 +790,8 @@ recompileRequired iface_path source_unchanged iface returnRn outOfDate else - -- CHECK WHETHER WE HAVE AN OLD IFACE -- Source code unchanged and no errors yet... carry on - checkList [checkModUsage u | u <- mi_usages iface] + checkList [checkModUsage u | u <- mi_usages iface] checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired checkList [] = returnRn upToDate @@ -915,12 +906,4 @@ getDeclErr name = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name), ptext SLIT("from module") <+> quotes (ppr (nameModule name)) ] - -importDeclWarn name - = sep [ptext SLIT( - "Compiler tried to import decl from interface file with same name as module."), - ptext SLIT( - "(possible cause: module name clashes with interface file already in scope.)") - ] $$ - hsep [ptext SLIT("name:"), quotes (ppr name)] \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 74101b7..12f4089 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -53,7 +53,7 @@ import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc, addListToRdrEnv, rdrEnvToList, rdrEnvElts ) import Name ( Name, OccName, NamedThing(..), getSrcLoc, - isLocallyDefinedName, nameOccName, + nameOccName, decode, mkLocalName, mkKnownKeyGlobal, NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList @@ -68,7 +68,7 @@ import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable import PrelNames ( mkUnboundName ) -import Maybes ( maybeToBool, seqMaybe ) +import Maybes ( maybeToBool ) import ErrUtils ( printErrorsAndWarnings ) infixr 9 `thenRn`, `thenRn_` @@ -145,7 +145,7 @@ data RnDown data SDown = SDown { rn_mode :: RnMode, - rn_genv :: GlobalRdrEnv, -- Global envt + rn_genv :: GlobalRdrEnv, -- Top level environment rn_lenv :: LocalRdrEnv, -- Local name envt -- Does *not* include global name envt; may shadow it @@ -155,9 +155,10 @@ data SDown = SDown { -- We still need the unsullied global name env so that -- we can look up record field names - rn_fixenv :: LocalFixityEnv -- Local fixities + rn_fixenv :: LocalFixityEnv -- Local fixities (for non-top-level + -- declarations) -- The global fixities are held in the - -- rn_ifaces field. Why? See the comments + -- HIT or PIT. Why? See the comments -- with RnIfaces.lookupLocalFixity } @@ -360,9 +361,12 @@ initRn dflags hit hst pcs mod do_rn is_done :: HomeSymbolTable -> PackageTypeEnv -> Name -> Bool -- Returns True iff the name is in either symbol table +-- The name is a Global, so it has a Module is_done hst pte n = maybeToBool (lookupType hst pte n) initRnMS rn_env fixity_env mode thing_inside rn_down g_down + -- The fixity_env appears in both the rn_fixenv field + -- and in the HIT. See comments with RnHiFiles.lookupFixityRn = let s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, rn_fixenv = fixity_env, rn_mode = mode } @@ -373,7 +377,6 @@ initIfaceRnMS :: Module -> RnMS r -> RnM d r initIfaceRnMS mod thing_inside = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $ setModuleRn mod thing_inside - \end{code} @renameSourceCode@ is used to rename stuff ``out-of-line''; @@ -588,6 +591,7 @@ getHomeIfaceTableRn :: RnM d HomeIfaceTable getHomeIfaceTableRn down l_down = return (rn_hit down) checkAlreadyAvailable :: Name -> RnM d Bool + -- Name is a Global name checkAlreadyAvailable name down l_down = return (rn_done down name) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 693c600..09979d4 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -109,7 +109,7 @@ rnDecl (TyClD tycl_decl) rnDecl (InstD inst) = rnInstDecl inst `thenRn` \ new_inst -> rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) -> - returnRn (InstD new_inst, fvs `plusFV` instDeclFVs new_inst') + returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst') rnDecl (RuleD rule) | isIfaceRuleDecl rule diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 3154f84..3af7420 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -42,7 +42,8 @@ import Class ( classTyVars, classBigSig, classSelIds, classTyCon, classTvsFds, import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, idType, idName ) -import Name ( Name, isLocallyDefined, NamedThing(..), +import Module ( Module ) +import Name ( Name, NamedThing(..), isFrom, NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts ) import NameSet ( emptyNameSet ) @@ -296,8 +297,8 @@ tcClassSig rec_env clas clas_tyvars fds dm_info and superclass dictionary. \begin{code} -mkImplicitClassBinds :: [Class] -> NF_TcM ([Id], TcMonoBinds) -mkImplicitClassBinds classes +mkImplicitClassBinds :: Module -> [Class] -> NF_TcM ([Id], TcMonoBinds) +mkImplicitClassBinds this_mod classes = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s) -- The selector binds are already in the selector Id's unfoldings -- We don't return the data constructor etc from the class, @@ -308,8 +309,8 @@ mkImplicitClassBinds classes mk_implicit clas = (sel_ids, binds) where sel_ids = classSelIds clas - binds | isLocallyDefined clas = idsToMonoBinds sel_ids - | otherwise = EmptyMonoBinds + binds | isFrom this_mod clas = idsToMonoBinds sel_ids + | otherwise = EmptyMonoBinds \end{code} @@ -379,14 +380,14 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to each local class decl. \begin{code} -tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds) +tcClassDecls2 :: Module -> [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds) -tcClassDecls2 decls +tcClassDecls2 this_mod decls = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds)) [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl, - isLocallyDefined (tyClDeclName cls_decl)] + isFrom this_mod (tyClDeclName cls_decl)] where combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) -> tc2 `thenNF_Tc` \ (lie2, binds2) -> diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index a654b7f..08d28dc 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -31,21 +31,18 @@ import BasicTypes ( Fixity ) import Class ( classKey, Class ) import ErrUtils ( dumpIfSet_dyn, Message ) import MkId ( mkDictFunId ) -import Id ( idType ) import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) -import Name ( Name, isLocallyDefined, getSrcLoc ) +import Name ( Name, isFrom, getSrcLoc ) import RdrName ( RdrName ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, TyCon ) -import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, - splitDFunTy, isUnboxedType - ) +import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, isUnboxedType ) import Var ( TyVar ) import PrelNames import Util ( zipWithEqual, sortLt, thenCmp ) @@ -184,16 +181,16 @@ tcDeriving :: PersistentRenamerState -> Module -- name of module under scrutiny -> InstEnv -- What we already know about instances -> (Name -> Maybe Fixity) -- used in deriving Show and Read - -> [TyCon] -- "local_tycons" ??? + -> [TyCon] -- All type constructors -> TcM ([InstInfo], -- The generated "instance decls". RenamedHsBinds) -- Extra generated bindings -tcDeriving prs mod inst_env_in get_fixity local_tycons +tcDeriving prs mod inst_env_in get_fixity tycons = recoverTc (returnTc ([], EmptyBinds)) $ -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - makeDerivEqns mod local_tycons `thenTc` \ eqns -> + makeDerivEqns mod tycons `thenTc` \ eqns -> if null eqns then returnTc ([], EmptyBinds) else @@ -230,7 +227,7 @@ tcDeriving prs mod inst_env_in get_fixity local_tycons returnRn (rn_method_binds_s, rn_extra_binds) ) - new_inst_infos = map gen_inst_info (new_dfuns `zip` rn_method_binds_s) + new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s in ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" @@ -244,16 +241,10 @@ tcDeriving prs mod inst_env_in get_fixity local_tycons where -- Make a Real dfun instead of the dummy one we have so far - gen_inst_info :: (DFunId, RenamedMonoBinds) -> InstInfo - gen_inst_info (dfun, binds) - = InstInfo { iLocal = True, - iClass = clas, iTyVars = tyvars, - iTys = tys, iTheta = theta, - iDFunId = dfun, - iBinds = binds, - iLoc = getSrcLoc dfun, iPrags = [] } - where - (tyvars, theta, clas, tys) = splitDFunTy (idType dfun) + gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo + gen_inst_info dfun binds + = InstInfo { iLocal = True, iDFunId = dfun, + iBinds = binds, iPrags = [] } rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths' -- Ignore the free vars returned @@ -284,12 +275,12 @@ all those. \begin{code} makeDerivEqns :: Module -> [TyCon] -> TcM [DerivEqn] -makeDerivEqns this_mod local_tycons +makeDerivEqns this_mod tycons = let - think_about_deriving = need_deriving local_tycons + think_about_deriving = need_deriving tycons (derive_these, _) = removeDups cmp_deriv think_about_deriving in - if null local_tycons then + if null think_about_deriving then returnTc [] -- Bale out now else mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> @@ -300,9 +291,9 @@ makeDerivEqns this_mod local_tycons -- find the tycons that have `deriving' clauses; need_deriving tycons_to_consider - = foldr (\ tycon acc -> [(clas,tycon) | clas <- tyConDerivings tycon] ++ acc) - [] - tycons_to_consider + = [ (clas,tycon) | tycon <- tycons_to_consider, + isFrom this_mod tycon, + clas <- tyConDerivings tycon ] ------------------------------------------------------------------ cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> Ordering @@ -525,7 +516,6 @@ the renamer. What a great hack! -- names.) gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds gen_bind get_fixity dfun - | not (isLocallyDefined tycon) = EmptyMonoBinds | clas `hasKey` showClassKey = gen_Show_binds get_fixity tycon | clas `hasKey` readClassKey = gen_Read_binds get_fixity tycon | otherwise diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 88d0159..3dfdb2e 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -11,7 +11,7 @@ module TcEnv( -- Instance environment, and InstInfo type tcGetInstEnv, tcSetInstEnv, InstInfo(..), pprInstInfo, - simpleInstInfoTy, simpleInstInfoTyCon, isLocalInst, + simpleInstInfoTy, simpleInstInfoTyCon, -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, @@ -49,8 +49,8 @@ import IdInfo ( vanillaIdInfo ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet -import Type ( Type, ThetaType, - tyVarsOfTypes, +import Type ( Type, + tyVarsOfTypes, splitDFunTy, splitForAllTys, splitRhoTy, getDFunTyKey, splitTyConApp_maybe ) @@ -60,7 +60,7 @@ import Class ( Class, ClassOpItem, ClassContext ) import Subst ( substTy ) import Name ( Name, OccName, NamedThing(..), nameOccName, nameModule, getSrcLoc, mkGlobalName, - isLocallyDefined, nameModule_maybe, + isLocalName, nameModule_maybe, NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) @@ -151,7 +151,8 @@ initTcEnv hst pte tcTyVars = gtv_var })} where - lookup name = lookupType hst pte name + lookup name | isLocalName name = Nothing + | otherwise = lookupType hst pte name tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)] @@ -508,16 +509,9 @@ The InstInfo type summarises the information in an instance declaration \begin{code} data InstInfo = InstInfo { - iClass :: Class, -- Class, k - iTyVars :: [TyVar], -- Type variables, tvs - iTys :: [Type], -- The types at which the class is being instantiated - iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the - -- instance declaration. It constrains (some of) - -- the TyVars above - iLocal :: Bool, -- True <=> it's defined in this module + iLocal :: Bool, -- True <=> it's defined in this module iDFunId :: DFunId, -- The dfun id iBinds :: RenamedMonoBinds, -- Bindings, b - iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances } @@ -525,7 +519,8 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)) nest 4 (ppr (iBinds info))] simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty +simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of + (_, _, _, [ty]) -> ty simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, @@ -533,9 +528,6 @@ simpleInstInfoTyCon :: InstInfo -> TyCon simpleInstInfoTyCon inst = case splitTyConApp_maybe (simpleInstInfoTy inst) of Just (tycon, _) -> tycon - -isLocalInst :: Module -> InstInfo -> Bool -isLocalInst mod info = isLocalThing mod (iDFunId info) \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index a7e7d9f..0280341 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -30,14 +30,14 @@ import TcDeriv ( tcDeriving ) import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcInstId, tcLookupClass, - InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst, + InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, newDFunName, tcExtendTyVarEnv ) import InstEnv ( InstEnv, classDataCon, extendInstEnv ) import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( zonkTcSigTyVars ) -import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId, +import HscTypes ( HomeSymbolTable, DFunId, ModDetails(..), PackageInstEnv, PersistentRenamerState ) @@ -48,18 +48,18 @@ import Maybes ( maybeToBool ) import MkId ( mkDictFunId ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) -import Name ( isLocallyDefined ) +import Name ( getSrcLoc ) import NameSet ( emptyNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import PprType ( pprConstraint, pprPred ) import TyCon ( TyCon, isSynTyCon, tyConDerivings ) -import Type ( mkTyVarTys, splitDFunTy, isTyVarTy, +import Type ( splitDFunTy, isTyVarTy, splitTyConApp_maybe, splitDictTy, - splitAlgTyConApp_maybe, + splitAlgTyConApp_maybe, splitForAllTys, unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy, getClassTys_maybe ) -import Subst ( mkTopTyVarSubst, substClasses, substTheta ) +import Subst ( mkTopTyVarSubst, substClasses ) import VarSet ( mkVarSet, varSetElems ) import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) @@ -170,7 +170,7 @@ tcInstDecls1 :: PackageInstEnv -> [RenamedHsDecl] -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds) -tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls +tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls = let inst_decls = [inst_decl | InstD inst_decl <- decls] clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl] @@ -189,8 +189,7 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls -- e) generic instances inst_env4 -- The result of (b) replaces the cached InstEnv in the PCS let - (local_inst_info, imported_inst_info) - = partition (isLocalInst mod) (concat inst_infos) + (local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos) imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId) imported_inst_info @@ -206,8 +205,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls -- we ignore deriving decls from interfaces! -- This stuff computes a context for the derived instance decl, so it -- needs to know about all the instances possible; hecne inst_env4 - tcDeriving prs mod inst_env4 get_fixity local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) -> - addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> + tcDeriving prs mod inst_env4 get_fixity tycons `thenTc` \ (deriv_inst_info, deriv_binds) -> + addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> returnTc (inst_env1, final_inst_env, @@ -255,17 +254,18 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) -- Make the dfun id and return it newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> - returnNF_Tc (True, mkDictFunId dfun_name clas tyvars inst_tys theta) + returnNF_Tc (True, dfun_name) Just dfun_name -> -- An interface-file instance declaration -- Make the dfun id - returnNF_Tc (False, mkDictFunId dfun_name clas tyvars inst_tys theta) - ) `thenNF_Tc` \ (is_local, dfun_id) -> + returnNF_Tc (False, dfun_name) + ) `thenNF_Tc` \ (is_local, dfun_name) -> - returnTc [InstInfo { iLocal = is_local, - iClass = clas, iTyVars = tyvars, iTys = inst_tys, - iTheta = theta, iDFunId = dfun_id, - iBinds = binds, iLoc = src_loc, iPrags = uprags }] + let + dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta + in + returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id, + iBinds = binds, iPrags = uprags }] \end{code} @@ -334,15 +334,18 @@ get_generics mod decl@(ClassDecl context class_name tyvar_names -- f {| x+y |} ... = ... -- Then at this point we'll have an InstInfo for each let - bad_groups = [group | group <- equivClassesByUniq get_uniq inst_infos, + tc_inst_infos :: [(TyCon, InstInfo)] + tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] + + bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, length group > 1] - get_uniq inst = getUnique (simpleInstInfoTyCon inst) + get_uniq (tc,_) = getUnique tc in mapTc (addErrTc . dupGenericInsts) bad_groups `thenTc_` -- Check that there is an InstInfo for each generic type constructor let - missing = genericTyCons `minusList` map simpleInstInfoTyCon inst_infos + missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos] in checkTc (null missing) (missingGenericInstances missing) `thenTc_` @@ -399,10 +402,8 @@ mkGenericInstance mod clas loc (hs_ty, binds) dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta in - returnTc (InstInfo { iLocal = True, - iClass = clas, iTyVars = tyvars, iTys = inst_tys, - iTheta = inst_theta, iDFunId = dfun_id, iBinds = binds, - iLoc = loc, iPrags = [] }) + returnTc (InstInfo { iLocal = True, iDFunId = dfun_id, + iBinds = binds, iPrags = [] }) \end{code} @@ -496,16 +497,15 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds) -tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys, - iTheta = inst_decl_theta, iDFunId = dfun_id, - iBinds = monobinds, iLoc = locn, iPrags = uprags }) - | not (isLocallyDefined dfun_id) +tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, + iBinds = monobinds, iPrags = uprags }) + | not is_local = returnNF_Tc (emptyLIE, EmptyMonoBinds) | otherwise = -- Prime error recovery recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ - tcAddSrcLoc locn $ + tcAddSrcLoc (getSrcLoc dfun_id) $ -- Instantiate the instance decl with tc-style type variables tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') -> @@ -518,15 +518,16 @@ tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys, dm_ids = [dm_id | (_, DefMeth dm_id) <- op_items] sel_names = [idName sel_id | (sel_id, _) <- op_items] - -- Instantiate the theta found in the original instance decl - inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) - inst_decl_theta - -- Instantiate the super-class context with inst_tys sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta -- Find any definitions in monobinds that aren't from the class bad_bndrs = collectMonoBinders monobinds `minusList` sel_names + + -- The type variable from the dict fun actually scope + -- over the bindings. They were gotten from + -- the original instance declaration + (inst_tyvars, _) = splitForAllTys (idType dfun_id) in -- Check that all the method bindings come from this class mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` @@ -534,7 +535,6 @@ tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys, -- Create dictionary Ids from the specified instance contexts. newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) -> - newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( @@ -542,7 +542,7 @@ tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys, -- Default-method Ids may be mentioned in synthesised RHSs mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' - inst_decl_theta' + dfun_theta' monobinds uprags True) op_items )) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> @@ -585,20 +585,6 @@ tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys, methods_lie ) `thenTc` \ (const_lie1, lie_binds1) -> - -- Check that we *could* construct the superclass dictionaries, - -- even though we are *actually* going to pass the superclass dicts in; - -- the check ensures that the caller will never have - --a problem building them. - tcAddErrCtxt superClassCtxt ( - tcSimplifyAndCheck - (ptext SLIT("instance declaration context")) - inst_tyvars_set -- Local tyvars - inst_decl_dicts -- The instance dictionaries available - sc_dicts -- The superclass dicationaries reqd - ) `thenTc` \ _ -> - -- Ignore the result; we're only doing - -- this to make sure it can be done. - -- Now do the simplification again, this time to get the -- bindings; this time we use an enhanced "avails" -- Ignore errors because they come from the *previous* tcSimplify @@ -791,11 +777,13 @@ missingGenericInstances missing -dupGenericInsts inst_infos +dupGenericInsts tc_inst_infos = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"), - nest 4 (vcat (map (ppr . simpleInstInfoTy) inst_infos)), + nest 4 (vcat (map ppr_inst_ty tc_inst_infos)), ptext SLIT("All the type patterns for a generic type constructor must be identical") ] + where + ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst) instTypeErr clas tys msg = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys), @@ -814,7 +802,6 @@ nonBoxedPrimCCallErr clas inst_ty ppr inst_ty]) methodCtxt = ptext SLIT("When checking the methods of an instance declaration") -superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration") \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 0e13efb..1387888 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -55,7 +55,7 @@ import Bag ( isEmptyBag ) import Outputable import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable, PackageTypeEnv, DFunId, ModIface(..), - TypeEnv, extendTypeEnvList, lookupTable, + TypeEnv, extendTypeEnvList, lookupIface, TyThing(..), mkTypeEnv ) import List ( partition ) \end{code} @@ -110,7 +110,7 @@ typecheckModule dflags this_mod pcs hst hit decls pit = pcs_PIT pcs get_fixity :: Name -> Maybe Fixity - get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface -> + get_fixity nm = lookupIface hit pit this_mod nm `thenMaybe` \ iface -> lookupNameEnv (mi_fixities iface) nm \end{code} @@ -136,20 +136,14 @@ tcModule pcs hst get_fixity this_mod decls unf_env tcTyAndClassDecls unf_env decls `thenTc` \ env -> tcSetEnv env $ let - classes = tcEnvClasses env - tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes - local_tycons = [ tc | tc <- tycons, - isLocallyDefined tc, - not (isClassTyCon tc) - ] - -- For local_tycons, filter out the ones derived from classes - -- Otherwise the latter show up in interface files + classes = tcEnvClasses env + tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes in -- Typecheck the instance decls, includes deriving tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) hst unf_env get_fixity this_mod - local_tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> + tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> tcSetInstEnv inst_env $ -- Default declarations @@ -173,8 +167,8 @@ tcModule pcs hst get_fixity this_mod decls unf_env -- We don't create bindings for dictionary constructors; -- they are always fully applied, and the bindings are just there -- to support partial applications - mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) -> - mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> + mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) -> + mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> -- Extend the global value environment with -- (a) constructors @@ -201,7 +195,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env -- Second pass over class and instance declarations, -- to compile the bindings themselves. tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> - tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> + tcClassDecls2 this_mod decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) -> -- Deal with constant or ambiguous InstIds. How could @@ -299,11 +293,7 @@ dump_sigs results -- Print type signatures ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocallyDefined n && - isGlobalName n && - not (isSysOcc (nameOccName n)) - where - n = idName id + | otherwise = isLocallyDefined id ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"), vcat (map ppr_gen_tycon (filter isLocallyDefined tcs)), diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index c44fef2..b2d82be 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -37,7 +37,8 @@ import DataCon ( DataCon, mkDataCon, import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) import FieldLabel import Var ( Id, TyVar ) -import Name ( Name, isLocallyDefined, NamedThing(..) ) +import Module ( Module ) +import Name ( Name, NamedThing(..), isFrom ) import Outputable import TyCon ( TyCon, isSynTyCon, isNewTyCon, tyConDataConsIfAvailable, tyConTyVars, tyConGenIds @@ -216,15 +217,15 @@ getBangStrictness (Unpacked _) = markedUnboxed %************************************************************************ \begin{code} -mkImplicitDataBinds :: [TyCon] -> TcM ([Id], TcMonoBinds) -mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds) -mkImplicitDataBinds (tycon : tycons) - | isSynTyCon tycon = mkImplicitDataBinds tycons - | otherwise = mkImplicitDataBinds_one tycon `thenTc` \ (ids1, b1) -> - mkImplicitDataBinds tycons `thenTc` \ (ids2, b2) -> +mkImplicitDataBinds :: Module -> [TyCon] -> TcM ([Id], TcMonoBinds) +mkImplicitDataBinds this_mod [] = returnTc ([], EmptyMonoBinds) +mkImplicitDataBinds this_mod (tycon : tycons) + | isSynTyCon tycon = mkImplicitDataBinds this_mod tycons + | otherwise = mkImplicitDataBinds_one this_mod tycon `thenTc` \ (ids1, b1) -> + mkImplicitDataBinds this_mod tycons `thenTc` \ (ids2, b2) -> returnTc (ids1++ids2, b1 `AndMonoBinds` b2) -mkImplicitDataBinds_one tycon +mkImplicitDataBinds_one this_mod tycon = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> let unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids @@ -233,8 +234,8 @@ mkImplicitDataBinds_one tycon -- For the locally-defined things -- we need to turn the unfoldings inside the selector Ids into bindings, -- and build bindigns for the constructor wrappers - binds | isLocallyDefined tycon = idsToMonoBinds unf_ids - | otherwise = EmptyMonoBinds + binds | isFrom this_mod tycon = idsToMonoBinds unf_ids + | otherwise = EmptyMonoBinds in returnTc (all_ids, binds) where -- 1.7.10.4