Disallow standalone deriving declarations involving unboxed tuples or sums

There was an awful leak where GHC permitted standalone `deriving`
declarations to create instances for unboxed sum or tuple types. This
fortifies the checks that GHC performs to catch this scenario and give
an appropriate error message.

Fixes #11509.

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2557

GHC Trac Issues: #11509

4 files changed, 39 insertions, 2 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index c47b00b827..3fcc80d152 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -591,12 +591,21 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
               , text "class types:" <+> ppr cls_tys
               , text "type:" <+> ppr inst_ty ]
 
+       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+                              inst_ty deriv_strat msg)
+
        ; case tcSplitTyConApp_maybe inst_ty of
            Just (tc, tc_args)
               | className cls == typeableClassName
               -> do warnUselessTypeable
                     return []
 
+              | isUnboxedTupleTyCon tc
+              -> bale_out $ unboxedTyConErr "tuple"
+
+              | isUnboxedSumTyCon tc
+              -> bale_out $ unboxedTyConErr "sum"
+
               | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
               -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
                                         tvs cls cls_tys tc tc_args
@@ -604,8 +613,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
                     ; return [spec] }
 
            _  -> -- Complain about functions, primitive types, etc,
-                 failWithTc $ derivingThingErr False cls cls_tys
-                                               inst_ty deriv_strat $
+                 bale_out $
                  text "The last argument of the instance must be a data or newtype application"
         }
 
@@ -2672,3 +2680,7 @@ standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
 derivInstCtxt :: PredType -> MsgDoc
 derivInstCtxt pred
   = text "When deriving the instance for" <+> parens (ppr pred)
+
+unboxedTyConErr :: String -> MsgDoc
+unboxedTyConErr thing =
+  text "The last argument of the instance cannot be an unboxed" <+> text thing
diff --git a/testsuite/tests/deriving/should_fail/T12512.hs b/testsuite/tests/deriving/should_fail/T12512.hs
new file mode 100644
index 0000000000..87c3d668df
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T12512.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+module T12512 where
+
+import GHC.Exts
+
+class Wat1 (a :: TYPE 'UnboxedTupleRep)
+deriving instance Wat1 (# a, b #)
+
+class Wat2 (a :: TYPE 'UnboxedSumRep)
+deriving instance Wat2 (# a | b #)
diff --git a/testsuite/tests/deriving/should_fail/T12512.stderr b/testsuite/tests/deriving/should_fail/T12512.stderr
new file mode 100644
index 0000000000..48f0eae205
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T12512.stderr
@@ -0,0 +1,10 @@
+
+T12512.hs:11:1: error:
+    • Can't make a derived instance of ‘Wat1 (# a, b #)’:
+        The last argument of the instance cannot be an unboxed tuple
+    • In the stand-alone deriving instance for ‘Wat1 (# a, b #)’
+
+T12512.hs:14:1: error:
+    • Can't make a derived instance of ‘Wat2 (# a | b #)’:
+        The last argument of the instance cannot be an unboxed sum
+    • In the stand-alone deriving instance for ‘Wat2 (# a | b #)’
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index aebfa9e470..ce0cc0f155 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -65,3 +65,4 @@ test('T10598_fail4', normal, compile_fail, [''])
 test('T10598_fail5', normal, compile_fail, [''])
 test('T10598_fail6', normal, compile_fail, [''])
 test('T12163', normal, compile_fail, [''])
+test('T12512', omit_ways(['ghci']), compile_fail, [''])