[commit: ghc] ghc-8.0: Less scary arity mismatch error message when deriving (52c7430)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/52c743033ab0d969101ab4616bfce3ecf2e6e472/ghc

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

commit 52c743033ab0d969101ab4616bfce3ecf2e6e472
Author: mniip <mniip at mniip.com>
Date:   Sun Sep 4 13:23:03 2016 -0400

    Less scary arity mismatch error message when deriving
    
    Test Plan: Corrected a few tests to include the new message.
    
    Reviewers: goldfire, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: goldfire, thomie
    
    Differential Revision: https://phabricator.haskell.org/D2484
    
    GHC Trac Issues: #12546
    
    (cherry picked from commit 8d00175f4ba969ca5f4edf26b0e8593a79d4f508)


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

52c743033ab0d969101ab4616bfce3ecf2e6e472
 compiler/typecheck/TcDeriv.hs                          |  9 ++++++++-
 compiler/typecheck/TcHsType.hs                         | 17 ++++++++---------
 testsuite/tests/deriving/should_fail/T7959.stderr      |  2 +-
 testsuite/tests/deriving/should_fail/drvfail005.stderr |  4 +---
 testsuite/tests/deriving/should_fail/drvfail009.stderr |  4 +---
 5 files changed, 19 insertions(+), 17 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index d37762a..f4069b5 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -616,7 +616,7 @@ deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
 -- I.e. not standalone deriving
 deriveTyData tvs tc tc_args deriv_pred
   = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
-    do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
+    do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
                 <- tcExtendTyVarEnv tvs $
                    tcHsDeriv deriv_pred
                 -- Deriving preds may (now) mention
@@ -627,6 +627,9 @@ deriveTyData tvs tc tc_args deriv_pred
                 -- Typeable is special, because Typeable :: forall k. k -> Constraint
                 -- so the argument kind 'k' is not decomposable by splitKindFunTys
                 -- as is the case for all other derivable type classes
+        ; when (length cls_arg_kinds /= 1) $
+            failWithTc (nonUnaryErr deriv_pred)
+        ; let [cls_arg_kind] = cls_arg_kinds
         ; if className cls == typeableClassName
           then do warnUselessTypeable
                   return []
@@ -1295,6 +1298,10 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc
 classArgsErr :: Class -> [Type] -> SDoc
 classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
 
+nonUnaryErr :: LHsSigType Name -> SDoc
+nonUnaryErr ct = quotes (ppr ct)
+  <+> text "is not a unary constraint, as expected by a deriving clause"
+
 nonStdErr :: Class -> SDoc
 nonStdErr cls =
       quotes (ppr cls)
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 5373d1a..16a05e7 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -211,26 +211,25 @@ tc_hs_sig_type (HsIB { hsib_body = hs_ty
        ; return (mkSpecForAllTys tkvs ty) }
 
 -----------------
-tcHsDeriv :: LHsSigType Name -> TcM ([TyVar], Class, [Type], Kind)
+tcHsDeriv :: LHsSigType Name -> TcM ([TyVar], Class, [Type], [Kind])
 -- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
--- Returns the C, [ty1, ty2, and the kind of C's *next* argument
+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments
 -- E.g.    class C (a::*) (b::k->k)
 --         data T a b = ... deriving( C Int )
---    returns ([k], C, [k, Int],  k->k)
--- Also checks that (C ty1 ty2 arg) :: Constraint
--- if arg has a suitable kind
+--    returns ([k], C, [k, Int], [k->k])
 tcHsDeriv hs_ty
-  = do { arg_kind <- newMetaKindVar
+  = do { cls_kind <- newMetaKindVar
                     -- always safe to kind-generalize, because there
                     -- can be no covars in an outer scope
        ; ty <- checkNoErrs $
                  -- avoid redundant error report with "illegal deriving", below
-               tc_hs_sig_type hs_ty (mkFunTy arg_kind constraintKind)
+               tc_hs_sig_type hs_ty cls_kind
        ; ty <- kindGeneralizeType ty  -- also zonks
-       ; arg_kind <- zonkTcType arg_kind
+       ; cls_kind <- zonkTcType cls_kind
        ; let (tvs, pred) = splitForAllTys ty
+       ; let (args, _) = splitFunTys cls_kind
        ; case getClassPredTys_maybe pred of
-           Just (cls, tys) -> return (tvs, cls, tys, arg_kind)
+           Just (cls, tys) -> return (tvs, cls, tys, args)
            Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }
 
 tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt
diff --git a/testsuite/tests/deriving/should_fail/T7959.stderr b/testsuite/tests/deriving/should_fail/T7959.stderr
index 4756f79..254cfed 100644
--- a/testsuite/tests/deriving/should_fail/T7959.stderr
+++ b/testsuite/tests/deriving/should_fail/T7959.stderr
@@ -4,5 +4,5 @@ T7959.hs:5:1: error:
     • In the stand-alone deriving instance for ‘A’
 
 T7959.hs:6:17: error:
-    • Expected kind ‘k0 -> Constraint’, but ‘A’ has kind ‘Constraint’
+    • ‘A’ is not a unary constraint, as expected by a deriving clause
     • In the data declaration for ‘B’
diff --git a/testsuite/tests/deriving/should_fail/drvfail005.stderr b/testsuite/tests/deriving/should_fail/drvfail005.stderr
index 552b3b0..5f10652 100644
--- a/testsuite/tests/deriving/should_fail/drvfail005.stderr
+++ b/testsuite/tests/deriving/should_fail/drvfail005.stderr
@@ -1,6 +1,4 @@
 
 drvfail005.hs:4:13: error:
-    • Expecting one fewer argument to ‘Show a’
-      Expected kind ‘k0 -> Constraint’,
-        but ‘Show a’ has kind ‘Constraint’
+    • ‘Show a’ is not a unary constraint, as expected by a deriving clause
     • In the data declaration for ‘Test’
diff --git a/testsuite/tests/deriving/should_fail/drvfail009.stderr b/testsuite/tests/deriving/should_fail/drvfail009.stderr
index 563bc5a..9c5f9ff 100644
--- a/testsuite/tests/deriving/should_fail/drvfail009.stderr
+++ b/testsuite/tests/deriving/should_fail/drvfail009.stderr
@@ -1,8 +1,6 @@
 
 drvfail009.hs:10:31: error:
-    Expecting one more argument to ‘C’
-    Expected kind ‘* -> Constraint’,
-      but ‘C’ has kind ‘* -> * -> Constraint’
+    ‘C’ is not a unary constraint, as expected by a deriving clause
     In the newtype declaration for ‘T1’
 
 drvfail009.hs:13:31: error: