import TypeRep
import Id
+import VarEnv
import Var
import TcType
-- * Nothing if we were not able to solve it
-- * Just wi' if we solved it, wi' (now a "given") should be put in the work list.
-- See Note [Touchables and givens]
--- Note, just passing the inerts through for the skolem equivalence classes
+-- NB: just passing the inerts through for the skolem equivalence classes
trySpontaneousSolve :: WorkItem -> InertSet -> TcS (Maybe SWorkList)
trySpontaneousSolve (CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi }) inerts
| isGiven gw
; case (tch1, tch2) of
(True, True) -> trySpontaneousEqTwoWay inerts cv gw tv1 tv2
(True, False) -> trySpontaneousEqOneWay inerts cv gw tv1 xi
- (False, True) | tyVarKind tv1 `isSubKind` tyVarKind tv2
- -> trySpontaneousEqOneWay inerts cv gw tv2 (mkTyVarTy tv1)
+ (False, True) -> trySpontaneousEqOneWay inerts cv gw tv2 (mkTyVarTy tv1)
_ -> return Nothing }
| otherwise
= do { tch1 <- isTouchableMetaTyVar tv1
trySpontaneousEqOneWay :: InertSet -> CoVar -> CtFlavor -> TcTyVar -> Xi
-> TcS (Maybe SWorkList)
-- tv is a MetaTyVar, not untouchable
--- Precondition: kind(xi) is a sub-kind of kind(tv)
trySpontaneousEqOneWay inerts cv gw tv xi
- | not (isSigTyVar tv) || isTyVarTy xi
+ | not (isSigTyVar tv) || isTyVarTy xi,
+ typeKind xi `isSubKind` tyVarKind tv
= solveWithIdentity inerts cv gw tv xi
| otherwise
= return Nothing
-- Both tyvars are *touchable* MetaTyvars
-- By the CTyEqCan invariant, k2 `isSubKind` k1
trySpontaneousEqTwoWay inerts cv gw tv1 tv2
- | k1 `eqKind` k2
+ | k1 `isSubKind` k2
, nicer_to_update_tv2 = solveWithIdentity inerts cv gw tv2 (mkTyVarTy tv1)
- | otherwise = ASSERT( k2 `isSubKind` k1 )
- solveWithIdentity inerts cv gw tv1 (mkTyVarTy tv2)
+ | k2 `isSubKind` k1
+ = solveWithIdentity inerts cv gw tv1 (mkTyVarTy tv2)
+ | otherwise = return Nothing
where
k1 = tyVarKind tv1
k2 = tyVarKind tv2
nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
\end{code}
+
+Note [Spontaneous solving and kind compatibility]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Note that our canonical constraints insist that only *given* equalities (tv ~ xi)
+or (F xis ~ rhs) require the LHS and the RHS to have exactly the same kinds.
+
+ - We have to require this because:
+ Given equalities can be freely used to rewrite inside
+ other types or constraints.
+ - We do not have to do the same for wanteds because:
+ First, wanted equations (tv ~ xi) where tv is a touchable unification variable
+ may have kinds that do not agree (the kind of xi must be a sub kind of the kind of tv).
+ Second, any potential kind mismatch will result in the constraint not being soluble,
+ which will be reported anyway. This is the reason that @trySpontaneousOneWay@ and
+ @trySpontaneousTwoWay@ will perform a kind compatibility check, and only then will
+ they proceed to @solveWithIdentity@.
+
+Caveat:
+ - Givens from higher-rank, such as:
+ type family T b :: * -> * -> *
+ type instance T Bool = (->)
+
+ f :: forall a. ((T a ~ (->)) => ...) -> a -> ...
+ flop = f (...) True
+ Whereas we would be able to apply the type instance, we would not be able to
+ use the given (T Bool ~ (->)) in the body of 'flop'
+
Note [Loopy spontaneous solving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the original wanted:
-> TcS (Maybe SWorkList)
-- Solve with the identity coercion
-- Precondition: kind(xi) is a sub-kind of kind(tv)
--- Precondition: CtFlavor is not Given
--- See [New Wanted Superclass Work] to see why we do this for *given* as well
+-- Precondition: CtFlavor is Wanted or Derived
+-- See [New Wanted Superclass Work] to see why solveWithIdentity
+-- must work for Derived as well as Wanted
solveWithIdentity inerts cv gw tv xi
- = do { tybnds <- getTcSTyBindsBag
+ = do { tybnds <- getTcSTyBindsMap
; case occurCheck tybnds inerts tv xi of
Nothing -> return Nothing
Just (xi_unflat,coi) -> solve_with xi_unflat coi }
-- See Note [Avoid double unifications]
; return (Just cts) }
-occurCheck :: Bag (TcTyVar, TcType) -> InertSet
+occurCheck :: VarEnv (TcTyVar, TcType) -> InertSet
-> TcTyVar -> TcType -> Maybe (TcType,CoercionI)
-- Traverse @ty@ to make sure that @tv@ does not appear under some flatten skolem.
-- If it appears under some flatten skolem look in that flatten skolem equivalence class
-- coi :: ty' ~ ty
-- NB: The returned type ty' may not be flat!
-occurCheck ty_binds_bag inerts tv ty
- = ok emptyVarSet ty
+occurCheck ty_binds inerts the_tv the_ty
+ = ok emptyVarSet the_ty
where
+ -- If (fsk `elem` bad) then tv occurs in any rendering
+ -- of the type under the expansion of fsk
ok bad this_ty@(TyConApp tc tys)
| Just tys_cois <- allMaybes (map (ok bad) tys)
, (tys',cois') <- unzip tys_cois
= Just (ForAllTy tv1 ty1', mkForAllTyCoI tv1 coi)
-- Variable cases
- ok _bad this_ty@(TyVarTy tv')
- | not $ isTcTyVar tv' = Just (this_ty, IdCo this_ty) -- Bound variable
- | tv == tv' = Nothing -- Occurs check error
-
- ok bad (TyVarTy fsk)
- | FlatSkol zty <- tcTyVarDetails fsk
- = if fsk `elemVarSet` bad then
- -- its type has been checked
- go_down_eq_class bad $ getFskEqClass inerts fsk
- else
- -- its type is not yet checked
- case ok bad zty of
- Nothing -> go_down_eq_class (bad `extendVarSet` fsk) $
- getFskEqClass inerts fsk
- Just (zty',ico) -> Just (zty',ico)
+ ok bad this_ty@(TyVarTy tv)
+ | tv == the_tv = Nothing -- Occurs check error
+ | not (isTcTyVar tv) = Just (this_ty, IdCo this_ty) -- Bound var
+ | FlatSkol zty <- tcTyVarDetails tv = ok_fsk bad tv zty
+ | Just (_,ty) <- lookupVarEnv ty_binds tv = ok bad ty
+ | otherwise = Just (this_ty, IdCo this_ty)
-- Check if there exists a ty bind already, as a result of sneaky unification.
- ok bad this_ty@(TyVarTy tv0)
- = case Bag.foldlBag find_bind Nothing ty_binds_bag of
- Nothing -> Just (this_ty, IdCo this_ty)
- Just ty0 -> ok bad ty0
- where find_bind Nothing (tvx,tyx) | tv0 == tvx = Just tyx
- find_bind m _ = m
-- Fall through
ok _bad _ty = Nothing
+ -----------
ok_pred bad (ClassP cn tys)
| Just tys_cois <- allMaybes $ map (ok bad) tys
= let (tys', cois') = unzip tys_cois
= Just (EqPred ty1' ty2', mkEqPredCoI coi1 coi2)
ok_pred _ _ = Nothing
- go_down_eq_class _bad_tvs [] = Nothing
- go_down_eq_class bad_tvs ((fsk1,co1):rest)
- | fsk1 `elemVarSet` bad_tvs = go_down_eq_class bad_tvs rest
- | otherwise
- = case ok bad_tvs (TyVarTy fsk1) of
- Nothing -> go_down_eq_class (bad_tvs `extendVarSet` fsk1) rest
- Just (ty1,co1i') -> Just (ty1, mkTransCoI co1i' (ACo co1))
+ -----------
+ ok_fsk bad fsk zty
+ | fsk `elemVarSet` bad
+ -- We are already trying to find a rendering of fsk,
+ -- and to do that it seems we need a rendering, so fail
+ = Nothing
+ | otherwise
+ = firstJusts (ok new_bad zty : map (go_under_fsk new_bad) fsk_equivs)
+ where
+ fsk_equivs = getFskEqClass inerts fsk
+ new_bad = bad `extendVarSetList` (fsk : map fst fsk_equivs)
+
+ -----------
+ go_under_fsk bad_tvs (fsk,co)
+ | FlatSkol zty <- tcTyVarDetails fsk
+ = case ok bad_tvs zty of
+ Nothing -> Nothing
+ Just (ty,coi') -> Just (ty, mkTransCoI coi' (ACo co))
+ | otherwise = pprPanic "go_down_equiv" (ppr fsk)
\end{code}
, cc_tyargs = args1, cc_rhs = xi1 })
workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2 })
- | fl1 `canRewrite` fl2 && lhss_match
+ | fl1 `canSolve` fl2 && lhss_match
= do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
; mkIRStop KeepInert cans }
- | fl2 `canRewrite` fl1 && lhss_match
+ | fl2 `canSolve` fl1 && lhss_match
= do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue workItem DropInert cans }
where
inert@(CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 })
workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 })
-- Check for matching LHS
- | fl1 `canRewrite` fl2 && tv1 == tv2
+ | fl1 `canSolve` fl2 && tv1 == tv2
= do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
; mkIRStop KeepInert cans }
- | fl2 `canRewrite` fl1 && tv1 == tv2
+ | fl2 `canSolve` fl1 && tv1 == tv2
= do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue workItem DropInert cans }
-- Fall-through case for all other situations
doInteractWithInert _ workItem = noInteraction workItem
---------------------------------------------
-combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
--- Precondition: At least one of them should be wanted
-combineCtLoc (Wanted loc) _ = loc
-combineCtLoc _ (Wanted loc) = loc
-combineCtLoc _ _ = panic "Expected one of wanted constraints (BUG)"
-
-
+-------------------------
-- Equational Rewriting
rewriteDict :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt
rewriteDict (cv,tv,xi) (dv,gw,cl,xis)
-- 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
+-- Where the cv1 `canSolve` cv2 equality
-- 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:
| isDerived ifl && isDerived wfl
= noInteraction workItem
- | ifl `canRewrite` wfl
+ | ifl `canSolve` 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
+ | otherwise -- wfl `canSolve` ifl
= do { unless (isGiven ifl) $ setEvBind iid (EvId wid)
; mkIRContinue workItem DropInert emptyCCan }
Now suppose that we have:
given: C a b
wanted: C a beta
- By interacting the given we will get that (F a ~ b) which is not
+ By interacting the given we will get given (F a ~ b) which is not
enough by itself to make us discharge (C a beta). However, we
- may create a new given equality from the super-class that we promise
- to solve: (F a ~ beta). Now we may interact this with the rest of
- constraint to finally get:
- given : beta ~ b
-
+ may create a new derived equality from the super-class of the
+ wanted constraint (C a beta), namely derived (F a ~ beta).
+ Now we may interact this with given (F a ~ b) to get:
+ derived : beta ~ b
But 'beta' is a touchable unification variable, and hence OK to
- unify it with 'b', replacing the given evidence with the identity.
+ unify it with 'b', replacing the derived evidence with the identity.
- This requires trySpontaneousSolve to solve given equalities that
- have a touchable in their RHS, *in addition* to solving wanted
- equalities.
+ This requires trySpontaneousSolve to solve *derived*
+ equalities that have a touchable in their RHS, *in addition*
+ to solving wanted equalities.
Here is another example where this is useful.
projects / ghc-hetmet.git / blobdiff