diff options
author | Joachim Breitner <mail@joachim-breitner.de> | 2013-11-22 08:38:10 +0000 |
---|---|---|
committer | Joachim Breitner <mail@joachim-breitner.de> | 2013-11-22 18:01:05 +0000 |
commit | 310e7e7f6129a6220163fd95c47363e3a80e2fad (patch) | |
tree | a4bd3785a7bf3e9e0f7697ed11bf1e757b53e3c0 | |
parent | e9e413ecbcc9676d12f7de6e461ab17e56a8ced5 (diff) | |
download | haskell-310e7e7f6129a6220163fd95c47363e3a80e2fad.tar.gz |
Add ctLoc = ctev_loc . cc_ev
-rw-r--r-- | compiler/typecheck/TcErrors.lhs | 18 | ||||
-rw-r--r-- | compiler/typecheck/TcInteract.lhs | 6 | ||||
-rw-r--r-- | compiler/typecheck/TcRnTypes.lhs | 8 |
3 files changed, 18 insertions, 14 deletions
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index a89cf7cd31..018483bb82 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -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 (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 -> [Ct] -> TcM () @@ -418,13 +418,13 @@ pprWithArising (ct:cts) | otherwise = (loc, vcat (map ppr_one (ct:cts))) where - loc = ctev_loc (ctEvidence ct) - ppr_one ct = hang (parens (pprType (ctPred ct))) - 2 (pprArisingAt (ctev_loc (ctEvidence ct))) + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprArisingAt (ctLoc ct')) mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg 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) ; 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 (ctev_loc (ctEvidence ct1)) + orig = ctLocOrigin (ctLoc ct1) givens = getUserGivens ctxt msg = couldNotDeduce givens (map ctPred cts, orig) @@ -551,7 +551,7 @@ mkIPErr ctxt cts ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) } where (ct1:_) = cts - orig = ctLocOrigin (ctev_loc (ctEvidence ct1)) + orig = ctLocOrigin (ctLoc ct1) preds = map ctPred cts givens = getUserGivens ctxt msg | null givens @@ -994,7 +994,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) | otherwise = return (ctxt, safe_haskell_msg) where - orig = ctLocOrigin (ctev_loc (ctEvidence ct)) + orig = ctLocOrigin (ctLoc ct) pred = ctPred ct (clas, tys) = getClassPredTys pred ispecs = [ispec | (ispec, _) <- matches] @@ -1325,7 +1325,7 @@ relevantBindings want_filtering ctxt ct else do { traceTc "rb" doc ; return (ctxt { cec_tidy = tidy_env' }, doc) } } where - lcl_env = ctLocEnv (ctev_loc (ctEvidence ct)) + lcl_env = ctLocEnv (ctLoc ct) ct_tvs = tyVarsOfCt ct run_out :: Maybe Int -> Bool diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 36d0c09c38..685eeb462a 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -153,7 +153,7 @@ selectNextWorkItem max_depth (Nothing,_) -> (NoWorkRemaining,wl) -- No more work (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) (Just ct, new_wl) -> (NextWorkItem ct, new_wl) -- New workitem and worklist @@ -410,8 +410,8 @@ interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) addFunDepWork :: Ct -> Ct -> TcS () addFunDepWork work_ct inert_ct - = do { let work_loc = ctev_loc (ctEvidence work_ct) - inert_loc = ctev_loc (ctEvidence inert_ct) + = do { let work_loc = ctLoc work_ct + inert_loc = ctLoc inert_ct inert_pred_loc = (ctPred inert_ct, pprArisingAt inert_loc) work_item_pred_loc = (ctPred work_ct, pprArisingAt work_loc) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index cc93ca975a..b00d15c7df 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -48,8 +48,9 @@ module TcRnTypes( isCDictCan_Maybe, isCFunEqCan_maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt, isHoleCt, - ctEvidence, mkNonCanonical, mkNonCanonicalCt, - ctPred, ctEvPred, ctEvTerm, ctEvId, + ctEvidence, ctLoc, ctPred, + mkNonCanonical, mkNonCanonicalCt, + ctEvPred, ctEvTerm, ctEvId, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols, @@ -1040,6 +1041,9 @@ mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } ctEvidence :: Ct -> CtEvidence ctEvidence = cc_ev +ctLoc :: Ct -> CtLoc +ctLoc = ctev_loc . cc_ev + ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] ctPred ct = ctEvPred (cc_ev ct) |