[commit: ghc] master: Remove code that generates FunDep error message context (9d7cbbc)
git at git.haskell.org
git at git.haskell.org
Wed Dec 4 16:56:25 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/9d7cbbcf625bc103d9fd086e9fcf99cb5c4b56ea/ghc
>---------------------------------------------------------------
commit 9d7cbbcf625bc103d9fd086e9fcf99cb5c4b56ea
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Dec 4 15:47:49 2013 +0000
Remove code that generates FunDep error message context
as it seems that this code is now dead (due to
[Dropping derived constraints]) (See #8592)
>---------------------------------------------------------------
9d7cbbcf625bc103d9fd086e9fcf99cb5c4b56ea
compiler/typecheck/FunDeps.lhs | 27 +++++++++++----------------
compiler/typecheck/TcInteract.lhs | 35 ++++++-----------------------------
2 files changed, 17 insertions(+), 45 deletions(-)
diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs
index 202ef1a..1dc96aa 100644
--- a/compiler/typecheck/FunDeps.lhs
+++ b/compiler/typecheck/FunDeps.lhs
@@ -133,12 +133,10 @@ unification variables when producing the FD constraints.
Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''
\begin{code}
-type Pred_Loc = (PredType, SDoc) -- SDoc says where the Pred comes from
-
data Equation
= FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars to fresh unification vars
, fd_eqs :: [FDEq] -- and then make these equal
- , fd_pred1, fd_pred2 :: Pred_Loc } -- The Equation arose from
+ , fd_pred1, fd_pred2 :: PredType } -- The Equation arose from
-- combining these two constraints
data FDEq = FDEq { fd_pos :: Int -- We use '0' for the first position
@@ -213,14 +211,14 @@ zipAndComputeFDEqs _ _ _ = []
-- Improve a class constraint from another class constraint
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-improveFromAnother :: Pred_Loc -- Template item (usually given, or inert)
- -> Pred_Loc -- Workitem [that can be improved]
+improveFromAnother :: PredType -- Template item (usually given, or inert)
+ -> PredType -- Workitem [that can be improved]
-> [Equation]
-- Post: FDEqs always oriented from the other to the workitem
-- Equations have empty quantified variables
-improveFromAnother pred1@(ty1, _) pred2@(ty2, _)
- | Just (cls1, tys1) <- getClassPredTys_maybe ty1
- , Just (cls2, tys2) <- getClassPredTys_maybe ty2
+improveFromAnother pred1 pred2
+ | Just (cls1, tys1) <- getClassPredTys_maybe pred1
+ , Just (cls2, tys2) <- getClassPredTys_maybe pred2
, tys1 `lengthAtLeast` 2 && cls1 == cls2
= [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 }
| let (cls_tvs, cls_fds) = classTvsFds cls1
@@ -243,15 +241,15 @@ pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })
nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | (FDEq _ t1 t2) <- pairs])]
improveFromInstEnv :: (InstEnv,InstEnv)
- -> Pred_Loc
+ -> PredType
-> [Equation] -- Needs to be an Equation because
-- of quantified variables
-- Post: Equations oriented from the template (matching instance) to the workitem!
-improveFromInstEnv _inst_env (pred,_loc)
+improveFromInstEnv _inst_env pred
| not (isClassPred pred)
= panic "improveFromInstEnv: not a class predicate"
-improveFromInstEnv inst_env pred@(ty, _)
- | Just (cls, tys) <- getClassPredTys_maybe ty
+improveFromInstEnv inst_env pred
+ | Just (cls, tys) <- getClassPredTys_maybe pred
, tys `lengthAtLeast` 2
, let (cls_tvs, cls_fds) = classTvsFds cls
instances = classInstances inst_env cls
@@ -267,10 +265,7 @@ improveFromInstEnv inst_env pred@(ty, _)
, ispec <- instances
, (meta_tvs, eqs) <- checkClsFD fd cls_tvs ispec
emptyVarSet tys trimmed_tcs -- NB: orientation
- , let p_inst = (mkClassPred cls (is_tys ispec),
- sep [ ptext (sLit "arising from the dependency") <+> quotes (pprFunDep fd)
- , ptext (sLit "in the instance declaration")
- <+> pprNameDefnLoc (getName ispec)])
+ , let p_inst = mkClassPred cls (is_tys ispec)
]
improveFromInstEnv _ _ = []
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index b6a62af..4323888 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -31,8 +31,6 @@ import FamInstEnv ( FamInstEnvs, instNewTyConTF_maybe )
import TcEvidence
import Outputable
-import TcMType ( zonkTcPredType )
-
import TcRnTypes
import TcErrors
import TcSMonad
@@ -411,13 +409,8 @@ interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
addFunDepWork :: Ct -> Ct -> TcS ()
addFunDepWork work_ct 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)
-
- ; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc
- ; fd_work <- rewriteWithFunDeps fd_eqns work_loc
+ = do { let fd_eqns = improveFromAnother (ctPred inert_ct) (ctPred work_ct)
+ ; fd_work <- rewriteWithFunDeps fd_eqns (ctLoc work_ct)
-- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
-- NB: We do create FDs for given to report insoluble equations that arise
-- from pairs of Givens, and also because of floating when we approximate
@@ -1355,20 +1348,17 @@ rewriteWithFunDeps eqn_pred_locs loc
instFunDepEqn :: CtLoc -> Equation -> TcS [Ct]
-- Post: Returns the position index as well as the corresponding FunDep equality
-instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs
- , fd_pred1 = d1, fd_pred2 = d2 })
+instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs })
= do { (subst, _) <- instFlexiTcS tvs -- Takes account of kind substitution
; foldM (do_one subst) [] eqs }
where
- der_loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
-
do_one subst ievs (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 })
| tcEqType sty1 sty2
= return ievs -- Return no trivial equalities
| otherwise
- = do { mb_eqv <- newDerived der_loc (mkTcEqPred sty1 sty2)
+ = do { mb_eqv <- newDerived loc (mkTcEqPred sty1 sty2)
; case mb_eqv of
- Just ev -> return (mkNonCanonical (ev {ctev_loc = der_loc}) : ievs)
+ Just ev -> return (mkNonCanonical (ev {ctev_loc = loc}) : ievs)
Nothing -> return ievs }
-- We are eventually going to emit FD work back in the work list so
-- it is important that we only return the /freshly created/ and not
@@ -1376,18 +1366,6 @@ instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs
where
sty1 = Type.substTy subst ty1
sty2 = Type.substTy subst ty2
-
-mkEqnMsg :: (TcPredType, SDoc)
- -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc)
-mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
- = do { zpred1 <- zonkTcPredType pred1
- ; zpred2 <- zonkTcPredType pred2
- ; let { tpred1 = tidyType tidy_env zpred1
- ; tpred2 = tidyType tidy_env zpred2 }
- ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
- nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]),
- nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])]
- ; return (tidy_env, msg) }
\end{code}
@@ -1459,7 +1437,6 @@ doTopReactDict inerts fl cls xis
; solve_from_instance wtvs ev_term }
NoInstance -> try_fundeps_and_return }
where
- arising_sdoc = pprArisingAt loc
dict_id = ctEvId fl
pred = mkClassPred cls xis
loc = ctev_loc fl
@@ -1492,7 +1469,7 @@ doTopReactDict inerts fl cls xis
-- so we make sure we get on and solve it first. See Note [Weird fundeps]
try_fundeps_and_return
= do { instEnvs <- getInstEnvs
- ; let fd_eqns = improveFromInstEnv instEnvs (pred, arising_sdoc)
+ ; let fd_eqns = improveFromInstEnv instEnvs pred
; fd_work <- rewriteWithFunDeps fd_eqns loc
; unless (null fd_work) (updWorkListTcS (extendWorkListEqs fd_work))
; return NoTopInt }
More information about the ghc-commits
mailing list