X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=3a05380752260e2db2bb7325468b83294dd7f482;hb=302e2e29f2e1074bfba561e077a484dc4e1d15f6;hp=5d2b829276c375398450b58c9a8f17d867e788a0;hpb=0884a2cb09cd5f609b6163a225ca3b8cce942250;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 5d2b829..3a05380 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. + %************************************************************************ %* * @@ -721,7 +743,7 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration -inferConstraints tvs cls inst_tys rep_tc rep_tc_args +inferConstraints _ cls inst_tys rep_tc rep_tc_args = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc ) stupid_constraints ++ extra_constraints ++ sc_constraints ++ con_arg_constraints @@ -762,15 +784,20 @@ inferConstraints tvs cls inst_tys rep_tc rep_tc_args stupid_constraints = substTheta subst (tyConStupidTheta rep_tc) subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args - -- Extra constraints + -- Extra Data constraints -- The Data class (only) requires that for - -- instance (...) => Data (T a b) - -- then (Data a, Data b) are among the (...) constraints - -- Reason: that's what you need to typecheck the method - -- dataCast1 f = gcast1 f + -- instance (...) => Data (T t1 t2) + -- IF t1:*, t2:* + -- THEN (Data t1, Data t2) are among the (...) constraints + -- Reason: when the IF holds, we generate a method + -- dataCast2 f = gcast2 f + -- and we need the Data constraints to typecheck the method extra_constraints - | cls `hasKey` dataClassKey = [mkClassPred cls [mkTyVarTy tv] | tv <- tvs] - | otherwise = [] + | cls `hasKey` dataClassKey + , all (isLiftedTypeKind . typeKind) rep_tc_args + = [mkClassPred cls [ty] | ty <- rep_tc_args] + | otherwise + = [] ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes @@ -965,13 +992,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 +1076,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 +1174,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 @@ -1262,6 +1300,7 @@ inferInstanceContexts oflag infer_specs weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds + ; traceTc (text "TcDeriv" <+> (ppr deriv_rhs $$ ppr theta)) -- Claim: the result instance declaration is guaranteed valid -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys @@ -1364,7 +1403,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)