Commit 8657bb00 authored by dimitris@microsoft.com's avatar dimitris@microsoft.com
Browse files

Major pass through type checker:(1) prioritizing equalities, (2) improved...

Major pass through type checker:(1) prioritizing equalities, (2) improved Derived mechanism, (3) bugfixes
parent 98bbd9b2
......@@ -578,9 +578,8 @@ canEqLeafOriented :: CtFlavor -> CoVar
canEqLeafOriented fl cv cls1@(FunCls fn tys) s2
| let k1 = kindAppResult (tyConKind fn) tys,
let k2 = typeKind s2,
isGiven fl && not (k1 `eqKind` k2) -- Establish the kind invariant for CFunEqCan
= do { kindErrorTcS fl (unClassify cls1) s2
; return emptyCCan }
isGiven fl && not (k1 `eqKind` k2) -- Establish the kind invariant for CFunEqCan
= kindErrorTcS fl (unClassify cls1) s2 -- Eagerly fails, see Note [Kind errors] in TcInteract
| otherwise
= ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) )
do { (xis1,ccs1) <- flattenMany fl tys -- flatten type function arguments
......@@ -596,8 +595,7 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys) s2
-- and then do an occurs check.
canEqLeafOriented fl cv (VarCls tv) s2
| isGiven fl && not (k1 `eqKind` k2) -- Establish the kind invariant for CTyEqCan
= do { kindErrorTcS fl (mkTyVarTy tv) s2
; return emptyCCan }
= kindErrorTcS fl (mkTyVarTy tv) s2 -- Eagerly fails, see Note [Kind errors] in TcInteract
| otherwise
= do { (xi2,ccs2) <- flatten fl s2 -- flatten RHS
......
......@@ -644,7 +644,7 @@ warnDefaulting wanteds default_ty
%************************************************************************
\begin{code}
kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
-- If there's a kind error, we don't want to blindly say "kind error"
-- We might, say, be unifying a skolem 'a' with a type 'Int',
-- in which case that's the error to report. So we set things
......@@ -654,7 +654,9 @@ kindErrorTcS fl ty1 ty2
do { let ctxt = CEC { cec_encl = []
, cec_extra = extra
, cec_tidy = env0 }
; reportEqErr ctxt ty1 ty2 }
; reportEqErr ctxt ty1 ty2
; failM
}
misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
misMatchErrorTcS fl ty1 ty2
......@@ -719,9 +721,9 @@ flattenForAllErrorTcS fl ty _bad_eqs
\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
wrapEqErrTcS :: CtFlavor -> TcType -> TcType
-> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
......@@ -740,10 +742,10 @@ wrapEqErrTcS fl ty1 ty2 thing_inside
(ctLocOrigin loc) ty1 ty2
; thing_inside env3 ty1 ty2 extra }
; case fl of
Wanted loc -> do_wanted loc
Derived loc -> do_wanted loc
Given {} -> thing_inside env2 ty1 ty2 empty
-- We could print more info, but it
Wanted loc -> do_wanted loc
Derived loc _ -> do_wanted loc
Given {} -> thing_inside env2 ty1 ty2 empty
-- We could print more info, but it
-- seems to be coming out already
} }
where
......
This diff is collapsed.
......@@ -4,12 +4,14 @@ module TcSMonad (
-- Canonical constraints
CanonicalCts, emptyCCan, andCCan, andCCans,
singleCCan, extendCCans, isEmptyCCan, isEqCCan,
CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals,
singleCCan, extendCCans, isEmptyCCan, isTyEqCCan,
CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts,
mkWantedConstraints, deCanonicaliseWanted,
makeGivens, makeSolved,
makeGivens, makeSolvedByInst,
CtFlavor (..), isWanted, isGiven, isDerived, canRewrite, canSolve,
CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst,
DerivedOrig (..),
canRewrite, canSolve,
combineCtLoc, mkGivenFlavor,
TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0, -- Basic functionality
......@@ -43,6 +45,7 @@ module TcSMonad (
isGoodRecEv,
isTouchableMetaTyVar,
isTouchableMetaTyVar_InRange,
getDefaultInfo, getDynFlags,
......@@ -169,12 +172,12 @@ makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSko
-- The UnkSkol doesn't matter because these givens are
-- not contradictory (else we'd have rejected them already)
makeSolved :: CanonicalCt -> CanonicalCt
makeSolvedByInst :: CanonicalCt -> CanonicalCt
-- Record that a constraint is now solved
-- Wanted -> Derived
-- Given, Derived -> no-op
makeSolved ct
| Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc }
makeSolvedByInst ct
| Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc DerInst }
| otherwise = ct
mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints
......@@ -193,6 +196,13 @@ tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (
tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCanonical (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty
tyVarsOfCDict :: CanonicalCt -> TcTyVarSet
tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCDict _ct = emptyVarSet
tyVarsOfCDicts :: CanonicalCts -> TcTyVarSet
tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet
tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet
......@@ -255,10 +265,10 @@ emptyCCan = emptyBag
isEmptyCCan :: CanonicalCts -> Bool
isEmptyCCan = isEmptyBag
isEqCCan :: CanonicalCt -> Bool
isEqCCan (CTyEqCan {}) = True
isEqCCan (CFunEqCan {}) = True
isEqCCan _ = False
isTyEqCCan :: CanonicalCt -> Bool
isTyEqCCan (CTyEqCan {}) = True
isTyEqCCan (CFunEqCan {}) = False
isTyEqCCan _ = False
\end{code}
......@@ -272,16 +282,21 @@ isEqCCan _ = False
\begin{code}
data CtFlavor
= Given GivenLoc -- We have evidence for this constraint in TcEvBinds
| Derived WantedLoc -- We have evidence for this constraint in TcEvBinds;
| Derived WantedLoc DerivedOrig
-- We have evidence for this constraint in TcEvBinds;
-- *however* this evidence can contain wanteds, so
-- it's valid only provisionally to the solution of
-- these wanteds
| Wanted WantedLoc -- We have no evidence bindings for this constraint.
data DerivedOrig = DerSC | DerInst
-- Deriveds are either superclasses of other wanteds or deriveds, or partially
-- solved wanteds from instances.
instance Outputable CtFlavor where
ppr (Given _) = ptext (sLit "[Given]")
ppr (Wanted _) = ptext (sLit "[Wanted]")
ppr (Derived _) = ptext (sLit "[Derived]")
ppr (Given _) = ptext (sLit "[Given]")
ppr (Wanted _) = ptext (sLit "[Wanted]")
ppr (Derived {}) = ptext (sLit "[Derived]")
isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
......@@ -295,6 +310,14 @@ isDerived :: CtFlavor -> Bool
isDerived (Derived {}) = True
isDerived _ = False
isDerivedSC :: CtFlavor -> Bool
isDerivedSC (Derived _ DerSC) = True
isDerivedSC _ = False
isDerivedByInst :: CtFlavor -> Bool
isDerivedByInst (Derived _ DerInst) = True
isDerivedByInst _ = False
canSolve :: CtFlavor -> CtFlavor -> Bool
-- canSolve ctid1 ctid2
-- The constraint ctid1 can be used to solve ctid2
......@@ -317,16 +340,16 @@ canRewrite = canSolve
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted
combineCtLoc (Wanted loc) _ = loc
combineCtLoc _ (Wanted loc) = loc
combineCtLoc (Derived loc) _ = loc
combineCtLoc _ (Derived loc) = loc
combineCtLoc (Wanted loc) _ = loc
combineCtLoc _ (Wanted loc) = loc
combineCtLoc (Derived loc _) _ = loc
combineCtLoc _ (Derived loc _) = loc
combineCtLoc _ _ = panic "combineCtLoc: both given"
mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
mkGivenFlavor (Derived loc _) sk = Given (setCtLocOrigin loc sk)
mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
\end{code}
......@@ -585,13 +608,20 @@ pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
isTouchableMetaTyVar :: TcTyVar -> TcS Bool
isTouchableMetaTyVar tv
= case tcTyVarDetails tv of
MetaTv TcsTv _ -> return True -- See Note [Touchable meta type variables]
MetaTv {} -> do { untch <- getUntouchables
; return (inTouchableRange untch tv) }
_ -> return False
= do { untch <- getUntouchables
; return $ isTouchableMetaTyVar_InRange untch tv }
isTouchableMetaTyVar_InRange :: Untouchables -> TcTyVar -> Bool
isTouchableMetaTyVar_InRange untch tv
= case tcTyVarDetails tv of
MetaTv TcsTv _ -> True -- See Note [Touchable meta type variables]
MetaTv {} -> inTouchableRange untch tv
_ -> False
\end{code}
Note [Touchable meta type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Meta type variables allocated *by the constraint solver itself* are always
......
......@@ -210,8 +210,12 @@ simplifyInfer apply_mr tau_tvs wanted
zonked_tau_tvs `minusVarSet` gbl_tvs
(perhaps_bound, surely_free)
= partitionBag (quantifyMeWC proto_qtvs) zonked_wanted
; emitConstraints surely_free
; traceTc "sinf" (ppr proto_qtvs $$ ppr perhaps_bound $$ ppr surely_free)
; traceTc "sinf" $ vcat
[ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound
, ptext (sLit "surely_free =") <+> ppr surely_free
]
-- Now simplify the possibly-bound constraints
; (simplified_perhaps_bound, tc_binds)
......@@ -808,7 +812,7 @@ applyDefaultingRules inert wanteds
| otherwise
= do { untch <- getUntouchables
; tv_cts <- mapM (defaultTyVar untch) $
varSetElems (tyVarsOfCanonicals wanteds)
varSetElems (tyVarsOfCDicts wanteds)
; info@(_, default_tys, _) <- getDefaultInfo
; let groups = findDefaultableGroups info untch wanteds
......@@ -836,8 +840,7 @@ defaultTyVar :: Untouchables -> TcTyVar -> TcS CanonicalCts
-- whatever, because the type-class defaulting rules have yet to run.
defaultTyVar untch the_tv
| isMetaTyVar the_tv
, inTouchableRange untch the_tv
| isTouchableMetaTyVar_InRange untch the_tv
, not (k `eqKind` default_k)
= do { (ev, better_ty) <- TcSMonad.newKindConstraint the_tv default_k
; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
......@@ -887,7 +890,7 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
is_defaultable_group ds@((_,tv):_)
= isTyConableTyVar tv -- Note [Avoiding spurious errors]
&& not (tv `elemVarSet` bad_tvs)
&& inTouchableRange untch tv
&& isTouchableMetaTyVar_InRange untch tv
&& defaultable_classes [cc_class cc | (cc,_) <- ds]
is_defaultable_group [] = panic "defaultable_group"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment