From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:49:53 +0000 (+0000) Subject: Import/export of data constructors in family instances X-Git-Tag: After_FC_branch_merge~9 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a835e9faf19400aa6b7999b6f64e60cb1c7737dd Import/export of data constructors in family instances Mon Sep 18 19:50:42 EDT 2006 Manuel M T Chakravarty * Import/export of data constructors in family instances Tue Sep 12 13:54:37 EDT 2006 Manuel M T Chakravarty * Import/export of data constructors in family instances - Data constructors of a data/newtype family F can be exported and imported by writing F(..) or F(ConName). - This appears the most natural from a user's persepctive - although, it has a slightly different flavour than similar import/exports items for closed data types. The data constructors denoted by F(..) vary in dependence on the visible data instances. - This has been non-trivial to achieve as RnNames derives its knowledge of what sub-binders an F(..) item exports/imports from the relation specified by Name.nameParent - ie, the constructors of a data/newtype instance need to have the family name (not the internal name of the representation tycon) as their parent. *** WARNING: This patched changes the iface format! *** *** Please re-compile from scratch! *** --- diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index e1a1aa1..89e6500 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -177,12 +177,13 @@ instance Binary ModIface where 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) @@ -976,6 +977,14 @@ instance Binary IfaceInst where 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 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index bf62095..a4942ba 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -17,10 +17,10 @@ module IfaceSyn ( 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, @@ -85,9 +85,8 @@ data IfaceDecl -- 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 @@ -155,6 +154,16 @@ data IfaceInst -- 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, @@ -283,9 +292,8 @@ pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec 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 @@ -342,6 +350,10 @@ instance Outputable IfaceInst where 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} @@ -554,10 +566,11 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) -- 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) &&& diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index ba72c25..710b68c 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -20,8 +20,9 @@ import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) 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(..), @@ -290,16 +291,19 @@ loadDecls ignore_prags ver_decls ; 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 @@ -335,6 +339,11 @@ loadDecl ignore_prags mod (_version, decl) (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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 2069f89..f1a0d57 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -202,10 +202,11 @@ import TysPrim ( alphaTyVars ) 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, @@ -266,17 +267,18 @@ mkIface :: HscEnv -- 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 @@ -294,10 +296,13 @@ mkIface hsc_env maybe_old_iface -- 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, @@ -306,6 +311,7 @@ mkIface hsc_env maybe_old_iface 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, @@ -339,8 +345,8 @@ mkIface hsc_env maybe_old_iface ; 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) @@ -1089,7 +1095,9 @@ tyThingToIfaceDecl ext (ATyCon tycon) 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 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 6c197cc..cb37580 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -35,8 +35,10 @@ import TyCon ( TyCon, tyConName, SynTyConRhs(..), 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 @@ -223,10 +225,12 @@ typecheckIface iface ; 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} @@ -372,7 +376,9 @@ tcIfaceDecl (IfaceData {ifName = occ_name, ; 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) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 9d77c4d..55d84b4 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -672,11 +672,13 @@ hscFileCheck hsc_env mod_summary = do { ; 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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e7df0ba..2c0fa6c 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -30,7 +30,7 @@ module HscTypes ( icPrintUnqual, mkPrintUnqualified, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - emptyIfaceDepCache, + emptyIfaceDepCache, mkIfaceFamInstsCache, mkDetailsFamInstCache, Deprecs(..), IfaceDeprecs, @@ -42,6 +42,7 @@ module HscTypes ( TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, + typeEnvDataCons, WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, @@ -77,6 +78,7 @@ import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, extendOccEnv ) import Module import InstEnv ( InstEnv, Instance ) +import FamInstEnv ( FamInst, extractFamInsts ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import Id ( Id ) @@ -85,7 +87,7 @@ import Type ( TyThing(..) ) 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 (..) ) @@ -93,7 +95,8 @@ import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) 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 ) @@ -407,9 +410,12 @@ data ModIface -- 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 @@ -422,20 +428,34 @@ data ModIface -- 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 @@ -539,10 +559,11 @@ emptyModIface mod 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, @@ -664,18 +685,20 @@ extendTypeEnvWithIds env ids \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 @@ -708,7 +731,6 @@ lookupType dflags hpt pte name this_pkg = thisPackage dflags \end{code} - \begin{code} tyThingTyCon (ATyCon tc) = tc tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 16df566..4e01fd3 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -46,7 +46,9 @@ import Module ( Module ) 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 ) @@ -135,10 +137,11 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod, ; 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 @@ -290,6 +293,8 @@ tidyProgram hsc_env ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_ispecs, + md_fam_insts = mkDetailsFamInstCache + tidy_type_env, md_exports = exports }) } diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 91b1269..b21c42d 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -5,7 +5,7 @@ \begin{code} module RnEnv ( - newTopSrcBinder, + newTopSrcBinder, lookupFamInstDeclBndr, lookupLocatedBndrRn, lookupBndrRn, lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, @@ -222,6 +222,28 @@ lookupInstDeclBndr cls_name rdr_name 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 -------------------------------------------------- diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 8f6d158..71890db 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -447,13 +447,18 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, 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)) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index ea29fb1..86061be 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -232,9 +232,10 @@ tcRnModule hsc_env hsc_src save_rn_syntax 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