[commit: ghc] wip/T8503: Add ctLoc = ctev_loc . cc_ev (664da20)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T8503
Link       : http://ghc.haskell.org/trac/ghc/changeset/664da205db7393991fe84d48082542072a967788/ghc

>---------------------------------------------------------------

commit 664da205db7393991fe84d48082542072a967788
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Nov 22 08:38:10 2013 +0000

    Add ctLoc = ctev_loc . cc_ev


>---------------------------------------------------------------

664da205db7393991fe84d48082542072a967788
 compiler/typecheck/TcErrors.lhs   |   18 +++++++++---------
 compiler/typecheck/TcInteract.lhs |    6 +++---
 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 a89cf7c..018483b 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 d623caf..a21f0e0 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 6cb29bf..aca4927 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,
@@ -1036,6 +1037,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)