Introduce and use DerivClauseTys (#18662)

This switches `deriv_clause_tys` so that instead of using a list of
`LHsSigType`s to represent the types in a `deriving` clause, it now
uses a sum type. `DctSingle` represents a `deriving` clause with no
enclosing parentheses, while `DctMulti` represents a clause with
enclosing parentheses. This makes pretty-printing easier and avoids
confusion between `HsParTy` and the enclosing parentheses in
`deriving` clauses, which are different semantically.

Fixes #18662.

11 files changed, 141 insertions, 46 deletions

diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index c4d9ff99c5..a8dd4549e4 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -25,7 +25,8 @@
 module GHC.Hs.Decls (
   -- * Toplevel declarations
   HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
-  HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
+  HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
+  NewOrData(..), newOrDataToFlavour,
   StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
 
   -- ** Class or type declarations
@@ -1321,15 +1322,8 @@ data HsDerivingClause pass
     , deriv_clause_strategy :: Maybe (LDerivStrategy pass)
       -- ^ The user-specified strategy (if any) to use when deriving
       -- 'deriv_clause_tys'.
-    , deriv_clause_tys :: XRec pass [LHsSigType pass]
+    , deriv_clause_tys :: LDerivClauseTys pass
       -- ^ The types to derive.
-      --
-      -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
-      -- we can mention type variables that aren't bound by the datatype, e.g.
-      --
-      -- > data T b = ... deriving (C [a])
-      --
-      -- should produce a derived instance for @C [a] (T b)@.
     }
   | XHsDerivingClause !(XXHsDerivingClause pass)
 
@@ -1342,16 +1336,9 @@ instance OutputableBndrId p
                         , deriv_clause_tys      = L _ dct })
     = hsep [ text "deriving"
            , pp_strat_before
-           , pp_dct dct
+           , ppr dct
            , pp_strat_after ]
       where
-        -- This complexity is to distinguish between
-        --    deriving Show
-        --    deriving (Show)
-        pp_dct [HsIB { hsib_body = ty }]
-                 = ppr (parenthesizeHsType appPrec ty)
-        pp_dct _ = parens (interpp'SP dct)
-
         -- @via@ is unique in that in comes /after/ the class being derived,
         -- so we must special-case it.
         (pp_strat_before, pp_strat_after) =
@@ -1359,6 +1346,43 @@ instance OutputableBndrId p
             Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
             _                            -> (ppDerivStrategy dcs, empty)
 
+type LDerivClauseTys pass = XRec pass (DerivClauseTys pass)
+
+-- | The types mentioned in a single @deriving@ clause. This can come in two
+-- forms, 'DctSingle' or 'DctMulti', depending on whether the types are
+-- surrounded by enclosing parentheses or not. These parentheses are
+-- semantically differnt than 'HsParTy'. For example, @deriving ()@ means
+-- \"derive zero classes\" rather than \"derive an instance of the 0-tuple\".
+--
+-- 'DerivClauseTys' use 'LHsSigType' because @deriving@ clauses can mention
+-- type variables that aren't bound by the datatype, e.g.
+--
+-- > data T b = ... deriving (C [a])
+--
+-- should produce a derived instance for @C [a] (T b)@.
+data DerivClauseTys pass
+  = -- | A @deriving@ clause with a single type. Moreover, that type can only
+    -- be a type constructor without any arguments.
+    --
+    -- Example: @deriving Eq@
+    DctSingle (XDctSingle pass) (LHsSigType pass)
+
+    -- | A @deriving@ clause with a comma-separated list of types, surrounded
+    -- by enclosing parentheses.
+    --
+    -- Example: @deriving (Eq, C a)@
+  | DctMulti (XDctMulti pass) [LHsSigType pass]
+
+  | XDerivClauseTys !(XXDerivClauseTys pass)
+
+type instance XDctSingle (GhcPass _) = NoExtField
+type instance XDctMulti  (GhcPass _) = NoExtField
+type instance XXDerivClauseTys (GhcPass _) = NoExtCon
+
+instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where
+  ppr (DctSingle _ ty) = ppr ty
+  ppr (DctMulti _ tys) = parens (interpp'SP tys)
+
 -- | Located Standalone Kind Signature
 type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)
 
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 072e3cc8a9..db1738ec02 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -447,6 +447,12 @@ type family XCHsDerivingClause      x
 type family XXHsDerivingClause      x
 
 -- -------------------------------------
+-- DerivClauseTys type families
+type family XDctSingle       x
+type family XDctMulti        x
+type family XXDerivClauseTys x
+
+-- -------------------------------------
 -- ConDecl type families
 type family XConDeclGADT   x
 type family XConDeclH98    x
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 34afe3a72d..e1f3d29f21 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -163,6 +163,11 @@ deriving instance Data (HsDerivingClause GhcPs)
 deriving instance Data (HsDerivingClause GhcRn)
 deriving instance Data (HsDerivingClause GhcTc)
 
+-- deriving instance DataIdLR p p => Data (DerivClauseTys p)
+deriving instance Data (DerivClauseTys GhcPs)
+deriving instance Data (DerivClauseTys GhcRn)
+deriving instance Data (DerivClauseTys GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (ConDecl p)
 deriving instance Data (ConDecl GhcPs)
 deriving instance Data (ConDecl GhcRn)
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 0716fe756a..2a82c986e3 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -193,13 +193,19 @@ subordinates instMap decl = case decl of
                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
                   , (L _ n) <- ns ]
         derivs  = [ (instName, [unLoc doc], M.empty)
-                  | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
-                                concatMap (unLoc . deriv_clause_tys . unLoc) $
+                  | (l, doc) <- concatMap (extract_deriv_clause_tys .
+                                           deriv_clause_tys . unLoc) $
                                 unLoc $ dd_derivs dd
                   , Just instName <- [lookupSrcSpan l instMap] ]
 
-        extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
-        extract_deriv_ty (L l ty) =
+        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]
+        extract_deriv_clause_tys (L _ dct) =
+          case dct of
+            DctSingle _ ty -> maybeToList $ extract_deriv_ty ty
+            DctMulti _ tys -> mapMaybe extract_deriv_ty tys
+
+        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)
+        extract_deriv_ty (HsIB{hsib_body =  L l ty}) =
           case ty of
             -- deriving (forall a. C a {- ^ Doc comment -})
             HsForAllTy{ hst_tele = HsForAllInvis{}
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index d6bfad2f89..0ef8db0efe 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -945,13 +945,18 @@ repDerivClause :: LHsDerivingClause GhcRn
                -> MetaM (Core (M TH.DerivClause))
 repDerivClause (L _ (HsDerivingClause
                           { deriv_clause_strategy = dcs
-                          , deriv_clause_tys      = L _ dct }))
+                          , deriv_clause_tys      = dct }))
   = repDerivStrategy dcs $ \(MkC dcs') ->
-    do MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
+    do MkC dct' <- rep_deriv_clause_tys dct
        rep2 derivClauseName [dcs',dct']
   where
-    rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
-    rep_deriv_ty ty = repLTy ty
+    rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type])
+    rep_deriv_clause_tys (L _ dct) = case dct of
+      DctSingle _ ty -> rep_deriv_tys [ty]
+      DctMulti _ tys -> rep_deriv_tys tys
+
+    rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])
+    rep_deriv_tys = repListM typeTyConName (repLTy . hsSigType)
 
 rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
                     -> MetaM ([GenSymBind], [Core (M TH.Dec)])
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 52a62862ce..b123450b60 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1507,12 +1507,16 @@ instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where
 
 instance ToHie (Located (HsDerivingClause GhcRn)) where
   toHie (L span cl) = concatM $ makeNode cl span : case cl of
