Commit a835e9fa authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Import/export of data constructors in family instances

Mon Sep 18 19:50:42 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Import/export of data constructors in family instances
  Tue Sep 12 13:54:37 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * 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!	    ***
parent 24bb49b7
......@@ -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
......
......@@ -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) &&&
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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 })
}
......
......@@ -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
--------------------------------------------------
......
......@@ -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))
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment