[commit: ghc] wip/new-flatten-skolems-Oct14: Define ctEvLoc and ctEvCoercion, and use them (12111e4)
git at git.haskell.org
git at git.haskell.org
Thu Oct 30 12:54:44 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/new-flatten-skolems-Oct14
Link : http://ghc.haskell.org/trac/ghc/changeset/12111e4bf4d8892d49e9768a90d48ae306e61371/ghc
>---------------------------------------------------------------
commit 12111e4bf4d8892d49e9768a90d48ae306e61371
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Oct 30 09:08:23 2014 +0000
Define ctEvLoc and ctEvCoercion, and use them
>---------------------------------------------------------------
12111e4bf4d8892d49e9768a90d48ae306e61371
compiler/typecheck/TcErrors.lhs | 4 ++--
compiler/typecheck/TcRnTypes.lhs | 16 +++++++++++++---
2 files changed, 15 insertions(+), 5 deletions(-)
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 927f522..9e9e551 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -614,7 +614,7 @@ mkEqErr1 ctxt ct
ct is_oriented ty1 ty2 }
where
ev = ctEvidence ct
- loc = ctev_loc ev
+ loc = ctEvLoc ev
(ty1, ty2) = getEqPredTys (ctEvPred ev)
mk_given :: [Implication] -> (CtLoc, SDoc)
@@ -1480,7 +1480,7 @@ solverDepthErrorTcS cnt ev
tidy_pred = tidyType tidy_env pred
; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
where
- loc = ctev_loc ev
+ loc = ctEvLoc ev
depth = ctLocDepth loc
value = subGoalCounterValue cnt depth
msg CountConstraints =
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 86475e0..7e80906 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -52,7 +52,7 @@ module TcRnTypes(
isGivenCt, isHoleCt,
ctEvidence, ctLoc, ctPred,
mkNonCanonical, mkNonCanonicalCt,
- ctEvPred, ctEvTerm, ctEvId, ctEvCheckDepth,
+ ctEvPred, ctEvLoc, ctEvTerm, ctEvCoercion, ctEvId, ctEvCheckDepth,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
@@ -1114,7 +1114,7 @@ ctEvidence :: Ct -> CtEvidence
ctEvidence = cc_ev
ctLoc :: Ct -> CtLoc
-ctLoc = ctev_loc . cc_ev
+ctLoc = ctEvLoc . ctEvidence
ctPred :: Ct -> PredType
-- See Note [Ct/evidence invariant]
@@ -1480,16 +1480,26 @@ ctEvPred :: CtEvidence -> TcPredType
-- The predicate of a flavor
ctEvPred = ctev_pred
+ctEvLoc :: CtEvidence -> CtLoc
+ctEvLoc = ctev_loc
+
ctEvTerm :: CtEvidence -> EvTerm
ctEvTerm (CtGiven { ctev_evtm = tm }) = tm
ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev
ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id"
(ppr ctev)
+ctEvCoercion :: CtEvidence -> TcCoercion
+-- ctEvCoercion ev = evTermCoercion (ctEvTerm ev)
+ctEvCoercion (CtGiven { ctev_evtm = tm }) = evTermCoercion tm
+ctEvCoercion (CtWanted { ctev_evar = v }) = mkTcCoVarCo v
+ctEvCoercion ctev@(CtDerived {}) = pprPanic "ctEvCoercion: derived constraint cannot have id"
+ (ppr ctev)
+
-- | Checks whether the evidence can be used to solve a goal with the given minimum depth
ctEvCheckDepth :: SubGoalDepth -> CtEvidence -> Bool
ctEvCheckDepth _ (CtGiven {}) = True -- Given evidence has infinite depth
-ctEvCheckDepth min ev@(CtWanted {}) = min <= ctLocDepth (ctev_loc ev)
+ctEvCheckDepth min ev@(CtWanted {}) = min <= ctLocDepth (ctEvLoc ev)
ctEvCheckDepth _ ev@(CtDerived {}) = pprPanic "ctEvCheckDepth: cannot consider derived evidence" (ppr ev)
ctEvId :: CtEvidence -> TcId
More information about the ghc-commits
mailing list