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.
%************************************************************************
%* *
-> [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
-- 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
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
; 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
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
| cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
| cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct)
| cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
- | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
- | cls_key == functorClassKey = Just (cond_functorOK True) -- NB: no cond_std!
- | cls_key == foldableClassKey = Just (cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
- | cls_key == traversableClassKey = Just (cond_functorOK False)
- | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
+ | cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond`
+ cond_std `andCond` cond_noUnliftedArgs)
+ | cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond`
+ cond_functorOK True) -- NB: no cond_std!
+ | cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond`
+ cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
+ | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
+ cond_functorOK False)
+ | getName cls `elem` typeableClassNames = Just (checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK)
| otherwise = Nothing
where
cls_key = getUnique cls
functions = ptext (sLit "contains function types")
wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
-cond_mayDeriveDataTypeable :: Condition
-cond_mayDeriveDataTypeable (dflags, _)
- | dopt Opt_DeriveDataTypeable dflags = Nothing
- | otherwise = Just why
+checkFlag :: DynFlag -> Condition
+checkFlag flag (dflags, _)
+ | dopt flag dflags = Nothing
+ | otherwise = Just why
where
- why = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
+ why = ptext (sLit "You need -X") <> text flag_str
+ <+> ptext (sLit "to derive an instance for this class")
+ flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
+ [s] -> s
+ other -> pprPanic "checkFlag" (ppr other)
std_class_via_iso :: Class -> Bool
std_class_via_iso clas -- These standard classes can be derived for a newtype