mi_decls = decls,
mi_globals = Nothing,
mi_insts = insts,
+ mi_fam_insts = mkIfaceFamInstsCache . map snd $ decls,
mi_rules = rules,
mi_rule_vers = rule_vers,
-- And build the cached values
- mi_dep_fn = mkIfaceDepCache deprecs,
- mi_fix_fn = mkIfaceFixCache fixities,
- mi_ver_fn = mkIfaceVerCache decls })
+ mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_fix_fn = mkIfaceFixCache fixities,
+ mi_ver_fn = mkIfaceVerCache decls })
GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
orph <- get bh
return (IfaceInst cls tys dfun flag orph)
+instance Binary IfaceFamInst where
+ put_ bh (IfaceFamInst tycon tys) = do
+ put_ bh tycon
+ put_ bh tys
+ get bh = do tycon <- get bh
+ tys <- get bh
+ return (IfaceFamInst tycon tys)
+
instance Binary OverlapFlag where
put_ bh NoOverlap = putByte bh 0
put_ bh OverlapOk = putByte bh 1
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
-- Misc
- visibleIfConDecls,
+ visibleIfConDecls, extractIfFamInsts,
-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
-- been compiled with
-- different flags to the
-- current compilation unit
- ifFamInst :: Maybe -- Just _ <=> instance of fam
- (IfaceTyCon, -- Family tycon
- [IfaceType]) -- Instance types
+ ifFamInst :: Maybe IfaceFamInst
+ -- Just <=> instance of family
}
| IfaceSyn { ifName :: OccName, -- Type constructor
-- If this instance decl is *used*, we'll record a usage on the dfun;
-- and if the head does not change it won't be used if it wasn't before
+data IfaceFamInst
+ = IfaceFamInst { ifFamInstTyCon :: IfaceTyCon -- Family tycon
+ , ifFamInstTys :: [IfaceType] -- Instance types
+ }
+
+extractIfFamInsts :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)]
+extractIfFamInsts decls =
+ [(famInst, decl) | decl@IfaceData {ifFamInst = Just famInst} <- decls]
+ -- !!!TODO: we also need a similar case for synonyms
+
data IfaceRule
= IfaceRule {
ifRuleName :: RuleName,
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
-pprFamily Nothing = ptext SLIT("FamilyInstance: none")
-pprFamily (Just (fam, tys)) = ptext SLIT("FamilyInstance:") <+>
- ppr fam <+> hsep (map ppr tys)
+pprFamily Nothing = ptext SLIT("FamilyInstance: none")
+pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
where
ppr_mb Nothing = dot
ppr_mb (Just tc) = ppr tc
+
+instance Outputable IfaceFamInst where
+ ppr (IfaceFamInst {ifFamInstTyCon = tycon, ifFamInstTys = tys})
+ = ppr tycon <+> hsep (map ppr tys)
\end{code}
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
where
- Nothing `eqIfTc_fam` Nothing = Equal
- (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
+ Nothing `eqIfTc_fam` Nothing = Equal
+ (Just (IfaceFamInst fam1 tys1))
+ `eqIfTc_fam` (Just (IfaceFamInst fam2 tys2)) =
fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
- _ `eqIfTc_fam` _ = NotEqual
+ _ `eqIfTc_fam` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
- IfaceConDecls(..), IfaceIdInfo(..) )
-import IfaceEnv ( newGlobalBinder )
+ IfaceConDecls(..), IfaceFamInst(..),
+ IfaceIdInfo(..) )
+import IfaceEnv ( newGlobalBinder, lookupIfaceTc )
import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..),
Deprecs(..), Dependencies(..),
emptyModIface, EpsStats(..), GenAvailInfo(..),
; return (concat thingss)
}
-loadDecl :: Bool -- Don't load pragmas into the decl pool
+loadDecl :: Bool -- Don't load pragmas into the decl pool
-> Module
-> (Version, IfaceDecl)
- -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
- -- TyThings are forkM'd thunks
+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
+ -- TyThings are forkM'd thunks
loadDecl ignore_prags mod (_version, decl)
= do { -- Populate the name cache with final versions of all
-- the names associated with the decl
main_name <- mk_new_bndr mod Nothing (ifName decl)
- ; implicit_names <- mapM (mk_new_bndr mod (Just main_name))
+ ; parent_name <- case ifFamily decl of -- make family the parent
+ Just famTyCon -> lookupIfaceTc famTyCon
+ _ -> return main_name
+ ; implicit_names <- mapM (mk_new_bndr mod (Just parent_name))
(ifaceDeclSubBndrs decl)
-- Typecheck the thing, lazily
(importedSrcLoc (showSDoc (ppr (moduleName mod))))
-- ToDo: qualify with the package name if necessary
+ ifFamily (IfaceData {
+ ifFamInst = Just (IfaceFamInst {ifFamInstTyCon = famTyCon})})
+ = Just famTyCon
+ ifFamily _ = Nothing
+
doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
discardDeclPrags :: IfaceDecl -> IfaceDecl
import InstEnv ( Instance(..) )
import TcRnMonad
import HscTypes ( ModIface(..), ModDetails(..),
- ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..),
+ ModGuts(..), HscEnv(..), hscEPS, Dependencies(..),
+ FixItem(..),
ModSummary(..), msHiFilePath,
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
- typeEnvElts,
+ typeEnvElts, mkIfaceFamInstsCache,
GenAvailInfo(..), availName,
ExternalPackageState(..),
Usage(..), IsBootInterface,
-- is identical, so no need to write it
mkIface hsc_env maybe_old_iface
- (ModGuts{ mg_module = this_mod,
- mg_boot = is_boot,
- mg_usages = usages,
- mg_deps = deps,
- mg_rdr_env = rdr_env,
- mg_fix_env = fix_env,
- mg_deprecs = src_deprecs })
- (ModDetails{ md_insts = insts,
- md_rules = rules,
- md_types = type_env,
- md_exports = exports })
+ (ModGuts{ mg_module = this_mod,
+ mg_boot = is_boot,
+ mg_usages = usages,
+ mg_deps = deps,
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_deprecs = src_deprecs })
+ (ModDetails{ md_insts = insts,
+ md_fam_insts= _fam_inst, -- we use the type_env instead
+ md_rules = rules,
+ md_types = type_env,
+ md_exports = exports })
-- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has
-- Don't put implicit Ids and class tycons in the interface file
-- Nor wired-in things; the compiler knows about them anyhow
- ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
- ; deprecs = mkIfaceDeprec src_deprecs
- ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules
- ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
+ ; fixities = [ (occ,fix)
+ | FixItem occ fix _ <- nameEnvElts fix_env]
+ ; deprecs = mkIfaceDeprec src_deprecs
+ ; iface_rules = map (coreRuleToIfaceRule
+ ext_nm_lhs ext_nm_rhs) rules
+ ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
+ ; iface_fam_insts = extractIfFamInsts decls
; intermediate_iface = ModIface {
mi_module = this_mod,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
mi_insts = sortLe le_inst iface_insts,
+ mi_fam_insts= mkIfaceFamInstsCache decls,
mi_rules = sortLe le_rule iface_rules,
mi_fixities = fixities,
mi_deprecs = deprecs,
; return (new_iface, no_change_at_all) }
where
- r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
- i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
+ r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
+ i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
dflags = hsc_dflags hsc_env
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
famInstToIface Nothing = Nothing
famInstToIface (Just (famTyCon, instTys)) =
- Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys)
+ Just $ IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext famTyCon
+ , ifFamInstTys = map (toIfaceType ext) instTys
+ }
tyThingToIfaceDecl ext (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
- emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
+ emptyModDetails, lookupTypeEnv, lookupType,
+ typeEnvIds, mkDetailsFamInstCache )
import InstEnv ( Instance(..), mkImportedInstance )
+import FamInstEnv ( extractFamInsts )
import CoreSyn
import CoreUtils ( exprType, dataConRepFSInstPat )
import CoreUnfold
; exports <- ifaceExportNames (mi_exports iface)
-- Finished
- ; return (ModDetails { md_types = type_env,
- md_insts = dfuns,
- md_rules = rules,
- md_exports = exports })
+ ; return $ ModDetails { md_types = type_env
+ , md_insts = dfuns
+ , md_fam_insts = mkDetailsFamInstCache type_env
+ , md_rules = rules
+ , md_exports = exports
+ }
}
\end{code}
; famInst <-
case mb_family of
Nothing -> return Nothing
- Just (fam, tys) ->
+ Just (IfaceFamInst { ifFamInstTyCon = fam
+ , ifFamInstTys = tys
+ }) ->
do { famTyCon <- tcIfaceTyCon fam
; insttys <- mapM tcIfaceType tys
; return $ Just (famTyCon, insttys)
; case maybe_tc_result of {
Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
Just tc_result -> do
- let md = ModDetails {
- md_types = tcg_type_env tc_result,
- md_exports = tcg_exports tc_result,
- md_insts = tcg_insts tc_result,
- md_rules = [panic "no rules"] }
+ let type_env = tcg_type_env tc_result
+ md = ModDetails {
+ md_types = type_env,
+ md_exports = tcg_exports tc_result,
+ md_insts = tcg_insts tc_result,
+ md_fam_insts = mkDetailsFamInstCache type_env,
+ md_rules = [panic "no rules"] }
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
rnInfo = do decl <- tcg_rn_decls tc_result
icPrintUnqual, mkPrintUnqualified,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
- emptyIfaceDepCache,
+ emptyIfaceDepCache, mkIfaceFamInstsCache, mkDetailsFamInstCache,
Deprecs(..), IfaceDeprecs,
TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
+ typeEnvDataCons,
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
extendOccEnv )
import Module
import InstEnv ( InstEnv, Instance )
+import FamInstEnv ( FamInst, extractFamInsts )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import Id ( Id )
import Class ( Class, classSelIds, classATs, classTyCon )
import TyCon ( TyCon, tyConSelIds, tyConDataCons, isNewTyCon,
newTyConCo_maybe, tyConFamilyCoercion_maybe )
-import DataCon ( dataConImplicitIds )
+import DataCon ( DataCon, dataConImplicitIds )
import PrelNames ( gHC_PRIM )
import Packages ( PackageId )
import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) )
import BasicTypes ( Version, initialVersion, IPName,
Fixity, defaultFixity, DeprecTxt )
-import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) )
+import IfaceSyn ( IfaceInst, IfaceFamInst, IfaceRule,
+ IfaceDecl(ifName), extractIfFamInsts )
import FiniteMap ( FiniteMap )
import CoreSyn ( CoreRule )
-- HomeModInfo, but that leads to more plumbing.
-- Instance declarations and rules
- mi_insts :: [IfaceInst], -- Sorted
- mi_rules :: [IfaceRule], -- Sorted
- mi_rule_vers :: !Version, -- Version number for rules and instances combined
+ mi_insts :: [IfaceInst], -- Sorted
+ mi_fam_insts :: [(IfaceFamInst, IfaceDecl)], -- Cached value
+ -- ...from mi_decls (not in iface file)
+ mi_rules :: [IfaceRule], -- Sorted
+ mi_rule_vers :: !Version, -- Version number for rules and
+ -- instances combined
-- Cached environments for easy lookup
-- These are computed (lazily) from other fields
-- seeing if we are up to date wrt the old interface
}
+-- Pre-compute the set of type instances from the declaration list.
+mkIfaceFamInstsCache :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)]
+mkIfaceFamInstsCache = extractIfFamInsts
+
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
= ModDetails {
-- The next three fields are created by the typechecker
- md_exports :: NameSet,
- md_types :: !TypeEnv,
- md_insts :: ![Instance], -- Dfun-ids for the instances in this module
- md_rules :: ![CoreRule] -- Domain may include Ids from other modules
+ md_exports :: NameSet,
+ md_types :: !TypeEnv,
+ md_fam_insts :: ![FamInst], -- Cached value extracted from md_types
+ md_insts :: ![Instance], -- Dfun-ids for the instances in this
+ -- module
+
+ md_rules :: ![CoreRule] -- Domain may include Ids from other
+ -- modules
+
}
emptyModDetails = ModDetails { md_types = emptyTypeEnv,
md_exports = emptyNameSet,
- md_insts = [],
- md_rules = [] }
+ md_insts = [],
+ md_rules = [],
+ md_fam_insts = [] }
+
+-- Pre-compute the set of type instances from the type environment.
+mkDetailsFamInstCache :: TypeEnv -> [FamInst]
+mkDetailsFamInstCache = extractFamInsts . typeEnvElts
-- A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
mi_exp_vers = initialVersion,
mi_fixities = [],
mi_deprecs = NoDeprecs,
- mi_insts = [],
- mi_rules = [],
- mi_decls = [],
- mi_globals = Nothing,
+ mi_insts = [],
+ mi_fam_insts = [],
+ mi_rules = [],
+ mi_decls = [],
+ mi_globals = Nothing,
mi_rule_vers = initialVersion,
mi_dep_fn = emptyIfaceDepCache,
mi_fix_fn = emptyIfaceFixCache,
\begin{code}
type TypeEnv = NameEnv TyThing
-emptyTypeEnv :: TypeEnv
-typeEnvElts :: TypeEnv -> [TyThing]
-typeEnvClasses :: TypeEnv -> [Class]
-typeEnvTyCons :: TypeEnv -> [TyCon]
-typeEnvIds :: TypeEnv -> [Id]
-lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
-
-emptyTypeEnv = emptyNameEnv
-typeEnvElts env = nameEnvElts env
-typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
-typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
-typeEnvIds env = [id | AnId id <- typeEnvElts env]
+emptyTypeEnv :: TypeEnv
+typeEnvElts :: TypeEnv -> [TyThing]
+typeEnvClasses :: TypeEnv -> [Class]
+typeEnvTyCons :: TypeEnv -> [TyCon]
+typeEnvIds :: TypeEnv -> [Id]
+typeEnvDataCons :: TypeEnv -> [DataCon]
+lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
+
+emptyTypeEnv = emptyNameEnv
+typeEnvElts env = nameEnvElts env
+typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
+typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
+typeEnvIds env = [id | AnId id <- typeEnvElts env]
+typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env]
mkTypeEnv :: [TyThing] -> TypeEnv
mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
this_pkg = thisPackage dflags
\end{code}
-
\begin{code}
tyThingTyCon (ATyCon tc) = tc
tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other)
import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons,
extendTypeEnvWithIds, lookupTypeEnv,
- ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..)
+ mkDetailsFamInstCache,
+ ModGuts(..), TyThing(..), ModDetails(..),
+ Dependencies(..)
)
import Maybes ( orElse, mapCatMaybes )
import ErrUtils ( showPass, dumpIfSet_core )
; type_env' = extendTypeEnvWithIds type_env2
(map instanceDFunId ispecs')
}
- ; return (ModDetails { md_types = type_env',
- md_insts = ispecs',
- md_rules = [],
- md_exports = exports })
+ ; return (ModDetails { md_types = type_env',
+ md_insts = ispecs',
+ md_fam_insts = mkDetailsFamInstCache type_env',
+ md_rules = [],
+ md_exports = exports })
}
where
ModDetails { md_types = tidy_type_env,
md_rules = tidy_rules,
md_insts = tidy_ispecs,
+ md_fam_insts = mkDetailsFamInstCache
+ tidy_type_env,
md_exports = exports })
}
\begin{code}
module RnEnv (
- newTopSrcBinder,
+ newTopSrcBinder, lookupFamInstDeclBndr,
lookupLocatedBndrRn, lookupBndrRn,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn,
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
+-- Looking up family names in type instances is a subtle affair. The family
+-- may be imported, in which case we need to lookup the occurence of a global
+-- name. Alternatively, the family may be in the same binding group (and in
+-- fact in a declaration processed later), and we need to create a new top
+-- source binder.
+--
+-- So, also this is strictly speaking an occurence, we cannot raise an error
+-- message yet for instances without a family declaration. This will happen
+-- during renaming the type instance declaration in RnSource.rnTyClDecl.
+--
+lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name
+lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name)
+ | not (isSrcRdrName rdr_name)
+ = lookupImportedName rdr_name
+
+ | otherwise
+ = -- First look up the name in the normal environment.
+ lookupGreRn rdr_name `thenM` \ mb_gre ->
+ case mb_gre of {
+ Just gre -> returnM (gre_name gre) ;
+ Nothing -> newTopSrcBinder mod Nothing lrdr_name }
+
--------------------------------------------------
-- Occurrences
--------------------------------------------------
for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls]
new_tc tc_decl
+ | isIdxTyDecl (unLoc tc_decl)
+ = do { main_name <- lookupFamInstDeclBndr mod main_rdr
+ ; sub_names <-
+ mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs
+ ; return sub_names } -- main_name is not declared here!
+ | otherwise
= do { main_name <- newTopSrcBinder mod Nothing main_rdr
- ; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs
- ; if isIdxTyDecl (unLoc tc_decl) -- index type definitions
- then return ( sub_names) -- are usage occurences
- else return (main_name : sub_names) }
- where
- (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
+ ; sub_names <-
+ mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs
+ ; return (main_name : sub_names) }
+ where
+ (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
inst_ats inst_decl
= mappM new_tc (instDeclATs (unLoc inst_decl))
reportDeprecations (hsc_dflags hsc_env) tcg_env ;
-- Process the export list
- rn_exports <- rnExports export_ies ;
+ rn_exports <- rnExports export_ies;
let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
- exports <- mkExportNameSet (isJust maybe_mod) (liftM2' (,) rn_exports export_ies) ;
+ exports <- mkExportNameSet (isJust maybe_mod)
+ (liftM2' (,) rn_exports export_ies) ;
-- Check whether the entire module is deprecated
-- This happens only once per module
projects / ghc-hetmet.git / commitdiff