Defer errors in derived instances

Fixes Trac #9576.  Turned out to be pretty easy.

10 files changed, 56 insertions, 33 deletions

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 17a84e2d68..a42a4861dd 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -481,7 +481,7 @@ renameDeriv is_boot inst_infos bagBinds
                             { ib_binds = binds
                             , ib_pragmas = sigs
                             , ib_extensions = exts -- only for type-checking
-                            , ib_standalone_deriving = sa } })
+                            , ib_derived = sa } })
         =       -- Bring the right type variables into
                 -- scope (yuk), and rename the method binds
            ASSERT( null sigs )
@@ -490,7 +490,7 @@ renameDeriv is_boot inst_infos bagBinds
               ; let binds' = InstBindings { ib_binds = rn_binds
                                            , ib_pragmas = []
                                            , ib_extensions = exts
-                                           , ib_standalone_deriving = sa }
+                                           , ib_derived = sa }
               ; return (inst_info { iBinds = binds' }, fvs) }
         where
           (tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
@@ -1897,9 +1897,11 @@ simplifyDeriv pred tvs theta
                          | otherwise = Right ct
                          where p = ctPred ct
 
-       -- We never want to defer these errors because they are errors in the
-       -- compiler! Hence the `False` below
-       ; reportAllUnsolved (residual_wanted { wc_flat = bad })
+       -- If we are deferring type errors, simply ignore any insoluble
+       -- constraints.  Tney'll come up again when we typecheck the
+       -- generated instance declaration
+       ; defer <- goptM Opt_DeferTypeErrors
+       ; unless defer (reportAllUnsolved (residual_wanted { wc_flat = bad }))
 
        ; let min_theta = mkMinimalBySCs (bagToList good)
        ; return (substTheta subst_skol min_theta) }
@@ -2057,7 +2059,7 @@ genInst :: Bool             -- True <=> standalone deriving
         -> CommonAuxiliaries
         -> DerivSpec ThetaType 
         -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
-genInst standalone_deriv default_oflag comauxs
+genInst _standalone_deriv default_oflag comauxs
         spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
                  , ds_overlap = overlap_mode
@@ -2072,7 +2074,7 @@ genInst standalone_deriv default_oflag comauxs
                         , ib_pragmas = []
                         , ib_extensions = [ Opt_ImpredicativeTypes
                                           , Opt_RankNTypes ]
-                        , ib_standalone_deriving = standalone_deriv } }
+                        , ib_derived = True } }
                 , emptyBag
                 , Just $ getName $ head $ tyConDataCons rep_tycon ) }
               -- See Note [Newtype deriving and unused constructors]
@@ -2087,7 +2089,7 @@ genInst standalone_deriv default_oflag comauxs
                                                 { ib_binds = meth_binds
                                                 , ib_pragmas = []
                                                 , ib_extensions = []
-                                                , ib_standalone_deriving = standalone_deriv } }
+                                                , ib_derived = True } }
        ; return ( inst_info, deriv_stuff, Nothing ) }
   where
     oflag  = setOverlapModeMaybe default_oflag overlap_mode
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index e02bd3733b..e9e4c188ad 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -724,23 +724,24 @@ iDFunId info = instanceDFunId (iSpec info)
 data InstBindings a
   = InstBindings
       { ib_binds :: (LHsBinds a)  -- Bindings for the instance methods
-      , ib_pragmas :: [LSig a]    -- User pragmas recorded for generating 
+      , ib_pragmas :: [LSig a]    -- User pragmas recorded for generating
                                   -- specialised instances
       , ib_extensions :: [ExtensionFlag] -- any extra extensions that should
                                          -- be enabled when type-checking this
                                          -- instance; needed for
                                          -- GeneralizedNewtypeDeriving
-                      
-      , ib_standalone_deriving :: Bool
-           -- True <=> This code came from a standalone deriving clause
-           --          Used only to improve error messages
+
+      , ib_derived :: Bool
+           -- True <=> This code was generated by GHC from a deriving clause
+           --          or standalone deriving declaration
+           -- Used only to improve error messages
       }
 
 instance OutputableBndr a => Outputable (InstInfo a) where
     ppr = pprInstInfoDetails
 
 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
