[commit: ghc] master: More detailed error message when GND fails (95ba5d8)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/95ba5d81efcf817768d65552843c7f6c4d63e340/ghc

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

commit 95ba5d81efcf817768d65552843c7f6c4d63e340
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Dec 4 08:42:13 2013 +0000

    More detailed error message when GND fails
    
    we now print the precise class method, with types, where the coercion
    failed.


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

95ba5d81efcf817768d65552843c7f6c4d63e340
 compiler/typecheck/TcDeriv.lhs    |    6 +++---
 compiler/typecheck/TcErrors.lhs   |    1 +
 compiler/typecheck/TcGenDeriv.lhs |   16 ++++++----------
 compiler/typecheck/TcRnTypes.lhs  |    9 ++++++++-
 4 files changed, 18 insertions(+), 14 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 49111a9..bc40d80 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1560,9 +1560,9 @@ mkNewTypeEqn dflags tvs
         -- newtype type; precisely the constraints required for the
         -- calls to coercible that we are going to generate.
         coercible_constraints =
-            mkThetaOrigin DerivOrigin $
-            map (\(Pair t1 t2) -> mkCoerciblePred t1 t2) $
-            mkCoerceClassMethEqn cls (varSetElemsKvsFirst dfun_tvs) inst_tys rep_inst_ty
+            [ let (Pair t1 t2) = mkCoerceClassMethEqn cls (varSetElemsKvsFirst dfun_tvs) inst_tys rep_inst_ty meth
+              in mkPredOrigin (DerivOriginCoerce meth t1 t2) (mkCoerciblePred t1 t2)
+            | meth <- classMethods cls ]
 
                 -- If there are no tyvars, there's no need
                 -- to abstract over the dictionaries we need
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index e0be85f..a28a9f5 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -1051,6 +1051,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
     drv_fixes = case orig of
                    DerivOrigin      -> [drv_fix]
                    DerivOriginDC {} -> [drv_fix]
+                   DerivOriginCoerce {} -> [drv_fix]
                    _                -> []
 
     drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index f2e5413..0040be2 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -1913,20 +1913,16 @@ mkCoerceClassMethEqn :: Class   -- the class being derived
                      -> [TyVar] -- the tvs in the instance head
                      -> [Type]  -- instance head parameters (incl. newtype)
                      -> Type    -- the representation type (already eta-reduced)
-                     -> [Pair Type]
-mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty
-  = map mk_tys $ classMethods cls
+                     -> Id      -- the method to look at
+                     -> Pair Type
+mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
+  = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
   where
     cls_tvs = classTyVars cls
     in_scope = mkInScopeSet $ mkVarSet inst_tvs
     lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
     rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
-
-    mk_tys :: Id -> Pair Type
-    mk_tys id = Pair (substTy rhs_subst user_meth_ty)
-                     (substTy lhs_subst user_meth_ty)
-      where
-        (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
+    (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
 
     changeLast :: [a] -> a -> [a]
     changeLast []     _  = panic "changeLast"
@@ -1943,7 +1939,7 @@ gen_Newtype_binds :: SrcSpan
 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
   = listToBag $ zipWith mk_bind
         (classMethods cls)
-        (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty)
+        (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
   where
     coerce_RDR = getRdrName coerceId
     mk_bind :: Id -> Pair Type -> LHsBind RdrName
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 1b38378..2ad9b95 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -1780,7 +1780,10 @@ data CtOrigin
   | ScOrigin            -- Typechecking superclasses of an instance declaration
   | DerivOrigin         -- Typechecking deriving
   | DerivOriginDC DataCon Int
-                        -- Checking constraings arising from this data an and field index
+                        -- Checking constraints arising from this data con and field index
+  | DerivOriginCoerce Id Type Type
+                        -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from
+                        -- `ty1` to `ty2`.
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin       -- Typechecking a default decl
   | DoOrigin            -- Arising from a do expression
@@ -1822,6 +1825,10 @@ pprO (DerivOriginDC dc n)  = hsep [ ptext (sLit "the"), speakNth n,
                                     ptext (sLit "field of"), quotes (ppr dc),
                                     parens (ptext (sLit "type") <+> quotes (ppr ty)) ]
     where ty = dataConOrigArgTys dc !! (n-1)
+pprO (DerivOriginCoerce meth ty1 ty2)
+                           = fsep [ ptext (sLit "the coercion"), ptext (sLit "of the method")
+                                  , quotes (ppr meth), ptext (sLit "from type"), quotes (ppr ty1)
+                                  , ptext (sLit "to type"), quotes (ppr ty2) ]
 pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
 pprO DefaultOrigin         = ptext (sLit "a 'default' declaration")
 pprO DoOrigin              = ptext (sLit "a do statement")