From: Ian Lynagh <igloo@earth.li>
Date: Thu, 3 Jul 2008 19:25:40 +0000 (+0000)
Subject: Fix trac #2307: conflicting functional dependencies
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=37cc35d23202c9846e68e4c0a279fa75273f6f1c

Fix trac #2307: conflicting functional dependencies
We were accepting some instances that should have been rejected as
their fundep constraints were violated. e.g. we accepted
    class C a b c | b -> c
    instance C Bool Int Float
    instance C Char Int Double
---

diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 69533dc..7f9f050 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -494,16 +494,16 @@ badFunDeps cls_insts clas ins_tv_set ins_tys
 
 trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
 -- Computing rough_tcs for a particular fundep
---	class C a b c | a -> b where ... 
+--     class C a b c | a -> b where ...
 -- For each instance .... => C ta tb tc
--- we want to match only on the types ta, tc; so our
+-- we want to match only on the type ta; so our
 -- rough-match thing must similarly be filtered.  
--- Hence, we Nothing-ise the tb type right here
-trimRoughMatchTcs clas_tvs (_,rtvs) mb_tcs
+-- Hence, we Nothing-ise the tb and tc types right here
+trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs
   = zipWith select clas_tvs mb_tcs
   where
-    select clas_tv mb_tc | clas_tv `elem` rtvs = Nothing
-			 | otherwise	       = mb_tc
+    select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
+                         | otherwise           = Nothing
 \end{code}