-pprInstInfoDetails info 
+pprInstInfoDetails info
    = hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where"))
         2 (details (iBinds info))
   where
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 158a1e74ca..c3efb32576 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -137,7 +137,7 @@ metaTyConsToDerivStuff tc metaDts =
         d_binds  = InstBindings { ib_binds = dBinds
                                 , ib_pragmas = []
                                 , ib_extensions = []
-                                , ib_standalone_deriving = False }
+                                , ib_derived = True }
         d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
 
         -- Constructor
@@ -147,7 +147,7 @@ metaTyConsToDerivStuff tc metaDts =
         c_binds = [ InstBindings { ib_binds = c
                                  , ib_pragmas = []
                                  , ib_extensions = []
-                                 , ib_standalone_deriving = False }
+                                 , ib_derived = True }
                   | c <- cBinds ]
         c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
                    | (is,bs) <- myZip1 c_insts c_binds ]
@@ -159,7 +159,7 @@ metaTyConsToDerivStuff tc metaDts =
         s_binds = [ [ InstBindings { ib_binds = s
                                    , ib_pragmas = []
                                    , ib_extensions = []
-                                   , ib_standalone_deriving = False }
+                                   , ib_derived = True }
                     | s <- ss ] | ss <- sBinds ]
         s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec  = is
                                                              , iBinds = bs})))
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 70553ff862..366f65f3ba 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -561,7 +561,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                                      { ib_binds = binds
                                      , ib_pragmas = uprags
                                      , ib_extensions = []
-                                     , ib_standalone_deriving = False } }
+                                     , ib_derived = False } }
 
         ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
 
@@ -1205,8 +1205,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                   op_items (InstBindings { ib_binds = binds
                                          , ib_pragmas = sigs
                                          , ib_extensions = exts
-                                         , ib_standalone_deriving
-                                              = standalone_deriv })
+                                         , ib_derived    = is_derived })
   = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
        ; let hs_sig_fn = mkHsSigFun sigs
        ; checkMinimalDefinition
@@ -1220,15 +1219,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     tc_item sig_fn (sel_id, dm_info)
       = case findMethodBind (idName sel_id) binds of
             Just (user_bind, bndr_loc)
-                     -> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc
+                     -> tc_body sig_fn sel_id user_bind bndr_loc
             Nothing  -> do { traceTc "tc_def" (ppr sel_id)
                            ; tc_default sig_fn sel_id dm_info }
 
     ----------------------
-    tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name
+    tc_body :: HsSigFun -> Id -> LHsBind Name
             -> SrcSpan -> TcM (TcId, LHsBind Id)
-    tc_body sig_fn sel_id generated_code rn_bind bndr_loc
-      = add_meth_ctxt sel_id generated_code rn_bind $
+    tc_body sig_fn sel_id rn_bind bndr_loc
+      = add_meth_ctxt sel_id rn_bind $
         do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
            ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $
                                           mkMethIds sig_fn clas tyvars dfun_ev_vars
@@ -1248,8 +1247,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     tc_default sig_fn sel_id (GenDefMeth dm_name)
       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
