X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=57e91251d284d54d06cc64e5c7b6f1dc7fe3ab0c;hb=b3e722e9ff0aeedceeeeacc67d61e11a5ee5b92a;hp=546d96e3a56113705cda177d52cbba9cff18ea27;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 546d96e..57e9125 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -676,7 +676,7 @@ floatEqualities :: TcTyVarSet -> [EvVar] -> CanonicalCts -> (CanonicalCts, CanonicalCts) floatEqualities skols can_given wanteds | hasEqualities can_given = (emptyBag, wanteds) - | otherwise = partitionBag is_floatable wanteds + | otherwise = partitionBag is_floatable wanteds where is_floatable :: CanonicalCt -> Bool is_floatable (CTyEqCan { cc_tyvar = tv, cc_rhs = ty }) @@ -787,7 +787,8 @@ defaultTyVar untch the_tv , not (the_tv `elemVarSet` untch) , not (k `eqKind` default_k) = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k - ; let loc = CtLoc TypeEqOrigin (getSrcSpan the_tv) [] -- Yuk + ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk + -- 'DefaultOrigin' is strictly the declaration, but it's convenient wanted_eq = CTyEqCan { cc_id = ev , cc_flavor = Wanted loc , cc_tyvar = the_tv @@ -816,7 +817,7 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries) where unaries :: [(CanonicalCt, TcTyVar)] -- (C tv) constraints - non_unaries :: [CanonicalCt] -- *other* constraints + non_unaries :: [CanonicalCt] -- and *other* constraints (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds) -- Finds unary type-class constraints