X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=7e3110a2607eb61ddba4b8df116263f4951b4fa5;hb=8fda9784f1eff82aa243073fd31b181080be3109;hp=8352f58fef9c176e8a41d92249a723e49b944a1b;hpb=1ef81a94d77cffce1b0a592b25d7f4a9aa8ea1d3;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 8352f58..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 @@ -881,20 +900,19 @@ cond_functorOK allowFunctions (dflags, rep_tc) | not (dopt Opt_DeriveFunctor dflags) = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class")) | otherwise - = msum (map check con_types) + = msum (map check_con data_cons) -- msum picks the first 'Just', if any where data_cons = tyConDataCons rep_tc - con_types = concatMap dataConOrigArgTys data_cons - check = functorLikeTraverse - Nothing - Nothing - (Just covariant) - (\x y -> if allowFunctions then x `mplus` y else Just functions) - (\_ xs -> msum xs) - (\_ x -> x) - (Just wrong_arg) - (\_ x -> x) - (last (tyConTyVars 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 } + covariant = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "uses the type variable in a function argument") functions = quotes (pprSourceTyCon rep_tc) <+>