From 8fda9784f1eff82aa243073fd31b181080be3109 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 13 Mar 2009 13:44:36 +0000 Subject: [PATCH] Fix Trac #3087: derived Data now defines dataCast1/2 This patch generates code in deriving(Data) for dataCast1 or 2 as appropriate. While I was there I did some refactoring (of course), pulling out the TcDeriv.inferConstraints as a separate function. I don't think it's worth merging this to 6.10.2, even though it's a bugfix, because it modifies code that I added in the HEAD only (for deriving Functor) so the merge will be sligtly awkward. And there's an easy workaround. --- compiler/typecheck/TcDeriv.lhs | 99 ++++++++++++++++++++++--------------- compiler/typecheck/TcGenDeriv.lhs | 27 +++++++++- 2 files changed, 84 insertions(+), 42 deletions(-) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index c1025d4..7e3110a 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -663,52 +663,16 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta | otherwise = do { dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM - ; let ordinary_constraints - = [ mkClassPred cls [arg_ty] - | data_con <- tyConDataCons rep_tc, - arg_ty <- ASSERT( isVanillaDataCon data_con ) - get_constrained_tys $ - substTys subst $ - dataConInstOrigArgTys data_con all_rep_tc_args, - not (isUnLiftedType arg_ty) ] - -- No constraints for unlifted types - -- Where they are legal we generate specilised function calls - - -- For functor-like classes, two things are different - -- (a) We recurse over argument types to generate constraints - -- See Functor examples in TcGenDeriv - -- (b) The rep_tc_args will be one short - is_functor_like = getUnique cls `elem` functorLikeClassKeys - - get_constrained_tys :: [Type] -> [Type] - get_constrained_tys tys - | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys - | otherwise = tys - - rep_tc_tvs = tyConTyVars rep_tc - last_tv = last rep_tc_tvs - all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv] - | otherwise = rep_tc_args - - - -- See Note [Superclasses of derived instance] - sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) - (classSCTheta cls) - inst_tys = [mkTyConApp tycon tc_args] - subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args - stupid_constraints = substTheta subst (tyConStupidTheta rep_tc) - - all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints - + ; let inst_tys = [mkTyConApp tycon tc_args] + inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args spec = DS { ds_loc = loc, ds_orig = orig , ds_name = dfun_name, ds_tvs = tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args - , ds_theta = mtheta `orElse` all_constraints + , ds_theta = mtheta `orElse` inferred_constraints , ds_newtype = False } - ; ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr tycon ) - return (if isJust mtheta then Right spec -- Specified context + ; return (if isJust mtheta then Right spec -- Specified context else Left spec) } -- Infer context mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta @@ -740,6 +704,61 @@ mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta , ds_theta = mtheta `orElse` [], ds_newtype = False }) } +inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType +-- 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 + = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc ) + stupid_constraints ++ extra_constraints + ++ sc_constraints ++ con_arg_constraints + where + -- Constraints arising from the arguments of each constructor + con_arg_constraints + = [ mkClassPred cls [arg_ty] + | data_con <- tyConDataCons rep_tc, + arg_ty <- ASSERT( isVanillaDataCon data_con ) + get_constrained_tys $ + dataConInstOrigArgTys data_con all_rep_tc_args, + not (isUnLiftedType arg_ty) ] + -- No constraints for unlifted types + -- Where they are legal we generate specilised function calls + + -- For functor-like classes, two things are different + -- (a) We recurse over argument types to generate constraints + -- See Functor examples in TcGenDeriv + -- (b) The rep_tc_args will be one short + is_functor_like = getUnique cls `elem` functorLikeClassKeys + + get_constrained_tys :: [Type] -> [Type] + get_constrained_tys tys + | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys + | otherwise = tys + + rep_tc_tvs = tyConTyVars rep_tc + last_tv = last rep_tc_tvs + all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv] + | otherwise = rep_tc_args + + -- Constraints arising from superclasses + -- See Note [Superclasses of derived instance] + sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) + (classSCTheta cls) + + -- Stupid constraints + stupid_constraints = substTheta subst (tyConStupidTheta rep_tc) + subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args + + -- Extra 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 + extra_constraints + | cls `hasKey` dataClassKey = [mkClassPred cls [mkTyVarTy tv] | tv <- tvs] + | otherwise = [] + ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes -- This is *apart* from the newtype-deriving mechanism diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index ba1c001..c579b94 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1142,13 +1142,18 @@ we generate dataTypeOf _ = $dT + dataCast1 = gcast1 -- If T :: * -> * + dataCast2 = gcast2 -- if T :: * -> * -> * + + \begin{code} gen_Data_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, -- The method bindings DerivAuxBinds) -- Auxiliary bindings gen_Data_binds loc tycon - = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], + = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] + `unionBags` gcast_binds, -- Auxiliary definitions: the data type and constructors MkTyCon tycon : map MkDataCon data_cons) where @@ -1200,13 +1205,31 @@ gen_Data_binds loc tycon [nlWildPat] (nlHsVar (mk_data_type_name tycon)) + ------------ gcast1/2 + tycon_kind = tyConKind tycon + gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR + | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR + | otherwise = emptyBag + mk_gcast dataCast_RDR gcast_RDR + = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] + (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) + + +kind1, kind2 :: Kind +kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind +kind2 = liftedTypeKind `mkArrowKind` kind1 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, - mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, + dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") +dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") +gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") +gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") -- 1.7.10.4