\begin{code}
module TcIface (
tcImportDecl, typecheckIface,
- tcIfaceKind, loadImportedInsts, loadImportedRules,
+ loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
#include "HsVersions.h"
newIfaceName, newIfaceNames )
import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
import TcRnMonad
-import Type ( Kind, openTypeKind, liftedTypeKind,
- unliftedTypeKind, mkArrowKind, splitTyConApp,
- mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
+import Type ( liftedTypeKind, splitTyConApp,
+ mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
ModIface(..), ModDetails(..), InstPool, ModGuts,
TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
- DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
+ RulePool, Pool(..) )
import InstEnv ( extendInstEnv )
import CoreSyn
-import PprType ( pprClassPred )
import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
import CoreUtils ( exprType )
if we are trying to resolve (C x [y]), we need *both* (b) and (c),
even though T is not involved yet, so that we spot the overlap.
+
+NOTE: if you use an instance decl with NO type constructors
+ instance C a where ...
+and look up an Inst that only has type variables such as (C (n o))
+then GHC won't necessarily suck in the instances that overlap with this.
+
+
\begin{code}
loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
loadImportedInsts cls tys
-- Suck in the instances
; let { (inst_pool', iface_insts)
- = selectInsts (eps_insts eps) cls_gate tc_gates }
+ = WARN( null tc_gates, ptext SLIT("Interesting! No tycons in Inst:")
+ <+> pprClassPred cls tys )
+ selectInsts (eps_insts eps) cls_gate tc_gates }
-- Empty => finish up rapidly, without writing to eps
; if null iface_insts then
(insts', iface_insts)
= case lookupNameEnv insts cls of {
Nothing -> (insts, []) ;
- Just gated_insts ->
+ Just gated_insts ->
- case foldl choose ([],[]) gated_insts of {
+ case choose1 gated_insts of {
(_, []) -> (insts, []) ; -- None picked
(gated_insts', iface_insts') ->
(extendNameEnv insts cls gated_insts', iface_insts') }}
+ choose1 gated_insts
+ | null tycons -- Bizarre special case of C (a b); then there are no tycons
+ = ([], map snd gated_insts) -- Just grab all the instances, no real alternative
+ | otherwise -- Normal case
+ = foldl choose2 ([],[]) gated_insts
+
-- Reverses the gated decls, but that doesn't matter
- choose (gis, decls) (gates, decl)
- | any (`elem` tycons) gates = (gis, decl:decls)
- | otherwise = ((gates,decl) : gis, decls)
+ choose2 (gis, decls) (gates, decl)
+ | null gates -- Happens when we have 'instance T a where ...'
+ || any (`elem` tycons) gates = (gis, decl:decls)
+ | otherwise = ((gates,decl) : gis, decls)
\end{code}
%************************************************************************
| null gates' = (pool, rule:if_rules)
| otherwise = ((gates',rule) : pool, if_rules)
where
- gates' = filter (`elemNameEnv` type_env) gates
+ gates' = filter (not . (`elemNameEnv` type_env)) gates
tcIfaceRule :: IfaceRule -> IfL IdCoreRule
%************************************************************************
\begin{code}
-tcIfaceKind :: IfaceKind -> Kind
-tcIfaceKind IfaceOpenTypeKind = openTypeKind
-tcIfaceKind IfaceLiftedTypeKind = liftedTypeKind
-tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind
-tcIfaceKind (IfaceFunKind k1 k2) = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2)
-
------------------------------------------
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
where
(occs,kinds) = unzip bndrs
-mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind)
+mk_iface_tyvar name kind = mkTyVar name kind
\end{code}