Commit 310e7e7f authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Add ctLoc = ctev_loc . cc_ev

parent e9e413ec
...@@ -337,7 +337,7 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) ...@@ -337,7 +337,7 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
mkGroupReporter mk_err ctxt cts mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts) = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
where where
cmp_loc ct1 ct2 = ctLocSpan (ctev_loc (ctEvidence ct1)) `compare` ctLocSpan (ctev_loc (ctEvidence ct2)) cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM () -> [Ct] -> TcM ()
...@@ -418,13 +418,13 @@ pprWithArising (ct:cts) ...@@ -418,13 +418,13 @@ pprWithArising (ct:cts)
| otherwise | otherwise
= (loc, vcat (map ppr_one (ct:cts))) = (loc, vcat (map ppr_one (ct:cts)))
where where
loc = ctev_loc (ctEvidence ct) loc = ctLoc ct
ppr_one ct = hang (parens (pprType (ctPred ct))) ppr_one ct' = hang (parens (pprType (ctPred ct')))
2 (pprArisingAt (ctev_loc (ctEvidence ct))) 2 (pprArisingAt (ctLoc ct'))
mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
mkErrorMsg ctxt ct msg mkErrorMsg ctxt ct msg
= do { let tcl_env = ctLocEnv (ctev_loc (ctEvidence ct)) = do { let tcl_env = ctLocEnv (ctLoc ct)
; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
; mkLongErrAt (tcl_loc tcl_env) msg err_info } ; mkLongErrAt (tcl_loc tcl_env) msg err_info }
...@@ -518,7 +518,7 @@ mkIrredErr ctxt cts ...@@ -518,7 +518,7 @@ mkIrredErr ctxt cts
; mkErrorMsg ctxt ct1 (msg $$ binds_msg) } ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
where where
(ct1:_) = cts (ct1:_) = cts
orig = ctLocOrigin (ctev_loc (ctEvidence ct1)) orig = ctLocOrigin (ctLoc ct1)
givens = getUserGivens ctxt givens = getUserGivens ctxt
msg = couldNotDeduce givens (map ctPred cts, orig) msg = couldNotDeduce givens (map ctPred cts, orig)
...@@ -551,7 +551,7 @@ mkIPErr ctxt cts ...@@ -551,7 +551,7 @@ mkIPErr ctxt cts
; mkErrorMsg ctxt ct1 (msg $$ bind_msg) } ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
where where
(ct1:_) = cts (ct1:_) = cts
orig = ctLocOrigin (ctev_loc (ctEvidence ct1)) orig = ctLocOrigin (ctLoc ct1)
preds = map ctPred cts preds = map ctPred cts
givens = getUserGivens ctxt givens = getUserGivens ctxt
msg | null givens msg | null givens
...@@ -994,7 +994,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) ...@@ -994,7 +994,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
| otherwise | otherwise
= return (ctxt, safe_haskell_msg) = return (ctxt, safe_haskell_msg)
where where
orig = ctLocOrigin (ctev_loc (ctEvidence ct)) orig = ctLocOrigin (ctLoc ct)
pred = ctPred ct pred = ctPred ct
(clas, tys) = getClassPredTys pred (clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches] ispecs = [ispec | (ispec, _) <- matches]
...@@ -1325,7 +1325,7 @@ relevantBindings want_filtering ctxt ct ...@@ -1325,7 +1325,7 @@ relevantBindings want_filtering ctxt ct
else do { traceTc "rb" doc else do { traceTc "rb" doc
; return (ctxt { cec_tidy = tidy_env' }, doc) } } ; return (ctxt { cec_tidy = tidy_env' }, doc) } }
where where
lcl_env = ctLocEnv (ctev_loc (ctEvidence ct)) lcl_env = ctLocEnv (ctLoc ct)
ct_tvs = tyVarsOfCt ct ct_tvs = tyVarsOfCt ct
run_out :: Maybe Int -> Bool run_out :: Maybe Int -> Bool
......
...@@ -153,7 +153,7 @@ selectNextWorkItem max_depth ...@@ -153,7 +153,7 @@ selectNextWorkItem max_depth
(Nothing,_) (Nothing,_)
-> (NoWorkRemaining,wl) -- No more work -> (NoWorkRemaining,wl) -- No more work
(Just ct, new_wl) (Just ct, new_wl)
| Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (ctev_loc (ctEvidence ct))) -- Depth exceeded | Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (ctLoc ct)) -- Depth exceeded
-> (MaxDepthExceeded cnt ct,new_wl) -> (MaxDepthExceeded cnt ct,new_wl)
(Just ct, new_wl) (Just ct, new_wl)
-> (NextWorkItem ct, new_wl) -- New workitem and worklist -> (NextWorkItem ct, new_wl) -- New workitem and worklist
...@@ -410,8 +410,8 @@ interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) ...@@ -410,8 +410,8 @@ interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
addFunDepWork :: Ct -> Ct -> TcS () addFunDepWork :: Ct -> Ct -> TcS ()
addFunDepWork work_ct inert_ct addFunDepWork work_ct inert_ct
= do { let work_loc = ctev_loc (ctEvidence work_ct) = do { let work_loc = ctLoc work_ct
inert_loc = ctev_loc (ctEvidence inert_ct) inert_loc = ctLoc inert_ct
inert_pred_loc = (ctPred inert_ct, pprArisingAt inert_loc) inert_pred_loc = (ctPred inert_ct, pprArisingAt inert_loc)
work_item_pred_loc = (ctPred work_ct, pprArisingAt work_loc) work_item_pred_loc = (ctPred work_ct, pprArisingAt work_loc)
......
...@@ -48,8 +48,9 @@ module TcRnTypes( ...@@ -48,8 +48,9 @@ module TcRnTypes(
isCDictCan_Maybe, isCFunEqCan_maybe, isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt, isGivenCt, isHoleCt,
ctEvidence, mkNonCanonical, mkNonCanonicalCt, ctEvidence, ctLoc, ctPred,
ctPred, ctEvPred, ctEvTerm, ctEvId, mkNonCanonical, mkNonCanonicalCt,
ctEvPred, ctEvTerm, ctEvId,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols, andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
...@@ -1040,6 +1041,9 @@ mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } ...@@ -1040,6 +1041,9 @@ mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }
ctEvidence :: Ct -> CtEvidence ctEvidence :: Ct -> CtEvidence
ctEvidence = cc_ev ctEvidence = cc_ev
ctLoc :: Ct -> CtLoc
ctLoc = ctev_loc . cc_ev
ctPred :: Ct -> PredType ctPred :: Ct -> PredType
-- See Note [Ct/evidence invariant] -- See Note [Ct/evidence invariant]
ctPred ct = ctEvPred (cc_ev ct) ctPred ct = ctEvPred (cc_ev ct)
......
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