diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 56fdc43ae6a6d153d7fc81f4eb6e65d809d22963..7fe7a17d335eabfb1c70e6d3c81b63b441ee8dd9 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 5010a29513d4a5ecbeb1ed866fccbf00359f7514..258fc1170960f13ab21bfa3f68c1b15ddc0b50c8 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 f27516258bcd87b163caf42583cd3be303319228..d6b02dcf0038f56d1d79b8646ed9bf680ac99bf8 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 70ceb3030586112bfe459e1aa5b9b8ac60475eb3..d9166e5e002adf46aca92d28e47bcff9efa8ef75 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 4ed70280eb9158d40337ab5d9d4c421001e46894..d7e5d6d61e260baa92d91c27bce179d684a7cd13 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 492b105764d9c1947d5d2784d96187e9b48595c7..06f2263a736e3313b1cf8af522fe77c7618bd04d 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 ed3cfbc3306466cd4a04f2d57df2eab1d180a7e8..beb6041f626aa67eeb1fef428ea4e582fc674468 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 3bb2299f32d9155ac9aa8c5ed8e4221a43783b09..3ae9a2cec5a4c3010e1646638de260340855cd0c 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 ff26ec6ce7620a42832a9728c1e602d91243d5f3..1979838a0756e1c0652dbabec4c707ccd44494a2 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 47d5a984abbf862c43fc088567f4efabddf062a4..e131c1cf5b6fbb0563d06529e760ceafa932f0c7 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 0000000000000000000000000000000000000000..730223f17972127ee7025203cdd7966d1b7e482d
--- /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 0000000000000000000000000000000000000000..feb841f962c9b8d32839313853a2e7d514555975
--- /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 1861e6dd0ad2002759ec61624d8a49487bd6e29d..c9b8469c3cbf35c5487022c2a831e6a957285796 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 e203374673aedd0fc0904d7c7260ededa33e63e4..0000000000000000000000000000000000000000
--- 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 0000000000000000000000000000000000000000..0ca95142bb715442d0c2c82a7c573a08c4593845
--- /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 0000000000000000000000000000000000000000..2f56df4e6919b2151d98e5bc3dbd9d7773887fc9
--- /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 0000000000000000000000000000000000000000..886c3aedacc96ae80cfb2a1deb79cee6ed39abda
--- /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 3bcebdf371de7c8b99684c365010d47441dc657b..c5605f627e3ac9b4ae8929028e7267eb62ac6fb5 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 3ae39d1ca2feda67189f9cb98d210e27194106fc..c26a38861c31b8ed38cb04e8dd348a75aeea19ba 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",