# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.103 2000/10/30 11:18:14 sewardj Exp $
+# $Id: Makefile,v 1.104 2000/10/31 08:08:38 simonpj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
#-----------------------------------------------------------------------------
# Linking
-SRC_LD_OPTS += -no-link-chk -ldl
+SRC_LD_OPTS += -no-link-chk
+# REMOVED SLPJ
+# -ldl
ifneq "$(GhcWithHscBuiltViaC)" "YES"
ifeq "$(GhcReportCompiles)" "YES"
toRdrName, hashName,
isUserExportedName,
- nameSrcLoc, isLocallyDefinedName, isDllName,
+ nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
isTyVarName,
-- Class NamedThing and overloaded friends
NamedThing(..),
- getSrcLoc, isLocallyDefined, getOccString, toRdrName
+ getSrcLoc, isLocallyDefined, getOccString, toRdrName,
+ isFrom, isLocalOrFrom
) where
#include "HsVersions.h"
\end{code}
\begin{code}
-isLocallyDefinedName :: Name -> Bool
+nameIsLocallyDefined :: Name -> Bool
+nameIsFrom :: Module -> Name -> Bool
+nameIsLocalOrFrom :: Module -> Name -> Bool
isUserExportedName :: Name -> Bool
isLocalName :: Name -> Bool -- Not globals
isGlobalName :: Name -> Bool
isLocalName name = not (isGlobalName name)
-isLocallyDefinedName name = isLocalName name
+nameIsLocallyDefined name = isLocalName name
+
+nameIsLocalOrFrom from (Name {n_sort = Global mod}) = mod == from
+nameIsLocalOrFrom from other = True
+
+nameIsFrom from (Name {n_sort = Global mod}) = mod == from
+nameIsFrom from other = pprPanic "nameIsFrom" (ppr other)
-- Global names are by definition those that are visible
-- outside the module, *as seen by the linker*. Externally visible
--- does not mean visible at the source level (that's isExported).
+-- does not mean visible at the source level (that's isUserExported).
isExternallyVisibleName name = isGlobalName name
+-- Constructors, selectors and suchlike Globals, and are all exported
+-- Other Local things may or may not be exported
isUserExportedName (Name { n_sort = Exported }) = True
+isUserExportedName (Name { n_sort = Global _ }) = True
isUserExportedName other = False
isSystemName (Name {n_sort = System}) = True
isDllName :: Name -> Bool
-- Does this name refer to something in a different DLL?
isDllName nm = not opt_Static &&
- not (isLocallyDefinedName nm) && -- isLocallyDefinedName test needed 'cos
+ not (nameIsLocallyDefined nm) && -- isLocallyDefinedName test needed 'cos
not (isModuleInThisPackage (nameModule nm)) -- nameModule won't work on local names
isLocallyDefined :: NamedThing a => a -> Bool
getOccString :: NamedThing a => a -> String
toRdrName :: NamedThing a => a -> RdrName
+isFrom :: NamedThing a => Module -> a -> Bool
+isLocalOrFrom :: NamedThing a => Module -> a -> Bool
getSrcLoc = nameSrcLoc . getName
-isLocallyDefined = isLocallyDefinedName . getName
+isLocallyDefined = nameIsLocallyDefined . getName
getOccString = occNameString . getOccName
toRdrName = ifaceNameRdrName . getName
+isFrom mod x = nameIsFrom mod (getName x)
+isLocalOrFrom mod x = nameIsLocalOrFrom mod ( getName x)
\end{code}
\begin{code}
ModDetails(..), ModIface(..),
HomeSymbolTable, PackageTypeEnv,
HomeIfaceTable, PackageIfaceTable, emptyIfaceTable,
- lookupTable, lookupTableByModName,
+ lookupIface, lookupIfaceByModName,
emptyModIface,
IfaceDecls(..),
import RdrName ( RdrNameEnv, emptyRdrEnv )
import Name ( Name, NameEnv, NamedThing,
emptyNameEnv, extendNameEnv,
- lookupNameEnv, emptyNameEnv, getName, nameModule,
- nameSrcLoc, nameEnvElts )
+ lookupNameEnv, emptyNameEnv, nameEnvElts,
+ isLocallyDefined, getName, nameModule,
+ nameSrcLoc )
import NameSet ( NameSet )
import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
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}
lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing
lookupType hst pte name
- = case lookupModuleEnv hst (nameModule name) of
+ = 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}
-- NB: 'Nothing' means that even the usages havn't changed, so there's no
-- need to write a new interface file. But even if the usages have
-- changed, the module version may not have.
- --
- -- The IO in the type is solely for debug output
- -- In particular, dumping a record of what has changed
completeIface maybe_old_iface new_iface mod_details
= addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
where
, vcat (map pprExport (mi_exports iface))
, vcat (map pprUsage (mi_usages iface))
- , pprIfaceDecls (vers_decls version_info)
- (mi_fixities iface)
- (mi_decls iface)
-
+ , pprFixities (mi_fixities iface) (dcl_tycl decls)
+ , pprIfaceDecls (vers_decls version_info) decls
, pprDeprecs (mi_deprecs iface)
]
where
version_info = mi_version iface
+ decls = mi_decls iface
exp_vers = vers_exports version_info
rule_vers = vers_rules version_info
\end{code}
\begin{code}
-pprIfaceDecls version_map fixity_map decls
+pprIfaceDecls version_map decls
= vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
, vcat (map ppr_decl (dcl_tycl decls))
, pprRules (dcl_rules decls)
]
where
- ppr_decl d = (ppr_vers d <+> ppr d <> semi) $$ ppr_fixes d
+ ppr_decl d = ppr_vers d <+> ppr d <> semi
-- Print the version for the decl
ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
Nothing -> empty
Just v -> int v
-
- -- Print fixities relevant to the decl
- ppr_fixes d = vcat [ ppr fix <+> ppr n <> semi
- | (n,_) <- tyClDeclNames d,
- Just fix <- [lookupNameEnv fixity_map n]
- ]
\end{code}
\begin{code}
+pprFixities fixity_map decls
+ = hsep [ ppr fix <+> ppr n
+ | d <- decls,
+ (n,_) <- tyClDeclNames d,
+ Just fix <- [lookupNameEnv fixity_map n]] <> semi
+
pprRules [] = empty
pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
moduleNameUserString, moduleName,
mkModuleInThisPackage, mkModuleName, moduleEnvElts
)
-import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
+import Name ( Name, NamedThing(..), getSrcLoc,
+ nameIsLocalOrFrom,
nameOccName, nameModule,
mkNameEnv, nameEnvElts, extendNameEnv
)
VersionInfo(..), ImportVersion, IfaceDecls(..),
GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo,
Provenance(..), ImportReason(..), initialVersionInfo,
- Deprecations(..), lookupDeprec, lookupTable
+ Deprecations(..), lookupDeprec, lookupIface
)
import List ( partition, nub )
\end{code}
else
-- GENERATE THE VERSION/USAGE INFO
- mkImportInfo mod_name imports `thenRn` \ my_usages ->
+ mkImportInfo mod_name imports `thenRn` \ my_usages ->
- -- RETURN THE RENAMED MODULE
- getNameSupplyRn `thenRn` \ name_supply ->
- getIfacesRn `thenRn` \ ifaces ->
+ -- BUILD THE MODULE INTERFACE
let
-- We record fixities even for things that aren't exported,
-- so that we can change into the context of this moodule easily
| FixitySig name fixity loc <- nameEnvElts local_fixity_env
]
-
-- Sort the exports to make them easier to compare for versions
my_exports = groupAvails this_module export_avails
+ final_decls = rn_local_decls ++ rn_imp_decls
+ is_orphan = any (isOrphanDecl this_module) rn_local_decls
+
mod_iface = ModIface { mi_module = this_module,
mi_version = initialVersionInfo,
+ mi_usages = my_usages,
mi_boot = False,
- mi_orphan = any isOrphanDecl rn_local_decls,
+ mi_orphan = is_orphan,
mi_exports = my_exports,
mi_globals = gbl_env,
- mi_usages = my_usages,
mi_fixities = fixities,
mi_deprecs = my_deprecs,
mi_decls = panic "mi_decls"
}
-
- final_decls = rn_local_decls ++ rn_imp_decls
in
-- REPORT UNUSED NAMES, AND DEBUG DUMP
\end{code}
\begin{code}
-isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
- = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames (removeContext inst_ty)))
+isOrphanDecl this_mod (InstD (InstDecl inst_ty _ _ _ _))
+ = not (foldNameSet ((||) . nameIsLocalOrFrom this_mod) False
+ (extractHsTyNames (removeContext inst_ty)))
-- The 'removeContext' is because of
-- instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
-isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _))
+isOrphanDecl this_mod (RuleD (HsRule _ _ _ lhs _ _))
= check lhs
where
-- At the moment we just check for common LHS forms
-- Expand as necessary. Getting it wrong just means
-- more orphans than necessary
- check (HsVar v) = not (isLocallyDefined v)
+ check (HsVar v) = not (nameIsLocalOrFrom this_mod v)
check (HsApp f a) = check f && check a
check (HsLit _) = False
check (HsOverLit _) = False
check other = True -- Safe fall through
-isOrphanDecl other = False
+isOrphanDecl _ _ = False
\end{code}
= warnUnusedModules unused_imp_mods `thenRn_`
warnUnusedLocalBinds bad_locals `thenRn_`
warnUnusedImports bad_imp_names `thenRn_`
- printMinimalImports my_mod_iface minimal_imports `thenRn_`
- warnDeprecations my_mod_iface really_used_names `thenRn_`
+ printMinimalImports this_mod minimal_imports `thenRn_`
+ warnDeprecations this_mod my_deprecs really_used_names `thenRn_`
returnRn ()
where
+ this_mod = mi_module my_mod_iface
gbl_env = mi_globals my_mod_iface
+ my_deprecs = mi_deprecs my_mod_iface
-- Now, a use of C implies a use of T,
-- if C was brought into scope by T(..) or T(C)
module_unused mod = moduleName mod `elem` unused_imp_mods
-warnDeprecations my_mod_iface used_names
+warnDeprecations this_mod my_deprecs used_names
= doptRn Opt_WarnDeprecations `thenRn` \ warn_drs ->
if not warn_drs then returnRn () else
mapRn_ warnDeprec deprecs
where
- my_deprecs = mi_deprecs my_mod_iface
- lookup_deprec hit pit n
- | isLocallyDefined n = lookupDeprec my_deprecs n
- | otherwise = case lookupTable hit pit n of
- Just iface -> lookupDeprec (mi_deprecs iface) n
- Nothing -> pprPanic "warnDeprecations:" (ppr n)
+ lookup_deprec hit pit n
+ | nameIsLocalOrFrom this_mod n
+ = lookupDeprec my_deprecs n
+ | otherwise
+ = case lookupIface hit pit this_mod n of
+ Just iface -> lookupDeprec (mi_deprecs iface) n
+ Nothing -> pprPanic "warnDeprecations:" (ppr n)
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
-printMinimalImports my_mod_iface imps
+printMinimalImports this_mod imps
= doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal ->
if not dump_minimal then returnRn () else
}) `thenRn_`
returnRn ()
where
- filename = moduleNameUserString (moduleName (mi_module my_mod_iface))
- ++ ".imports"
+ filename = moduleNameUserString (moduleName this_mod) ++ ".imports"
ppr_mod_ie (mod_name, ies)
| mod_name == pRELUDE_Name
= empty
rnDump imp_decls local_decls
= doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
- doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
+ doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
getIfacesRn `thenRn` \ ifaces ->
ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)]
-- This is really only right for a one-shot compile
- decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
+ decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces)
-- Data, newtype, and class decls are in the decls_fm
-- under multiple names; the tycon/class, and each
-- constructor/class op too.
-- The 'True' selects just the 'main' decl
- not (isLocallyDefined (availName avail))
]
(cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read
]
where
groupFM :: FiniteMap FastString Avails
- -- Deliberatey use the FastString so we
+ -- Deliberately use the FastString so we
-- get a canonical ordering
groupFM = foldl add emptyFM avails
import HscTypes ( ModuleLocation(..),
ModIface(..), emptyModIface,
VersionInfo(..),
- lookupTableByModName,
+ lookupIfaceByModName,
ImportVersion, WhetherHasOrphans, IsBootInterface,
DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
import ParseIface ( parseIface, IfaceStuff(..) )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isLocallyDefined,
+ nameModule, isLocalName, nameIsLocalOrFrom,
NamedThing(..),
mkNameEnv, extendNameEnv
)
\begin{code}
loadHomeInterface :: SDoc -> Name -> RnM d ModIface
loadHomeInterface doc_str name
- = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
+ = ASSERT2( not (isLocalName name), ppr name <+> parens doc_str )
+ loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
loadOrphanModules :: [ModuleName] -> RnM d ()
loadOrphanModules mods
getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) ->
-- CHECK WHETHER WE HAVE IT ALREADY
- case lookupTableByModName hit pit mod_name of {
+ case lookupIfaceByModName hit pit mod_name of {
Just iface -> returnRn (iface, Nothing) ; -- Already loaded
Nothing ->
ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map
other -> mod_map
mod_map2 = delFromFM mod_map1 mod_name
- is_loaded m = maybeToBool (lookupTableByModName hit pit m)
+ is_loaded m = maybeToBool (lookupIfaceByModName hit pit m)
-- Now add info about this module to the PIT
has_orphans = pi_orphan iface
%* *
%*********************************************************
-This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
+@lookupFixityRn@ has to be in RnIfaces (or RnHiFiles) because
+it calls @loadHomeInterface@.
+
+lookupFixity is a bit strange.
+
+* Nested local fixity decls are put in the local fixity env, which we
+ find with getFixtyEnv
+
+* Imported fixities are found in the HIT or PIT
+
+* Top-level fixity decls in this module may be for Names that are
+ either Global (constructors, class operations)
+ or Local/Exported (everything else)
+ (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+ We put them all in the local fixity environment
\begin{code}
lookupFixityRn :: Name -> RnMS Fixity
lookupFixityRn name
- | isLocallyDefined name
- = getFixityEnv `thenRn` \ local_fix_env ->
- returnRn (lookupLocalFixity local_fix_env name)
+ = getModuleRn `thenRn` \ this_mod ->
+ if nameIsLocalOrFrom this_mod name
+ then -- It's defined in this module
+ getFixityEnv `thenRn` \ local_fix_env ->
+ returnRn (lookupLocalFixity local_fix_env name)
- | otherwise -- Imported
+ else -- It's imported
-- For imported names, we have to get their fixities by doing a loadHomeInterface,
-- and consulting the Ifaces that comes back from that, because the interface
-- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
-- right away (after all, it's possible that nothing from B will be used).
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
- = getHomeIfaceTableRn `thenRn` \ hit ->
- loadHomeInterface doc name `thenRn` \ iface ->
- returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
+ loadHomeInterface doc name `thenRn` \ iface ->
+ returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
+ doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
import Type ( namesOfType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isLocallyDefined, nameUnique,
+ nameModule, isLocalName, nameUnique,
NamedThing(..),
elemNameEnv
)
recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = (imp_mods, imp_names) })
avail
- = let
- new_slurped_names = addAvailToNameSet slurped_names avail
- new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names name)
- | otherwise = (extendModuleSet imp_mods mod, imp_names)
- where
- mod = nameModule name
- name = availName avail
- in
+ = ASSERT2( not (isLocalName (availName avail)), pprAvail avail )
ifaces { iSlurp = new_slurped_names, iVSlurp = new_vslurp }
+ where
+ main_name = availName avail
+ mod = nameModule main_name
+ new_slurped_names = addAvailToNameSet slurped_names avail
+ new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name)
+ | otherwise = (extendModuleSet imp_mods mod, imp_names)
recordLocalSlurps local_avails
= getIfacesRn `thenRn` \ ifaces ->
importDecl name
= -- Check if it was loaded before beginning this module
- if isLocallyDefined name then
+ if isLocalName name then
returnRn AlreadySlurped
else
checkAlreadyAvailable name `thenRn` \ done ->
returnRn AlreadySlurped
else
- -- Don't slurp in decls from this module's own interface file
- -- (Indeed, this shouldn't happen.)
- if isLocallyDefined name then
- addWarnRn (importDeclWarn name) `thenRn_`
- returnRn AlreadySlurped
- else
-
-- When we find a wired-in name we must load its home
-- module so that we find any instance decls lurking therein
if name `elemNameEnv` wiredInThingEnv then
returnRn outOfDate
else
- -- CHECK WHETHER WE HAVE AN OLD IFACE
-- Source code unchanged and no errors yet... carry on
- checkList [checkModUsage u | u <- mi_usages iface]
+ checkList [checkModUsage u | u <- mi_usages iface]
checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
checkList [] = returnRn upToDate
= vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name),
ptext SLIT("from module") <+> quotes (ppr (nameModule name))
]
-
-importDeclWarn name
- = sep [ptext SLIT(
- "Compiler tried to import decl from interface file with same name as module."),
- ptext SLIT(
- "(possible cause: module name clashes with interface file already in scope.)")
- ] $$
- hsep [ptext SLIT("name:"), quotes (ppr name)]
\end{code}
addListToRdrEnv, rdrEnvToList, rdrEnvElts
)
import Name ( Name, OccName, NamedThing(..), getSrcLoc,
- isLocallyDefinedName, nameOccName,
+ nameOccName,
decode, mkLocalName, mkKnownKeyGlobal,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
extendNameEnvList
import UniqSupply
import Outputable
import PrelNames ( mkUnboundName )
-import Maybes ( maybeToBool, seqMaybe )
+import Maybes ( maybeToBool )
import ErrUtils ( printErrorsAndWarnings )
infixr 9 `thenRn`, `thenRn_`
data SDown = SDown {
rn_mode :: RnMode,
- rn_genv :: GlobalRdrEnv, -- Global envt
+ rn_genv :: GlobalRdrEnv, -- Top level environment
rn_lenv :: LocalRdrEnv, -- Local name envt
-- Does *not* include global name envt; may shadow it
-- We still need the unsullied global name env so that
-- we can look up record field names
- rn_fixenv :: LocalFixityEnv -- Local fixities
+ rn_fixenv :: LocalFixityEnv -- Local fixities (for non-top-level
+ -- declarations)
-- The global fixities are held in the
- -- rn_ifaces field. Why? See the comments
+ -- HIT or PIT. Why? See the comments
-- with RnIfaces.lookupLocalFixity
}
is_done :: HomeSymbolTable -> PackageTypeEnv -> Name -> Bool
-- Returns True iff the name is in either symbol table
+-- The name is a Global, so it has a Module
is_done hst pte n = maybeToBool (lookupType hst pte n)
initRnMS rn_env fixity_env mode thing_inside rn_down g_down
+ -- The fixity_env appears in both the rn_fixenv field
+ -- and in the HIT. See comments with RnHiFiles.lookupFixityRn
= let
s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv,
rn_fixenv = fixity_env, rn_mode = mode }
initIfaceRnMS mod thing_inside
= initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $
setModuleRn mod thing_inside
-
\end{code}
@renameSourceCode@ is used to rename stuff ``out-of-line'';
getHomeIfaceTableRn down l_down = return (rn_hit down)
checkAlreadyAvailable :: Name -> RnM d Bool
+ -- Name is a Global name
checkAlreadyAvailable name down l_down = return (rn_done down name)
\end{code}
rnDecl (InstD inst)
= rnInstDecl inst `thenRn` \ new_inst ->
rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) ->
- returnRn (InstD new_inst, fvs `plusFV` instDeclFVs new_inst')
+ returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
rnDecl (RuleD rule)
| isIfaceRuleDecl rule
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, idType, idName )
-import Name ( Name, isLocallyDefined, NamedThing(..),
+import Module ( Module )
+import Name ( Name, NamedThing(..), isFrom,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
plusNameEnv, nameEnvElts )
import NameSet ( emptyNameSet )
and superclass dictionary.
\begin{code}
-mkImplicitClassBinds :: [Class] -> NF_TcM ([Id], TcMonoBinds)
-mkImplicitClassBinds classes
+mkImplicitClassBinds :: Module -> [Class] -> NF_TcM ([Id], TcMonoBinds)
+mkImplicitClassBinds this_mod classes
= returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
-- The selector binds are already in the selector Id's unfoldings
-- We don't return the data constructor etc from the class,
mk_implicit clas = (sel_ids, binds)
where
sel_ids = classSelIds clas
- binds | isLocallyDefined clas = idsToMonoBinds sel_ids
- | otherwise = EmptyMonoBinds
+ binds | isFrom this_mod clas = idsToMonoBinds sel_ids
+ | otherwise = EmptyMonoBinds
\end{code}
each local class decl.
\begin{code}
-tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds)
+tcClassDecls2 :: Module -> [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds)
-tcClassDecls2 decls
+tcClassDecls2 this_mod decls
= foldr combine
(returnNF_Tc (emptyLIE, EmptyMonoBinds))
[tcClassDecl2 cls_decl | TyClD cls_decl <- decls,
isClassDecl cls_decl,
- isLocallyDefined (tyClDeclName cls_decl)]
+ isFrom this_mod (tyClDeclName cls_decl)]
where
combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
tc2 `thenNF_Tc` \ (lie2, binds2) ->
import Class ( classKey, Class )
import ErrUtils ( dumpIfSet_dyn, Message )
import MkId ( mkDictFunId )
-import Id ( idType )
import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes )
import Module ( Module )
-import Name ( Name, isLocallyDefined, getSrcLoc )
+import Name ( Name, isFrom, getSrcLoc )
import RdrName ( RdrName )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, TyCon
)
-import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp,
- splitDFunTy, isUnboxedType
- )
+import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, isUnboxedType )
import Var ( TyVar )
import PrelNames
import Util ( zipWithEqual, sortLt, thenCmp )
-> Module -- name of module under scrutiny
-> InstEnv -- What we already know about instances
-> (Name -> Maybe Fixity) -- used in deriving Show and Read
- -> [TyCon] -- "local_tycons" ???
+ -> [TyCon] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
-tcDeriving prs mod inst_env_in get_fixity local_tycons
+tcDeriving prs mod inst_env_in get_fixity tycons
= recoverTc (returnTc ([], EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- makeDerivEqns mod local_tycons `thenTc` \ eqns ->
+ makeDerivEqns mod tycons `thenTc` \ eqns ->
if null eqns then
returnTc ([], EmptyBinds)
else
returnRn (rn_method_binds_s, rn_extra_binds)
)
- new_inst_infos = map gen_inst_info (new_dfuns `zip` rn_method_binds_s)
+ new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s
in
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
where
-- Make a Real dfun instead of the dummy one we have so far
- gen_inst_info :: (DFunId, RenamedMonoBinds) -> InstInfo
- gen_inst_info (dfun, binds)
- = InstInfo { iLocal = True,
- iClass = clas, iTyVars = tyvars,
- iTys = tys, iTheta = theta,
- iDFunId = dfun,
- iBinds = binds,
- iLoc = getSrcLoc dfun, iPrags = [] }
- where
- (tyvars, theta, clas, tys) = splitDFunTy (idType dfun)
+ gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
+ gen_inst_info dfun binds
+ = InstInfo { iLocal = True, iDFunId = dfun,
+ iBinds = binds, iPrags = [] }
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
\begin{code}
makeDerivEqns :: Module -> [TyCon] -> TcM [DerivEqn]
-makeDerivEqns this_mod local_tycons
+makeDerivEqns this_mod tycons
= let
- think_about_deriving = need_deriving local_tycons
+ think_about_deriving = need_deriving tycons
(derive_these, _) = removeDups cmp_deriv think_about_deriving
in
- if null local_tycons then
+ if null think_about_deriving then
returnTc [] -- Bale out now
else
mapTc mk_eqn derive_these `thenTc` \ maybe_eqns ->
-- find the tycons that have `deriving' clauses;
need_deriving tycons_to_consider
- = foldr (\ tycon acc -> [(clas,tycon) | clas <- tyConDerivings tycon] ++ acc)
- []
- tycons_to_consider
+ = [ (clas,tycon) | tycon <- tycons_to_consider,
+ isFrom this_mod tycon,
+ clas <- tyConDerivings tycon ]
------------------------------------------------------------------
cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> Ordering
-- names.)
gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds
gen_bind get_fixity dfun
- | not (isLocallyDefined tycon) = EmptyMonoBinds
| clas `hasKey` showClassKey = gen_Show_binds get_fixity tycon
| clas `hasKey` readClassKey = gen_Read_binds get_fixity tycon
| otherwise
-- Instance environment, and InstInfo type
tcGetInstEnv, tcSetInstEnv,
InstInfo(..), pprInstInfo,
- simpleInstInfoTy, simpleInstInfoTyCon, isLocalInst,
+ simpleInstInfoTy, simpleInstInfoTyCon,
-- Global environment
tcExtendGlobalEnv, tcExtendGlobalValEnv,
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
import VarSet
-import Type ( Type, ThetaType,
- tyVarsOfTypes,
+import Type ( Type,
+ tyVarsOfTypes, splitDFunTy,
splitForAllTys, splitRhoTy,
getDFunTyKey, splitTyConApp_maybe
)
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
nameOccName, nameModule, getSrcLoc, mkGlobalName,
- isLocallyDefined, nameModule_maybe,
+ isLocalName, nameModule_maybe,
NameEnv, lookupNameEnv, nameEnvElts,
extendNameEnvList, emptyNameEnv
)
tcTyVars = gtv_var
})}
where
- lookup name = lookupType hst pte name
+ lookup name | isLocalName name = Nothing
+ | otherwise = lookupType hst pte name
tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
\begin{code}
data InstInfo
= InstInfo {
- iClass :: Class, -- Class, k
- iTyVars :: [TyVar], -- Type variables, tvs
- iTys :: [Type], -- The types at which the class is being instantiated
- iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the
- -- instance declaration. It constrains (some of)
- -- the TyVars above
- iLocal :: Bool, -- True <=> it's defined in this module
+ iLocal :: Bool, -- True <=> it's defined in this module
iDFunId :: DFunId, -- The dfun id
iBinds :: RenamedMonoBinds, -- Bindings, b
- iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn
iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
}
nest 4 (ppr (iBinds info))]
simpleInstInfoTy :: InstInfo -> Type
-simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
+simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of
+ (_, _, _, [ty]) -> ty
simpleInstInfoTyCon :: InstInfo -> TyCon
-- Gets the type constructor for a simple instance declaration,
simpleInstInfoTyCon inst
= case splitTyConApp_maybe (simpleInstInfoTy inst) of
Just (tycon, _) -> tycon
-
-isLocalInst :: Module -> InstInfo -> Bool
-isLocalInst mod info = isLocalThing mod (iDFunId info)
\end{code}
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
- InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
+ InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
newDFunName, tcExtendTyVarEnv
)
import InstEnv ( InstEnv, classDataCon, extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
-import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
+import HscTypes ( HomeSymbolTable, DFunId,
ModDetails(..), PackageInstEnv, PersistentRenamerState
)
import MkId ( mkDictFunId )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
-import Name ( isLocallyDefined )
+import Name ( getSrcLoc )
import NameSet ( emptyNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint, pprPred )
import TyCon ( TyCon, isSynTyCon, tyConDerivings )
-import Type ( mkTyVarTys, splitDFunTy, isTyVarTy,
+import Type ( splitDFunTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy,
- splitAlgTyConApp_maybe,
+ splitAlgTyConApp_maybe, splitForAllTys,
unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
getClassTys_maybe
)
-import Subst ( mkTopTyVarSubst, substClasses, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
-- e) generic instances inst_env4
-- The result of (b) replaces the cached InstEnv in the PCS
let
- (local_inst_info, imported_inst_info)
- = partition (isLocalInst mod) (concat inst_infos)
+ (local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos)
imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId)
imported_inst_info
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
- tcDeriving prs mod inst_env4 get_fixity local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) ->
- addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
+ tcDeriving prs mod inst_env4 get_fixity tycons `thenTc` \ (deriv_inst_info, deriv_binds) ->
+ addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
returnTc (inst_env1,
final_inst_env,
-- Make the dfun id and return it
newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
- returnNF_Tc (True, mkDictFunId dfun_name clas tyvars inst_tys theta)
+ returnNF_Tc (True, dfun_name)
Just dfun_name -> -- An interface-file instance declaration
-- Make the dfun id
- returnNF_Tc (False, mkDictFunId dfun_name clas tyvars inst_tys theta)
- ) `thenNF_Tc` \ (is_local, dfun_id) ->
+ returnNF_Tc (False, dfun_name)
+ ) `thenNF_Tc` \ (is_local, dfun_name) ->
- returnTc [InstInfo { iLocal = is_local,
- iClass = clas, iTyVars = tyvars, iTys = inst_tys,
- iTheta = theta, iDFunId = dfun_id,
- iBinds = binds, iLoc = src_loc, iPrags = uprags }]
+ let
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
+ in
+ returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id,
+ iBinds = binds, iPrags = uprags }]
\end{code}
-- f {| x+y |} ... = ...
-- Then at this point we'll have an InstInfo for each
let
- bad_groups = [group | group <- equivClassesByUniq get_uniq inst_infos,
+ tc_inst_infos :: [(TyCon, InstInfo)]
+ tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
+
+ bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
length group > 1]
- get_uniq inst = getUnique (simpleInstInfoTyCon inst)
+ get_uniq (tc,_) = getUnique tc
in
mapTc (addErrTc . dupGenericInsts) bad_groups `thenTc_`
-- Check that there is an InstInfo for each generic type constructor
let
- missing = genericTyCons `minusList` map simpleInstInfoTyCon inst_infos
+ missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]
in
checkTc (null missing) (missingGenericInstances missing) `thenTc_`
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
in
- returnTc (InstInfo { iLocal = True,
- iClass = clas, iTyVars = tyvars, iTys = inst_tys,
- iTheta = inst_theta, iDFunId = dfun_id, iBinds = binds,
- iLoc = loc, iPrags = [] })
+ returnTc (InstInfo { iLocal = True, iDFunId = dfun_id,
+ iBinds = binds, iPrags = [] })
\end{code}
\begin{code}
tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
-tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys,
- iTheta = inst_decl_theta, iDFunId = dfun_id,
- iBinds = monobinds, iLoc = locn, iPrags = uprags })
- | not (isLocallyDefined dfun_id)
+tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id,
+ iBinds = monobinds, iPrags = uprags })
+ | not is_local
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
| otherwise
= -- Prime error recovery
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
- tcAddSrcLoc locn $
+ tcAddSrcLoc (getSrcLoc dfun_id) $
-- Instantiate the instance decl with tc-style type variables
tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
dm_ids = [dm_id | (_, DefMeth dm_id) <- op_items]
sel_names = [idName sel_id | (sel_id, _) <- op_items]
- -- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta
-
-- Instantiate the super-class context with inst_tys
sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
-- Find any definitions in monobinds that aren't from the class
bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
+
+ -- The type variable from the dict fun actually scope
+ -- over the bindings. They were gotten from
+ -- the original instance declaration
+ (inst_tyvars, _) = splitForAllTys (idType dfun_id)
in
-- Check that all the method bindings come from this class
mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
-- Create dictionary Ids from the specified instance contexts.
newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
- newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
-- Default-method Ids may be mentioned in synthesised RHSs
mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
- inst_decl_theta'
+ dfun_theta'
monobinds uprags True)
op_items
)) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
methods_lie
) `thenTc` \ (const_lie1, lie_binds1) ->
- -- Check that we *could* construct the superclass dictionaries,
- -- even though we are *actually* going to pass the superclass dicts in;
- -- the check ensures that the caller will never have
- --a problem building them.
- tcAddErrCtxt superClassCtxt (
- tcSimplifyAndCheck
- (ptext SLIT("instance declaration context"))
- inst_tyvars_set -- Local tyvars
- inst_decl_dicts -- The instance dictionaries available
- sc_dicts -- The superclass dicationaries reqd
- ) `thenTc` \ _ ->
- -- Ignore the result; we're only doing
- -- this to make sure it can be done.
-
-- Now do the simplification again, this time to get the
-- bindings; this time we use an enhanced "avails"
-- Ignore errors because they come from the *previous* tcSimplify
-dupGenericInsts inst_infos
+dupGenericInsts tc_inst_infos
= vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
- nest 4 (vcat (map (ppr . simpleInstInfoTy) inst_infos)),
+ nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
ptext SLIT("All the type patterns for a generic type constructor must be identical")
]
+ where
+ ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
instTypeErr clas tys msg
= sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
ppr inst_ty])
methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
-superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
\end{code}
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
PackageTypeEnv, DFunId, ModIface(..),
- TypeEnv, extendTypeEnvList, lookupTable,
+ TypeEnv, extendTypeEnvList, lookupIface,
TyThing(..), mkTypeEnv )
import List ( partition )
\end{code}
pit = pcs_PIT pcs
get_fixity :: Name -> Maybe Fixity
- get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface ->
+ get_fixity nm = lookupIface hit pit this_mod nm `thenMaybe` \ iface ->
lookupNameEnv (mi_fixities iface) nm
\end{code}
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
tcSetEnv env $
let
- classes = tcEnvClasses env
- tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
- local_tycons = [ tc | tc <- tycons,
- isLocallyDefined tc,
- not (isClassTyCon tc)
- ]
- -- For local_tycons, filter out the ones derived from classes
- -- Otherwise the latter show up in interface files
+ classes = tcEnvClasses env
+ tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
in
-- Typecheck the instance decls, includes deriving
tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
hst unf_env get_fixity this_mod
- local_tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
+ tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
tcSetInstEnv inst_env $
-- Default declarations
-- We don't create bindings for dictionary constructors;
-- they are always fully applied, and the bindings are just there
-- to support partial applications
- mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) ->
- mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
+ mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) ->
+ mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
-- Extend the global value environment with
-- (a) constructors
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
- tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
+ tcClassDecls2 this_mod decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) ->
-- Deal with constant or ambiguous InstIds. How could
ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
want_sig id | opt_PprStyle_Debug = True
- | otherwise = isLocallyDefined n &&
- isGlobalName n &&
- not (isSysOcc (nameOccName n))
- where
- n = idName id
+ | otherwise = isLocallyDefined id
ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
vcat (map ppr_gen_tycon (filter isLocallyDefined tcs)),
import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
import FieldLabel
import Var ( Id, TyVar )
-import Name ( Name, isLocallyDefined, NamedThing(..) )
+import Module ( Module )
+import Name ( Name, NamedThing(..), isFrom )
import Outputable
import TyCon ( TyCon, isSynTyCon, isNewTyCon,
tyConDataConsIfAvailable, tyConTyVars, tyConGenIds
%************************************************************************
\begin{code}
-mkImplicitDataBinds :: [TyCon] -> TcM ([Id], TcMonoBinds)
-mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds)
-mkImplicitDataBinds (tycon : tycons)
- | isSynTyCon tycon = mkImplicitDataBinds tycons
- | otherwise = mkImplicitDataBinds_one tycon `thenTc` \ (ids1, b1) ->
- mkImplicitDataBinds tycons `thenTc` \ (ids2, b2) ->
+mkImplicitDataBinds :: Module -> [TyCon] -> TcM ([Id], TcMonoBinds)
+mkImplicitDataBinds this_mod [] = returnTc ([], EmptyMonoBinds)
+mkImplicitDataBinds this_mod (tycon : tycons)
+ | isSynTyCon tycon = mkImplicitDataBinds this_mod tycons
+ | otherwise = mkImplicitDataBinds_one this_mod tycon `thenTc` \ (ids1, b1) ->
+ mkImplicitDataBinds this_mod tycons `thenTc` \ (ids2, b2) ->
returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
-mkImplicitDataBinds_one tycon
+mkImplicitDataBinds_one this_mod tycon
= mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
let
unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids
-- For the locally-defined things
-- we need to turn the unfoldings inside the selector Ids into bindings,
-- and build bindigns for the constructor wrappers
- binds | isLocallyDefined tycon = idsToMonoBinds unf_ids
- | otherwise = EmptyMonoBinds
+ binds | isFrom this_mod tycon = idsToMonoBinds unf_ids
+ | otherwise = EmptyMonoBinds
in
returnTc (all_ids, binds)
where
projects / ghc-hetmet.git / commitdiff