-      HsDerivingClause _ strat (L ispan tys) ->
+      HsDerivingClause _ strat dct ->
         [ toHie strat
-        , locOnly ispan
-        , toHie $ map (TS (ResolvedScopes [])) tys
+        , toHie dct
         ]
 
+instance ToHie (Located (DerivClauseTys GhcRn)) where
+  toHie (L span dct) = concatM $ makeNode dct span : case dct of
+      DctSingle _ ty -> [ toHie $ TS (ResolvedScopes[]) ty ]
+      DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
+
 instance ToHie (Located (DerivStrategy GhcRn)) where
   toHie (L span strat) = concatM $ makeNode strat span : case strat of
       StockStrategy -> []
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 50f63796ee..b8398dee7f 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2276,15 +2276,13 @@ deriving :: { LHsDerivingClause GhcPs }
                  in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)
                         [mj AnnDeriving $1] }
 
-deriv_clause_types :: { Located [LHsSigType GhcPs] }
+deriv_clause_types :: { LDerivClauseTys GhcPs }
         : qtycon              { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in
-                                sL1 $1 [mkLHsSigType tc] }
-        | '(' ')'             {% ams (sLL $1 $> [])
+                                sL1 $1 (DctSingle noExtField (mkLHsSigType tc)) }
+        | '(' ')'             {% ams (sLL $1 $> (DctMulti noExtField []))
                                      [mop $1,mcp $2] }
-        | '(' deriv_types ')' {% ams (sLL $1 $> $2)
+        | '(' deriv_types ')' {% ams (sLL $1 $> (DctMulti noExtField $2))
                                      [mop $1,mcp $3] }
-             -- Glasgow extension: allow partial
-             -- applications in derivings
 
 -----------------------------------------------------------------------------
 -- Value definitions
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 7dc36db037..feb0a32351 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -628,15 +628,34 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where
               Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l)
               Just (L l _) -> (registerLocHdkA l, pure ())
         register_strategy_before
-        deriv_clause_tys' <-
-          extendHdkA (getLoc deriv_clause_tys) $
-          traverse @Located addHaddock deriv_clause_tys
+        deriv_clause_tys' <- addHaddock deriv_clause_tys
         register_strategy_after
         pure HsDerivingClause
           { deriv_clause_ext = noExtField,
             deriv_clause_strategy,
             deriv_clause_tys = deriv_clause_tys' }
 
+-- Process the types in a single deriving clause, which may come in one of the
+-- following forms:
+--
+--    1. A singular type constructor:
+--          deriving Eq -- ^ Comment on Eq
+--
+--    2. A list of comma-separated types surrounded by enclosing parentheses:
+--          deriving ( Eq  -- ^ Comment on Eq
+--                   , C a -- ^ Comment on C a
+--                   )
+instance HasHaddock (Located (DerivClauseTys GhcPs)) where
+  addHaddock (L l_dct dct) =
+    extendHdkA l_dct $
+    case dct of
+      DctSingle x ty -> do
+        ty' <- addHaddock ty
+        pure $ L l_dct $ DctSingle x ty'
+      DctMulti x tys -> do
+        tys' <- addHaddock tys
+        pure $ L l_dct $ DctMulti x tys'
+
 -- Process a single data constructor declaration, which may come in one of the
 -- following forms:
 --
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 581af6e2d4..bdc1957627 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1895,15 +1895,25 @@ rnLHsDerivingClause doc
                 (L loc (HsDerivingClause
                               { deriv_clause_ext = noExtField
                               , deriv_clause_strategy = dcs
-                              , deriv_clause_tys = L loc' dct }))
+                              , deriv_clause_tys = dct }))
   = do { (dcs', dct', fvs)
-           <- rnLDerivStrategy doc dcs $ mapFvRn rn_clause_pred dct
+           <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct
        ; warnNoDerivStrat dcs' loc
        ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
                                         , deriv_clause_strategy = dcs'
-                                        , deriv_clause_tys = L loc' dct' })
+                                        , deriv_clause_tys = dct' })
               , fvs ) }
   where
+    rn_deriv_clause_tys :: LDerivClauseTys GhcPs
+                        -> RnM (LDerivClauseTys GhcRn, FreeVars)
+    rn_deriv_clause_tys (L l dct) = case dct of
+      DctSingle x ty -> do
+        (ty', fvs) <- rn_clause_pred ty
+        pure (L l (DctSingle x ty'), fvs)
+      DctMulti x tys -> do
+        (tys', fvs) <- mapFvRn rn_clause_pred tys
+        pure (L l (DctMulti x tys'), fvs)
+
     rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
     rn_clause_pred pred_ty = do
       let inf_err = Just (text "Inferred type variables are not allowed")
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 02c885ce51..12bf79db0f 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -437,17 +437,22 @@ makeDerivSpecs :: [DerivInfo]
                -> TcM [EarlyDerivSpec]
 makeDerivSpecs deriv_infos deriv_decls
   = do  { eqns1 <- sequenceA
-                     [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt
+                     [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt
                      | DerivInfo { di_rep_tc = rep_tc
                                  , di_scoped_tvs = scoped_tvs
                                  , di_clauses = clauses
                                  , di_ctxt = err_ctxt } <- deriv_infos
                      , L _ (HsDerivingClause { deriv_clause_strategy = dcs
-                                             , deriv_clause_tys = L _ preds })
+                                             , deriv_clause_tys = dct })
                          <- clauses
                      ]
         ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
         ; return $ concat eqns1 ++ catMaybes eqns2 }
+  where
+    deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
+    deriv_clause_preds (L _ dct) = case dct of
+      DctSingle _ ty -> [ty]
+      DctMulti _ tys -> tys
 
 ------------------------------------------------------------------
 -- | Process the derived classes in a single @deriving@ clause.
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index d6ecba4149..bdc0203c90 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1393,12 +1393,25 @@ cvtContext p tys = do { preds' <- mapM cvtPred tys
 cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
 cvtPred = cvtType
 
+cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
+cvtDerivClauseTys tys
+  = do { tys' <- mapM cvtType tys
+         -- Since TH.Cxt doesn't indicate the presence or absence of
+         -- parentheses in a deriving clause, we have to choose between
+         -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti
+         -- unless the TH.Cxt is a singleton list whose type is a bare type
+         -- constructor with no arguments.
+       ; case tys' of
+           [ty'@(L l (HsTyVar _ NotPromoted _))]
+                 -> return $ L l $ DctSingle noExtField $ mkLHsSigType ty'
+           _     -> returnL $ DctMulti noExtField (map mkLHsSigType tys') }
+
 cvtDerivClause :: TH.DerivClause
                -> CvtM (LHsDerivingClause GhcPs)
-cvtDerivClause (TH.DerivClause ds ctxt)
-  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt
-       ; ds'   <- traverse cvtDerivStrategy ds
-       ; returnL $ HsDerivingClause noExtField ds' ctxt' }
+cvtDerivClause (TH.DerivClause ds tys)
+  = do { tys' <- cvtDerivClauseTys tys
+       ; ds'  <- traverse cvtDerivStrategy ds
+       ; returnL $ HsDerivingClause noExtField ds' tys' }
 
 cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
 cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy