Implement the EmptyDataDeriving proposal

This implements the `EmptyDataDeriving` proposal put forth in
https://github.com/ghc-proposals/ghc-proposals/blob/dbf51608/proposals/0006-deriving-empty.rst.
This has two major changes:

* The introduction of an `EmptyDataDeriving` extension, which
  permits directly deriving `Eq`, `Ord`, `Read`, and `Show` instances
  for empty data types.
* An overhaul in the code that is emitted in derived instances for
  empty data types. To see an overview of the changes brought forth,
  refer to the changes to the 8.4.1 release notes.

Test Plan: ./validate

Reviewers: bgamari, dfeuer, austin, hvr, goldfire

Reviewed By: bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #7401, #10577, #13117

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

19 files changed, 514 insertions, 96 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 56fdc43ae6..7fe7a17d33 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -3928,6 +3928,7 @@ xFlagsDeps = [
   flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,
   flagSpec "EmptyCase"                        LangExt.EmptyCase,
   flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,
+  flagSpec "EmptyDataDeriving"                LangExt.EmptyDataDeriving,
   flagSpec "ExistentialQuantification"        LangExt.ExistentialQuantification,
   flagSpec "ExplicitForAll"                   LangExt.ExplicitForAll,
   flagSpec "ExplicitNamespaces"               LangExt.ExplicitNamespaces,
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 5010a29513..258fc11709 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -10,7 +10,7 @@
 
 module ErrUtils (
         -- * Basic types
-        Validity(..), andValid, allValid, isValid, getInvalids,
+        Validity(..), andValid, allValid, isValid, getInvalids, orValid,
         Severity(..),
 
         -- * Messages
@@ -110,6 +110,10 @@ allValid (v : vs) = v `andValid` allValid vs
 getInvalids :: [Validity] -> [MsgDoc]
 getInvalids vs = [d | NotValid d <- vs]
 
+orValid :: Validity -> Validity -> Validity
+orValid IsValid _ = IsValid
+orValid _       v = v
+
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
 
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index f27516258b..d6b02dcf00 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -458,7 +458,7 @@ sideConditions mtheta cls
   | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
   | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
   | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
-                                           cond_std `andCond`
+                                           cond_vanilla `andCond`
                                            cond_args cls)
   | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
                                            cond_vanilla `andCond`
@@ -521,13 +521,18 @@ cond_stdOK (Just _) _ _ _
   = IsValid     -- Don't check these conservative conditions for
                 -- standalone deriving; just generate the code
                 -- and let the typechecker handle the result
-cond_stdOK Nothing permissive _ rep_tc
+cond_stdOK Nothing permissive dflags rep_tc
   | null data_cons
-  , not permissive      = NotValid (no_cons_why rep_tc $$ suggestion)
-  | not (null con_whys) = NotValid (vcat con_whys $$ suggestion)
+  , not permissive = checkFlag LangExt.EmptyDataDeriving dflags rep_tc
+                     `orValid`
+                     NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
+  | not (null con_whys) = NotValid (vcat con_whys $$ standalone_suggestion)
   | otherwise           = IsValid
   where
-    suggestion = text "Possible fix: use a standalone deriving declaration instead"
+    empty_data_suggestion =
+      text "Use EmptyDataDeriving to enable deriving for empty data types"
+    standalone_suggestion =
+      text "Possible fix: use a standalone deriving declaration instead"
     data_cons  = tyConDataCons rep_tc
     con_whys   = getInvalids (map check_con data_cons)
 
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 70ceb30305..d9166e5e00 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -194,8 +194,9 @@ gen_Eq_binds loc tycon = do
               | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
     method_binds dflags = unitBag (eq_bind dflags)
-    eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons
-                                            ++ fall_through_eqn dflags)
+    eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)
+                                 (map pats_etc pat_match_cons
+                                   ++ fall_through_eqn dflags)
 
     ------------------------------------------------------------------
     pats_etc data_con
@@ -339,7 +340,7 @@ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
 gen_Ord_binds loc tycon = do
     dflags <- getDynFlags
     return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
-      then ( unitBag $ mkFunBindSE 2 loc compare_RDR []
+      then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
            , emptyBag)
       else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
            , aux_binds)
@@ -961,11 +962,15 @@ gen_Read_binds get_fixity loc tycon
     data_cons = tyConDataCons tycon
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 
-    read_prec = mkHsVarBind loc readPrec_RDR
-                              (nlHsApp (nlHsVar parens_RDR) read_cons)
+    read_prec = mkHsVarBind loc readPrec_RDR rhs
+      where
+        rhs | null data_cons -- See Note [Read for empty data types]
+            = nlHsVar pfail_RDR
+            | otherwise
+            = nlHsApp (nlHsVar parens_RDR)
+                      (foldr1 mk_alt (read_nullary_cons ++
+                                      read_non_nullary_cons))
 
-    read_cons | null data_cons = nlHsVar pfail_RDR  -- See Note [Read for empty data types]
-              | otherwise      = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 
     read_nullary_cons
@@ -1127,7 +1132,7 @@ gen_Show_binds get_fixity loc tycon
   = (unitBag shows_prec, emptyBag)
   where
     data_cons = tyConDataCons tycon
-    shows_prec = mkFunBindSE 1 loc showsPrec_RDR (map pats_etc data_cons)
+    shows_prec = mkFunBindEC 1 loc showsPrec_RDR id (map pats_etc data_cons)
     comma_space = nlHsVar showCommaSpace_RDR
 
     pats_etc data_con
@@ -1348,7 +1353,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
                | otherwise = prefix_RDR
 
         ------------ gfoldl
-    gfoldl_bind = mkFunBindSE 3 loc gfoldl_RDR (map gfoldl_eqn data_cons)
+    gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
 
     gfoldl_eqn con
       = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
@@ -1384,7 +1389,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
         tag = dataConTag dc
 
         ------------ toConstr
-    toCon_bind = mkFunBindSE 1 loc toConstr_RDR
+    toCon_bind = mkFunBindEC 1 loc toConstr_RDR id
                      (zipWith to_con_eqn data_cons constr_names)
     to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
 
@@ -1519,23 +1524,11 @@ makeG_d.
 -}
 
 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon
-  | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
-                       [mkMatch (mkPrefixFunRhs (L loc lift_RDR))
-                                        [nlWildPat] errorMsg_Expr
-                                        (noLoc emptyLocalBinds)])
-                     , emptyBag)
-  | otherwise = (unitBag lift_bind, emptyBag)
+gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
   where
-    -- We may want to make mkFunBindSE's error message generation general
-    -- enough to avoid needing to duplicate its logic here. On the other
-    -- hand, it may not be worth the trouble.
-    errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
-        (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
-
-    lift_bind = mkFunBindSE 1 loc lift_RDR (map pats_etc data_cons)
+    lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
+                            (map pats_etc data_cons)
     data_cons = tyConDataCons tycon
-    tycon_str = occNameString . nameOccName . tyConName $ tycon
 
     pats_etc data_con
       = ([con_pat], lift_Expr)
@@ -1865,6 +1858,21 @@ mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
 mkRdrFunBind fun@(L loc _fun_rdr) matches
   = L loc (mkFunBind fun matches)
 
+-- | Make a function binding. If no equations are given, produce a function
+-- with the given arity that uses an empty case expression for the last
+-- argument that is passes to the given function to produce the right-hand
+-- side.
+mkFunBindEC :: Arity -> SrcSpan -> RdrName
+            -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+            -> [([LPat GhcPs], LHsExpr GhcPs)]
+            -> LHsBind GhcPs
+mkFunBindEC arity loc fun catch_all pats_and_exprs
+  = mkRdrFunBindEC arity catch_all (L loc fun) matches
+  where
+    matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) p e
+                                (noLoc emptyLocalBinds)
+              | (p,e) <- pats_and_exprs ]
+
 -- | Produces a function binding. When no equations are given, it generates
 -- a binding of the given arity and an empty case expression
 -- for the last argument that it passes to the given function to produce
@@ -2115,7 +2123,7 @@ bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) ..
 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
 
 a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
-    true_Expr :: LHsExpr GhcPs
+    true_Expr, pure_Expr :: LHsExpr GhcPs
 a_Expr          = nlHsVar a_RDR
 b_Expr          = nlHsVar b_RDR
 c_Expr          = nlHsVar c_RDR
@@ -2125,6 +2133,7 @@ eqTag_Expr      = nlHsVar eqTag_RDR
 gtTag_Expr      = nlHsVar gtTag_RDR
 false_Expr      = nlHsVar false_RDR
 true_Expr       = nlHsVar true_RDR
+pure_Expr       = nlHsVar pure_RDR
 
 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
 a_Pat           = nlVarPat a_RDR
diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst
index 4ed70280eb..d7e5d6d61e 100644
--- a/docs/users_guide/8.4.1-notes.rst
+++ b/docs/users_guide/8.4.1-notes.rst
@@ -88,6 +88,18 @@ Language
   order that the users writes them, so the type of ``MkT`` is now
   ``forall b a. b -> T a`` (this matters for :ghc-flag:`-XTypeApplications`).
 
+- The new :ghc-flag:`-XEmptyDataDeriving` extension allows deriving ``Eq``,
+  ``Ord``, ``Read``, and ``Show`` instances directly for empty data types, as
+  in ``data Empty deriving Eq``. (Previously, this would require the use of
+  :ghc-flag:`-XStandaloneDeriving` to accomplish.)
+
+  One can also now derive ``Data`` instances directly for empty data types (as
+  in ``data Empty deriving Data``) without needing to use
+  :ghc-flag:`-XStandaloneDeriving`. However, since already requires a GHC
+  extension (:ghc-flag:`-XDeriveDataTypeable`), one does not need to enable
+  :ghc-flag:`-XEmptyDataDeriving` to do so. This also goes for other classes
+  which require extensions to derive, such as :ghc-flag:`-XDeriveFunctor`.
+
 Compiler
 ~~~~~~~~
 
@@ -112,36 +124,112 @@ Compiler
   See also :ref:`deriving-functor`, :ref:`deriving-foldable`, and
   :ref:`deriving-traversable`.
 
-- Derived ``Functor``, ``Foldable``, ``Traversable``, ``Generic``, and
-  ``Generic1`` instances now have better, and generally better-documented,
-  behaviors for types with no constructors. In particular, ::
+- Derived instances for empty data types are now substantially different
+  than before. Here is an overview of what has changed. These examples will
+  use a running example of ``data Empty a`` to describe what happens when an
+  instance is derived for ``Empty``:
 
-      fmap _ x = case x of
-      foldMap _ _ = mempty
-      traverse _ x = pure (case x of)
-      to x = case x of
-      to1 x = case x of
-      from x = case x of
-      from1 x = case x of
+  - Derived ``Eq`` and ``Ord`` instances would previously emit code that used
+    ``error``: ::
 
-  The new behavior generally leads to more useful error messages than the
-  old did, and lazier semantics for ``foldMap`` and ``traverse``.
+      instance Eq (Empty a) where
+        (==) = error "Void =="
 
-- Derived ``Foldable`` instances now derive custom definitions for ``null``
-  instead of using the default one. This leads to asymptotically better
-  performance for recursive types not shaped like cons-lists, and allows ``null``
-  to terminate for more (but not all) infinitely large structures.
+      instance Ord (Empty a) where
+        compare = error "Void compare"
+
+    Now, they emit code that uses maximally defined, lazier semantics: ::
+
+      instance Eq (Empty a) where
+        _ == _ = True
+
+      instance Ord (Empty a) where
+        compare _ _ = EQ
+
+  - Derived ``Read`` instances would previous emit code that used
+    ``parens``: ::
+
+      instance Read (Empty a) where
+        readPrec = parens pfail
+
+    But ``parens`` forces parts of the parsed string that it doesn't need to.
+    Now, the derived instance will not use ``parens`` (that it, parsing
+    ``Empty`` will always fail, without reading *any* input): ::
+
+      instance Read (Empty a) where
+        readPrec = pfail
+
+  - Derived ``Show`` instances would previously emit code that used
+    ``error``: ::
+
+      instance Show (Empty a) where
+        showsPrec = "Void showsPrec"
+
+    Now, they emit code that inspects the argument. That is, if the argument
+    diverges, then showing it will also diverge: ::
+
+      instance Show (Empty a) where
+        showsPrec _ x = case x of {}
+
+  - Derived ``Functor``, ``Foldable``, ``Traversable``, ``Generic``,
+    ``Generic1``, ``Lift``, and ``Data`` instances previously emitted code that
+    used ``error``: ::
 
-- Derived instances for types with no constructors now have appropriate
-  arities: they take all their arguments before producing errors. This may not
-  be terribly important in practice, but it seems like the right thing to do.
-  Previously, we generated ::
+      instance Functor Empty where
+        fmap = error "Void fmap"
 
-      (==) = error ...
+      instance Foldable Empty where
+        foldMap = error "Void foldMap"
 
-Now we generate ::
+      instance Traversable Empty where
+        traverse = error "Void traverse"
 
-      _ == _ = error ...
+      instance Generic (Empty a) where
+        from = M1 (error "No generic representation for empty datatype Empty")
+        to (M1 _) = error "No values for empty datatype Empty"
+      -- Similarly for Generic1
+
+      instance Lift (Empty a) where
+        lift _ = error "Can't lift value of empty datatype Empty"
+
+      instance Data a => Data (Empty a) where
+        gfoldl _ _ _ = error "Void gfoldl"
+        toConstr _ = error "Void toConstr"
+        ...
+
+    Now, derived ``Functor``, ``Traversable, ``Generic``, ``Generic1``,
+    ``Lift``, and ``Data`` instances emit code which inspects their
+    arguments: ::
+
+      instance Functor Empty where
+        fmap _ x = case x of {}
+
+      instance Traversable Empty where
+        traverse _ x = pure (case x of {})
+
+      instance Generic (Empty a) where
+        from x = M1 (case x of {})
+        to (M1 x) = case x of {}
+
+      -- Similarly for Generic1
+
+      instance Lift (Empty a) where
+        lift x = pure (case x of {})
+
+      instance Data a => Data (Empty a) where
+        gfoldl _ x = case x of {}
+        toConstr x = case x of {}
+        ...
+
+    Derived ``Foldable`` instances now are maximally lazy: ::
+
+      instance Foldable Empty where
+        foldMap _ _ = mempty
+
+- Derived ``Foldable`` instances now derive custom definitions for ``null``
+  instead of using the default one. This leads to asymptotically better
+  performance for recursive types not shaped like cons-lists, and allows ``null``
+  to terminate for more (but not all) infinitely large structures.
 
 - `-fsplit-sections` is now supported on x86_64 Windows and is on by default.
   See :ghc-ticket:`12913`.
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 492b105764..06f2263a73 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -2087,6 +2087,10 @@ then an explicit kind annotation must be used (see :ref:`kinding`).
 Such data types have only one value, namely bottom. Nevertheless, they
 can be useful when defining "phantom types".
 
+In conjunction with the :ghc-flag:`-XEmptyDataDeriving` extension, empty data
+declarations can also derive instances of standard type classes
+(see :ref:`empty-data-deriving`).
+
 .. _datatype-contexts:
 
 Data type contexts
@@ -3554,6 +3558,54 @@ GHC extends this mechanism along several axes:
   <#deriving-stragies>`__, especially if the compiler chooses the wrong
   one `by default <#default-deriving-strategy>`__.
 
+.. _empty-data-deriving:
+
+Deriving instances for empty data types
+---------------------------------------
+
+.. ghc-flag:: -XEmptyDataDeriving
+    :shortdesc: Allow deriving instances of standard type classes for
+                empty data types.
+    :type: dynamic
+    :reverse: -XNoEmptyDataDeriving
+    :category:
+
+    :since: 8.4.1
+
+    Allow deriving instances of standard type classes for empty data types.
+
+One can write data types with no constructors using the
+:ghc-flag:`-XEmptyDataDecls` flag (see :ref:`nullary-types`), which is on by
+default in Haskell 2010. What is not on by default is the ability to derive
+type class instances for these types. This ability is enabled through use of
+the :ghc-flag:`-XEmptyDataDeriving` flag. For instance, this lets one write: ::
+
+    data Empty deriving (Eq, Ord, Read, Show)
+
+This would generate the following instances: ::
+
+    instance Eq Empty where
+      _ == _ = True
+
+    instance Ord Empty where
+      compare _ _ = EQ
+
+    instance Read Empty where
+      readPrec = pfail
+
+    instance Show Empty where
+      showsPrec _ x = case x of {}
+
+The :ghc-flag:`-XEmptyDataDeriving` flag is only required to enable deriving
+of these four "standard" type classes (which are mentioned in the Haskell
+Report). Other extensions to the ``deriving`` mechanism, which are explained
+below in greater detail, do not require :ghc-flag:`-XEmptyDataDeriving` to be
+used in conjunction with empty data types. These include:
+
+* :ghc-flag:`-XStandaloneDeriving` (see :ref:`stand-alone-deriving`)
+* Type classes which require their own extensions to be enabled to be derived,
+  such as :ghc-flag:`-XDeriveFunctor` (see :ref:`deriving-extra`)
+* :ghc-flag:`-XDeriveAnyClass` (see :ref:`derive-any-class`)
 
 .. _deriving-inferred:
 
diff --git a/libraries/base/Data/Void.hs b/libraries/base/Data/Void.hs
index ed3cfbc330..beb6041f62 100644
--- a/libraries/base/Data/Void.hs
+++ b/libraries/base/Data/Void.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE EmptyDataDeriving #-}
 {-# LANGUAGE Safe #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
@@ -33,27 +34,17 @@ import Data.Semigroup (Semigroup(..), stimesIdempotent)
 -- | Uninhabited data type
 --
 -- @since 4.8.0.0
-data Void deriving (Generic)
-
-deriving instance Data Void
-
--- | @since 4.8.0.0
-instance Eq Void where
-    _ == _ = True
-
--- | @since 4.8.0.0
-instance Ord Void where
-    compare _ _ = EQ
-
--- | Reading a 'Void' value is always a parse error, considering
--- 'Void' as a data type with no constructors.
--- | @since 4.8.0.0
-instance Read Void where
-    readsPrec _ _ = []
-
--- | @since 4.8.0.0
-instance Show Void where
-    showsPrec _ = absurd
+data Void deriving
+  ( Eq      -- ^ @since 4.8.0.0
+  , Data    -- ^ @since 4.8.0.0
+  , Generic -- ^ @since 4.8.0.0
+  , Ord     -- ^ @since 4.8.0.0
+  , Read    -- ^ Reading a 'Void' value is always a parse error, considering
+            -- 'Void' as a data type with no constructors.
+            --
+            -- @since 4.8.0.0
+  , Show    -- ^ @since 4.8.0.0
+  )
 
 -- | @since 4.8.0.0
 instance Ix Void where
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index 3bb2299f32..3ae9a2cec5 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE EmptyDataDeriving          #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
@@ -755,12 +756,14 @@ import GHC.TypeLits ( Nat, Symbol, KnownSymbol, KnownNat, symbolVal, natVal )
 
 -- | Void: used for datatypes without constructors
 data V1 (p :: k)
-  deriving (Functor, Generic, Generic1)
-
-deriving instance Eq   (V1 p)
-deriving instance Ord  (V1 p)
-deriving instance Read (V1 p)
-deriving instance Show (V1 p)
+  deriving ( Eq       -- ^ @since 4.9.0.0
+           , Ord      -- ^ @since 4.9.0.0
+           , Read     -- ^ @since 4.9.0.0
+           , Show     -- ^ @since 4.9.0.0
+           , Functor  -- ^ @since 4.9.0.0
+           , Generic  -- ^ @since 4.9.0.0
+           , Generic1 -- ^ @since 4.9.0.0
+           )
 
 -- | Unit: used for constructors without arguments
 data U1 (p :: k) = U1
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index ff26ec6ce7..1979838a07 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -131,4 +131,5 @@ data Extension
    | Strict
    | StrictData
    | MonadFailDesugaring
+   | EmptyDataDeriving
    deriving (Eq, Enum, Show, Generic)
diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
index 47d5a984ab..e131c1cf5b 100644
--- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
+++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
@@ -2,25 +2,24 @@
 ==================== Derived instances ====================
 Derived class instances:
   instance GHC.Read.Read (DrvEmptyData.Void a) where
-    GHC.Read.readPrec
-      = GHC.Read.parens Text.ParserCombinators.ReadPrec.pfail
+    GHC.Read.readPrec = Text.ParserCombinators.ReadPrec.pfail
     GHC.Read.readList = GHC.Read.readListDefault
     GHC.Read.readListPrec = GHC.Read.readListPrecDefault
   
   instance GHC.Show.Show (DrvEmptyData.Void a) where
-    GHC.Show.showsPrec _ = GHC.Err.error "Void showsPrec"
+    GHC.Show.showsPrec z = case z of
   
   instance GHC.Classes.Ord (DrvEmptyData.Void a) where
-    GHC.Classes.compare _ _ = GHC.Err.error "Void compare"
+    GHC.Classes.compare _ z = GHC.Types.EQ
   
   instance GHC.Classes.Eq (DrvEmptyData.Void a) where
-    (GHC.Classes.==) _ _ = GHC.Err.error "Void =="
+    (GHC.Classes.==) _ z = GHC.Types.True
   
   instance Data.Data.Data a =>
            Data.Data.Data (DrvEmptyData.Void a) where
-    Data.Data.gfoldl _ _ _ = GHC.Err.error "Void gfoldl"
+    Data.Data.gfoldl _ _ z = case z of
     Data.Data.gunfold k z c = case Data.Data.constrIndex c of
-    Data.Data.toConstr _ = GHC.Err.error "Void toConstr"
+    Data.Data.toConstr z = case z of
     Data.Data.dataTypeOf _ = DrvEmptyData.$tVoid
     Data.Data.dataCast1 f = Data.Typeable.gcast1 f
   
@@ -46,8 +45,7 @@ Derived class instances:
   
   instance Language.Haskell.TH.Syntax.Lift
              (DrvEmptyData.Void a) where
-    Language.Haskell.TH.Syntax.lift _
-      = GHC.Err.error "Can't lift value of empty datatype Void"
+    Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of)
   
   DrvEmptyData.$tVoid :: Data.Data.DataType
   DrvEmptyData.$tVoid = Data.Data.mkDataType "Void" []
@@ -65,3 +63,237 @@ Derived type family instances:
 
 
 ==================== Filling in method body ====================
+GHC.Read.Read [DrvEmptyData.Void a[ssk:2]]
+  GHC.Read.readsPrec = GHC.Read.$dmreadsPrec
+                         @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Show.Show [DrvEmptyData.Void a[ssk:2]]
+  GHC.Show.show = GHC.Show.$dmshow @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Show.Show [DrvEmptyData.Void a[ssk:2]]
+  GHC.Show.showList = GHC.Show.$dmshowList
+                        @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.< = GHC.Classes.$dm< @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.<= = GHC.Classes.$dm<= @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.> = GHC.Classes.$dm> @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.>= = GHC.Classes.$dm>= @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.max = GHC.Classes.$dmmax @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes.min = GHC.Classes.$dmmin @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+GHC.Classes.Eq [DrvEmptyData.Void a[ssk:2]]
+  GHC.Classes./= = GHC.Classes.$dm/= @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.dataCast2 = Data.Data.$dmdataCast2
+                          @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapT = Data.Data.$dmgmapT @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQl = Data.Data.$dmgmapQl
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQr = Data.Data.$dmgmapQr
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQ = Data.Data.$dmgmapQ @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapQi = Data.Data.$dmgmapQi
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapM = Data.Data.$dmgmapM @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapMp = Data.Data.$dmgmapMp
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+  Data.Data.gmapMo = Data.Data.$dmgmapMo
+                       @(DrvEmptyData.Void a[ssk:2])
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.fold = Data.Foldable.$dmfold @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldr = Data.Foldable.$dmfoldr @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldr' = Data.Foldable.$dmfoldr' @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldl = Data.Foldable.$dmfoldl @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldl' = Data.Foldable.$dmfoldl' @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldr1 = Data.Foldable.$dmfoldr1 @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.foldl1 = Data.Foldable.$dmfoldl1 @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.toList = Data.Foldable.$dmtoList @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.null = Data.Foldable.$dmnull @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.length = Data.Foldable.$dmlength @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.elem = Data.Foldable.$dmelem @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.maximum = Data.Foldable.$dmmaximum
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.minimum = Data.Foldable.$dmminimum
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.sum = Data.Foldable.$dmsum @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+  Data.Foldable.product = Data.Foldable.$dmproduct
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Traversable.Traversable [DrvEmptyData.Void]
+  Data.Traversable.sequenceA = Data.Traversable.$dmsequenceA
+                                 @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Traversable.Traversable [DrvEmptyData.Void]
+  Data.Traversable.mapM = Data.Traversable.$dmmapM
+                            @(DrvEmptyData.Void)
+
+
+
+==================== Filling in method body ====================
+Data.Traversable.Traversable [DrvEmptyData.Void]
+  Data.Traversable.sequence = Data.Traversable.$dmsequence
+                                @(DrvEmptyData.Void)
+
+
diff --git a/testsuite/tests/deriving/should_fail/T7401_fail.hs b/testsuite/tests/deriving/should_fail/T7401_fail.hs
new file mode 100644
index 0000000000..730223f179
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T7401_fail.hs
@@ -0,0 +1,3 @@
+module T7401_fail where
+
+data D deriving Eq
diff --git a/testsuite/tests/deriving/should_fail/T7401_fail.stderr b/testsuite/tests/deriving/should_fail/T7401_fail.stderr
new file mode 100644
index 0000000000..feb841f962
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T7401_fail.stderr
@@ -0,0 +1,6 @@
+
+T7401_fail.hs:3:17: error:
+    • Can't make a derived instance of ‘Eq D’:
+        ‘D’ must have at least one data constructor
+        Use EmptyDataDeriving to enable deriving for empty data types
+    • In the data declaration for ‘D’
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index 1861e6dd0a..c9b8469c3c 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -44,6 +44,7 @@ test('T7148a', normal, compile_fail, [''])
 # T7800 was removed as it was out of date re: fixing #9858
 test('T5498', normal, compile_fail, [''])
 test('T6147', normal, compile_fail, [''])
+test('T7401_fail', normal, compile_fail, [''])
 test('T8165_fail1', normal, compile_fail, [''])
 test('T8165_fail2', normal, compile_fail, [''])
 test('T8851', normal, compile_fail, [''])
diff --git a/testsuite/tests/deriving/should_run/T5628.stderr b/testsuite/tests/deriving/should_run/T5628.stderr
deleted file mode 100644
index e203374673..0000000000
--- a/testsuite/tests/deriving/should_run/T5628.stderr
+++ /dev/null
@@ -1,3 +0,0 @@
-T5628: Void ==
-CallStack (from ImplicitParams):
-  error, called at T5628.hs:5:1 in main:Main
diff --git a/testsuite/tests/deriving/should_run/T5628.stdout b/testsuite/tests/deriving/should_run/T5628.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T5628.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/deriving/should_run/T7401.hs b/testsuite/tests/deriving/should_run/T7401.hs
new file mode 100644
index 0000000000..2f56df4e69
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T7401.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE EmptyDataDeriving #-}
+module Main where
+
+import Data.Function
+
+data Foo
+  deriving (Eq, Ord, Read, Show)
+
+foo1 :: Foo
+foo1 = fix id
+
+foo2 :: Foo
+foo2 = let x = y
+           y = x
+        in y
+
+main :: IO ()
+main = do
+  print (foo1 ==        foo2)
+  print (foo1 `compare` foo2)
diff --git a/testsuite/tests/deriving/should_run/T7401.stdout b/testsuite/tests/deriving/should_run/T7401.stdout
new file mode 100644
index 0000000000..886c3aedac
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T7401.stdout
@@ -0,0 +1,2 @@
+True
+EQ
diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T
index 3bcebdf371..c5605f627e 100644
--- a/testsuite/tests/deriving/should_run/all.T
+++ b/testsuite/tests/deriving/should_run/all.T
@@ -32,8 +32,9 @@ test('drvrun-foldable1', normal, compile_and_run, [''])
 test('T4136', normal, compile_and_run, [''])
 test('T4528a', normal, compile_and_run, [''])
 test('T5041', normal, compile_and_run, [''])
-test('T5628', exit_code(1), compile_and_run, [''])
+test('T5628', normal, compile_and_run, [''])
 test('T5712', normal, compile_and_run, [''])
+test('T7401', normal, compile_and_run, [''])
 test('T7931', normal, compile_and_run, [''])
 # T8280 is superseded by T10104
 test('T9576', exit_code(1), compile_and_run, [''])
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 3ae39d1ca2..c26a38861c 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -40,7 +40,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
                              "UnboxedSums",
-                             "DerivingStrategies"]
+                             "DerivingStrategies",
+                             "EmptyDataDeriving"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",