Suppress unused warnings for selectors for some derived classes

Although derived `Read`, `Show`, and `Generic` instances technically
don't //use// the record selectors of the data type for which an
instance is being derived, the derived code is affected by the
//presence// of record selectors. As a result, we should suppress
`-Wunused-binds` for those record selectors when deriving these classes.
This is accomplished by threading through more information from
`hasStockDeriving`.

Test Plan: make test TEST=T13919

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #13919

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

5 files changed, 110 insertions, 38 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 946ef69efc..9e92f18fce 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -237,7 +237,7 @@ tcDeriving deriv_infos deriv_decls
 
         ; dflags <- getDynFlags
 
-        ; let (_, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
+        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)
         ; loc <- getSrcSpanM
         ; let (binds, famInsts) = genAuxBinds dflags loc
                                     (unionManyBags deriv_stuff)
@@ -276,7 +276,7 @@ tcDeriving deriv_infos deriv_decls
 
         ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
                                           getGblEnv
-        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ catMaybes maybe_fvs)
+        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
         ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
   where
     ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
@@ -380,7 +380,7 @@ had written
      ...etc...
 
 So we want to signal a user of the data constructor 'MkP'.
-This is the reason behind the (Maybe Name) part of the return type
+This is the reason behind the [Name] part of the return type
 of genInst.
 
 Note [Staging of tcDeriving]
@@ -1523,15 +1523,15 @@ the renamer.  What a great hack!
 -- case of instances for indexed families.
 --
 genInst :: DerivSpec theta
-        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, Maybe Name)
+        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
 -- We must use continuation-returning style here to get the order in which we
 -- typecheck family instances and derived instances right.
 -- See Note [Staging of tcDeriving]
 genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
                  , ds_mechanism = mechanism, ds_tys = tys
                  , ds_cls = clas, ds_loc = loc })
-  = do (meth_binds, deriv_stuff) <- genDerivStuff mechanism loc clas
-                                      rep_tycon tys tvs
+  = do (meth_binds, deriv_stuff, unusedNames)
+         <- genDerivStuff mechanism loc clas rep_tycon tys tvs
        let mk_inst_info theta = do
              inst_spec <- newDerivClsInst theta spec
              doDerivInstErrorChecks2 clas inst_spec mechanism
@@ -1544,16 +1544,8 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
                                      , ib_pragmas = []
                                      , ib_extensions = extensions
                                      , ib_derived = True } }
-       return (mk_inst_info, deriv_stuff, unusedConName)
+       return (mk_inst_info, deriv_stuff, unusedNames)
   where
-    unusedConName :: Maybe Name
-    unusedConName
-      | isDerivSpecNewtype mechanism
-        -- See Note [Newtype deriving and unused constructors]
-      = Just $ getName $ head $ tyConDataCons rep_tycon
-      | otherwise
-      = Nothing
-
     extensions :: [LangExt.Extension]
     extensions
       | isDerivSpecNewtype mechanism
@@ -1611,12 +1603,13 @@ doDerivInstErrorChecks2 clas clas_inst mechanism
 
 genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
               -> TyCon -> [Type] -> [TyVar]
-              -> TcM (LHsBinds GhcPs, BagDerivStuff)
+              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
 genDerivStuff mechanism loc clas tycon inst_tys tyvars
   = case mechanism of
       -- See Note [Bindings for Generalised Newtype Deriving]
-      DerivSpecNewtype rhs_ty -> gen_Newtype_binds loc clas tyvars
-                                                   inst_tys rhs_ty
+      DerivSpecNewtype rhs_ty -> do
+        (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys rhs_ty
+        return (binds, faminsts, maybeToList unusedConName)
 
       -- Try a stock deriver
       DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys
@@ -1639,7 +1632,15 @@ genDerivStuff mechanism loc clas tycon inst_tys tyvars
                -- ...but we may need to generate binding for associated type
                -- family default instances.
                -- See Note [DeriveAnyClass and default family instances]
-               )
+               , [] )
+  where
+    unusedConName :: Maybe Name
+    unusedConName
+      | isDerivSpecNewtype mechanism
+        -- See Note [Newtype deriving and unused constructors]
+      = Just $ getName $ head $ tyConDataCons tycon
+      | otherwise
+      = Nothing
 
 {-
 Note [Bindings for Generalised Newtype Deriving]
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index 8991407831..09876afb70 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -105,13 +105,27 @@ instance Outputable theta => Outputable (DerivSpec theta) where
 
 -- What action to take in order to derive a class instance.
 -- See Note [Deriving strategies] in TcDeriv
--- NB: DerivSpecMechanism is purely local to this module
 data DerivSpecMechanism
   = DerivSpecStock   -- "Standard" classes
-      (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff))
+      (SrcSpan -> TyCon
+               -> [Type]
+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+      -- This function returns three things:
+      --
+      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
+      --    (e.g., @compare (T x) (T y) = compare x y@)
+      -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived
+      --    instance. As examples, derived 'Generic' instances require
+      --    associated type family instances, and derived 'Eq' and 'Ord'
+      --    instances require top-level @con2tag@ functions.
+      --    See Note [Auxiliary binders] in TcGenDeriv.
+      -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be
+      --    suppressed. This is used to suppress unused warnings for record
+      --    selectors when deriving 'Read', 'Show', or 'Generic'.
+      --    See Note [Deriving and unused record selectors].
 
   | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
-      Type -- ^ The newtype rep type
+      Type -- The newtype rep type
 
   | DerivSpecAnyClass -- -XDeriveAnyClass
 
@@ -236,25 +250,26 @@ is willing to support it. The canDeriveAnyClass function checks if this is the
 case.
 -}
 
