[commit: ghc] master: Look inside tuple predicates when checking instance declaration contexts (4407614)

[git at git.haskell.org]

Repository : ssh://git at git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4407614cb19a65ddb2f9ede4778a0b47396f8ec9/ghc

>---------------------------------------------------------------

commit 4407614cb19a65ddb2f9ede4778a0b47396f8ec9
Author: unknown <simonpj at MSRC-4971295.europe.corp.microsoft.com>
Date:   Thu Sep 26 19:10:04 2013 +0100

    Look inside tuple predicates when checking instance declaration contexts
    
    This fixes Trac #8359


>---------------------------------------------------------------

4407614cb19a65ddb2f9ede4778a0b47396f8ec9
 compiler/typecheck/TcValidity.lhs |   26 ++++++++++++++++++--------
 1 file changed, 18 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 7d02866..963d67f 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -915,18 +915,28 @@ The underlying idea is that
 checkInstTermination :: [TcType] -> ThetaType -> TcM ()
 -- See Note [Paterson conditions]
 checkInstTermination tys theta
-  = mapM_ check theta
+  = check_preds theta
   where
    fvs  = fvTypes tys
    size = sizeTypes tys
+
+   check_preds :: [PredType] -> TcM ()
+   check_preds preds = mapM_ check preds
+
+   check :: PredType -> TcM ()
    check pred 
-      | not (null bad_tvs)
-      = addErrTc (predUndecErr pred (nomoreMsg bad_tvs) $$ parens undecidableMsg)
-      | sizePred pred >= size
-      = addErrTc (predUndecErr pred smallerMsg $$ parens undecidableMsg)
-      | otherwise
-      = return ()
-      where
+     = case classifyPredType pred of
+         TuplePred preds -> check_preds preds  -- Look inside tuple predicates; Trac #8359
+         EqPred {}       -> return ()          -- You can't get from equalities
+                                               -- to class predicates, so this is safe
+         _other      -- ClassPred, IrredPred
+           | not (null bad_tvs)
+           -> addErrTc (predUndecErr pred (nomoreMsg bad_tvs) $$ parens undecidableMsg)
+           | sizePred pred >= size
+           -> addErrTc (predUndecErr pred smallerMsg $$ parens undecidableMsg)
+           | otherwise
+           -> return ()
+     where
         bad_tvs = filterOut isKindVar (fvType pred \\ fvs)
              -- Rightly or wrongly, we only check for
              -- excessive occurrences of *type* variables.