Commit 453e0ce0 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Modest refactoring in TcCanonical (and TcSMonad)

parent 7fdcf2c7
......@@ -247,20 +247,15 @@ canClassNC d ev cls tys
`andWhenContinue` emitSuperclasses
canClass d ev cls tys
= do { -- sctx <- getTcSContext
; (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys
= do { (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys
; let co = mkTcTyConAppCo (classTyCon cls) cos
xi = mkClassPred cls xis
; mb <- rewriteCtFlavor ev xi co
; case mb of
Just new_ev ->
let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_ev)
in continueWith $
CDictCan { cc_ev = new_ev, cc_loc = d
, cc_tyargs = xis_for_dict, cc_class = cls }
Nothing -> return Stop }
Nothing -> return Stop
Just new_ev -> continueWith $
CDictCan { cc_ev = new_ev, cc_loc = d
, cc_tyargs = xis, cc_class = cls } }
emitSuperclasses :: Ct -> TcS StopOrContinue
emitSuperclasses ct@(CDictCan { cc_loc = d, cc_ev = ev
......@@ -567,24 +562,22 @@ flatten loc f ctxt (TyConApp tc tys)
, cc_tyargs = xi_args
, cc_rhs = rhs_ty
, cc_loc = loc }
; updWorkListTcS $ extendWorkListEq ct
; updWorkListTcS $ extendWorkListFunEq ct
; return (co, rhs_ty) }
| otherwise -- Wanted or Derived: make new unification variable
-> do { traceTcS "flatten/flat-cache miss" $ empty
; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
; let pred = mkTcEqPred fam_ty rhs_xi_var
; mw <- newWantedEvVar pred
; case mw of
Fresh ctev ->
do { let ct = CFunEqCan { cc_ev = ctev
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_xi_var
, cc_loc = loc }
; updWorkListTcS $ extendWorkListEq ct
; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) }
Cached {} -> panic "flatten TyConApp, var must be fresh!" }
; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_xi_var)
-- NC (no-cache) version because we've already
-- looked in the solved goals an inerts (lookupFlatEqn)
; let ct = CFunEqCan { cc_ev = ctev
, cc_fun = tc
, cc_tyargs = xi_args
, cc_rhs = rhs_xi_var
, cc_loc = loc }
; updWorkListTcS $ extendWorkListFunEq ct
; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) }
}
-- Emit the flat constraints
; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable
......@@ -1149,7 +1142,7 @@ canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2
Nothing -> return Stop ;
Just new_ev
| isTcReflCo xco -> continueWith new_ct
| otherwise -> do { updWorkListTcS (extendWorkListEq new_ct); return Stop }
| otherwise -> do { updWorkListTcS (extendWorkListFunEq new_ct); return Stop }
where
new_ct = CFunEqCan { cc_ev = new_ev, cc_loc = loc
, cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } }
......
......@@ -13,7 +13,8 @@ module TcSMonad (
WorkList(..), isEmptyWorkList, emptyWorkList,
workListFromEq, workListFromNonEq, workListFromCt,
extendWorkListEq, extendWorkListNonEq, extendWorkListCt,
extendWorkListEq, extendWorkListFunEq,
extendWorkListNonEq, extendWorkListCt,
extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem,
withWorkList,
......@@ -46,7 +47,7 @@ module TcSMonad (
xCtFlavor, -- Transform a CtEvidence during a step
rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions
newWantedEvVar, instDFunConstraints,
newWantedEvVar, newWantedEvVarNC, instDFunConstraints,
newDerived,
-- Creation of evidence variables
......@@ -237,10 +238,14 @@ extendWorkListEq :: Ct -> WorkList -> WorkList
-- Extension by equality
extendWorkListEq ct wl
| Just {} <- isCFunEqCan_Maybe ct
= wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
= extendWorkListFunEq ct wl
| otherwise
= wl { wl_eqs = ct : wl_eqs wl }
extendWorkListFunEq :: Ct -> WorkList -> WorkList
extendWorkListFunEq ct wl
= wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
extendWorkListEqs :: [Ct] -> WorkList -> WorkList
-- Append a list of equalities
extendWorkListEqs cts wl = foldr extendWorkListEq wl cts
......@@ -1404,6 +1409,12 @@ newGivenEvVar pred rhs
; setEvBind new_ev rhs
; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) }
newWantedEvVarNC :: TcPredType -> TcS CtEvidence
-- Don't look up in the solved/inerts; we know it's not there
newWantedEvVarNC pty
= do { new_ev <- wrapTcS $ TcM.newEvVar pty
; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })}
newWantedEvVar :: TcPredType -> TcS MaybeNew
newWantedEvVar pty
= do { mb_ct <- lookupInInerts pty
......@@ -1411,10 +1422,8 @@ newWantedEvVar pty
Just ctev | not (isDerived ctev)
-> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
; return (Cached (ctEvTerm ctev)) }
_ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty
; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev
; let ctev = CtWanted { ctev_pred = pty
, ctev_evar = new_ev }
_ -> do { ctev <- newWantedEvVarNC pty
; traceTcS "newWantedEvVar/cache miss" $ ppr ctev
; return (Fresh ctev) } }
newDerived :: TcPredType -> TcS (Maybe CtEvidence)
......@@ -1471,7 +1480,7 @@ See Note [Coercion evidence terms] in TcEvidence.
\begin{code}
xCtFlavor :: CtEvidence -- Original flavor
xCtFlavor :: CtEvidence -- Original flavor
-> [TcPredType] -- New predicate types
-> XEvTerm -- Instructions about how to manipulate evidence
-> TcS [CtEvidence]
......
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