diff options
| -rw-r--r-- | compiler/main/DynFlags.hs | 1 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.hs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcDerivUtils.hs | 15 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 61 | ||||
| -rw-r--r-- | docs/users_guide/8.4.1-notes.rst | 134 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.rst | 52 | ||||
| -rw-r--r-- | libraries/base/Data/Void.hs | 33 | ||||
| -rw-r--r-- | libraries/base/GHC/Generics.hs | 15 | ||||
| -rw-r--r-- | libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs | 1 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/drv-empty-data.stderr | 250 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_fail/T7401_fail.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_fail/T7401_fail.stderr | 6 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_fail/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_run/T5628.stderr | 3 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_run/T5628.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_run/T7401.hs | 20 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_run/T7401.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_run/all.T | 3 | ||||
| -rw-r--r-- | testsuite/tests/driver/T4437.hs | 3 |
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", |