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

compiler/typecheck/TcDeriv.hs

@@ -612,7 +612,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
@@ -623,6 +623,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 []
@@ -1305,6 +1308,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)

compiler/typecheck/TcHsType.hs

@@ -226,26 +226,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

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’

testsuite/tests/deriving/should_fail/drvfail005.stderr

 
 drvfail005.hs:4:13: error:
-    • Expecting one fewer arguments 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’

testsuite/tests/deriving/should_fail/drvfail009.stderr

 
 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: