Use InstanceSigs in GND/DerivingVia-generated code (#17899)wip/T17899

Aside from making the generated code easier to read when
`-ddump-deriv` is enabled, this makes the error message in `T15073`
substantially simpler (see the updated `T15073` expected stderr).

Fixes #17899.

4 files changed, 82 insertions, 44 deletions

diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index ac157d4caf..36e0c6d2c4 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -725,9 +725,10 @@ signatures in order to kind-check. Here is an example from #14579:
 The derived Eq instance for Glurp (without any kind signatures) would be:
 
   instance Eq a => Eq (Glurp a) where
+    (==) :: Glurp a -> Glurp a -> Bool
     (==) = coerce @(Wat2 P  -> Wat2 P  -> Bool)
                   @(Glurp a -> Glurp a -> Bool)
-                  (==) :: Glurp a -> Glurp a -> Bool
+                  (==)
 
 (Where the visible type applications use types produced by typeToLHsType.)
 
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index aa5f5258df..711a30117e 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -42,7 +42,6 @@ import TyCoPpr    ( pprTyVars )
 import GHC.Rename.Names  ( extendGlobalRdrEnvRn )
 import GHC.Rename.Binds
 import GHC.Rename.Env
-import GHC.Rename.Utils  ( bindLocalNamesFV )
 import GHC.Rename.Source ( addTcgDUs )
 import Avail
 
@@ -315,12 +314,11 @@ renameDeriv inst_infos bagBinds
                             , ib_pragmas = sigs
                             , ib_extensions = exts -- Only for type-checking
                             , ib_derived = sa } })
-        =  ASSERT( null sigs )
-           bindLocalNamesFV tyvars $
-           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
+        =  do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst)
+                                                          tyvars binds sigs
               ; let binds' = InstBindings { ib_binds = rn_binds
                                           , ib_tyvars = tyvars
-                                          , ib_pragmas = []
+                                          , ib_pragmas = rn_sigs
                                           , ib_extensions = exts
                                           , ib_derived = sa }
               ; return (inst_info { iBinds = binds' }, fvs) }
@@ -1846,7 +1844,7 @@ genInst :: DerivSpec theta
 genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism
                  , ds_tys = tys, ds_cls = clas, ds_loc = loc
                  , ds_standalone_wildcard = wildcard })
-  = do (meth_binds, deriv_stuff, unusedNames)
+  = do (meth_binds, meth_sigs, deriv_stuff, unusedNames)
          <- set_span_and_ctxt $
             genDerivStuff mechanism loc clas tys tvs
        let mk_inst_info theta = set_span_and_ctxt $ do
@@ -1858,7 +1856,7 @@ genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism
                        , iBinds  = InstBindings
                                      { ib_binds = meth_binds
                                      , ib_tyvars = map Var.varName tvs
-                                     , ib_pragmas = []
+                                     , ib_pragmas = meth_sigs
                                      , ib_extensions = extensions
                                      , ib_derived = True } }
        return (mk_inst_info, deriv_stuff, unusedNames)
@@ -1866,9 +1864,14 @@ genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism
     extensions :: [LangExt.Extension]
     extensions
       | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism
-        -- Both these flags are needed for higher-rank uses of coerce
-        -- See Note [Newtype-deriving instances] in TcGenDeriv
-      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]
+      = [
+          -- Both these flags are needed for higher-rank uses of coerce...
+          LangExt.ImpredicativeTypes, LangExt.RankNTypes
+          -- ...and this flag is needed to support the instance signatures
+          -- that bring type variables into scope.
+          -- See Note [Newtype-deriving instances] in TcGenDeriv
+        , LangExt.InstanceSigs
+        ]
       | otherwise
       = []
 
@@ -2035,7 +2038,7 @@ derivingThingFailWith newtype_deriving msg = do
 
 genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
               -> [Type] -> [TyVar]
-              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
+              -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
 genDerivStuff mechanism loc clas inst_tys tyvars
   = case mechanism of
       -- See Note [Bindings for Generalised Newtype Deriving]
@@ -2045,7 +2048,8 @@ genDerivStuff mechanism loc clas inst_tys tyvars
       -- Try a stock deriver
       DerivSpecStock { dsm_stock_dit    = DerivInstTys{dit_rep_tc = rep_tc}
                      , dsm_stock_gen_fn = gen_fn }
