X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=8284e2f73458801c661ab0e454c4b5507e21fba8;hb=9fc29e6eedbb0cee53960a0664d99c0b2c33f3d7;hp=d29b7f47705cd17aed3a8c5aee664c24abf48443;hpb=47eef4b5780f0a5b5a37847097842daebd0f9285;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index d29b7f4..8284e2f 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -13,18 +13,18 @@ module HscTypes ( lookupIface, lookupIfaceByModName, emptyModIface, - IfaceDecls(..), + IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, VersionInfo(..), initialVersionInfo, - TyThing(..), isTyClThing, + TyThing(..), isTyClThing, implicitTyThingIds, TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList, typeEnvClasses, typeEnvTyCons, WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, GatedDecl, + IfaceInsts, IfaceRules, GatedDecl, IsExported, OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, AvailEnv, AvailInfo, GenAvailInfo(..), PersistentCompilerState(..), @@ -34,19 +34,18 @@ module HscTypes ( InstEnv, ClsInstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, RdrAvailInfo, + GlobalRdrEnv, RdrAvailInfo, pprGlobalRdrEnv, -- Provenance - Provenance(..), ImportReason(..), PrintUnqualified, + Provenance(..), ImportReason(..), pprNameProvenance, hasBetterProv ) where #include "HsVersions.h" -import RdrName ( RdrNameEnv, emptyRdrEnv ) -import Name ( Name, NamedThing, isLocallyDefined, - getName, nameModule, nameSrcLoc ) +import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList ) +import Name ( Name, NamedThing, getName, nameModule, nameSrcLoc ) import Name -- Env import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, @@ -55,12 +54,13 @@ import Module ( Module, ModuleName, ModuleEnv, import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) import Id ( Id ) -import Class ( Class ) -import TyCon ( TyCon ) +import Class ( Class, classSelIds ) +import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) +import DataCon ( dataConId, dataConWrapId ) import BasicTypes ( Version, initialVersion, Fixity ) -import HsSyn ( DeprecTxt ) +import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName ) import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) @@ -71,7 +71,7 @@ import Bag ( Bag ) import Maybes ( seqMaybe ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import Util ( thenCmp ) +import Util ( thenCmp, sortLt ) import UniqSupply ( UniqSupply ) \end{code} @@ -144,6 +144,16 @@ data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted dcl_rules :: [RenamedRuleDecl], -- Sorted dcl_insts :: [RenamedInstDecl] } -- Unsorted +mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls +mkIfaceDecls tycls rules insts + = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls, + dcl_rules = sortLt lt_rule rules, + dcl_insts = insts } + where + d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 + r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 + + -- typechecker should only look at this, not ModIface -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails @@ -196,20 +206,17 @@ emptyIfaceTable = emptyModuleEnv Simple lookups in the symbol table. \begin{code} -lookupIface :: HomeIfaceTable -> PackageIfaceTable - -> Module -> Name -- The module is to use for locally-defined names - -> Maybe ModIface +lookupIface :: HomeIfaceTable -> PackageIfaceTable -> Name -> 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 +lookupIface hit pit name + = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod where mod = nameModule name -lookupIfaceByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a --- We often have two Symbol- or IfaceTables, and want to do a lookup -lookupIfaceByModName ht pt mod - = lookupModuleEnvByName ht mod `seqMaybe` lookupModuleEnvByName pt mod +lookupIfaceByModName :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIfaceByModName hit pit mod + = lookupModuleEnvByName hit mod `seqMaybe` lookupModuleEnvByName pit mod \end{code} @@ -234,9 +241,26 @@ instance NamedThing TyThing where getName (ATyCon tc) = getName tc getName (AClass cl) = getName cl +instance Outputable TyThing where + ppr (AnId id) = ptext SLIT("AnId") <+> ppr id + ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc + ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl + typeEnvClasses env = [cl | AClass cl <- nameEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env] +implicitTyThingIds :: [TyThing] -> [Id] +-- Add the implicit data cons and selectors etc +implicitTyThingIds things + = concat (map go things) + where + go (AnId f) = [] + go (AClass cl) = classSelIds cl + go (ATyCon tc) = tyConGenIds tc ++ + tyConSelIds tc ++ + [ n | dc <- tyConDataConsIfAvailable tc, + n <- [dataConId dc, dataConWrapId dc] ] + -- Synonyms return empty list of constructors and selectors \end{code} @@ -259,8 +283,7 @@ extendTypeEnvList env things \begin{code} lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing lookupType hst pte name - = ASSERT2( not (isLocallyDefined name), ppr name ) - case lookupModuleEnv hst (nameModule name) of + = case lookupModuleEnv hst (nameModule name) of Just details -> lookupNameEnv (md_types details) name Nothing -> lookupNameEnv pte name \end{code} @@ -377,6 +400,8 @@ data WhatsImported name = NothingAtAll -- The module is below us in the -- we imported the module without saying exactly what we imported -- We need to recompile if the module exports changes, because we might -- now have a name clash in the importing module. + +type IsExported = Name -> Bool -- True for names that are exported from this module \end{code} @@ -435,8 +460,7 @@ data PersistentRenamerState = PRS { prsOrig :: OrigNameEnv, prsDecls :: DeclsMap, prsInsts :: IfaceInsts, - prsRules :: IfaceRules, - prsNS :: UniqSupply + prsRules :: IfaceRules } \end{code} @@ -454,7 +478,9 @@ we just store junk. Then when we find the binding site, we fix it up. \begin{code} data OrigNameEnv - = Orig { origNames :: OrigNameNameEnv, + = Orig { origNS :: UniqSupply, + -- Supply of uniques + origNames :: OrigNameNameEnv, -- Ensures that one original name gets one unique origIParam :: OrigNameIParamEnv -- Ensures that one implicit parameter name gets one unique @@ -494,6 +520,12 @@ one for each module, corresponding to that module's top-level scope. type GlobalRdrEnv = RdrNameEnv [(Name,Provenance)] -- The list is because there may be name clashes -- These only get reported on lookup, -- not on construction + +pprGlobalRdrEnv env + = vcat (map pp (rdrEnvToList env)) + where + pp (rn, nps) = ppr rn <> colon <+> + vcat [ppr n <+> pprNameProvenance n p | (n,p) <- nps] \end{code} The "provenance" of something says how it came to be in scope. @@ -504,7 +536,6 @@ data Provenance | NonLocalDef -- Defined non-locally ImportReason - PrintUnqualified -- Just used for grouping error messages (in RnEnv.warnUnusedBinds) instance Eq Provenance where @@ -515,10 +546,10 @@ instance Eq ImportReason where instance Ord Provenance where compare LocalDef LocalDef = EQ - compare LocalDef (NonLocalDef _ _) = LT - compare (NonLocalDef _ _) LocalDef = GT + compare LocalDef (NonLocalDef _) = LT + compare (NonLocalDef _) LocalDef = GT - compare (NonLocalDef reason1 _) (NonLocalDef reason2 _) + compare (NonLocalDef reason1) (NonLocalDef reason2) = compare reason1 reason2 instance Ord ImportReason where @@ -542,11 +573,6 @@ data ImportReason -- This info is used when warning of unused names. | ImplicitImport -- Imported implicitly for some other reason - - -type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is - -- in scope in this module, so print it - -- unqualified in error messages \end{code} \begin{code} @@ -555,15 +581,14 @@ hasBetterProv :: Provenance -> Provenance -> Bool -- a local thing over an imported thing -- a user-imported thing over a non-user-imported thing -- an explicitly-imported thing over an implicitly imported thing -hasBetterProv LocalDef _ = True -hasBetterProv (NonLocalDef (UserImport _ _ True) _) _ = True -hasBetterProv (NonLocalDef (UserImport _ _ _ ) _) (NonLocalDef ImplicitImport _) = True -hasBetterProv _ _ = False +hasBetterProv LocalDef _ = True +hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True +hasBetterProv _ _ = False pprNameProvenance :: Name -> Provenance -> SDoc -pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) -pprNameProvenance name (NonLocalDef why _) = sep [ppr_reason why, - nest 2 (parens (ppr_defn (nameSrcLoc name)))] +pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance name (NonLocalDef why) = sep [ppr_reason why, + nest 2 (parens (ppr_defn (nameSrcLoc name)))] ppr_reason ImplicitImport = ptext SLIT("implicitly imported") ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc