Fix Trac #3221: renamer warnings for deriving clauses

This patch arranges to gather the variables used by 'deriving' clauses,
so that unused bindings are correctly reported.

3 files changed, 33 insertions, 23 deletions

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 442d4652d6..5a071ee2e2 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -216,6 +216,8 @@ rnTyClDecls tycl_decls = do  (decls', _fvs) <- rnList rnTyClDecl tycl_decls
 			     return decls'
 
 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
+-- This function could be defined lower down in the module hierarchy, 
+-- but there doesn't seem anywhere very logical to put it.
 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 
 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
@@ -659,10 +661,10 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 		    else lookupLocatedTopBndrRn tycon
 	; context' <- rnContext data_doc context
 	; typats' <- rnTyPats data_doc typatsMaybe
-	; (derivs', deriv_fvs) <- rn_derivs derivs
 	; condecls' <- rnConDecls (unLoc tycon') condecls
 		-- No need to check for duplicate constructor decls
 		-- since that is done by RnNames.extendGlobalRdrEnvRn
+	; (derivs', deriv_fvs) <- rn_derivs derivs
 	; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
 			   tcdLName = tycon', tcdTyVars = tyvars', 
 			   tcdTyPats = typats', tcdKindSig = Nothing, 
@@ -689,11 +691,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 		-- do not scope over the constructor signatures
 		-- 	data T a where { T1 :: forall b. b-> b }
 
-	; (derivs', deriv_fvs) <- rn_derivs derivs
 	; condecls' <- rnConDecls (unLoc tycon') condecls
 		-- No need to check for duplicate constructor decls
 		-- since that is done by RnNames.extendGlobalRdrEnvRn
 
+	; (derivs', deriv_fvs) <- rn_derivs derivs
 	; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], 
 			   tcdLName = tycon', tcdTyVars = tyvars', 
 			   tcdTyPats = typats', tcdKindSig = sig,
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 54ffe6b2da..545a342892 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -257,7 +257,12 @@ There may be a coercion needed which we get from the tycon for the newtype
 when the dict is constructed in TcInstDcls.tcInstDecl2
 
 
-
+Note [Unused constructors and deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #3221.  Consider
+   data T = T1 | T2 deriving( Show )
+Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
+both of them.  So we gather defs/uses from deriving just like anything else.
 
 %************************************************************************
 %*									*
@@ -270,10 +275,11 @@ tcDeriving  :: [LTyClDecl Name]  -- All type constructors
             -> [LInstDecl Name]  -- All instance declarations
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
 	    -> TcM ([InstInfo Name],	-- The generated "instance decls"
-		    HsValBinds Name)	-- Extra generated top-level bindings
+		    HsValBinds Name,	-- Extra generated top-level bindings
+                    DefUses)
 
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (return ([], emptyValBindsOut)) $
+  = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
     do	{   	-- Fish the "deriving"-related information out of the TcEnv
 		-- And make the necessary "equations".
 	  is_boot <- tcIsHsBoot
@@ -291,13 +297,13 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 		 -- Generate the generic to/from functions from each type declaration
 	; gen_binds <- mkGenericBinds is_boot
-	; (inst_info, rn_binds) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
+	; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
 
 	; dflags <- getDOpts
 	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
 	         (ddump_deriving inst_info rn_binds))
 
-	; return (inst_info, rn_binds) }
+	; return (inst_info, rn_binds, rn_dus) }
   where
     ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
     ddump_deriving inst_infos extra_binds
@@ -305,13 +311,13 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 renameDeriv :: Bool -> LHsBinds RdrName
 	    -> [(InstInfo RdrName, DerivAuxBinds)]
- 	    -> TcM ([InstInfo Name], HsValBinds Name)
+ 	    -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
 renameDeriv is_boot gen_binds insts
   | is_boot	-- If we are compiling a hs-boot file, don't generate any derived bindings
 		-- The inst-info bindings will all be empty, but it's easier to
 		-- just use rn_inst_info to change the type appropriately
-  = do	{ rn_inst_infos <- mapM rn_inst_info inst_infos	
-	; return (rn_inst_infos, emptyValBindsOut) }
+  = do	{ (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos	
+	; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
 
   | otherwise
   = discardWarnings $ 	 -- Discard warnings about unused bindings etc
@@ -330,9 +336,10 @@ renameDeriv is_boot gen_binds insts
 	; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs)
 
 	; bindLocalNames aux_names $ 
-    do	{ (rn_aux, _dus) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
-	; rn_inst_infos <- mapM rn_inst_info inst_infos
-	; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen) } }
+    do	{ (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs
+	; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
+	; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
+                  dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
 
   where
     (inst_infos, deriv_aux_binds) = unzip insts
@@ -344,15 +351,15 @@ renameDeriv is_boot gen_binds insts
 
 
     rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
-	= return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co })
+	= return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs)
 
     rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs })
 	= 	-- Bring the right type variables into 
 		-- scope (yuk), and rename the method binds
 	   ASSERT( null sigs )
 	   bindLocalNames (map Var.varName tyvars) $
- 	   do { (rn_binds, _fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
-	      ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }) }
+ 	   do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+	      ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }, fvs) }
 	where
 	  (tyvars,_,clas,_) = instanceHead inst
 	  clas_nm  	    = className clas
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 74879f39b0..2435395546 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -22,6 +22,7 @@ import FamInstEnv
 import TcDeriv
 import TcEnv
 import RnEnv	( lookupGlobalOccRn )
+import RnSource ( addTcgDUs )
 import TcHsType
 import TcUnify
 import TcSimplify
@@ -339,9 +340,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 --   a) local instance decls
                 --   b) generic instances
                 --   c) local family instance decls
-       ; addInsts local_info         $ do {
-       ; addInsts generic_inst_info  $ do {
-       ; addFamInsts at_idx_tycons   $ do {
+       ; addInsts local_info         $
+         addInsts generic_inst_info  $
+         addFamInsts at_idx_tycons   $ do {
 
                 -- (4) Compute instances from "deriving" clauses;
                 -- This stuff computes a context for the derived instance
@@ -351,13 +352,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 	 failIfErrsM		-- If the addInsts stuff gave any errors, don't
 				-- try the deriving stuff, becuase that may give
 				-- more errors still
-       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
-                                                      deriv_decls
+       ; (deriv_inst_info, deriv_binds, deriv_dus) 
+              <- tcDeriving tycl_decls inst_decls deriv_decls
        ; gbl_env <- addInsts deriv_inst_info getGblEnv
-       ; return (gbl_env,
+       ; return ( addTcgDUs gbl_env deriv_dus,
                   generic_inst_info ++ deriv_inst_info ++ local_info,
                   aux_binds `plusHsValBinds` deriv_binds)
-    }}}}}
+    }}}
   where
     -- Make sure that toplevel type instance are not for associated types.
     -- !!!TODO: Need to perform this check for the TyThing of type functions,