-hasStockDeriving :: Class
-                   -> Maybe (SrcSpan
-                             -> TyCon
-                             -> [Type]
-                             -> TcM (LHsBinds GhcPs, BagDerivStuff))
+hasStockDeriving
+  :: Class -> Maybe (SrcSpan
+                     -> TyCon
+                     -> [Type]
+                     -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
 hasStockDeriving clas
   = assocMaybe gen_list (getUnique clas)
   where
-    gen_list :: [(Unique, SrcSpan
-                          -> TyCon
-                          -> [Type]
-                          -> TcM (LHsBinds GhcPs, BagDerivStuff))]
+    gen_list
+      :: [(Unique, SrcSpan
+                   -> TyCon
+                   -> [Type]
+                   -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
     gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)
                , (ordClassKey,         simpleM gen_Ord_binds)
                , (enumClassKey,        simpleM gen_Enum_binds)
                , (boundedClassKey,     simple gen_Bounded_binds)
                , (ixClassKey,          simpleM gen_Ix_binds)
-               , (showClassKey,        with_fix_env gen_Show_binds)
-               , (readClassKey,        with_fix_env gen_Read_binds)
+               , (showClassKey,        read_or_show gen_Show_binds)
+               , (readClassKey,        read_or_show gen_Read_binds)
                , (dataClassKey,        simpleM gen_Data_binds)
                , (functorClassKey,     simple gen_Functor_binds)
                , (foldableClassKey,    simple gen_Foldable_binds)
@@ -264,18 +279,57 @@ hasStockDeriving clas
                , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]
 
     simple gen_fn loc tc _
-      = return (gen_fn loc tc)
+      = let (binds, deriv_stuff) = gen_fn loc tc
+        in return (binds, deriv_stuff, [])
 
     simpleM gen_fn loc tc _
-      = gen_fn loc tc
+      = do { (binds, deriv_stuff) <- gen_fn loc tc
+           ; return (binds, deriv_stuff, []) }
 
-    with_fix_env gen_fn loc tc _
+    read_or_show gen_fn loc tc _
       = do { fix_env <- getDataConFixityFun tc
-           ; return (gen_fn fix_env loc tc) }
+           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+                 field_names          = all_field_names tc
+           ; return (binds, deriv_stuff, field_names) }
 
     generic gen_fn _ tc inst_tys
       = do { (binds, faminst) <- gen_fn tc inst_tys
-           ; return (binds, unitBag (DerivFamInst faminst)) }
+           ; let field_names = all_field_names tc
+           ; return (binds, unitBag (DerivFamInst faminst), field_names) }
+
+    -- See Note [Deriving and unused record selectors]
+    all_field_names = map flSelector . concatMap dataConFieldLabels
+                                     . tyConDataCons
+
+{-
+Note [Deriving and unused record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (see Trac #13919):
+
+  module Main (main) where
+
+  data Foo = MkFoo {bar :: String} deriving Show
+
+  main :: IO ()
+  main = print (Foo "hello")
+
+Strictly speaking, the record selector `bar` is unused in this module, since
+neither `main` nor the derived `Show` instance for `Foo` mention `bar`.
+However, the behavior of `main` is affected by the presence of `bar`, since
+it will print different output depending on whether `MkFoo` is defined using
+record selectors or not. Therefore, we do not to issue a
+"Defined but not used: ‘bar’" warning for this module, since removing `bar`
+changes the program's behavior. This is the reason behind the [Name] part of
+the return type of `hasStockDeriving`—it tracks all of the record selector
+`Name`s for which -Wunused-binds should be suppressed.
+
+Currently, the only three stock derived classes that require this are Read,
+Show, and Generic, as their derived code all depend on the record selectors
+of the derived data type's constructors.
+
+See also Note [Newtype deriving and unused constructors] in TcDeriv for
+another example of a similar trick.
+-}
 
 getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
 -- If the TyCon is locally defined, we want the local fixity env;
diff --git a/testsuite/tests/deriving/should_compile/T13919.hs b/testsuite/tests/deriving/should_compile/T13919.hs
new file mode 100644
index 0000000000..59138cab82
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T13919.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# OPTIONS_GHC -Wunused-binds #-}
+module T13919 () where
+
+import GHC.Generics
+
+data Foo1 = Foo1 {bar1 :: String} deriving Show
+data Foo2 = Foo2 {bar2 :: String} deriving Read
+data Foo3 = Foo3 {bar3 :: String} deriving Generic
+
+-- Only this one should emit a "Defined but not used" warning for its
+-- record selector
+data Foo4 = Foo4 {bar4 :: String} deriving Eq
diff --git a/testsuite/tests/deriving/should_compile/T13919.stderr b/testsuite/tests/deriving/should_compile/T13919.stderr
new file mode 100644
index 0000000000..e57fc77371
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T13919.stderr
@@ -0,0 +1,3 @@
+
+T13919.hs:13:19: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)]
+    Defined but not used: ‘bar4’
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index d1615ab647..7c7b29070b 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -92,3 +92,4 @@ test('T13758', normal, compile, [''])
 test('drv-empty-data', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques'])
 test('drv-phantom', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques'])
 test('T13813', normal, compile, [''])
+test('T13919', normal, compile, [''])