From c8005e42f927869b41e47ac1da3be86362171569 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 8 Oct 2019 14:37:00 -0400 Subject: 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. --- compiler/typecheck/TcDeriv.hs | 64 +++++++++++++--------- testsuite/tests/deriving/should_compile/T17324.hs | 17 ++++++ .../tests/deriving/should_compile/T17324.stderr | 4 ++ testsuite/tests/deriving/should_compile/all.T | 1 + 4 files changed, 60 insertions(+), 26 deletions(-) create mode 100644 testsuite/tests/deriving/should_compile/T17324.hs create mode 100644 testsuite/tests/deriving/should_compile/T17324.stderr 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, ['']) -- cgit v1.2.1