Commit e9e413ec authored by Joachim Breitner's avatar Joachim Breitner

Large refactor: Move CtLoc field from Ct to CtEvidence

parent b6b5c417
......@@ -83,7 +83,8 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred
= do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred
; emitFlat (mkNonCanonical loc (CtWanted { ctev_pred = pred, ctev_evar = ev }))
; emitFlat $ mkNonCanonical $
CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -568,8 +569,7 @@ tidyCt env ct
= case ct of
CHoleCan { cc_ev = ev }
-> ct { cc_ev = tidy_ev env ev }
_ -> CNonCanonical { cc_ev = tidy_ev env (cc_ev ct)
, cc_loc = cc_loc ct }
_ -> mkNonCanonical (tidy_ev env (ctEvidence ct))
where
tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evtm/var field because we don't
......
This diff is collapsed.
......@@ -337,7 +337,7 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
where
cmp_loc ct1 ct2 = ctLocSpan (cc_loc ct1) `compare` ctLocSpan (cc_loc ct2)
cmp_loc ct1 ct2 = ctLocSpan (ctev_loc (ctEvidence ct1)) `compare` ctLocSpan (ctev_loc (ctEvidence ct2))
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM ()
......@@ -361,7 +361,7 @@ maybeReportError ctxt err
maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
maybeAddDeferredBinding ctxt err ct
| CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
| CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
-- Only add deferred bindings for Wanted constraints
, isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors
, Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings
......@@ -418,13 +418,13 @@ pprWithArising (ct:cts)
| otherwise
= (loc, vcat (map ppr_one (ct:cts)))
where
loc = cc_loc ct
loc = ctev_loc (ctEvidence ct)
ppr_one ct = hang (parens (pprType (ctPred ct)))
2 (pprArisingAt (cc_loc ct))
2 (pprArisingAt (ctev_loc (ctEvidence ct)))
mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
mkErrorMsg ctxt ct msg
= do { let tcl_env = ctLocEnv (cc_loc ct)
= do { let tcl_env = ctLocEnv (ctev_loc (ctEvidence ct))
; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
; mkLongErrAt (tcl_loc tcl_env) msg err_info }
......@@ -518,7 +518,7 @@ mkIrredErr ctxt cts
; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
where
(ct1:_) = cts
orig = ctLocOrigin (cc_loc ct1)
orig = ctLocOrigin (ctev_loc (ctEvidence ct1))
givens = getUserGivens ctxt
msg = couldNotDeduce givens (map ctPred cts, orig)
......@@ -528,7 +528,7 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
= do { let tyvars = varSetElems (tyVarsOfCt ct)
tyvars_msg = map loc_msg tyvars
msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
2 (ptext (sLit "with type:") <+> pprType (ctEvPred (cc_ev ct)))
2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
, ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
; (ctxt, binds_doc) <- relevantBindings False ctxt ct
-- The 'False' means "don't filter the bindings; see Trac #8191
......@@ -551,7 +551,7 @@ mkIPErr ctxt cts
; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
where
(ct1:_) = cts
orig = ctLocOrigin (cc_loc ct1)
orig = ctLocOrigin (ctev_loc (ctEvidence ct1))
preds = map ctPred cts
givens = getUserGivens ctxt
msg | null givens
......@@ -602,25 +602,26 @@ mkEqErr1 ctxt ct
; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
; dflags <- getDynFlags
; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
(ct { cc_loc = given_loc}) -- Note [Inaccessible code]
(ct { cc_ev = ev {ctev_loc = given_loc}}) -- Note [Inaccessible code]
Nothing ty1 ty2 }
| otherwise -- Wanted or derived
= do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct))
; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin loc)
; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
; dflags <- getDynFlags
; mkEqErr_help dflags ctxt (wanted_msg $$ binds_msg)
ct is_oriented ty1 ty2 }
where
ev = cc_ev ct
ev = ctEvidence ct
loc = ctev_loc ev
(ty1, ty2) = getEqPredTys (ctEvPred ev)
mk_given :: [Implication] -> (CtLoc, SDoc)
-- For given constraints we overwrite the env (and hence src-loc)
-- with one from the implication. See Note [Inaccessible code]
mk_given [] = (cc_loc ct, empty)
mk_given (implic : _) = (setCtLocEnv (cc_loc ct) (ic_env implic)
mk_given [] = (loc, empty)
mk_given (implic : _) = (setCtLocEnv loc (ic_env implic)
, hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ic_info implic)))
......@@ -993,7 +994,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
| otherwise
= return (ctxt, safe_haskell_msg)
where
orig = ctLocOrigin (cc_loc ct)
orig = ctLocOrigin (ctev_loc (ctEvidence ct))
pred = ctPred ct
(clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches]
......@@ -1324,7 +1325,7 @@ relevantBindings want_filtering ctxt ct
else do { traceTc "rb" doc
; return (ctxt { cec_tidy = tidy_env' }, doc) } }
where
lcl_env = ctLocEnv (cc_loc ct)
lcl_env = ctLocEnv (ctev_loc (ctEvidence ct))
ct_tvs = tyVarsOfCt ct
run_out :: Maybe Int -> Bool
......@@ -1396,16 +1397,16 @@ are created by in RtClosureInspect.zonkRTTIType.
%************************************************************************
\begin{code}
solverDepthErrorTcS :: SubGoalCounter -> Ct -> TcM a
solverDepthErrorTcS cnt ct
solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a
solverDepthErrorTcS cnt ev
= setCtLoc loc $
do { pred <- zonkTcType (ctPred ct)
do { pred <- zonkTcType (ctEvPred ev)
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType pred)
tidy_pred = tidyType tidy_env pred
; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
where
loc = cc_loc ct
loc = ctev_loc ev
depth = ctLocDepth loc
value = subGoalCounterValue cnt depth
msg CountConstraints =
......
......@@ -137,7 +137,7 @@ tcHole occ res_ty
; name <- newSysName occ
; let ev = mkLocalId name ty
; loc <- getCtLoc HoleOrigin
; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc, cc_occ = occ }
; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ }
; emitInsoluble can
; tcWrapResult (HsVar ev) ty res_ty }
\end{code}
......
This diff is collapsed.
......@@ -170,9 +170,10 @@ newFlatWanteds orig theta
where
inst_to_wanted loc pty
= do { v <- newWantedEvVar pty
; return $ mkNonCanonical loc $
; return $ mkNonCanonical $
CtWanted { ctev_evar = v
, ctev_pred = pty } }
, ctev_pred = pty
, ctev_loc = loc } }
\end{code}
%************************************************************************
......@@ -874,8 +875,7 @@ zonkCt ct@(CHoleCan { cc_ev = ev })
; return $ ct { cc_ev = ev' } }
zonkCt ct
= do { fl' <- zonkCtEvidence (cc_ev ct)
; return (CNonCanonical { cc_ev = fl'
, cc_loc = cc_loc ct }) }
; return (mkNonCanonical fl') }
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
......
......@@ -913,19 +913,16 @@ data Ct
= CDictCan { -- e.g. Num xi
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_class :: Class,
cc_tyargs :: [Xi],
cc_loc :: CtLoc
cc_tyargs :: [Xi]
}
| CIrredEvCan { -- These stand for yet-unusable predicates
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_ev :: CtEvidence -- See Note [Ct/evidence invariant]
-- The ctev_pred of the evidence is
-- of form (tv xi1 xi2 ... xin)
-- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails
-- or (F tys ~ ty) where the CFunEqCan kind invariant fails
-- See Note [CIrredEvCan constraints]
cc_loc :: CtLoc
}
| CTyEqCan { -- tv ~ xi (recall xi means function free)
......@@ -936,8 +933,7 @@ data Ct
-- * We prefer unification variables on the left *JUST* for efficiency
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_tyvar :: TcTyVar,
cc_rhs :: Xi,
cc_loc :: CtLoc
cc_rhs :: Xi
}
| CFunEqCan { -- F xis ~ xi
......@@ -947,21 +943,17 @@ data Ct
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_fun :: TyCon, -- A type function
cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated
cc_rhs :: Xi, -- *never* over-saturated (because if so
cc_rhs :: Xi -- *never* over-saturated (because if so
-- we should have decomposed)
cc_loc :: CtLoc
}
| CNonCanonical { -- See Note [NonCanonical Semantics]
cc_ev :: CtEvidence,
cc_loc :: CtLoc
cc_ev :: CtEvidence
}
| CHoleCan { -- Treated as an "insoluble" constraint
-- See Note [Insoluble constraints]
cc_ev :: CtEvidence,
cc_loc :: CtLoc,
cc_occ :: OccName -- The name of this hole
}
\end{code}
......@@ -1039,11 +1031,11 @@ the evidence may *not* be fully zonked; we are careful not to look at it
during constraint solving. See Note [Evidence field of CtEvidence]
\begin{code}
mkNonCanonical :: CtLoc -> CtEvidence -> Ct
mkNonCanonical loc ev = CNonCanonical { cc_ev = ev, cc_loc = loc }
mkNonCanonical :: CtEvidence -> Ct
mkNonCanonical ev = CNonCanonical { cc_ev = ev }
mkNonCanonicalCt :: Ct -> Ct
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_loc = cc_loc ct }
mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }
ctEvidence :: Ct -> CtEvidence
ctEvidence = cc_ev
......@@ -1384,15 +1376,18 @@ may be un-zonked.
\begin{code}
data CtEvidence
= CtGiven { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
, ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence]
, ctev_evtm :: EvTerm -- See Note [Evidence field of CtEvidence]
, ctev_loc :: CtLoc }
-- Truly given, not depending on subgoals
-- NB: Spontaneous unifications belong here
| CtWanted { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant]
, ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence]
, ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence]
, ctev_loc :: CtLoc }
-- Wanted goal
| CtDerived { ctev_pred :: TcPredType }
| CtDerived { ctev_pred :: TcPredType
, ctev_loc :: CtLoc }
-- A goal that we don't really have to solve and can't immediately
-- rewrite anything other than a derived (there's no evidence!)
-- but if we do manage to solve it may help in solving other goals.
......
......@@ -627,7 +627,8 @@ prepareInertsForImplications is
where
ev = ctEvidence funeq
given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev)
, ctev_pred = ctev_pred ev }
, ctev_pred = ctev_pred ev
, ctev_loc = ctev_loc ev }
given_from_wanted _ fhm = fhm -- Drop derived constraints
......@@ -1034,9 +1035,10 @@ traceFireTcS ct doc
do { dflags <- getDynFlags
; when (dopt Opt_D_dump_cs_trace dflags && traceLevel dflags >= 1) $
do { n <- TcM.readTcRef (tcs_count env)
; let msg = int n <> brackets (ppr (ctLocDepth (cc_loc ct)))
<+> ppr (ctEvidence ct) <> colon <+> doc
; let msg = int n <> brackets (ppr (ctLocDepth (ctev_loc ev)))
<+> ppr ev <> colon <+> doc
; TcM.debugDumpTcRn msg } }
where ev = cc_ev ct
runTcS :: TcS a -- What to run
-> TcM (a, Bag EvBind)
......@@ -1421,7 +1423,8 @@ newFlattenSkolem ev fam_ty
; let rhs_ty = mkTyVarTy tv
ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty
, ctev_evtm = EvCoercion (mkTcReflCo fam_ty) }
, ctev_evtm = EvCoercion (mkTcReflCo fam_ty)
, ctev_loc = ctev_loc ev }
; dflags <- getDynFlags
; updInertTcS $ \ is@(IS { inert_fsks = fsks }) ->
extendFlatCache dflags fam_ty ctev rhs_ty
......@@ -1431,7 +1434,7 @@ newFlattenSkolem ev fam_ty
| otherwise -- Wanted or Derived: make new unification variable
= do { rhs_ty <- newFlexiTcSTy (typeKind fam_ty)
; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_ty)
; ctev <- newWantedEvVarNC (ctev_loc ev) (mkTcEqPred fam_ty rhs_ty)
-- NC (no-cache) version because we've already
-- looked in the solved goals an inerts (lookupFlatEqn)
; dflags <- getDynFlags
......@@ -1531,43 +1534,43 @@ setEvBind the_ev tm
; tc_evbinds <- getTcEvBinds
; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm }
newGivenEvVar :: TcPredType -> EvTerm -> TcS CtEvidence
newGivenEvVar :: CtLoc -> TcPredType -> EvTerm -> TcS CtEvidence
-- Make a new variable of the given PredType,
-- immediately bind it to the given term
-- and return its CtEvidence
newGivenEvVar pred rhs
newGivenEvVar loc pred rhs
= do { new_ev <- wrapTcS $ TcM.newEvVar pred
; setEvBind new_ev rhs
; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) }
; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) }
newWantedEvVarNC :: TcPredType -> TcS CtEvidence
newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence
-- Don't look up in the solved/inerts; we know it's not there
newWantedEvVarNC pty
newWantedEvVarNC loc pty
= do { new_ev <- wrapTcS $ TcM.newEvVar pty
; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })}
; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc })}
newWantedEvVar :: TcPredType -> TcS MaybeNew
newWantedEvVar pty
newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew
newWantedEvVar loc pty
= do { mb_ct <- lookupInInerts pty
; case mb_ct of
Just ctev | not (isDerived ctev)
-> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
; return (Cached (ctEvTerm ctev)) }
_ -> do { ctev <- newWantedEvVarNC pty
_ -> do { ctev <- newWantedEvVarNC loc pty
; traceTcS "newWantedEvVar/cache miss" $ ppr ctev
; return (Fresh ctev) } }
newDerived :: TcPredType -> TcS (Maybe CtEvidence)
newDerived :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
-- Returns Nothing if cached,
-- Just pred if not cached
newDerived pty
newDerived loc pty
= do { mb_ct <- lookupInInerts pty
; return (case mb_ct of
Just {} -> Nothing
Nothing -> Just (CtDerived { ctev_pred = pty })) }
Nothing -> Just (CtDerived { ctev_pred = pty, ctev_loc = loc })) }
instDFunConstraints :: TcThetaType -> TcS [MaybeNew]
instDFunConstraints = mapM newWantedEvVar
instDFunConstraints :: CtLoc -> TcThetaType -> TcS [MaybeNew]
instDFunConstraints loc = mapM (newWantedEvVar loc)
\end{code}
......@@ -1616,18 +1619,18 @@ xCtFlavor :: CtEvidence -- Original flavor
-> XEvTerm -- Instructions about how to manipulate evidence
-> TcS [CtEvidence]
xCtFlavor (CtGiven { ctev_evtm = tm }) ptys xev
xCtFlavor (CtGiven { ctev_evtm = tm, ctev_loc = loc }) ptys xev
= ASSERT( equalLength ptys (ev_decomp xev tm) )
zipWithM newGivenEvVar ptys (ev_decomp xev tm)
zipWithM (newGivenEvVar loc) ptys (ev_decomp xev tm)
-- See Note [Bind new Givens immediately]
xCtFlavor (CtWanted { ctev_evar = evar }) ptys xev
= do { new_evars <- mapM newWantedEvVar ptys
xCtFlavor (CtWanted { ctev_evar = evar, ctev_loc = loc }) ptys xev
= do { new_evars <- mapM (newWantedEvVar loc) ptys
; setEvBind evar (ev_comp xev (getEvTerms new_evars))
; return (freshGoals new_evars) }
xCtFlavor (CtDerived {}) ptys _xev
= do { ders <- mapM newDerived ptys
xCtFlavor (CtDerived { ctev_loc = loc }) ptys _xev
= do { ders <- mapM (newDerived loc) ptys
; return (catMaybes ders) }
-----------------------------
......@@ -1659,7 +1662,7 @@ Main purpose: create new evidence for new_pred;
-}
rewriteCtFlavor (CtDerived {}) new_pred _co
rewriteCtFlavor (CtDerived { ctev_loc = loc }) new_pred _co
= -- If derived, don't even look at the coercion.
-- This is very important, DO NOT re-order the equations for
-- rewriteCtFlavor to put the isTcReflCo test first!
......@@ -1667,7 +1670,7 @@ rewriteCtFlavor (CtDerived {}) new_pred _co
-- was produced by flattening, may contain suspended calls to
-- (ctEvTerm c), which fails for Derived constraints.
-- (Getting this wrong caused Trac #7384.)
newDerived new_pred
newDerived loc new_pred
rewriteCtFlavor old_ev new_pred co
| isTcReflCo co -- If just reflexivity then you may re-use the same variable
......@@ -1680,14 +1683,14 @@ rewriteCtFlavor old_ev new_pred co
-- However, if they *do* look the same, we'd prefer to stick with old_pred
-- then retain the old type, so that error messages come out mentioning synonyms
rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) new_pred co
= do { new_ev <- newGivenEvVar new_pred new_tm -- See Note [Bind new Givens immediately]
rewriteCtFlavor (CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co
= do { new_ev <- newGivenEvVar loc new_pred new_tm -- See Note [Bind new Givens immediately]
; return (Just new_ev) }
where
new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCast optimises ReflCo
rewriteCtFlavor (CtWanted { ctev_evar = evar }) new_pred co
= do { new_evar <- newWantedEvVar new_pred
rewriteCtFlavor (CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co
= do { new_evar <- newWantedEvVar loc new_pred
; setEvBind evar (mkEvCast (getEvTerm new_evar) co)
; case new_evar of
Fresh ctev -> return (Just ctev)
......@@ -1741,13 +1744,13 @@ deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2)
phi1 = Type.substTy subst1 body1
phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2
skol_info = UnifyForAllSkol skol_tvs phi1
; mev <- newWantedEvVar (mkTcEqPred phi1 phi2)
; mev <- newWantedEvVar loc (mkTcEqPred phi1 phi2)
; coe_inside <- case mev of
Cached ev_tm -> return (evTermCoercion ev_tm)
Fresh ctev -> do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds
; env <- wrapTcS $ TcM.getLclEnv
; let ev_binds = TcEvBinds ev_binds_var
new_ct = mkNonCanonical loc ctev
new_ct = mkNonCanonical ctev
new_co = evTermCoercion (ctEvTerm ctev)
new_untch = pushUntouchables (tcl_untch env)
; let wc = WC { wc_flat = singleCt new_ct
......
......@@ -539,9 +539,10 @@ uType, uType_defer
uType_defer origin ty1 ty2
= do { eqv <- newEq ty1 ty2
; loc <- getCtLoc origin
; let ctev = CtWanted { ctev_evar = eqv
, ctev_pred = mkTcEqPred ty1 ty2 }
; emitFlat $ mkNonCanonical loc ctev
; emitFlat $ mkNonCanonical $
CtWanted { ctev_evar = eqv
, ctev_pred = mkTcEqPred ty1 ty2
, ctev_loc = loc }
-- Error trace only
-- NB. do *not* call mkErrInfo unless tracing is on, because
......
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