noInteraction :: Monad m => WorkItem -> m InteractResult
noInteraction workItem = mkIRContinue workItem KeepInert emptyCCan
+data WhichComesFromInert = LeftComesFromInert | RightComesFromInert
---------------------------------------------------
-- Interact a single WorkItem with an InertSet as far as possible, i.e. until we get a Stop
-- so we just generate a fresh coercion variable that isn't used anywhere.
doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 })
workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
+ | nm1 == nm2 && isGiven wfl && isGiven ifl
+ = -- See Note [Overriding implicit parameters]
+ -- Dump the inert item, override totally with the new one
+ -- Do not require type equality
+ mkIRContinue workItem DropInert emptyCCan
+
| nm1 == nm2 && ty1 `tcEqType` ty2
= solveOneFromTheOther (id1,ifl) workItem
- | nm1 == nm2 && (not (isGiven ifl && isGiven wfl))
+ | nm1 == nm2
= -- See Note [When improvement happens]
do { co_var <- newWantedCoVar ty1 ty2
; let flav = Wanted (combineCtLoc ifl wfl)
workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2 })
| fl1 `canRewrite` fl2 && lhss_match
- = do { cans <- rewriteEqLHS (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
+ = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
; mkIRStop KeepInert cans }
| fl2 `canRewrite` fl1 && lhss_match
- = do { cans <- rewriteEqLHS (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
+ = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue workItem DropInert cans }
where
lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2)
workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 })
-- Check for matching LHS
| fl1 `canRewrite` fl2 && tv1 == tv2
- = do { cans <- rewriteEqLHS (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
+ = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
; mkIRStop KeepInert cans }
{-
; mkIRStop KeepInert cans }
-}
| fl2 `canRewrite` fl1 && tv1 == tv2
- = do { cans <- rewriteEqLHS (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
+ = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue workItem DropInert cans }
-- Check for rewriting RHS
xi2' = substTyWith [tv1] [xi1] xi2
co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2 -- xi2 ~ xi2[xi1/tv1]
-rewriteEqLHS :: (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS CanonicalCts
+
+rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS CanonicalCts
-- Used to ineratct two equalities of the following form:
-- First Equality: co1: (XXX ~ xi1)
-- Second Equality: cv2: (XXX ~ xi2)
-- Where the cv1 `canRewrite` cv2 equality
-rewriteEqLHS (co1,xi1) (cv2,gw,xi2)
- = do { cv2' <- if isWanted gw then
- do { cv2' <- newWantedCoVar xi1 xi2
- ; setWantedCoBind cv2 $
- co1 `mkTransCoercion` mkCoVarCoercion cv2'
- ; return cv2' }
- else newGivOrDerCoVar xi1 xi2 $
- mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2
+-- We have an option of creating new work (xi1 ~ xi2) OR (xi2 ~ xi1). This
+-- depends on whether the left or the right equality comes from the inert set.
+-- We must:
+-- prefer to create (xi2 ~ xi1) if the first comes from the inert
+-- prefer to create (xi1 ~ xi2) if the second comes from the inert
+rewriteEqLHS which (co1,xi1) (cv2,gw,xi2)
+ = do { cv2' <- case (isWanted gw, which) of
+ (True,LeftComesFromInert) ->
+ do { cv2' <- newWantedCoVar xi2 xi1
+ ; setWantedCoBind cv2 $
+ co1 `mkTransCoercion` mkSymCoercion (mkCoVarCoercion cv2')
+ ; return cv2' }
+ (True,RightComesFromInert) ->
+ do { cv2' <- newWantedCoVar xi1 xi2
+ ; setWantedCoBind cv2 $
+ co1 `mkTransCoercion` mkCoVarCoercion cv2'
+ ; return cv2' }
+ (False,LeftComesFromInert) ->
+ newGivOrDerCoVar xi2 xi1 $
+ mkSymCoercion (mkCoVarCoercion cv2) `mkTransCoercion` co1
+ (False,RightComesFromInert) ->
+ newGivOrDerCoVar xi1 xi2 $
+ mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2
; mkCanonical gw cv2' }
+-- ->
+-- if isWanted gw then
+-- do { cv2' <- newWantedCoVar xi1 xi2
+-- ; setWantedCoBind cv2 $
+-- co1 `mkTransCoercion` mkCoVarCoercion cv2'
+-- ; return cv2' }
+-- else newGivOrDerCoVar xi1 xi2 $
+-- mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2
+-- ; mkCanonical gw cv2' }
+
solveOneFromTheOther :: (EvVar, CtFlavor) -> CanonicalCt -> TcS InteractResult
-- First argument inert, second argument workitem. They both represent
| isDerived ifl && isDerived wfl
= noInteraction workItem
- | wfl `canRewrite` ifl
+ | ifl `canRewrite` wfl
+ = do { unless (isGiven wfl) $ setEvBind wid (EvId iid)
+ -- Overwrite the binding, if one exists
+ -- For Givens, which are lambda-bound, nothing to overwrite,
+ ; dischargeWorkItem }
+
+ | otherwise -- wfl `canRewrite` ifl
= do { unless (isGiven ifl) $ setEvBind iid (EvId wid)
- -- Overwrite the binding, if one exists
- -- (For Givens, they are lambda-bound so nothing to overwrite,
- -- but we still drop the overridden one and replace it in
- -- the inert set with the new one
; mkIRContinue workItem DropInert emptyCCan }
- -- The order is important here: must do (wfl `canRewrite` ifl) first
- -- so that we override the inert item with an inner given if possible.
- -- See Note [Overriding implicit parameters]
- | otherwise -- ifl `canRewrite` wfl
- = do { unless (isGiven wfl) $ setEvBind wid (EvId iid)
- ; dischargeWorkItem }
where
wfl = cc_flavor workItem
wid = cc_id workItem
newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi]
-> TcS WorkList
newSCWorkFromFlavored ev flavor cls xis
- | Given loc <- flavor -- The NoScSkol says "don't add superclasses"
- , NoScSkol <- ctLocOrigin loc
- = pprTrace "Oh dear! Superclasses of self" (pprEvVarWithType ev) $
- return emptyWorkList
+ | Given loc <- flavor -- The NoScSkol says "don't add superclasses"
+ , NoScSkol <- ctLocOrigin loc -- Very important!
+ = return emptyWorkList
| otherwise
= do { let (tyvars, sc_theta, _, _) = classBigSig cls
projects / ghc-hetmet.git / blobdiff