X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=8284e2f73458801c661ab0e454c4b5507e21fba8;hb=9fc29e6eedbb0cee53960a0664d99c0b2c33f3d7;hp=ccfddd5e5115cdc913dc74b4a82fc372df7623ed;hpb=88f315a135bd00d2efa00d991bb9487929562d91;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index ccfddd5..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,49 +34,44 @@ 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, NameEnv, NamedThing, - emptyNameEnv, extendNameEnv, - lookupNameEnv, emptyNameEnv, nameEnvElts, - isLocallyDefined, getName, nameModule, - nameSrcLoc ) -import NameSet ( NameSet ) +import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList ) +import Name ( Name, NamedThing, getName, nameModule, nameSrcLoc ) +import Name -- Env import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, - lookupModuleEnv, lookupModuleEnvByName + lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv ) +import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) -import VarSet ( TyVarSet ) 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 RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) +import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName ) +import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) import CoreSyn ( IdCoreRule ) -import Type ( Type ) import FiniteMap ( FiniteMap ) import Bag ( Bag ) import Maybes ( seqMaybe ) -import UniqFM ( UniqFM, emptyUFM ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import Util ( thenCmp ) +import Util ( thenCmp, sortLt ) import UniqSupply ( UniqSupply ) \end{code} @@ -149,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 @@ -195,26 +200,23 @@ type PackageIfaceTable = IfaceTable type HomeSymbolTable = SymbolTable -- Domain = modules in the home package emptyIfaceTable :: IfaceTable -emptyIfaceTable = emptyUFM +emptyIfaceTable = emptyModuleEnv \end{code} 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} @@ -239,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} @@ -264,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} @@ -310,11 +328,6 @@ lookupDeprec (DeprecAll txt) name = Just txt lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of Just (_, txt) -> Just txt Nothing -> Nothing - -type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class - -type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class -type DFunId = Id \end{code} @@ -333,6 +346,16 @@ data GenAvailInfo name = Avail name -- An ordinary identifier -- Equality used when deciding if the interface has changed type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it + +instance Outputable n => Outputable (GenAvailInfo n) where + ppr = pprAvail + +pprAvail :: Outputable n => GenAvailInfo n -> SDoc +pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of + [] -> empty + ns' -> braces (hsep (punctuate comma (map ppr ns'))) + +pprAvail (Avail n) = ppr n \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 @@ -470,12 +496,14 @@ including the constructors of a type decl etc. The Bool is True just for the 'main' Name. \begin{code} -type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)) +type DeclsMap = (NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)), Int) + -- The Int says how many have been sucked in -type IfaceInsts = Bag GatedDecl -type IfaceRules = Bag GatedDecl +type IfaceInsts = GatedDecls RdrNameInstDecl +type IfaceRules = GatedDecls RdrNameRuleDecl -type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) +type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in +type GatedDecl d = ([Name], (Module, d)) \end{code} @@ -492,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. @@ -502,7 +536,6 @@ data Provenance | NonLocalDef -- Defined non-locally ImportReason - PrintUnqualified -- Just used for grouping error messages (in RnEnv.warnUnusedBinds) instance Eq Provenance where @@ -513,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 @@ -540,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} @@ -553,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