dataConSourceArity, dataConRepArity,
dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
- isExistentialDataCon,
+ isExistentialDataCon, classDataCon,
splitProductType_maybe, splitProductType,
)
import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
-import Class ( classTyCon )
+import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
\end{code}
+\begin{code}
+classDataCon :: Class -> DataCon
+classDataCon clas = case tyConDataCons (classTyCon clas) of
+ (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
+\end{code}
+
%************************************************************************
%* *
\subsection{Splitting products}
-- Environment
RdrNameEnv,
emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
- extendRdrEnv, rdrEnvToList, elemRdrEnv,
+ extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv,
-- Printing; instance Outputable RdrName
pprUnqualRdrName
rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)]
rdrEnvElts :: RdrNameEnv a -> [a]
elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool
+foldRdrEnv :: (RdrName -> a -> b -> b) -> b -> RdrNameEnv a -> b
emptyRdrEnv = emptyFM
lookupRdrEnv = lookupFM
extendRdrEnv = addToFM
rdrEnvToList = fmToList
elemRdrEnv = elemFM
+foldRdrEnv = foldFM
\end{code}
import NameSet ( NameSet )
import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
- lookupModuleEnv, lookupModuleEnvByName
+ lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv
)
+import InstEnv ( InstEnv, ClsInstEnv, DFunId )
import Rules ( RuleBase )
-import VarSet ( TyVarSet )
import Id ( Id )
import Class ( Class )
import TyCon ( TyCon )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( IdCoreRule )
-import Type ( Type )
import FiniteMap ( FiniteMap )
import Bag ( Bag )
import Maybes ( seqMaybe )
-import UniqFM ( UniqFM, emptyUFM )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Util ( thenCmp )
type HomeSymbolTable = SymbolTable -- Domain = modules in the home package
emptyIfaceTable :: IfaceTable
-emptyIfaceTable = emptyUFM
+emptyIfaceTable = emptyModuleEnv
\end{code}
Simple lookups in the symbol table.
lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of
Just (_, txt) -> Just txt
Nothing -> Nothing
-
-type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
-
-type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class
-type DFunId = Id
\end{code}
type IfaceInsts = Bag GatedDecl
type IfaceRules = Bag GatedDecl
-type GatedDecl = (NameSet, (Module, RdrNameHsDecl))
+type GatedDecl = ([Name], (Module, RdrNameHsDecl))
\end{code}
import RnEnv ( availName,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
- lookupOrigNames, lookupGlobalRn, newGlobalName
+ lookupOrigNames, lookupSrcName, newGlobalName
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
nameOccName, nameModule,
)
import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
-import RdrName ( elemRdrEnv )
+import RdrName ( elemRdrEnv, foldRdrEnv, isQual )
import OccName ( occNameFlavour )
import NameSet
import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
-- when compiling the prelude, locally-defined (), Bool, etc
-- override the implicit ones.
in
+ traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs))) `thenRn_`
slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls ->
-- EXIT IF ERRORS FOUND
\begin{code}
fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
fixitiesFromLocalDecls gbl_env decls
- = doptRn Opt_WarnUnusedBinds `thenRn` \ warn_unused ->
- foldlRn (getFixities warn_unused) emptyNameEnv decls `thenRn` \ env ->
- traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))
- `thenRn_`
+ = foldlRn getFixities emptyNameEnv decls `thenRn` \ env ->
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_`
returnRn env
where
- getFixities :: Bool -> LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
- getFixities warn_uu acc (FixD fix)
- = fix_decl warn_uu acc fix
+ getFixities :: LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
+ getFixities acc (FixD fix)
+ = fix_decl acc fix
- getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
- = foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs]
+ getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
+ = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
- getFixities warn_uu acc other_decl
+ getFixities acc other_decl
= returnRn acc
- fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc)
+ fix_decl acc sig@(FixitySig rdr_name fixity loc)
= -- Check for fixity decl for something not declared
pushSrcLocRn loc $
- lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
- case maybe_name of {
- Nothing -> checkRn (not warn_uu) (unusedFixityDecl rdr_name fixity) `thenRn_`
- returnRn acc ;
-
- Just name ->
+ lookupSrcName gbl_env rdr_name `thenRn` \ name ->
-- Check for duplicate fixity decl
- case lookupNameEnv acc name of {
- Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
- `thenRn_` returnRn acc ;
+ case lookupNameEnv acc name of
+ Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_`
+ returnRn acc ;
- Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
- }}
+ Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
\end{code}
returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
where
rn_deprec (Deprecation rdr_name txt loc)
- = pushSrcLocRn loc $
- lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name ->
- case maybe_name of
- Just n -> returnRn (Just (n,(n,txt)))
- Nothing -> returnRn Nothing
+ = pushSrcLocRn loc $
+ lookupSrcName gbl_env rdr_name `thenRn` \ name ->
+ returnRn (Just (name, (name,txt)))
\end{code}
warnUnusedImports bad_imp_names `thenRn_`
printMinimalImports this_mod minimal_imports `thenRn_`
warnDeprecations this_mod my_deprecs really_used_names `thenRn_`
+ traceRn (text "Used" <+> fsep (map ppr (nameSetToList used_names))) `thenRn_`
returnRn ()
where
other -> Nothing]
]
- defined_names, defined_and_used, defined_but_not_used :: [(Name,Provenance)]
- defined_names = concat (rdrEnvElts gbl_env)
+ -- Collect the defined names from the in-scope environment
+ -- Look for the qualified ones only, else get duplicates
+ defined_names :: [(Name,Provenance)]
+ defined_names = foldRdrEnv add [] gbl_env
+ add rdr_name ns acc | isQual rdr_name = ns ++ acc
+ | otherwise = acc
+
+ defined_and_used, defined_but_not_used :: [(Name,Provenance)]
(defined_and_used, defined_but_not_used) = partition used defined_names
- used (name,_) = not (name `elemNameSet` really_used_names)
+ used (name,_) = name `elemNameSet` really_used_names
-- Filter out the ones only defined implicitly
bad_locals :: [Name]
text "is deprecated:", nest 4 (ppr txt) ]
-unusedFixityDecl rdr_name fixity
- = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
-
dupFixityDecl rdr_name loc1 loc2
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
-- if there are many with the same occ name
-- There must *be* a binding
getModuleRn `thenRn` \ mod ->
- lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
+ getGlobalNameEnv `thenRn` \ global_env ->
+ lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
-- lookupSigOccRn is used for type signatures and pragmas
-- Is this valid?
-- class op names in class and instance decls
lookupGlobalOccRn rdr_name
+ = getModeRn `thenRn` \ mode ->
+ case mode of
+ SourceMode -> getGlobalNameEnv `thenRn` \ global_env ->
+ lookupSrcName global_env rdr_name
+
+ InterfaceMode -> lookupIfaceName rdr_name
+
+lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
+-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
+lookupSrcName global_env rdr_name
| isOrig rdr_name -- Can occur in source code too
= lookupOrigName rdr_name
| otherwise
- = getModeRn `thenRn` \ mode ->
- case mode of
- SourceMode -> lookupSrcGlobalOcc rdr_name
- InterfaceMode -> lookupIfaceUnqual rdr_name
-
-lookupSrcGlobalOcc rdr_name
- -- Lookup a source-code rdr-name; may be qualified or not
- = getGlobalNameEnv `thenRn` \ global_env ->
- case lookupRdrEnv global_env rdr_name of
+ = case lookupRdrEnv global_env rdr_name of
Just [(name,_)] -> returnRn name
Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_`
returnRn name
lookupIfaceName rdr_name
| isUnqual rdr_name = lookupIfaceUnqual rdr_name
| otherwise = lookupOrigName rdr_name
-
-lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
- -- Checks that there is exactly one
-lookupGlobalRn global_env rdr_name
- = case lookupRdrEnv global_env rdr_name of
- Just [(name,_)] -> returnRn (Just name)
- Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_`
- returnRn (Just name)
- Nothing -> returnRn Nothing
\end{code}
@lookupOrigName@ takes an RdrName representing an {\em original}
in
setModuleRn mod $
mapRn lookupIfaceName free_names `thenRn` \ gate_names ->
- returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
+ returnRn ((gate_names, (mod, InstD decl)) `consBag` insts)
-- In interface files, the instance decls now look like
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
= lookupIfaceName var `thenRn` \ var_name ->
- returnRn (unitNameSet var_name, (mod, RuleD decl))
+ returnRn ([var_name], (mod, RuleD decl))
-----------------------------------------------------
import RnEnv
import RnMonad
import Id ( idType )
+import DataCon ( classDataCon, dataConId )
import Type ( namesOfType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import Name ( Name {-instance NamedThing-}, nameOccName,
%*********************************************************
%* *
-\subsection{Instance declarations are handled specially}
-%* *
-%*********************************************************
-
-\begin{code}
-getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
-getImportedInstDecls gates
- = -- First, load any orphan-instance modules that aren't aready loaded
- -- Orphan-instance modules are recorded in the module dependecnies
- getIfacesRn `thenRn` \ ifaces ->
- let
- orphan_mods =
- [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
- in
- loadOrphanModules orphan_mods `thenRn_`
-
- -- Now we're ready to grab the instance declarations
- -- Find the un-gated ones and return them,
- -- removing them from the bag kept in Ifaces
- getIfacesRn `thenRn` \ ifaces ->
- let
- (decls, new_insts) = selectGated gates (iInsts ifaces)
- in
- setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_`
-
- traceRn (sep [text "getImportedInstDecls:",
- nest 4 (fsep (map ppr gate_list)),
- text "Slurped" <+> int (length decls) <+> text "instance declarations",
- nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_`
- returnRn decls
- where
- gate_list = nameSetToList gates
-
-ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
- = case inst_ty of
- HsForAllTy _ _ tau -> ppr tau
- other -> ppr inst_ty
-
-getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
-getImportedRules
- | opt_IgnoreIfacePragmas = returnRn []
- | otherwise
- = getIfacesRn `thenRn` \ ifaces ->
- let
- gates = iSlurp ifaces -- Anything at all that's been slurped
- rules = iRules ifaces
- (decls, new_rules) = selectGated gates rules
- in
- if null decls then
- returnRn []
- else
- setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
- traceRn (sep [text "getImportedRules:",
- text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
- returnRn decls
-
-selectGated gates decl_bag
- -- Select only those decls whose gates are *all* in 'gates'
-#ifdef DEBUG
- | opt_NoPruneDecls -- Just to try the effect of not gating at all
- = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all
-
- | otherwise
-#endif
- = foldrBag select ([], emptyBag) decl_bag
- where
- select (reqd, decl) (yes, no)
- | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no)
- | otherwise = (yes, (reqd,decl) `consBag` no)
-\end{code}
-
-
-%*********************************************************
-%* *
\subsection{Keeping track of what we've slurped, and version numbers}
%* *
%*********************************************************
go_inner (decls, fvs, gates) wanted_name
= importDecl wanted_name `thenRn` \ import_result ->
case import_result of
- AlreadySlurped -> returnRn (decls, fvs, gates)
- WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
- Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
+ AlreadySlurped -> returnRn (decls, fvs, gates)
+ InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing)
+ Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (TyClD new_decl : decls,
%* *
%*********************************************************
+The gating story
+~~~~~~~~~~~~~~~~~
+We want to avoid sucking in too many instance declarations.
+An instance decl is only useful if the types and classes mentioned in
+its 'head' are all available in the program being compiled. E.g.
+
+ instance (..) => C (T1 a) (T2 b) where ...
+
+is only useful if C, T1 and T2 are all available. So we keep
+instance decls that have been parsed from .hi files, but not yet
+slurped in, in a pool called the 'gated instance pool'.
+Each has its set of 'gates': {C, T1, T2} in the above example.
+
+THE GATING INVARIANT
+
+ *All* the instances whose gates are entirely in the stuff that's
+ already been through the type checker (i.e. are already in the
+ Persistent Type Environment or Home Symbol Table) have already been
+ slurped in, and are no longer in the gated instance pool.
+
+Hence, when we read a new module, we see what new gates we have,
+and let in any instance decls whose gates are
+ either in the new gates,
+ or in the HST/PTE
+
+An earlier optimisation: now infeasible
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we import a declaration like
\begin{verbatim}
data T = T1 Wibble | T2 Wobble
\end{verbatim}
-we don't want to treat @Wibble@ and @Wobble@ as gates
-{\em unless} @T1@, @T2@ respectively are mentioned by the user program.
-If only @T@ is mentioned
-we want only @T@ to be a gate;
-that way we don't suck in useless instance
-decls for (say) @Eq Wibble@, when they can't possibly be useful.
+we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless}
+@T1@, @T2@ respectively are mentioned by the user program. If only
+@T@ is mentioned we want only @T@ to be a gate; that way we don't suck
+in useless instance decls for (say) @Eq Wibble@, when they can't
+possibly be useful.
+
+BUT, I can't see how to do this and still maintain the GATING INVARIANT.
+So I've simply ditched the optimisation to get things working.
+
+
+
@getGates@ takes a newly imported (and renamed) decl, and the free
vars of the source program, and extracts from the decl the gate names.
\begin{code}
-getGates source_fvs (IfaceSig _ ty _ _)
+getGates :: FreeVars -- Things mentioned in the source program
+ -> RenamedHsDecl
+ -> FreeVars
+
+get_gates source_fvs decl = get_gates (\n -> True) decl
+ -- We'd use (\n -> n `elemNameSet` source_fvs)
+ -- if we were using the 'earlier optimisation above
+
+get_gates is_used (IfaceSig _ ty _ _)
= extractHsTyNames ty
-getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
+get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ )
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
`plusFV` maybe_double
where
get (ClassOpSig n _ ty _)
- | n `elemNameSet` source_fvs = extractHsTyNames ty
- | otherwise = emptyFVs
+ | is_used n = extractHsTyNames ty
+ | otherwise = emptyFVs
-- If we load any numeric class that doesn't have
-- Int as an instance, add Double to the gates.
| otherwise
= emptyFVs
-getGates source_fvs (TySynonym tycon tvs ty _)
- = delListFromNameSet (extractHsTyNames ty)
- (hsTyVarNames tvs)
+get_gates is_used (TySynonym tycon tvs ty _)
+ = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _)
+get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _)
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
where
get (ConDecl n _ tvs ctxt details _)
- | n `elemNameSet` source_fvs
+ | is_used n
-- If the constructor is method, get fvs from all its fields
= delListFromNameSet (get_details details `plusFV`
extractHsCtxtTyNames ctxt)
get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
- get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
- | otherwise = emptyFVs
+ get_field (fs,t) | any is_used fs = get_bang t
+ | otherwise = emptyFVs
get_bang bty = extractHsTyNames (getBangType bty)
\end{code}
rather than a declaration.
\begin{code}
-getWiredInGates :: Name -> FreeVars
-getWiredInGates name -- No classes are wired in
- = case lookupNameEnv wiredInThingEnv name of
- Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id))
-
- Just (ATyCon tc)
- | isSynTyCon tc
- -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
- where
- (tyvars,ty) = getSynTyConDefn tc
-
- other -> unitFV name
+getWiredInGates :: TyThing -> FreeVars
+-- The TyThing is one that we already have in our type environment, either
+-- a) because the TyCon or Id is wired in, or
+-- b) from a previous compile
+-- Either way, we might have instance decls in the (persistend) collection
+-- of parsed-but-not-slurped instance decls that should be slurped in.
+-- This might be the first module that mentions both the type and the class
+-- for that instance decl, even though both the type and the class were
+-- mentioned in other modules, and hence are in the type environment
+
+getWiredInGates (AnId the_id) = getWiredInGates_s (namesOfType (idType the_id))
+getWiredInGates (AClass cl) = namesOfType (idType (dataConId (classDataCon cl))) -- Cunning
+getWiredInGates (ATyCon tc)
+ | isSynTyCon tc = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
+ | otherwise = unitFV (getName tc)
+ where
+ (tyvars,ty) = getSynTyConDefn tc
getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
\end{code}
getInstDeclGates other = emptyFVs
\end{code}
+\begin{code}
+getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)]
+getImportedInstDecls gates
+ = -- First, load any orphan-instance modules that aren't aready loaded
+ -- Orphan-instance modules are recorded in the module dependecnies
+ getIfacesRn `thenRn` \ ifaces ->
+ let
+ orphan_mods =
+ [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
+ in
+ loadOrphanModules orphan_mods `thenRn_`
+
+ -- Now we're ready to grab the instance declarations
+ -- Find the un-gated ones and return them,
+ -- removing them from the bag kept in Ifaces
+ getIfacesRn `thenRn` \ ifaces ->
+ getTypeEnvRn `thenRn` \ lookup ->
+ let
+ (decls, new_insts) = selectGated gates lookup (iInsts ifaces)
+ in
+ setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_`
+
+ traceRn (sep [text "getImportedInstDecls:",
+ nest 4 (fsep (map ppr gate_list)),
+ text "Slurped" <+> int (length decls) <+> text "instance declarations",
+ nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_`
+ returnRn decls
+ where
+ gate_list = nameSetToList gates
+
+ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _))
+ = case inst_ty of
+ HsForAllTy _ _ tau -> ppr tau
+ other -> ppr inst_ty
+
+getImportedRules :: RnMG [(Module,RdrNameHsDecl)]
+getImportedRules
+ | opt_IgnoreIfacePragmas = returnRn []
+ | otherwise
+ = getIfacesRn `thenRn` \ ifaces ->
+ getTypeEnvRn `thenRn` \ lookup ->
+ let
+ gates = iSlurp ifaces -- Anything at all that's been slurped
+ rules = iRules ifaces
+ (decls, new_rules) = selectGated gates lookup rules
+ in
+ if null decls then
+ returnRn []
+ else
+ setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
+ traceRn (sep [text "getImportedRules:",
+ text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
+ returnRn decls
+
+selectGated gates lookup decl_bag
+ -- Select only those decls whose gates are *all* in 'gates'
+ -- or are in the range of lookup
+#ifdef DEBUG
+ | opt_NoPruneDecls -- Just to try the effect of not gating at all
+ = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all
+
+ | otherwise
+#endif
+ = foldrBag select ([], emptyBag) decl_bag
+ where
+ available n = n `elemNameSet` gates || maybeToBool (lookup n)
+ select (reqd, decl) (yes, no)
+ | all available reqd = (decl:yes, no)
+ | otherwise = (yes, (reqd,decl) `consBag` no)
+\end{code}
+
%*********************************************************
%* *
data ImportDeclResult
= AlreadySlurped
- | WiredIn
+ | InTypeEnv TyThing
| Deferred
| HereItIs (Module, RdrNameTyClDecl)
importDecl name
- = -- Check if it was loaded before beginning this module
+ = -- STEP 1: Check if it was loaded before beginning this module
if isLocalName name then
+ traceRn (text "Already (local)" <+> ppr name) `thenRn_`
returnRn AlreadySlurped
else
- checkAlreadyAvailable name `thenRn` \ done ->
- if done then
- returnRn AlreadySlurped
- else
- -- Check if we slurped it in while compiling this module
+ -- STEP 2: Check if it's already in the type environment
+ getTypeEnvRn `thenRn` \ lookup ->
+ case lookup name of {
+ Just ty_thing | name `elemNameEnv` wiredInThingEnv
+ -> -- When we find a wired-in name we must load its home
+ -- module so that we find any instance decls lurking therein
+ loadHomeInterface wi_doc name `thenRn_`
+ returnRn (InTypeEnv (getWiredInGates ty_thing))
+
+ | otherwise
+ -> returnRn (InTypeEnv ty_thing) ;
+
+ Nothing ->
+
+ -- STEP 3: Check if we've slurped it in while compiling this module
getIfacesRn `thenRn` \ ifaces ->
if name `elemNameSet` iSlurp ifaces then
returnRn AlreadySlurped
- else
+ 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
- loadHomeInterface doc name `thenRn_`
- returnRn WiredIn
+ -- STEP 4: OK, we have to slurp it in from an interface file
+ -- First load the interface file
+ traceRn nd_doc `thenRn_`
+ loadHomeInterface nd_doc name `thenRn_`
+ getIfacesRn `thenRn` \ ifaces ->
+
+ -- STEP 5: Get the declaration out
+ case lookupNameEnv (iDecls ifaces) name of
+ Just (avail,_,decl)
+ -> setIfacesRn (recordSlurp ifaces avail) `thenRn_`
+ returnRn (HereItIs decl)
- else getNonWiredInDecl name
+ Nothing
+ -> addErrRn (getDeclErr name) `thenRn_`
+ returnRn AlreadySlurped
+ }
where
- doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+ wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+ nd_doc = ptext SLIT("need decl for") <+> ppr name
-getNonWiredInDecl :: Name -> RnMG ImportDeclResult
-getNonWiredInDecl needed_name
- = traceRn doc_str `thenRn_`
- loadHomeInterface doc_str needed_name `thenRn_`
- getIfacesRn `thenRn` \ ifaces ->
- case lookupNameEnv (iDecls ifaces) needed_name of
{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS
Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _)))
tycon_name = availName avail
-}
- Just (avail,_,decl)
- -> setIfacesRn (recordSlurp ifaces avail) `thenRn_`
- returnRn (HereItIs decl)
-
- Nothing
- -> addErrRn (getDeclErr needed_name) `thenRn_`
- returnRn AlreadySlurped
- where
- doc_str = ptext SLIT("need decl for") <+> ppr needed_name
-
{- OMIT FOR NOW
getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)]
getDeferredDecls
WhetherHasOrphans, ImportVersion,
PersistentRenamerState(..), IsBootInterface, Avails,
DeclsMap, IfaceInsts, IfaceRules,
- HomeSymbolTable, PackageTypeEnv,
+ HomeSymbolTable, TyThing,
PersistentCompilerState(..), GlobalRdrEnv,
HomeIfaceTable, PackageIfaceTable,
RdrAvailInfo )
import UniqSupply
import Outputable
import PrelNames ( mkUnboundName )
-import Maybes ( maybeToBool )
import ErrUtils ( printErrorsAndWarnings )
infixr 9 `thenRn`, `thenRn_`
rn_dflags :: DynFlags,
rn_hit :: HomeIfaceTable,
- rn_done :: Name -> Bool, -- Tells what things (both in the
- -- home package and other packages)
- -- were already available (i.e. in
- -- the relevant SymbolTable) before
- -- compiling this module
+ rn_done :: Name -> Maybe TyThing, -- Tells what things (both in the
+ -- home package and other packages)
+ -- were already available (i.e. in
+ -- the relevant SymbolTable) before
+ -- compiling this module
+ -- The Name passed to rn_done is guaranteed to be a Global,
+ -- so it has a Module, so it can be looked up
rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),
rn_dflags = dflags,
rn_hit = hit,
- rn_done = is_done hst pte,
+ rn_done = lookupType hst pte,
rn_ns = names_var,
rn_errs = errs_var,
return (new_pcs, not (isEmptyBag errs), res)
-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
getHomeIfaceTableRn :: RnM d HomeIfaceTable
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)
+getTypeEnvRn :: RnM d (Name -> Maybe TyThing)
+getTypeEnvRn down l_down = return (rn_done down)
\end{code}
%================
returnRn (mod:mods, occs', avails')
exports_from_item warn_dups acc@(mods, occs, avails) ie
- | not (maybeToBool maybe_in_scope)
- = failWithRn acc (unknownNameErr (ieName ie))
+ = lookupSrcName global_name_env (ieName ie) `thenRn` \ name ->
- | not (null dup_names)
- = addNameClashErrRn rdr_name ((name,prov):dup_names) `thenRn_`
- returnRn acc
-
-#ifdef DEBUG
- -- I can't see why this should ever happen; if the thing is in scope
- -- at all it ought to have some availability
- | not (maybeToBool maybe_avail)
- = pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
- returnRn acc
-#endif
+ -- See what's available in the current environment
+ case lookupUFM entity_avail_env name of {
+ Nothing -> -- I can't see why this should ever happen; if the thing
+ -- is in scope at all it ought to have some availability
+ pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
+ returnRn acc ;
- | not enough_avail
- = failWithRn acc (exportItemErr ie)
+ Just avail ->
- | otherwise -- Phew! It's OK! Now to check the occurrence stuff!
+ -- Filter out the bits we want
+ case filterAvail ie avail of {
+ Nothing -> -- Not enough availability
+ failWithRn acc (exportItemErr ie) ;
+ Just export_avail ->
- = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_`
+ -- Phew! It's OK! Now to check the occurrence stuff!
+ warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_`
check_occs ie occs export_avail `thenRn` \ occs' ->
returnRn (mods, occs', addAvail avails export_avail)
+ }}
+
+
- where
- rdr_name = ieName ie
- maybe_in_scope = lookupFM global_name_env rdr_name
- Just ((name,prov):dup_names) = maybe_in_scope
- maybe_avail = lookupUFM entity_avail_env name
- Just avail = maybe_avail
- maybe_export_avail = filterAvail ie avail
- enough_avail = maybeToBool maybe_export_avail
- Just export_avail = maybe_export_avail
-
- ok_item (IEThingAll _) (AvailTC _ [n]) = False
- -- This occurs when you import T(..), but
- -- only export T abstractly. The single [n]
- -- in the AvailTC is the type or class itself
- ok_item _ _ = True
+ok_item (IEThingAll _) (AvailTC _ [n]) = False
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+ok_item _ _ = True
check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
check_occs ie occs avail
case maybe_ty2 of
Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2'
- Nothing | tv1_dominates_tv2
+ Nothing | update_tv2
-> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) )
tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_`
where
k1 = tyVarKind tv1
k2 = tyVarKind tv2
- tv1_dominates_tv2 = isSigTyVar tv1
+ update_tv2 = (k2 == openTypeKind) || (k1 /= openTypeKind && nicer_to_update_tv2)
+ -- Try to get rid of open type variables as soon as poss
+
+ nicer_to_update_tv2 = isSigTyVar tv1
-- Don't unify a signature type variable if poss
- || k2 == openTypeKind
- -- Try to get rid of open type variables as soon as poss
|| isSystemName (varName tv2)
-- Try to update sys-y type variables in preference to sig-y ones
\begin{code}
module InstEnv (
- -- Instance environment
- InstEnv, emptyInstEnv, extendInstEnv,
+ DFunId, ClsInstEnv, InstEnv,
+
+ emptyInstEnv, extendInstEnv,
lookupInstEnv, InstLookupResult(..),
- classInstEnv, classDataCon, simpleDFunClassTyCon
+ classInstEnv, simpleDFunClassTyCon
) where
#include "HsVersions.h"
-import HscTypes ( InstEnv, ClsInstEnv, DFunId )
import Class ( Class )
import Var ( Id )
-import VarSet ( unionVarSet, mkVarSet )
+import VarSet ( TyVarSet, unionVarSet, mkVarSet )
import VarEnv ( TyVarSubstEnv )
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
import Name ( getSrcLoc )
splitSigmaTy, splitDFunTy, tyVarsOfTypes
)
import PprType ( )
-import Class ( classTyCon )
import DataCon ( DataCon )
-import TyCon ( TyCon, tyConDataCons )
+import TyCon ( TyCon )
import Outputable
import Unify ( matchTys, unifyTyListsX )
-import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM )
+import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM )
import Id ( idType )
import ErrUtils ( Message )
import CmdLineOpts
\end{code}
-
-A tiny function which doesn't belong anywhere else.
-It makes a nasty mutual-recursion knot if you put it in Class.
+%************************************************************************
+%* *
+\subsection{The key types}
+%* *
+%************************************************************************
\begin{code}
+type DFunId = Id
+
+type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
+
+type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class
+
simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
simpleDFunClassTyCon dfun
= (clas, tycon)
(_,_,clas,[ty]) = splitDFunTy (idType dfun)
tycon = case splitTyConApp_maybe ty of
Just (tycon,_) -> tycon
-
-classDataCon :: Class -> DataCon
-classDataCon clas = case tyConDataCons (classTyCon clas) of
- (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
\end{code}
%************************************************************************
projects / ghc-hetmet.git / commitdiff