X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=6934eb1d2f463259d45d209f86388b95c2b5f554;hb=ab241c5d6187a93acffc609bdbffdae30ff9b284;hp=f9be61f96d81b85695756e3a33f0df8b5a9c16b8;hpb=09d0e7d9ca9213c9c51f733dbda38cf8507dfa8d;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index f9be61f..6934eb1 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") 
+					    rep_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}
+
 
 %************************************************************************
 %*									*
@@ -578,7 +604,7 @@ std_class_via_iso clas	-- These standard classes can be derived for a newtype
 
 
 new_dfun_name clas tycon 	-- Just a simple wrapper
-  = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
+  = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
 	-- The type passed to newDFunName is only used to generate
 	-- a suitable string; hence the empty type arg list
 \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 
@@ -1122,4 +1148,4 @@ badDerivedPred pred
 	  nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
 \end{code}
 
- 
\ No newline at end of file
+