[commit: ghc] master: Make sure that polykinded Typeable is defaultable (Trac #8931) (791f4fa)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/791f4fa24dd6929ab2e55c9f8b870d8078337427/ghc

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

commit 791f4fa24dd6929ab2e55c9f8b870d8078337427
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Apr 1 14:34:11 2014 +0100

    Make sure that polykinded Typeable is defaultable (Trac #8931)


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

791f4fa24dd6929ab2e55c9f8b870d8078337427
 compiler/typecheck/TcSimplify.lhs |   14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index c4308f6..64ef3fe 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -16,7 +16,7 @@ import TcMType as TcM
 import TcType
 import TcSMonad as TcS
 import TcInteract
-import Kind     ( defaultKind_maybe )
+import Kind     ( isKind, defaultKind_maybe )
 import Inst
 import FunDeps  ( growThetaTyVars )
 import Type     ( classifyPredType, PredTree(..), getClassPredTys_maybe )
@@ -1249,16 +1249,22 @@ findDefaultableGroups
     -> Cts              -- Unsolved (wanted or derived)
     -> [[(Ct,Class,TcTyVar)]]
 findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
-  | null default_tys             = []
-  | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries)
+  | null default_tys = []
+  | otherwise        = defaultable_groups
   where
+    defaultable_groups = filter is_defaultable_group groups
+    groups             = equivClasses cmp_tv unaries
     unaries     :: [(Ct, Class, TcTyVar)]  -- (C tv) constraints
     non_unaries :: [Ct]             -- and *other* constraints
 
     (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds)
         -- Finds unary type-class constraints
+        -- But take account of polykinded classes like Typeable,
+        -- which may look like (Typeable * (a:*))   (Trac #8931)
     find_unary cc
-        | Just (cls,[ty]) <- getClassPredTys_maybe (ctPred cc)
+        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)
+        , Just (kinds, ty) <- snocView tys
+        , all isKind kinds
         , Just tv <- tcGetTyVar_maybe ty
         , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and
                           -- we definitely don't want to try to assign to those!