Don't suppress unimplemented type family warnings with DeriveAnyClass

Summary:
For some asinine reason, we were suppressing warnings when
deriving associated type family instances with `DeriveAnyClass`. That seems
like a bad idea. Let's not do that.

Along the way, I noticed that the error contexts associated with these
newly emitted warnings were less than ideal, so I did some minor refactoring
to improve the story there.

Fixes #14094

Test Plan: ./validate

Reviewers: bgamari, austin

Subscribers: rwbarton, thomie

GHC Trac Issues: #14094

Differential Revision: https://phabricator.haskell.org/D3828

8 files changed, 82 insertions, 23 deletions

diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index 5519cc8bca..0a64ffea60 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -14,6 +14,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
                     tcClassMinimalDef,
                     HsSigFun, mkHsSigFun,
                     tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
+                    instDeclCtxt1, instDeclCtxt2, instDeclCtxt3,
                     tcATDefault
                   ) where
 
@@ -461,9 +462,25 @@ warningMinimalDefIncomplete mindef
          , nest 2 (pprBooleanFormulaNice mindef)
          , text "but there is no default implementation." ]
 
-tcATDefault :: Bool -- If a warning should be emitted when a default instance
-                    -- definition is not provided by the user
-            -> SrcSpan
+instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+instDeclCtxt1 hs_inst_ty
+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+instDeclCtxt2 :: Type -> SDoc
+instDeclCtxt2 dfun_ty
+  = instDeclCtxt3 cls tys
+  where
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
+
+instDeclCtxt3 :: Class -> [Type] -> SDoc
+instDeclCtxt3 cls cls_tys
+  = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))
+
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = hang (text "In the instance declaration for")
+                        2 (quotes doc)
+
+tcATDefault :: SrcSpan
             -> TCvSubst
             -> NameSet
             -> ClassATItem
@@ -471,7 +488,7 @@ tcATDefault :: Bool -- If a warning should be emitted when a default instance
 -- ^ Construct default instances for any associated types that
 -- aren't given a user definition
 -- Returns [] or singleton
-tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
+tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
   -- User supplied instances ==> everything is OK
   | tyConName fam_tc `elemNameSet` defined_ats
   = return []
@@ -503,7 +520,7 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
 
    -- No defaults ==> generate a warning
   | otherwise  -- defs = Nothing
-  = do { when emit_warn $ warnMissingAT (tyConName fam_tc)
+  = do { warnMissingAT (tyConName fam_tc)
        ; return [] }
   where
     subst_tv subst tc_tv
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 056bc9bfaf..c46225684d 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -21,7 +21,7 @@ import FamInst
 import TcDerivInfer
 import TcDerivUtils
 import TcValidity( allDistinctTyVars )
-import TcClassDcl( tcATDefault, tcMkDeclCtxt )
+import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
 import TcEnv
 import TcGenDeriv                       -- Deriv stuff
 import InstEnv
@@ -1600,8 +1600,9 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
                  , ds_mechanism = mechanism, ds_tys = tys
                  , ds_cls = clas, ds_loc = loc })
   = do (meth_binds, deriv_stuff, unusedNames)
-         <- genDerivStuff mechanism loc clas rep_tycon tys tvs
-       let mk_inst_info theta = do
+         <- set_span_and_ctxt $
+            genDerivStuff mechanism loc clas rep_tycon tys tvs
+       let mk_inst_info theta = set_span_and_ctxt $ do
              inst_spec <- newDerivClsInst theta spec
              doDerivInstErrorChecks2 clas inst_spec mechanism
              traceTc "newder" (ppr inst_spec)
@@ -1624,6 +1625,9 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
       | otherwise
       = []
 
+    set_span_and_ctxt :: TcM a -> TcM a
+    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
+
 doDerivInstErrorChecks1 :: Class -> [Type] -> TyCon -> [Type] -> TyCon
                         -> DerivContext -> Bool -> DerivSpecMechanism
                         -> TcM ()
@@ -1665,10 +1669,8 @@ doDerivInstErrorChecks2 clas clas_inst mechanism
       DerivSpecStock{} -> False
       _                -> True
 
-    gen_inst_err = hang (text ("Generic instances can only be derived in "
-                            ++ "Safe Haskell using the stock strategy.") $+$
-                         text "In the following instance:")
-                      2 (pprInstanceHdr clas_inst)
+    gen_inst_err = text "Generic instances can only be derived in"
+               <+> text "Safe Haskell using the stock strategy."
 
 genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
               -> TyCon -> [Type] -> [TyVar]
@@ -1694,7 +1696,7 @@ genDerivStuff mechanism loc clas tycon inst_tys tyvars
           -- unless -XDeriveAnyClass is enabled.
           ASSERT2( isValid (canDeriveAnyClass dflags)
                  , ppr "genDerivStuff: bad derived class" <+> ppr clas )
-          mapM (tcATDefault False loc mini_subst emptyNameSet)
+          mapM (tcATDefault loc mini_subst emptyNameSet)
                (classATItems clas)
         return ( emptyBag -- No method bindings are needed...
                , listToBag (map DerivFamInst (concat tyfam_insts))
@@ -1755,8 +1757,8 @@ is used:
 In the latter case, we must take care to check if C has any associated type
 families with default instances, because -XDeriveAnyClass will never provide
 an implementation for them. We "fill in" the default instances using the
-tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle
-the empty instance declaration case).
+tcATDefault function from TcClassDcl (which is also used in TcInstDcls to
+handle the empty instance declaration case).
 
 Note [Deriving strategies]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 58d45061f7..36a4b41983 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -488,7 +488,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
                             `unionNameSet`
                             mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
-        ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats)
+        ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
                                (classATItems clas)
 
         -- Finally, construct the Core representation of the instance.
diff --git a/testsuite/tests/deriving/should_compile/T14094.hs b/testsuite/tests/deriving/should_compile/T14094.hs
new file mode 100644
index 0000000000..29fa693e97
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T14094.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wall #-}
+module Bug where
+
+class C a where
+  type T a
+  data D a
+  m :: a
+
+instance C Int
+deriving instance C Bool
diff --git a/testsuite/tests/deriving/should_compile/T14094.stderr b/testsuite/tests/deriving/should_compile/T14094.stderr
new file mode 100644
index 0000000000..b323a775f5
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T14094.stderr
@@ -0,0 +1,26 @@
+
+T14094.hs:12:1: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit associated type or default declaration for ‘T’
+    • In the instance declaration for ‘C Int’
+
+T14094.hs:12:1: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit associated type or default declaration for ‘D’
+    • In the instance declaration for ‘C Int’
+
+T14094.hs:12:10: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit implementation for
+        ‘m’
+    • In the instance declaration for ‘C Int’
+
+T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit associated type or default declaration for ‘T’
+    • In the instance declaration for ‘C Bool’
+
+T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit associated type or default declaration for ‘D’
+    • In the instance declaration for ‘C Bool’
+
+T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit implementation for
+        ‘m’
+    • In the instance declaration for ‘C Bool’
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 5b69565c52..65c6d7284e 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -95,3 +95,4 @@ test('T13813', normal, compile, [''])
 test('T13919', normal, compile, [''])
 test('T13998', normal, compile, [''])
 test('T14045b', normal, compile, [''])
+test('T14094', normal, compile, [''])
diff --git a/testsuite/tests/deriving/should_fail/T10598_fail3.stderr b/testsuite/tests/deriving/should_fail/T10598_fail3.stderr
index a987a4993d..c3f4e123b7 100644
--- a/testsuite/tests/deriving/should_fail/T10598_fail3.stderr
+++ b/testsuite/tests/deriving/should_fail/T10598_fail3.stderr
@@ -1,5 +1,4 @@
 
-T10598_fail3.hs:1:1: error:
-    Generic instances can only be derived in Safe Haskell using the stock strategy.
-    In the following instance:
-      instance [safe] Generic T
+T10598_fail3.hs:8:36: error:
+    • Generic instances can only be derived in Safe Haskell using the stock strategy.
+    • In the instance declaration for ‘Generic T’
diff --git a/testsuite/tests/deriving/should_fail/T8165_fail2.stderr b/testsuite/tests/deriving/should_fail/T8165_fail2.stderr
index 4c925f52a3..5e19173a33 100644
--- a/testsuite/tests/deriving/should_fail/T8165_fail2.stderr
+++ b/testsuite/tests/deriving/should_fail/T8165_fail2.stderr
@@ -1,5 +1,6 @@
 
 T8165_fail2.hs:9:12: error:
-    The type family application ‘T Loop’
-      is no smaller than the instance head
-    (Use UndecidableInstances to permit this)
+    • The type family application ‘T Loop’
+        is no smaller than the instance head
+      (Use UndecidableInstances to permit this)
+    • In the instance declaration for ‘C Loop’