Commit 66c58d1c authored by TomSchrijvers's avatar TomSchrijvers
Browse files

fix of wanted equational class context

Previously failed to account for equational
class context for wanted dictionary contraints, e.g. wanted C a
in 

	class a ~ Int => C a
	instance C Int

should give rise to wanted a ~ Int and consequently discharge a ~ Int by
unifying a with Int and then discharge C Int with the instance.

All ancestor equalities are taken into account.
parent fe4dd430
...@@ -48,7 +48,7 @@ module Inst ( ...@@ -48,7 +48,7 @@ module Inst (
mkWantedCo, mkGivenCo, mkWantedCo, mkGivenCo,
fromWantedCo, fromGivenCo, fromWantedCo, fromGivenCo,
eitherEqInst, mkEqInst, mkEqInsts, eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
finalizeEqInst, writeWantedCoercion, finalizeEqInst, writeWantedCoercion,
eqInstType, updateEqInstCoercion, eqInstType, updateEqInstCoercion,
eqInstCoercion, eqInstCoercion,
...@@ -1004,6 +1004,12 @@ mkEqInst (EqPred ty1 ty2) co ...@@ -1004,6 +1004,12 @@ mkEqInst (EqPred ty1 ty2) co
} }
where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
mkWantedEqInst :: PredType -> TcM Inst
mkWantedEqInst pred@(EqPred ty1 ty2)
= do { cotv <- newMetaTyVar TauTv (mkCoKind ty1 ty2)
; mkEqInst pred (Left cotv)
}
-- type inference: -- type inference:
-- We want to promote the wanted EqInst to a given EqInst -- We want to promote the wanted EqInst to a given EqInst
-- in the signature context. -- in the signature context.
......
...@@ -1680,7 +1680,11 @@ reduceContext env wanteds ...@@ -1680,7 +1680,11 @@ reduceContext env wanteds
; let givens = red_givens env ; let givens = red_givens env
(given_eqs0,given_dicts0) = partitionGivenEqInsts givens (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 ; -- 1. Normalise the *given* *equality* constraints
(given_eqs,eliminate_skolems) <- normaliseGivens given_eqs0 (given_eqs,eliminate_skolems) <- normaliseGivens given_eqs0
...@@ -2476,6 +2480,31 @@ addSCs is_loop avails dict ...@@ -2476,6 +2480,31 @@ addSCs is_loop avails dict
is_given sc_dict = case findAvail avails sc_dict of is_given sc_dict = case findAvail avails sc_dict of
Just (Given _) -> True -- Given is cheaper than superclass selection Just (Given _) -> True -- Given is cheaper than superclass selection
other -> False 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} \end{code}
%************************************************************************ %************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment