X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=4e1a0657972813ff97933a8eb3d0c018c48ae7eb;hb=923ee9d360ed15331ac6faf8a6b4aca334fc0cee;hp=98d7fcf24a9827f0722a246e909d5f31932eb87f;hpb=940524aec90652b5ef81789c9a453c57c0e42cc9;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 98d7fcf..4e1a065 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -47,6 +47,8 @@ import Util
 import ListSetOps
 import Outputable
 import Bag
+
+import Monad (unless)
 \end{code}
 
 %************************************************************************
@@ -395,11 +397,14 @@ mkEqnHelp orig tvs cls cls_tys tc_app
 	      full_tc_args = tc_args ++ mkTyVarTys extra_tvs
 	      full_tvs = tvs ++ extra_tvs
 		
-	; (rep_tc, rep_tc_args) <- tcLookupFamInst tycon full_tc_args
+	; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
 
 	; gla_exts <- doptM Opt_GlasgowExts
 	; overlap_flag <- getOverlapFlag
-	; if isDataTyCon tycon then
+
+          -- Be careful to test rep_tc here: in the case of families, we want
+          -- to check the instance tycon, not the family tycon
+	; if isDataTyCon rep_tc then
 		mkDataTypeEqn orig gla_exts full_tvs cls cls_tys 
 			      tycon full_tc_args rep_tc rep_tc_args
 	  else
@@ -412,6 +417,27 @@ mkEqnHelp orig tvs cls cls_tys tc_app
 baleOut err = addErrTc err >> returnM (Nothing, Nothing) 
 \end{code}
 
+Auxiliary lookup wrapper which requires that looked up family instances are
+not type instances.
+
+\begin{code}
+tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
+tcLookupFamInstExact tycon tys
+  = do { result@(rep_tycon, rep_tys) <- tcLookupFamInst tycon tys
+       ; let { tvs		      = map (Type.getTyVar 
+                                               "TcDeriv.tcLookupFamInstExact") 
+					    tys
+	     ; variable_only_subst = all Type.isTyVarTy rep_tys &&
+				     sizeVarSet (mkVarSet tvs) == length tvs
+					-- renaming may have no repetitions
+             }
+       ; unless variable_only_subst $
+           famInstNotFound tycon tys [result]
+       ; return result
+       }
+       
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -977,7 +1003,7 @@ genInst spec
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)
-        ; (tycon, _) <- tcLookupFamInst visible_tycon tyArgs
+        ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
 	; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
 
 	-- Bring the right type variables into