X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=54ffe6b2da316d8afc9bbf813fd832aef77b9817;hb=8c554937f8824da81e03e504936320b3321022ed;hp=c1025d4eefcc52f0f2462954d721d765765f0922;hpb=22eefb510ad56379cc96b8d14a440579cd55fc81;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index c1025d4..54ffe6b 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 @@ -776,9 +795,9 @@ sideConditions cls | 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_std `andCond` cond_functorOK True) - | cls_key == foldableClassKey = Just (cond_std `andCond` cond_functorOK False) - | cls_key == traversableClassKey = Just (cond_std `andCond` cond_functorOK False) + | 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) | otherwise = Nothing where @@ -807,15 +826,21 @@ andCond c1 c2 tc = case c1 tc of cond_std :: Condition cond_std (_, rep_tc) - | any (not . isVanillaDataCon) data_cons = Just existential_why - | null data_cons = Just no_cons_why - | otherwise = Nothing + | null data_cons = Just no_cons_why + | not (null con_whys) = Just (vcat con_whys) + | otherwise = Nothing where data_cons = tyConDataCons rep_tc no_cons_why = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "has no data constructors") - existential_why = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "has non-Haskell-98 constructor(s)") + + con_whys = mapCatMaybes check_con data_cons + + check_con :: DataCon -> Maybe SDoc + check_con con + | isVanillaDataCon con + , all isTauTy (dataConOrigArgTys con) = Nothing + | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type"))) cond_enumOrProduct :: Condition cond_enumOrProduct = cond_isEnumeration `orCond` @@ -830,8 +855,7 @@ cond_noUnliftedArgs (_, tc) where bad_cons = [ con | con <- tyConDataCons tc , any isUnLiftedType (dataConOrigArgTys con) ] - why = ptext (sLit "Constructor") <+> quotes (ppr (head bad_cons)) - <+> ptext (sLit "has arguments of unlifted type") + why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type")) cond_isEnumeration :: Condition cond_isEnumeration (_, rep_tc) @@ -884,22 +908,26 @@ cond_functorOK allowFunctions (dflags, rep_tc) = msum (map check_con data_cons) -- msum picks the first 'Just', if any where data_cons = tyConDataCons rep_tc - check_con con = msum (foldDataConArgs ft_check con) - - ft_check :: FFoldType (Maybe SDoc) - ft_check = FT { ft_triv = Nothing, ft_var = Nothing, ft_co_var = Just covariant - , ft_fun = \x y -> if allowFunctions then x `mplus` y else Just functions - , ft_tup = \_ xs -> msum xs - , ft_ty_app = \_ x -> x - , ft_bad_app = Just wrong_arg - , ft_forall = \_ x -> x } + check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con) + + check_vanilla :: DataCon -> Maybe SDoc + check_vanilla con | isVanillaDataCon con = Nothing + | otherwise = Just (badCon con existential) + + ft_check :: DataCon -> FFoldType (Maybe SDoc) + ft_check con = FT { ft_triv = Nothing, ft_var = Nothing + , ft_co_var = Just (badCon con covariant) + , ft_fun = \x y -> if allowFunctions then x `mplus` y + else Just (badCon con functions) + , ft_tup = \_ xs -> msum xs + , ft_ty_app = \_ x -> x + , ft_bad_app = Just (badCon con wrong_arg) + , ft_forall = \_ x -> x } - covariant = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "uses the type variable in a function argument") - functions = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "contains function types") - wrong_arg = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "uses the type variable in an argument other than the last") + existential = ptext (sLit "has existential arguments") + covariant = ptext (sLit "uses the type variable in a function argument") + 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, _) @@ -922,6 +950,9 @@ new_dfun_name clas tycon -- Just a simple wrapper ; newDFunName clas [mkTyConApp tycon []] loc } -- The type passed to newDFunName is only used to generate -- a suitable string; hence the empty type arg list + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg \end{code} Note [Superclasses of derived instance]