X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=e121cc6e2ec7febb9dd566086813f6b8d9e6854a;hb=2f223e8f4a4e2fb22a8bb0638cd48256e9f2f0e2;hp=54ffe6b2da316d8afc9bbf813fd832aef77b9817;hpb=8c554937f8824da81e03e504936320b3321022ed;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 54ffe6b..e121cc6 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 @@ -794,11 +801,15 @@ sideConditions cls | 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 @@ -929,12 +940,16 @@ cond_functorOK allowFunctions (dflags, rep_tc) 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