summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2019-10-08 14:37:00 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-10-09 16:21:50 -0400
commitd584e3f08cfee6e28b70bf53c573d86e44f326f8 (patch)
tree289b0d0128e1cfae35321ddf1c9489d85ede4c7e
parent35cc5eff3d54bacf626ecf0b6e0a1d660cbd6ba9 (diff)
downloadhaskell-d584e3f08cfee6e28b70bf53c573d86e44f326f8.tar.gz
Use addUsedDataCons more judiciously in TcDeriv (#17324)
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.
-rw-r--r--compiler/typecheck/TcDeriv.hs64
-rw-r--r--testsuite/tests/deriving/should_compile/T17324.hs17
-rw-r--r--testsuite/tests/deriving/should_compile/T17324.stderr4
-rw-r--r--testsuite/tests/deriving/should_compile/all.T1
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, [''])