\begin{code}
module HscTypes (
- Finder, ModuleLocation(..),
+ ModuleLocation(..),
- ModDetails(..), ModIface(..), GlobalSymbolTable,
- HomeSymbolTable, PackageSymbolTable,
- HomeIfaceTable, PackageIfaceTable,
- lookupTable, lookupTableByModName,
+ ModDetails(..), ModIface(..),
+ HomeSymbolTable, PackageTypeEnv,
+ HomeIfaceTable, PackageIfaceTable, emptyIfaceTable,
+ lookupIface, lookupIfaceByModName,
+ emptyModIface,
- IfaceDecls(..),
+ IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
VersionInfo(..), initialVersionInfo,
- TyThing(..), groupTyThings,
+ TyThing(..), isTyClThing,
- TypeEnv, extendTypeEnv, lookupTypeEnv,
+ TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList,
+ typeEnvClasses, typeEnvTyCons,
WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
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, unitNameEnv, extendNameEnv, plusNameEnv,
- lookupNameEnv, emptyNameEnv, getName, nameModule,
- nameSrcLoc )
-import NameSet ( NameSet )
+import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList )
+import Name ( Name, NamedThing, isLocallyDefined,
+ 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 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 ( CoreRule, IdCoreRule )
-import Type ( Type )
+import CoreSyn ( IdCoreRule )
-import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
+import FiniteMap ( FiniteMap )
import Bag ( Bag )
import Maybes ( seqMaybe )
-import UniqFM ( UniqFM )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
-import Util ( thenCmp )
+import Util ( thenCmp, sortLt )
import UniqSupply ( UniqSupply )
\end{code}
%************************************************************************
%* *
-\subsection{The Finder type}
+\subsection{Module locations}
%* *
%************************************************************************
\begin{code}
-type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation))
-
data ModuleLocation
= ModuleLocation {
- hs_file :: FilePath,
- hi_file :: FilePath,
- obj_file :: FilePath
- }
+ ml_hs_file :: Maybe FilePath,
+ ml_hspp_file :: Maybe FilePath, -- path of preprocessed source
+ ml_hi_file :: Maybe FilePath,
+ ml_obj_file :: Maybe FilePath
+ }
+ deriving Show
+
+instance Outputable ModuleLocation where
+ ppr = text . show
\end{code}
For a module in another package, the hs_file and obj_file
mi_module :: Module, -- Complete with package info
mi_version :: VersionInfo, -- Module version number
mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
+ mi_boot :: IsBootInterface, -- Whether this interface was read from an hi-boot file
mi_usages :: [ImportVersion Name], -- Usages; kept sorted so that it's easy
-- to decide whether to write a new iface file
-- (changing usages doesn't affect the version of
-- this module)
- mi_exports :: Avails, -- What it exports
+ mi_exports :: [(ModuleName,Avails)], -- What it exports
-- Kept sorted by (mod,occ),
-- to make version comparisons easier
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 = nameOccName (tyClDeclName d1) < nameOccName (tyClDeclName d2)
+ r1 `lt_rule` r2 = nameOccName (ifaceRuleDeclName r1) < nameOccName (ifaceRuleDeclName r2)
+
+ -- I wanted to sort just by the Name, but there's a problem: we are comparing
+ -- the old version of an interface with the new version. The latter will use
+ -- local names like 'lvl23' that were constructed not by the renamer but by
+ -- the simplifier. So the unqiues aren't going to line up.
+ --
+ -- It's ok to compare by OccName because this comparison only drives the
+ -- computation of new version numbers.
+ --
+ -- Better solutions: Compare in a way that is insensitive to the name used
+ -- for local things. This would decrease the wobbles due
+ -- to 'lvl23' changing to 'lvl24'.
+ --
+ -- NB: there's a related comparision on MkIface.diffDecls!
+
+
+
+
-- typechecker should only look at this, not ModIface
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
emptyModIface :: Module -> ModIface
emptyModIface mod
= ModIface { mi_module = mod,
+ mi_version = initialVersionInfo,
+ mi_usages = [],
+ mi_orphan = False,
+ mi_boot = False,
mi_exports = [],
+ mi_fixities = emptyNameEnv,
mi_globals = emptyRdrEnv,
- mi_deprecs = NoDeprecs
+ mi_deprecs = NoDeprecs,
+ mi_decls = panic "emptyModIface: decls"
}
\end{code}
type PackageIfaceTable = IfaceTable
type HomeSymbolTable = SymbolTable -- Domain = modules in the home package
-type PackageSymbolTable = SymbolTable -- Domain = modules in the some other package
-type GlobalSymbolTable = SymbolTable -- Domain = all modules
+
+emptyIfaceTable :: IfaceTable
+emptyIfaceTable = emptyModuleEnv
\end{code}
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}
%************************************************************************
\begin{code}
-type TypeEnv = NameEnv TyThing
-emptyTypeEnv = emptyNameEnv
-
data TyThing = AnId Id
| ATyCon TyCon
| AClass Class
+isTyClThing :: TyThing -> Bool
+isTyClThing (ATyCon _) = True
+isTyClThing (AClass _) = True
+isTyClThing (AnId _) = False
+
instance NamedThing TyThing where
getName (AnId id) = getName id
getName (ATyCon tc) = getName tc
getName (AClass cl) = getName cl
+
+typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
+typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env]
+
\end{code}
\begin{code}
-lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing
-lookupTypeEnv tbl name
- = case lookupModuleEnv tbl (nameModule name) of
- Just details -> lookupNameEnv (md_types details) name
- Nothing -> Nothing
+type TypeEnv = NameEnv TyThing
+emptyTypeEnv = emptyNameEnv
-groupTyThings :: [TyThing] -> FiniteMap Module TypeEnv
- -- Finite map because we want the range too
-groupTyThings things
- = foldl add emptyFM things
- where
- add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv
- add tbl thing = addToFM tbl mod new_env
- where
- name = getName thing
- mod = nameModule name
- new_env = case lookupFM tbl mod of
- Nothing -> unitNameEnv name thing
- Just env -> extendNameEnv env name thing
+mkTypeEnv :: [TyThing] -> TypeEnv
+mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
-extendTypeEnv :: SymbolTable -> FiniteMap Module TypeEnv -> SymbolTable
-extendTypeEnv tbl things
- = foldFM add tbl things
+extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
+extendTypeEnvList env things
+ = foldl add_thing env things
where
- add mod type_env tbl
- = panic "extendTypeEnv" --extendModuleEnv mod new_details
- where
- new_details
- = case lookupModuleEnv tbl mod of
- Nothing -> emptyModDetails {md_types = type_env}
- Just details -> details {md_types = md_types details
- `plusNameEnv` type_env}
+ add_thing :: TypeEnv -> TyThing -> TypeEnv
+ add_thing env thing = extendNameEnv env (getName thing) thing
\end{code}
+\begin{code}
+lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing
+lookupType hst pte name
+ = 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}
%************************************************************************
%* *
vers_decls = emptyNameEnv }
data Deprecations = NoDeprecs
- | DeprecAll DeprecTxt -- Whole module deprecated
- | DeprecSome (NameEnv DeprecTxt) -- Some things deprecated
- -- Just "big" names
-
-lookupDeprec :: ModIface -> Name -> Maybe DeprecTxt
-lookupDeprec iface name
- = case mi_deprecs iface of
- NoDeprecs -> Nothing
- DeprecAll txt -> Just txt
- DeprecSome env -> lookupNameEnv env name
-
-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
+ | DeprecAll DeprecTxt -- Whole module deprecated
+ | DeprecSome (NameEnv (Name,DeprecTxt)) -- Some things deprecated
+ -- Just "big" names
+ -- We keep the Name in the range, so we can print them out
+
+lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt
+lookupDeprec NoDeprecs name = Nothing
+lookupDeprec (DeprecAll txt) name = Just txt
+lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of
+ Just (_, txt) -> Just txt
+ Nothing -> Nothing
\end{code}
-- 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}
pcs_PIT :: PackageIfaceTable, -- Domain = non-home-package modules
-- the mi_decls component is empty
- pcs_PST :: PackageSymbolTable, -- Domain = non-home-package modules
+ pcs_PTE :: PackageTypeEnv, -- Domain = non-home-package modules
-- except that the InstEnv components is empty
pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all
* A name supply, which deals with allocating unique names to
(Module,OccName) original names,
- * An accumulated InstEnv from all the modules in pcs_PST
+ * An accumulated TypeEnv from all the modules in imported packages
+
+ * An accumulated InstEnv from all the modules in imported packages
The point is that we don't want to keep recreating it whenever
we compile a new module. The InstEnv component of pcPST is empty.
(This means we might "see" instances that we shouldn't "really" see;
interface files but not yet sucked in, renamed, and typechecked
\begin{code}
+type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
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}
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.
| NonLocalDef -- Defined non-locally
ImportReason
- PrintUnqualified
-- Just used for grouping error messages (in RnEnv.warnUnusedBinds)
instance Eq Provenance 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
-- 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}
-- 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
projects / ghc-hetmet.git / blobdiff