diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs
index 202ef1a12c26fcaa97880e9a654fde5481de0fd3..9cf4c8212b8c116beba72f8e3e6b4785770cef52 100644
--- a/compiler/typecheck/FunDeps.lhs
+++ b/compiler/typecheck/FunDeps.lhs
@@ -31,6 +31,8 @@ import Outputable
import Util
import FastString
+import TcRnTypes
+
import Data.List ( nubBy )
import Data.Maybe ( isJust )
\end{code}
@@ -133,12 +135,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 :: PredOrigin } -- The Equation arose from
-- combining these two constraints
data FDEq = FDEq { fd_pos :: Int -- We use '0' for the first position
@@ -213,14 +213,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 :: PredOrigin -- Template item (usually given, or inert)
+ -> PredOrigin -- 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 (predOriginPred pred1)
+ , Just (cls2, tys2) <- getClassPredTys_maybe (predOriginPred 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 +243,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
+ -> PredOrigin
-> [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)
- | not (isClassPred pred)
+improveFromInstEnv _inst_env pred
+ | not (isClassPred (predOriginPred 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 (predOriginPred pred)
, tys `lengthAtLeast` 2
, let (cls_tvs, cls_fds) = classTvsFds cls
instances = classInstances inst_env cls
@@ -267,10 +267,8 @@ 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 = mkPredOrigin (FunDepInstOrigin fd ispec)
+ (mkClassPred cls (is_tys ispec))
]
improveFromInstEnv _ _ = []
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 49111a919d3282382f9aebc111202cf5104613b5..fc47e6b1f36435981cf29ef441736324bbf866b2 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -122,15 +122,6 @@ type DerivContext = Maybe ThetaType
-- Nothing <=> Vanilla deriving; infer the context of the instance decl
-- Just theta <=> Standalone deriving: context supplied by programmer
-data PredOrigin = PredOrigin PredType CtOrigin
-type ThetaOrigin = [PredOrigin]
-
-mkPredOrigin :: CtOrigin -> PredType -> PredOrigin
-mkPredOrigin origin pred = PredOrigin pred origin
-
-mkThetaOrigin :: CtOrigin -> ThetaType -> ThetaOrigin
-mkThetaOrigin origin = map (mkPredOrigin origin)
-
data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
| GivenTheta (DerivSpec ThetaType)
-- InferTheta ds => the context for the instance should be inferred
@@ -175,8 +166,6 @@ instance Outputable EarlyDerivSpec where
ppr (InferTheta spec) = ppr spec <+> ptext (sLit "(Infer)")
ppr (GivenTheta spec) = ppr spec <+> ptext (sLit "(Given)")
-instance Outputable PredOrigin where
- ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging
\end{code}
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index f2289b1d01f015bc051df85d70fd9c23e689651d..da9285a59de5900435c015f99fbfbccfeb645d37 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -413,8 +413,8 @@ 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)
+ inert_pred_loc = mkPredOrigin (ctLocOrigin inert_loc) (ctPred inert_ct)
+ work_item_pred_loc = mkPredOrigin (ctLocOrigin work_loc) (ctPred work_ct)
; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc
; fd_work <- rewriteWithFunDeps fd_eqns work_loc
@@ -1374,17 +1374,17 @@ instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs
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
+mkEqnMsg :: PredOrigin -> PredOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
+mkEqnMsg (PredOrigin pred1 from1) (PredOrigin 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])]
+ nest 2 (sep [ppr tpred1 <> comma, nest 2 (arr <+> ppr from1)]),
+ nest 2 (sep [ppr tpred2 <> comma, nest 2 (arr <+> ppr from2)])]
; return (tidy_env, msg) }
+ where arr = ptext (sLit "arising from")
\end{code}
@@ -1456,7 +1456,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
@@ -1489,7 +1488,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 (mkPredOrigin (ctLocOrigin loc) pred)
; fd_work <- rewriteWithFunDeps fd_eqns loc
; unless (null fd_work) (updWorkListTcS (extendWorkListEqs fd_work))
; return NoTopInt }
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 1b38378d2e19688c528b98548b193241a8cae48d..e9aec59cfcd02e474688e429613bf2555806b60c 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -72,6 +72,10 @@ module TcRnTypes(
isWanted, isGiven, isDerived,
canRewrite, canRewriteOrSame,
+ PredOrigin(..), ThetaOrigin,
+ mkPredOrigin, mkThetaOrigin,
+ predOriginPred,
+
-- Pretty printing
pprEvVarTheta, pprWantedsWithLocs,
pprEvVars, pprEvVarWithType,
@@ -88,7 +92,7 @@ import HsSyn
import HscTypes
import TcEvidence
import Type
-import Class ( Class )
+import Class ( Class, FunDep, pprFunDep )
import TyCon ( TyCon )
import DataCon ( DataCon, dataConUserType, dataConOrigArgTys )
import TcType
@@ -1657,6 +1661,7 @@ pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl})
, text "at" <+> ppr (tcl_loc lcl)]
\end{code}
+
%************************************************************************
%* *
SkolemInfo
@@ -1789,6 +1794,7 @@ data CtOrigin
| ProcOrigin -- Arising from a proc expression
| AnnOrigin -- An annotation
| FunDepOrigin
+ | FunDepInstOrigin (FunDep TyVar) ClsInst
| HoleOrigin
| UnboundOccurrenceOf RdrName
| ListOrigin -- An overloaded list
@@ -1831,6 +1837,11 @@ pprO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, cha
pprO (KindEqOrigin t1 t2 _) = ptext (sLit "a kind equality arising from") <+> sep [ppr t1, char '~', ppr t2]
pprO AnnOrigin = ptext (sLit "an annotation")
pprO FunDepOrigin = ptext (sLit "a functional dependency")
+pprO (FunDepInstOrigin fd ispec) = sep [ ptext (sLit "the dependency") <+>
+ quotes (pprFunDep fd)
+ , ptext (sLit "in the instance declaration") <+>
+ pprNameDefnLoc (getName ispec)
+ ]
pprO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
pprO (UnboundOccurrenceOf name) = hsep [ptext (sLit "an undeclared identifier"), quotes (ppr name)]
pprO ListOrigin = ptext (sLit "an overloaded list")
@@ -1839,3 +1850,25 @@ instance Outputable CtOrigin where
ppr = pprO
\end{code}
+%************************************************************************
+%* *
+ PredOrigin
+%* *
+%************************************************************************
+
+\begin{code}
+data PredOrigin = PredOrigin PredType CtOrigin
+type ThetaOrigin = [PredOrigin]
+
+mkPredOrigin :: CtOrigin -> PredType -> PredOrigin
+mkPredOrigin origin pred = PredOrigin pred origin
+
+predOriginPred :: PredOrigin -> PredType
+predOriginPred (PredOrigin p _) = p
+
+mkThetaOrigin :: CtOrigin -> ThetaType -> ThetaOrigin
+mkThetaOrigin origin = map (mkPredOrigin origin)
+
+instance Outputable PredOrigin where
+ ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging
+\end{code}