[commit: ghc] wip/rae: Finish fixing validDerivPred change (040ad38)

[git at git.haskell.org]

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

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/040ad38d2aeb7957cad83731bae03cdcdb5cd664/ghc

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

commit 040ad38d2aeb7957cad83731bae03cdcdb5cd664
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Thu Dec 18 20:24:59 2014 -0500

    Finish fixing validDerivPred change


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

040ad38d2aeb7957cad83731bae03cdcdb5cd664
 compiler/typecheck/TcDeriv.hs                      | 12 ++++++++++-
 compiler/typecheck/TcErrors.hs                     | 24 ++++++++++++----------
 .../tests/indexed-types/should_fail/T6088.stderr   | 11 ++++++++++
 3 files changed, 35 insertions(+), 12 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 8b7af86..8b2e6dc 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1880,7 +1880,17 @@ simplifyDeriv pred tvs theta
        -- constraints.  They'll come up again when we typecheck the
        -- generated instance declaration
        ; defer <- goptM Opt_DeferTypeErrors
-       ; unless defer (reportAllUnsolved (residual_wanted { wc_simple = bad }))
+       ; unless defer $ reportAllUnsolved (residual_wanted { wc_simple = bad })
+       ; ifErrsM (do { let bad_preds = [ ctPred bad_ct
+                                       | bad_ct <- bagToList bad
+                                       , isWantedCt bad_ct ] -- omit Deriveds
+                           inf_theta = bagToList good ++ bad_preds
+                     ; setErrCtxt [] $ addErr $
+                       hang (hsep [ text "The full inferred context for"
+                                  , doc, text "is" ])
+                          2 (pprTheta inf_theta) $$
+                       text "Try using this context for standalone-deriving." })
+         (return ())   -- do nothing if there are no errors
 
        ; let min_theta = mkMinimalBySCs (bagToList good)
        ; return (substTheta subst_skol min_theta) }
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 3fdf4e9..8fda2c8 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -676,7 +676,8 @@ mkEqErr1 ctxt ct
        ; dflags <- getDynFlags
        ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
        ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
-                      (wanted_msg $$ coercible_msg $$ binds_msg)
+                      (vcat [ wanted_msg, coercible_msg, binds_msg
+                            , show_fixes (drv_fixes tidy_orig) ])
                       ct is_oriented ty1 ty2 }
   where
     ev         = ctEvidence ct
@@ -1206,7 +1207,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
              , vcat (pp_givens givens)
              , ppWhen (has_ambig_tvs && not (null unifiers && null givens))
                (vcat [ ambig_msg, binds_msg, potential_msg ])
-             , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
+             , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes orig) ]
 
     potential_msg
       = ppWhen (not (null unifiers) && want_potential orig) $
@@ -1251,15 +1252,6 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
     type_has_arrow (ForAllTy _ t)   = type_has_arrow t
     type_has_arrow (LitTy _)        = False
 
-    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,"))
-                 2 (ptext (sLit "so you can specify the instance context yourself"))
-
     -- Normal overlap error
     overlap_msg
       = ASSERT( not (null matches) )
@@ -1348,6 +1340,16 @@ show_fixes []     = empty
 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
                         , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 
+drv_fixes :: CtOrigin -> [SDoc]
+drv_fixes orig = case orig of
+  DerivOrigin          -> [drv_fix]
+  DerivOriginDC {}     -> [drv_fix]
+  DerivOriginCoerce {} -> [drv_fix]
+  _                    -> []
+  where
+    drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
+                 2 (ptext (sLit "so you can specify the instance context yourself"))
+
 ppr_insts :: [ClsInst] -> SDoc
 ppr_insts insts
   = pprInstances (take 3 insts) $$ dot_dot_message
diff --git a/testsuite/tests/indexed-types/should_fail/T6088.stderr b/testsuite/tests/indexed-types/should_fail/T6088.stderr
new file mode 100644
index 0000000..d9aeee6
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T6088.stderr
@@ -0,0 +1,11 @@
+
+T6088.hs:16:33:
+    Couldn't match type ‘Pos n’ with ‘True’
+    Possible fix:
+      use a standalone 'deriving instance' declaration,
+        so you can specify the instance context yourself
+    When deriving the instance for (C (B n))
+
+T6088.hs:16:33:
+    The full inferred context for deriving (C (B n)) is (Pos n ~ True)
+    Try using this context for standalone-deriving.