Use PredOrigin in FunDeps.lhswip/T8592

4 files changed, 57 insertions, 38 deletions

diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs
index 202ef1a12c..9cf4c8212b 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 49111a919d..fc47e6b1f3 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 f2289b1d01..da9285a59d 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 1b38378d2e..e9aec59cfc 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}