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

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 7a584cd..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}
 
 %************************************************************************
@@ -381,6 +383,8 @@ deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name,
 		-- The "deriv_pred" is a LHsType to take account of the fact that for
 		-- newtype deriving we allow deriving (forall a. C [a]).
 	; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app } }
+deriveTyData (deriv_pred, other_decl)
+  = panic "derivTyData"	-- Caller ensures that only TyData can happen
 
 ------------------------------------------------------------------
 mkEqnHelp orig tvs cls cls_tys tc_app
@@ -393,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
@@ -410,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}
+
 
 %************************************************************************
 %*									*
@@ -541,7 +569,7 @@ cond_isProduct (gla_exts, rep_tc)
   | isProductTyCon rep_tc = Nothing
   | otherwise	          = Just why
   where
-    why = (pprSourceTyCon rep_tc) <+> 
+    why = quotes (pprSourceTyCon rep_tc) <+> 
 	  ptext SLIT("has more than one constructor")
 
 cond_typeableOK :: Condition
@@ -576,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}
@@ -975,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 
@@ -1120,4 +1148,4 @@ badDerivedPred pred
 	  nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
 \end{code}
 
- 
\ No newline at end of file
+