X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInteract.lhs;h=b079368816a1dcd98883f96d31f83b82ab1f6e88;hb=bff88b3a5bf96eea57e99a09774a74bd18cf4e13;hp=6f48a4f2cc2d20f213f1bbacb822e3cc31822550;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 6f48a4f..b079368 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -568,6 +568,7 @@ dischargeWorkItem = mkIRStop KeepInert emptyCCan 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 @@ -709,10 +710,16 @@ doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_i -- 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) @@ -751,10 +758,10 @@ doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1 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) @@ -763,7 +770,7 @@ doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc 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 } {- @@ -775,7 +782,7 @@ doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc ; 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 @@ -880,21 +887,47 @@ rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) 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 @@ -911,20 +944,16 @@ solveOneFromTheOther (iid,ifl) workItem | 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 @@ -1618,10 +1647,9 @@ NB: The desugarer needs be more clever to deal with equalities 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