canonicalization. We now check whether the returned
coercion is an identity coercion. We used to check
whether we return any constraints from flattening but
that's wrong in the presence of the flattening cache.
-- Flatten a bunch of types all at once.
flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
-- Coercions :: Xi ~ Type
-- Flatten a bunch of types all at once.
flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
-- Coercions :: Xi ~ Type
-- Preserve type synonyms if possible
-- We can tell if ty' is function-free by
-- whether there are any floated constraints
-- Preserve type synonyms if possible
-- We can tell if ty' is function-free by
-- whether there are any floated constraints
- ; if isEmptyCCan ccs then
- return (ty, ty, emptyCCan)
+ ; if isIdentityCoercion co then
+ return (ty, ty, emptyCCan)
else
return (xi, co, ccs) }
else
return (xi, co, ccs) }
canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
canClassToWorkList fl v cn tys
= do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys
canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
canClassToWorkList fl v cn tys
= do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys
- ; let no_flattening_happened = isEmptyCCan ccs
+ ; let no_flattening_happened = all isIdentityCoercion cos
dict_co = mkTyConCoercion (classTyCon cn) cos
; v_new <- if no_flattening_happened then return v
else if isGivenOrSolved fl then return v
dict_co = mkTyConCoercion (classTyCon cn) cos
; v_new <- if no_flattening_happened then return v
else if isGivenOrSolved fl then return v
; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS
-- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2
; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS
-- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2
- no_flattening_happened = isEmptyCCan ccs
+ no_flattening_happened = all isIdentityCoercion (co2:cos1)
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
; case mxi2' of {
Nothing -> canEqFailure fl cv ;
Just xi2' ->
; case mxi2' of {
Nothing -> canEqFailure fl cv ;
Just xi2' ->
- do { let no_flattening_happened = isEmptyCCan ccs2
+ do { let no_flattening_happened = isIdentityCoercion co
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv
else if isWanted fl then
-- outer ones!
; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
-- outer ones!
; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
- ; flat_cache_var <- TcM.newTcRef orig_flat_cache -- emptyFlatCache
+ ; flat_cache_var <- TcM.newTcRef orig_flat_cache
+ -- One could be more conservative as well:
+ -- ; flat_cache_var <- TcM.newTcRef emptyFlatCache
-- Consider copying the results the tcs_flat_map of the
-- incomping constraint, but we must make sure that we
-- Consider copying the results the tcs_flat_map of the
-- incomping constraint, but we must make sure that we