X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=fa5c6776c62bfcfe41cdc8ee8ded24bc38068869;hb=421819753b3eb4940a26e578ef0e4c5cd31761fa;hp=36312f57f7e9b23ac411de46c7529d5d39b99873;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 36312f5..fa5c677 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -10,7 +10,7 @@ TcSimplify -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module TcSimplify ( @@ -1680,7 +1680,11 @@ reduceContext env wanteds ; let givens = red_givens env (given_eqs0,given_dicts0) = partitionGivenEqInsts givens - (wanted_eqs,wanted_dicts) = partitionWantedEqInsts wanteds + (wanted_eqs0,wanted_dicts) = partitionWantedEqInsts wanteds + + ; wanted_ancestor_eqs <- (mapM wantedAncestorEqualities wanted_dicts >>= \ls -> return (concat ls)) + ; traceTc (text "test wanted SCs" <+> ppr wanted_ancestor_eqs) + ; let wanted_eqs = wanted_ancestor_eqs ++ wanted_eqs0 ; -- 1. Normalise the *given* *equality* constraints (given_eqs,eliminate_skolems) <- normaliseGivens given_eqs0 @@ -2476,6 +2480,31 @@ addSCs is_loop avails dict is_given sc_dict = case findAvail avails sc_dict of Just (Given _) -> True -- Given is cheaper than superclass selection other -> False + + +wantedAncestorEqualities :: Inst -> TcM [Inst] +wantedAncestorEqualities dict + | isClassDict dict + = mapM mkWantedEqInst $ filter isEqPred $ bagToList $ wantedAncestorEqualities' (dictPred dict) emptyBag + | otherwise + = return [] + +wantedAncestorEqualities' :: PredType -> Bag PredType -> Bag PredType +wantedAncestorEqualities' pred bag + = ASSERT( isClassPred pred ) + let (clas, tys) = getClassPredTys pred + (tyvars, sc_theta, _, _) = classBigSig clas + sc_theta' = substTheta (zipTopTvSubst tyvars tys) sc_theta + add_sc bag sc_pred + | elemBag sc_pred bag = bag + | not (isEqPred sc_pred) + && not (isClassPred sc_pred) + = bag + | isEqPred sc_pred = consBag sc_pred bag + | otherwise = let bag' = consBag sc_pred bag + in wantedAncestorEqualities' sc_pred bag' + in foldl add_sc bag sc_theta' + \end{code} %************************************************************************ @@ -2740,7 +2769,6 @@ tcSimplifyDeriv :: InstOrigin -> TcM ThetaType -- Needed -- Given instance (wanted) => C inst_ty -- Simplify 'wanted' as much as possible --- The inst_ty is needed only for the termination check tcSimplifyDeriv orig tyvars theta = do { (tvs, _, tenv) <- tcInstTyVars tyvars @@ -2750,8 +2778,9 @@ tcSimplifyDeriv orig tyvars theta ; wanteds <- newDictBndrsO orig (substTheta tenv theta) ; (irreds, _) <- tryHardCheckLoop doc wanteds - ; let (tv_dicts, others) = partition isTyVarDict irreds + ; let (tv_dicts, others) = partition ok irreds ; addNoInstanceErrs others + -- See Note [Exotic derived instance contexts] in TcMType ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) simpl_theta = substTheta rev_env (map dictPred tv_dicts) @@ -2761,49 +2790,10 @@ tcSimplifyDeriv orig tyvars theta ; return simpl_theta } where doc = ptext SLIT("deriving classes for a data type") -\end{code} - -Note [Exotic derived instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b c = MkT (Foo a b c) deriving( Eq ) - instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) - -Notice that this instance (just) satisfies the Paterson termination -conditions. Then we *could* derive an instance decl like this: - - instance (C Int a, Eq b, Eq c) => Eq (T a b c) -even though there is no instance for (C Int a), because there just -*might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. - -However, this seems pretty exotic, and it's quite tricky to allow -this, and yet give sensible error messages in the (much more common) -case where we really want that instance decl for C. - -So for now we simply require that the derived instance context -should have only type-variable constraints. - -Here is another example: - data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -fallow-undecidable-instances we -could derive the instance - instance Eq (f (Fix f)) => Eq (Fix f) -but this is so delicate that I don't think it should happen inside -'deriving'. If you want this, write it yourself! - -NB: if you want to lift this condition, make sure you still meet the -termination conditions! If not, the deriving mechanism generates -larger and larger constraints. Example: - data Succ a = S a - data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show - -Note the lack of a Show instance for Succ. First we'll generate - instance (Show (Succ a), Show a) => Show (Seq a) -and then - instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) -and so on. Instead we want to complain of no instance for (Show (Succ a)). + ok dict | isDict dict = validDerivPred (dictPred dict) + | otherwise = False +\end{code} @tcSimplifyDefault@ just checks class-type constraints, essentially; @@ -3095,51 +3085,28 @@ misMatchMsg :: TcType -> TcType -> TcM (TidyEnv, SDoc) -- The argument order is: actual type, expected type misMatchMsg ty_act ty_exp = do { env0 <- tcInitTidyEnv - ; (env1, pp_exp, extra_exp) <- ppr_ty env0 ty_exp ty_act - ; (env2, pp_act, extra_act) <- ppr_ty env1 ty_act ty_exp + ; ty_exp <- zonkTcType ty_exp + ; ty_act <- zonkTcType ty_act + ; (env1, pp_exp, extra_exp) <- ppr_ty env0 ty_exp + ; (env2, pp_act, extra_act) <- ppr_ty env1 ty_act ; return (env2, sep [sep [ptext SLIT("Couldn't match expected type") <+> pp_exp, nest 7 $ ptext SLIT("against inferred type") <+> pp_act], nest 2 (extra_exp $$ extra_act)]) } -ppr_ty :: TidyEnv -> TcType -> TcType -> TcM (TidyEnv, SDoc, SDoc) -ppr_ty env ty other_ty - = do { ty' <- zonkTcType ty - ; let (env1, tidy_ty) = tidyOpenType env ty' - ; (env2, extra) <- ppr_extra env1 tidy_ty other_ty +ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc) +ppr_ty env ty + = do { let (env1, tidy_ty) = tidyOpenType env ty + ; (env2, extra) <- ppr_extra env1 tidy_ty ; return (env2, quotes (ppr tidy_ty), extra) } --- (ppr_extra env ty other_ty) shows extra info about 'ty' -ppr_extra env (TyVarTy tv) other_ty +-- (ppr_extra env ty) shows extra info about 'ty' +ppr_extra env (TyVarTy tv) | isSkolemTyVar tv || isSigTyVar tv = return (env1, pprSkolTvBinding tv1) where (env1, tv1) = tidySkolemTyVar env tv -ppr_extra env (TyConApp tc1 _) (TyConApp tc2 _) - | getOccName tc1 == getOccName tc2 - = -- This case helps with messages that would otherwise say - -- Could not match 'T' does not match 'M.T' - -- which is not helpful - do { this_mod <- getModule - ; return (env, quotes (ppr tc1) <+> ptext SLIT("is defined") <+> mk_mod this_mod) } - where - tc_mod = nameModule (getName tc1) - tc_pkg = modulePackageId tc_mod - tc2_pkg = modulePackageId (nameModule (getName tc2)) - mk_mod this_mod - | tc_mod == this_mod = ptext SLIT("in this module") - - | not home_pkg && tc2_pkg /= tc_pkg = pp_pkg - -- Suppress the module name if (a) it's from another package - -- (b) other_ty isn't from that same package - - | otherwise = ptext SLIT("in module") <+> quotes (ppr tc_mod) <+> pp_pkg - where - home_pkg = tc_pkg == modulePackageId this_mod - pp_pkg | home_pkg = empty - | otherwise = ptext SLIT("in package") <+> quotes (ppr tc_pkg) - -ppr_extra env ty other_ty = return (env, empty) -- Normal case +ppr_extra env ty = return (env, empty) -- Normal case \end{code}