Use addUsedDataCons more judiciously in TcDeriv (#17324)wip/T17324

If you derive an instance like this:

```hs
deriving <...> instance Foo C
```

And the data constructors for `C` aren't in scope, then
`doDerivInstErrorChecks1` throws an error. Moreover, it will
_only_ throw an error if `<...>` is either `stock` or `newtype`.
This is because the code that the `anyclass` or `via` strategies
would generate would not require the use of the data constructors
for `C`.

However, `doDerivInstErrorChecks1` has another purpose. If you
write this:

```hs
import M (C(MkC1, ..., MkCn))

deriving <...> instance Foo C
```

Then `doDerivInstErrorChecks1` will call `addUsedDataCons` on
`MkC1` through `MkCn` to ensure that `-Wunused-imports` does not
complain about them. However, `doDerivInstErrorChecks1` was doing
this for _every_ deriving strategy, which mean that if `<...>` were
`anyclass` or `via`, then the warning about `MkC1` through `MkCn`
being unused would be suppressed!

The fix is simple enough: only call `addUsedDataCons` when the
strategy is `stock` or `newtype`, just like the other code paths
in `doDerivInstErrorChecks1`.

Fixes #17324.

4 files changed, 60 insertions, 26 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 6688ed7cbc..9b4f31e6d1 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1972,34 +1972,46 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
     set_span_and_ctxt :: TcM a -> TcM a
     set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
 
+-- When processing a standalone deriving declaration, check that all of the
+-- constructors for the data type are in scope. For instance:
+--
+--   import M (T)
+--   deriving stock instance Eq T
+--
+-- This should be rejected, as the derived Eq instance would need to refer to
+-- the constructors for T, which are not in scope.
+--
+-- Note that the only strategies that require this check are `stock` and
+-- `newtype`. Neither `anyclass` nor `via` require it as the code that they
+-- generate does not require using data constructors.
 doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
 doDerivInstErrorChecks1 mechanism = do
-    DerivEnv { denv_tc      = tc
-             , denv_rep_tc  = rep_tc } <- ask
-    standalone <- isStandaloneDeriv
-    let anyclass_strategy = isDerivSpecAnyClass mechanism
-        via_strategy      = isDerivSpecVia mechanism
-        bale_out msg = do err <- derivingThingErrMechanism mechanism msg
-                          lift $ failWithTc err
-
-    -- For standalone deriving, check that all the data constructors are in
-    -- scope...
-    rdr_env <- lift getGlobalRdrEnv
-    let data_con_names = map dataConName (tyConDataCons rep_tc)
-        hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
-                           (isAbstractTyCon rep_tc ||
-                            any not_in_scope data_con_names)
-        not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)
-
-    lift $ addUsedDataCons rdr_env rep_tc
-
-    -- ...however, we don't perform this check if we're using DeriveAnyClass,
-    -- since it doesn't generate any code that requires use of a data
-    -- constructor. Nor do we perform this check with @deriving via@, as it
-    -- doesn't explicitly require the constructors to be in scope.
-    unless (anyclass_strategy || via_strategy
-            || not standalone || not hidden_data_cons) $
-           bale_out $ derivingHiddenErr tc
+  standalone <- isStandaloneDeriv
+  when standalone $ case mechanism of
+    DerivSpecStock{}    -> check
+    DerivSpecNewtype{}  -> check
+    DerivSpecAnyClass{} -> pure ()
+    DerivSpecVia{}      -> pure ()
+  where
+    check :: DerivM ()
+    check = do
+      DerivEnv { denv_tc = tc, denv_rep_tc = rep_tc } <- ask
+      let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                            lift $ failWithTc err
+
+      rdr_env <- lift getGlobalRdrEnv
+      let data_con_names = map dataConName (tyConDataCons rep_tc)
+          hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
+                             (isAbstractTyCon rep_tc ||
+                              any not_in_scope data_con_names)
+          not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)
+
+      -- Make sure to also mark the data constructors as used so that GHC won't
+      -- mistakenly emit -Wunused-imports warnings about them.
+      lift $ addUsedDataCons rdr_env rep_tc
+
+      unless (not hidden_data_cons) $
+        bale_out $ derivingHiddenErr tc
 
 doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
                         -> DerivSpecMechanism -> TcM ()
diff --git a/testsuite/tests/deriving/should_compile/T17324.hs b/testsuite/tests/deriving/should_compile/T17324.hs
new file mode 100644
index 0000000000..7373af8936
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T17324.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -Wunused-imports #-}
+module T17324 where
+
+import Data.Monoid (Sum(Sum), Product(Product), Dual(Dual))
+
+class C1 a
+deriving anyclass instance C1 (Sum a)
+
+class C2 a
+deriving anyclass instance C2 (Product a)
+
+class C3 a
+deriving via Dual a instance C3 (Dual a)
diff --git a/testsuite/tests/deriving/should_compile/T17324.stderr b/testsuite/tests/deriving/should_compile/T17324.stderr
new file mode 100644
index 0000000000..54e6534462
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T17324.stderr
@@ -0,0 +1,4 @@
+
+T17324.hs:8:1: warning: [-Wunused-imports (in -Wextra)]
+    The import of ‘Dual, Product, Sum’
+    from module ‘Data.Monoid’ is redundant
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index a12cf95c28..04fd02518f 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -118,3 +118,4 @@ test('T15637', normal, compile, [''])
 test('T15831', normal, compile, [''])
 test('T16179', normal, compile, [''])
 test('T16518', normal, compile, [''])
+test('T17324', normal, compile, [''])