-        -> gen_fn loc rep_tc inst_tys
+        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys
+              pure (binds, [], faminsts, field_names)
 
       -- Try DeriveAnyClass
       DerivSpecAnyClass -> do
@@ -2059,7 +2063,7 @@ genDerivStuff mechanism loc clas inst_tys tyvars
                  , ppr "genDerivStuff: bad derived class" <+> ppr clas )
           mapM (tcATDefault loc mini_subst emptyNameSet)
                (classATItems clas)
-        return ( emptyBag -- No method bindings are needed...
+        return ( emptyBag, [] -- No method bindings are needed...
                , listToBag (map DerivFamInst (concat tyfam_insts))
                -- ...but we may need to generate binding for associated type
                -- family default instances.
@@ -2071,8 +2075,8 @@ genDerivStuff mechanism loc clas inst_tys tyvars
         -> gen_newtype_or_via via_ty
   where
     gen_newtype_or_via ty = do
-      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
-      return (binds, faminsts, [])
+      (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
+      return (binds, sigs, faminsts, [])
 
 {-
 Note [Bindings for Generalised Newtype Deriving]
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 37eb4c2f98..c525ce15e9 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -952,7 +952,8 @@ pprInstInfoDetails info
    = hang (pprInstanceHdr (iSpec info) <+> text "where")
         2 (details (iBinds info))
   where
-    details (InstBindings { ib_binds = b }) = pprLHsBinds b
+    details (InstBindings { ib_pragmas = p, ib_binds = b }) =
+      pprDeclList (pprLHsBindsForUser b p)
 
 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 4e6bbc935b..c81d15cf86 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1610,9 +1610,10 @@ coercing from.  So from, say,
   newtype T x = MkT <rep-ty>
 
   instance C a <rep-ty> => C a (T x) where
-    op = coerce @ (a -> [<rep-ty>] -> c -> Int)
-                @ (a -> [T x]      -> c -> Int)
-                op :: forall c. a -> [T x] -> c -> Int
+    op :: forall c. a -> [T x] -> c -> Int
+    op = coerce @(a -> [<rep-ty>] -> c -> Int)
+                @(a -> [T x]      -> c -> Int)
+                op
 
 In addition to the type applications, we also have an explicit
 type signature on the entire RHS. This brings the method-bound variable
@@ -1632,16 +1633,17 @@ a polytype.  E.g.
    class C a where op :: a -> forall b. b -> b
    newtype T x = MkT <rep-ty>
    instance C <rep-ty> => C (T x) where
-     op = coerce @ (<rep-ty> -> forall b. b -> b)
-                 @ (T x      -> forall b. b -> b)
-                op :: T x -> forall b. b -> b
+     op :: T x -> forall b. b -> b
+     op = coerce @(<rep-ty> -> forall b. b -> b)
+                 @(T x      -> forall b. b -> b)
+                op
 
 The use of type applications is crucial here. If we had tried using only
 explicit type signatures, like so:
 
    instance C <rep-ty> => C (T x) where
+     op :: T x -> forall b. b -> b
      op = coerce (op :: <rep-ty> -> forall b. b -> b)
-                     :: T x      -> forall b. b -> b
 
 Then GHC will attempt to deeply skolemize the two type signatures, which will
 wreak havoc with the Coercible solver. Therefore, we instead use type
@@ -1721,23 +1723,26 @@ See Note [Instances in no-evidence implications] in TcInteract.
 But this isn't the death knell for combining QuantifiedConstraints with GND.
 On the contrary, if we generate GND bindings in a slightly different way, then
 we can avoid this situation altogether. Instead of applying `coerce` to two
-polymorphic types, we instead let an explicit type signature do the polymorphic
+polymorphic types, we instead let an instance signature do the polymorphic
 instantiation, and omit the `forall`s in the type applications.
 More concretely, we generate the following code instead:
 
   instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
       C (T m) where
+    join :: forall a. T m (T m a) -> T m a
     join = coerce @(  m   (m a) ->   m a)
                   @(T m (T m a) -> T m a)
-                  join :: forall a. T m (T m a) -> T m a
+                  join
 
-Now the visible type arguments are both monotypes, so we need do any of this
-funny quantified constraint instantiation business.
+Now the visible type arguments are both monotypes, so we don't need any of this
+funny quantified constraint instantiation business. While this particular
+example no longer uses impredicative instantiation, we still need to enable
+ImpredicativeTypes to typecheck GND-generated code for class methods with
+higher-rank types. See Note [Newtype-deriving instances].
 
 You might think that that second @(T m (T m a) -> T m a) argument is redundant
-in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type
-signature, but in fact leaving it off will break this example (from the
-T15290d test case):
+in the presence of the instance signature, but in fact leaving it off will
+break this example (from the T15290d test case):
 
   class C a where
     c :: Int -> forall b. b -> a
@@ -1745,14 +1750,15 @@ T15290d test case):
   instance C Int
 
   instance C Age where
+    c :: Int -> forall b. b -> Age
     c = coerce @(Int -> forall b. b -> Int)
-               c :: Int -> forall b. b -> Age
+               c
 
-That is because the explicit type signature deeply skolemizes the forall-bound
+That is because the instance signature deeply skolemizes the forall-bound
 `b`, which wreaks havoc with the `Coercible` solver. An additional visible type
 argument of @(Int -> forall b. b -> Age) is enough to prevent this.
 
-Be aware that the use of an explicit type signature doesn't /solve/ this
+Be aware that the use of an instance signature doesn't /solve/ this
 problem; it just makes it less likely to occur. For example, if a class has
 a truly higher-rank type like so:
 
@@ -1775,8 +1781,8 @@ ambiguous type variables. As one example, consider the following example
 A naïve attempt and generating a C T instance would be:
 
   instance C T where
+    f :: String
     f = coerce @String @String f
-          :: String
 
 This isn't going to typecheck, however, since GHC doesn't know what to
 instantiate the type variable `a` with in the call to `f` in the method body.
@@ -1784,8 +1790,8 @@ instantiate the type variable `a` with in the call to `f` in the method body.
 ambiguity here, we explicitly instantiate `a` like so:
 
   instance C T where
+    f :: String
     f = coerce @String @String (f @())
-          :: String
 
 All better now.
 -}
@@ -1797,32 +1803,58 @@ gen_Newtype_binds :: SrcSpan
                              -- newtype itself)
                   -> [Type]  -- instance head parameters (incl. newtype)
                   -> Type    -- the representation type
-                  -> TcM (LHsBinds GhcPs, BagDerivStuff)
+                  -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
 -- See Note [Newtype-deriving instances]
 gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
   = do let ats = classATs cls
+           (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
        atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
                     mapM mk_atf_inst ats
-       return ( listToBag $ map mk_bind (classMethods cls)
+       return ( listToBag binds
+              , sigs
               , listToBag $ map DerivFamInst atf_insts )
   where
-    mk_bind :: Id -> LHsBind GhcPs
-    mk_bind meth_id
-      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
-                                          (mkPrefixFunRhs (L loc meth_RDR))
-                                          [] rhs_expr]
+    -- For each class method, generate its derived binding and instance
+    -- signature. Using the first example from
+    -- Note [Newtype-deriving instances]:
+    --
+    --   class C a b where
+    --     op :: forall c. a -> [b] -> c -> Int
+    --
+    --   newtype T x = MkT <rep-ty>
+    --
+    -- Then we would generate <derived-op-impl> below:
+    --
+    --   instance C a <rep-ty> => C a (T x) where
+    --     <derived-op-impl>
+    mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)
+    mk_bind_and_sig meth_id
+      = ( -- The derived binding, e.g.,
+          --
+          --   op = coerce @(a -> [<rep-ty>] -> c -> Int)
+          --               @(a -> [T x]      -> c -> Int)
+          --               op
+          mkRdrFunBind loc_meth_RDR [mkSimpleMatch
+                                        (mkPrefixFunRhs loc_meth_RDR)
+                                        [] rhs_expr]
+        , -- The derived instance signature, e.g.,
+          --
+          --   op :: forall c. a -> [T x] -> c -> Int
+          L loc $ ClassOpSig noExtField False [loc_meth_RDR]
+                $ mkLHsSigType $ typeToLHsType to_ty
+        )
       where
         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
         (_, _, from_tau) = tcSplitSigmaTy from_ty
         (_, _, to_tau)   = tcSplitSigmaTy to_ty
 
         meth_RDR = getRdrName meth_id
+        loc_meth_RDR = L loc meth_RDR
 
         rhs_expr = nlHsVar (getRdrName coerceId)
                                       `nlHsAppType`     from_tau
                                       `nlHsAppType`     to_tau
                                       `nlHsApp`         meth_app
-                                      `nlExprWithTySig` to_ty
 
         -- The class method, applied to all of the class instance types
         -- (including the representation type) to avoid potential ambiguity.