X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=2aba527a62dbedfbd5748a239aaf914245dc9d6f;hb=b7a8d2059f982599d31d14395c6628a049ec5179;hp=5d2b829276c375398450b58c9a8f17d867e788a0;hpb=0884a2cb09cd5f609b6163a225ca3b8cce942250;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 5d2b829..2aba527 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -337,7 +337,7 @@ renameDeriv is_boot gen_binds insts ; let aux_binds = listToBag $ map (genAuxBind loc) $ rm_dups [] $ concat deriv_aux_binds ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds []) - ; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs) + ; let aux_names = collectHsValBinders rn_aux_lhs ; bindLocalNames aux_names $ do { (rn_aux, dus_aux) <- rnTopBindsRHS (mkNameSet aux_names) rn_aux_lhs @@ -354,8 +354,11 @@ renameDeriv is_boot gen_binds insts | otherwise = rm_dups (b:acc) bs - rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }) - = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs) + rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars) + rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc }) + = return ( info { iBinds = NewTypeDerived coi tc } + , mkFVs (map dataConName (tyConDataCons tc))) + -- See Note [Newtype deriving and unused constructors] rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv }) = -- Bring the right type variables into @@ -384,6 +387,25 @@ mkGenericBinds is_boot tycl_decls -- The predicate tyConHasGenerics finds both of these \end{code} +Note [Newtype deriving and unused constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (see Trac #1954): + + module Bug(P) where + newtype P a = MkP (IO a) deriving Monad + +If you compile with -fwarn-unused-binds you do not expect the warning +"Defined but not used: data consructor MkP". Yet the newtype deriving +code does not explicitly mention MkP, but it should behave as if you +had written + instance Monad P where + return x = MkP (return x) + ...etc... + +So we want to signal a user of the data constructor 'MkP'. That's +what we do in rn_inst_info, and it's the only reason we have the TyCon +stored in NewTypeDerived. + %************************************************************************ %* * @@ -965,13 +987,25 @@ checkFlag flag (dflags, _) 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 - -- using the isomorphism trick *even if no -fglasgow-exts* +-- These standard classes can be derived for a newtype +-- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving +-- because giving so gives the same results as generating the boilerplate +std_class_via_iso clas = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] -- Not Read/Show because they respect the type -- Not Enum, because newtypes are never in Enum +non_iso_class :: Class -> Bool +-- *Never* derive Read,Show,Typeable,Data by isomorphism, +-- even with -XGeneralizedNewtypeDeriving +non_iso_class cls + = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++ + typeableClassKeys) + +typeableClassKeys :: [Unique] +typeableClassKeys = map getUnique typeableClassNames + new_dfun_name :: Class -> TyCon -> TcM Name new_dfun_name clas tycon -- Just a simple wrapper = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon @@ -1037,18 +1071,21 @@ mkNewTypeEqn orig dflags tvs | otherwise = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of - CanDerive -> go_for_it -- Use the standard H98 method - DerivableClassError msg -> bale_out msg -- Error with standard class + CanDerive -> go_for_it -- Use the standard H98 method + DerivableClassError msg -- Error with standard class + | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd) + | otherwise -> bale_out msg NonDerivableClass -- Must use newtype deriving - | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving - | otherwise -> bale_out non_std_err -- Try newtype deriving! + | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving + | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving! + | otherwise -> bale_out non_std where newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg) - non_std_err = nonStdErr cls $$ - ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension") + non_std = nonStdErr cls + suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension") -- Here is the plan for newtype derivings. We see -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) @@ -1132,10 +1169,6 @@ mkNewTypeEqn orig dflags tvs && ats_ok -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - -- Never derive Read,Show,Typeable,Data by isomorphism - non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++ - typeableClassNames) - arity_ok = length cls_tys + 1 == classArity cls -- Well kinded; eg not: newtype T ... deriving( ST ) -- because ST needs *2* type params @@ -1364,7 +1397,7 @@ genInst :: Bool -- True <=> standalone deriving genInst standalone_deriv oflag spec | ds_newtype spec = return (InstInfo { iSpec = mkInstance oflag (ds_theta spec) spec - , iBinds = NewTypeDerived co }, []) + , iBinds = NewTypeDerived co rep_tycon }, []) | otherwise = do { let loc = getSrcSpan (ds_name spec)