[commit: ghc] master: Elaborate "deriving" error messages (4025d66)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4025d66cc795b728f745aec23fc5c2267d1839f0/ghc

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

commit 4025d66cc795b728f745aec23fc5c2267d1839f0
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Dec 3 10:42:55 2013 +0000

    Elaborate "deriving" error messages
    
    If "deriving (C)" fails, it will now, if possible, indicate which
    particular field of which constructor has caused the failure. (This
    fixes #8576)


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

4025d66cc795b728f745aec23fc5c2267d1839f0
 compiler/typecheck/TcDeriv.lhs   |   10 ++++++----
 compiler/typecheck/TcErrors.lhs  |    5 +++--
 compiler/typecheck/TcRnTypes.lhs |    8 +++++++-
 3 files changed, 16 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 5931652..49111a9 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1049,11 +1049,13 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
   where
        -- Constraints arising from the arguments of each constructor
     con_arg_constraints cls' get_constrained_tys
-      = [ mkPredOrigin DerivOrigin (mkClassPred cls' [arg_ty])
+      = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [arg_ty])
         | data_con <- tyConDataCons rep_tc,
-          arg_ty   <- ASSERT( isVanillaDataCon data_con )
-                        get_constrained_tys $
-                        dataConInstOrigArgTys data_con all_rep_tc_args,
+          (arg_n, arg_ty) <-
+                ASSERT( isVanillaDataCon data_con )
+                zip [1..] $
+                get_constrained_tys $
+                dataConInstOrigArgTys data_con all_rep_tc_args,
           not (isUnLiftedType arg_ty) ]
                 -- No constraints for unlifted types
                 -- See Note [Deriving and unboxed types]
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 83d38da..e0be85f 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -1049,8 +1049,9 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
       = ptext (sLit "Could not deduce") <+> pprParendType pred
 
     drv_fixes = case orig of
-                   DerivOrigin -> [drv_fix]
-                   _           -> []
+                   DerivOrigin      -> [drv_fix]
+                   DerivOriginDC {} -> [drv_fix]
+                   _                -> []
 
     drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
                  2 (ptext (sLit "so you can specify the instance context yourself"))
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 9fc2ceb..1b38378 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -90,7 +90,7 @@ import TcEvidence
 import Type
 import Class    ( Class )
 import TyCon    ( TyCon )
-import DataCon  ( DataCon, dataConUserType )
+import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )
 import TcType
 import Annotations
 import InstEnv
@@ -1779,6 +1779,8 @@ 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
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin       -- Typechecking a default decl
   | DoOrigin            -- Arising from a do expression
@@ -1816,6 +1818,10 @@ pprO TupleOrigin           = ptext (sLit "a tuple")
 pprO NegateOrigin          = ptext (sLit "a use of syntactic negation")
 pprO ScOrigin              = ptext (sLit "the superclasses of an instance declaration")
 pprO DerivOrigin           = ptext (sLit "the 'deriving' clause of a data type declaration")
+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 StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
 pprO DefaultOrigin         = ptext (sLit "a 'default' declaration")
 pprO DoOrigin              = ptext (sLit "a do statement")