X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=58a391621d6b18aa775b4e1fcba9a5e1d2237598;hp=c9b3967c4ce7270cda8ac07c7de3d63ff4acd4a1;hb=5822cb8d13aa3c05d2b46b4510c13d94b902eb21;hpb=db14f9df7f2f62039af85ac75ac59a4e22d09787

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index c9b3967..58a3916 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -47,8 +47,6 @@ import Util
 import ListSetOps
 import Outputable
 import Bag
-
-import Monad (unless)
 \end{code}
 
 %************************************************************************
@@ -443,24 +441,29 @@ baleOut err = addErrTc err >> returnM (Nothing, Nothing)
 \end{code}
 
 Auxiliary lookup wrapper which requires that looked up family instances are
-not type instances.
+not type instances.  If called with a vanilla tycon, the old type application
+is simply returned.
 
 \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
+  | not (isOpenTyCon tycon)
+  = return (tycon, tys)
+  | otherwise
+  = do { maybeFamInst <- tcLookupFamInst tycon tys
+       ; case maybeFamInst of
+           Nothing                     -> famInstNotFound tycon tys False
+           Just famInst@(_, rep_tys)
+             | not variable_only_subst -> famInstNotFound tycon tys True
+             | otherwise               -> return famInst
+             where
+               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}
 
 
@@ -1165,6 +1168,11 @@ badDerivedPred pred
   = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
 	  ptext SLIT("type variables that are not data type parameters"),
 	  nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
-\end{code}
 
- 
+famInstNotFound tycon tys notExact
+  = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
+  where
+    msg = ptext $ if notExact
+		  then SLIT("No family instance exactly matching")
+		  else SLIT("More than one family instance for")
+\end{code}