From 924a2362810d9fa27c5da212cb35fd3e357ab9d1 Mon Sep 17 00:00:00 2001
From: Gregory Gerasev <uhbif19@gmail.com>
Date: Fri, 30 Jun 2023 22:58:16 +0900
Subject: [PATCH] Better error for data deriving of type synonym/family. Closes
 #23522

---
 compiler/GHC/Tc/Errors/Types.hs                    |  6 +++++-
 compiler/GHC/Tc/Gen/HsType.hs                      | 13 +++++++++----
 testsuite/tests/deriving/should_fail/T23522.hs     |  5 +++++
 testsuite/tests/deriving/should_fail/T23522.stderr |  5 +++++
 testsuite/tests/deriving/should_fail/all.T         |  1 +
 5 files changed, 25 insertions(+), 5 deletions(-)
 create mode 100644 testsuite/tests/deriving/should_fail/T23522.hs
 create mode 100644 testsuite/tests/deriving/should_fail/T23522.stderr

diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index cbd737cc7a71..fc41719d8304 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1201,11 +1201,15 @@ data TcRnMessage where
   {-| TcRnIllegalClassInst is an error that occurs whenever a class instance is specified
       for a non-class.
 
+      This also includes derived instances. See the T23522 test case.
+
       Examples(s):
         type C1 a = (Show (a -> Bool))
         instance C1 Int where
 
-      Test cases: polykinds/T13267
+      Test cases:
+        polykinds/T13267
+        deriving/should_fail/T23522
   -}
   TcRnIllegalClassInst :: !(TyConFlavour TyCon) -> TcRnMessage
 
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index bbad885ac0ce..71d1c5952387 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -99,7 +99,6 @@ import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBin
 import GHC.Tc.Zonk.TcType
 
 import GHC.Core.Type
-import GHC.Core.Predicate
 import GHC.Core.TyCo.Rep
 import GHC.Core.TyCo.Ppr
 
@@ -639,9 +638,15 @@ tcHsDeriv hs_ty
   = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty
        ; let (tvs, pred)    = splitForAllTyCoVars ty
              (kind_args, _) = splitFunTys (typeKind pred)
-       ; case getClassPredTys_maybe pred of
-           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)
-           Nothing -> failWithTc $ TcRnIllegalDerivingItem hs_ty }
+      -- Checking that `pred` a is type class application
+       ; case splitTyConApp_maybe pred of
+          Just (tyCon, tyConArgs) ->
+            case tyConClass_maybe tyCon of
+              Just clas ->
+                return (tvs, clas, tyConArgs, map scaledThing kind_args)
+              Nothing -> failWithTc $ TcRnIllegalClassInst (tyConFlavour tyCon)
+          Nothing -> failWithTc $ TcRnIllegalDerivingItem hs_ty
+    }
 
 -- | Typecheck a deriving strategy. For most deriving strategies, this is a
 -- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.
diff --git a/testsuite/tests/deriving/should_fail/T23522.hs b/testsuite/tests/deriving/should_fail/T23522.hs
new file mode 100644
index 000000000000..1a5c4a29042b
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T23522.hs
@@ -0,0 +1,5 @@
+module T23522 where
+
+type F x = Show x
+
+data Proposition = Proposition deriving (F)
diff --git a/testsuite/tests/deriving/should_fail/T23522.stderr b/testsuite/tests/deriving/should_fail/T23522.stderr
new file mode 100644
index 000000000000..f5a9c9b7bee0
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T23522.stderr
@@ -0,0 +1,5 @@
+
+T23522.hs:5:42: [GHC-53946]
+     Illegal instance for a type synonym
+      A class instance must be for a class
+     In the data declaration for ‘Proposition’
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index d1c897e059cc..e0ef6d61749f 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -87,3 +87,4 @@ test('T21087b', [extra_files(['T21087b_aux.hs','T21087b_aux.hs-boot'])], multimo
 test('T21302', normal, compile_fail, [''])
 test('T21871', normal, compile_fail, [''])
 test('T22696b', normal, compile_fail, [''])
+test('T23522', normal, compile_fail, [''])
-- 
GitLab