-           ; tc_body sig_fn sel_id False {- Not generated code? -}
-                     meth_bind inst_loc }
+           ; tc_body sig_fn sel_id meth_bind inst_loc }
 
     tc_default sig_fn sel_id NoDefMeth     -- No default method at all
       = do { traceTc "tc_def: warn" (ppr sel_id)
@@ -1331,12 +1329,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     inst_loc = getSrcSpan dfun_id
 
-        -- For instance decls that come from standalone deriving clauses
+        -- For instance decls that come from deriving clauses
         -- we want to print out the full source code if there's an error
         -- because otherwise the user won't see the code at all
-    add_meth_ctxt sel_id generated_code rn_bind thing
-      | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
-      | otherwise      = thing
+    add_meth_ctxt sel_id rn_bind thing
+      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
+      | otherwise  = thing
 
     ----------------------
 
@@ -1369,7 +1367,7 @@ wrapId wrapper id = mkHsWrap wrapper (HsVar id)
 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
 derivBindCtxt sel_id clas tys _bind
    = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
-          , nest 2 (ptext (sLit "in a standalone derived instance for")
+          , nest 2 (ptext (sLit "in a derived instance for")
                     <+> quotes (pprClassPred clas tys) <> colon)
           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
 
diff --git a/testsuite/tests/deriving/should_fail/T4846.stderr b/testsuite/tests/deriving/should_fail/T4846.stderr
index 6024165c25..8d6198ea8e 100644
--- a/testsuite/tests/deriving/should_fail/T4846.stderr
+++ b/testsuite/tests/deriving/should_fail/T4846.stderr
@@ -9,6 +9,6 @@ T4846.hs:29:1:
     In an equation for ‘mkExpr’:
         mkExpr = GHC.Prim.coerce (mkExpr :: Expr Bool) :: Expr BOOL
     When typechecking the code for  ‘mkExpr’
-      in a standalone derived instance for ‘B BOOL’:
+      in a derived instance for ‘B BOOL’:
       To see the code I am typechecking, use -ddump-deriv
     In the instance declaration for ‘B BOOL’
diff --git a/testsuite/tests/deriving/should_fail/drvfail011.stderr b/testsuite/tests/deriving/should_fail/drvfail011.stderr
index 99e62fc48e..6ea42e1b08 100644
--- a/testsuite/tests/deriving/should_fail/drvfail011.stderr
+++ b/testsuite/tests/deriving/should_fail/drvfail011.stderr
@@ -5,6 +5,6 @@ drvfail011.hs:8:1:
     In the expression: ((a1 == b1))
     In an equation for ‘==’: (==) (T1 a1) (T1 b1) = ((a1 == b1))
     When typechecking the code for  ‘==’
-      in a standalone derived instance for ‘Eq (T a)’:
+      in a derived instance for ‘Eq (T a)’:
       To see the code I am typechecking, use -ddump-deriv
     In the instance declaration for ‘Eq (T a)’
diff --git a/testsuite/tests/deriving/should_run/T9576.hs b/testsuite/tests/deriving/should_run/T9576.hs
new file mode 100644
index 0000000000..b80de9cc0e
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T9576.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -fdefer-type-errors #-}
+
+module Main where
+
+data Foo = MkFoo
+data Bar = MkBar Foo deriving Show
+
+main = do { print True; print (MkBar MkFoo) }
+
diff --git a/testsuite/tests/deriving/should_run/T9576.stderr b/testsuite/tests/deriving/should_run/T9576.stderr
new file mode 100644
index 0000000000..6f8bf7f4e7
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T9576.stderr
@@ -0,0 +1,11 @@
+T9576: T9576.hs:6:31:
+    No instance for (Show Foo) arising from a use of ‘showsPrec’
+    In the second argument of ‘(.)’, namely ‘(showsPrec 11 b1)’
+    In the second argument of ‘showParen’, namely
+      ‘((.) (showString "MkBar ") (showsPrec 11 b1))’
+    In the expression:
+      showParen ((a >= 11)) ((.) (showString "MkBar ") (showsPrec 11 b1))
+    When typechecking the code for  ‘showsPrec’
+      in a derived instance for ‘Show Bar’:
+      To see the code I am typechecking, use -ddump-deriv
+(deferred type error)
diff --git a/testsuite/tests/deriving/should_run/T9576.stdout b/testsuite/tests/deriving/should_run/T9576.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T9576.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T
index 572f95bacd..21c1962ed1 100644
--- a/testsuite/tests/deriving/should_run/all.T
+++ b/testsuite/tests/deriving/should_run/all.T
@@ -36,4 +36,5 @@ test('T5628', exit_code(1), compile_and_run, [''])
 test('T5712', normal, compile_and_run, [''])
 test('T7931', normal, compile_and_run, [''])
 test('T8280', normal, compile_and_run, [''])
+test('T9576', exit_code(1), compile_and_run, [''])