X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=39eadfb681b61453db59be4dc4970b66f2d2b797;hb=9d458d01d2a75b1e452ba00c4e76f3c3d0bc5ba6;hp=8f60c8af446a791ebbd730ca46a11496fbab1972;hpb=7db1714bc461645af15c3a1bc2914149bdc20aa5;p=ghc-hetmet.git

diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs
index 8f60c8a..39eadfb 100644
--- a/ghc/compiler/iface/TcIface.lhs
+++ b/ghc/compiler/iface/TcIface.lhs
@@ -22,17 +22,16 @@ import BuildTyCl	( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
 import TcRnMonad
 import Type		( Kind, openTypeKind, liftedTypeKind, 
 			  unliftedTypeKind, mkArrowKind, splitTyConApp, 
-			  mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
+			  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 )
@@ -447,6 +446,13 @@ Then, if we are trying to resolve (C Int x), we need (a)
 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
@@ -468,7 +474,9 @@ 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
@@ -505,18 +513,25 @@ selectInsts pool@(Pool insts n_in n_out) cls tycons
     (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}
 
 %************************************************************************
@@ -572,7 +587,7 @@ selectRules (Pool rules n_in n_out) type_env
 	| 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