diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,42 @@ +# 1.1.0.2 -- 2024-12-07 + +- Compatibility with *base-orphans* 0.9.3 +- Tested with GHC 8.0 - 9.12.0 + +# 1.1.0.1 + +- Compatibility with *base* 4.21 (GHC 9.12) +- Avoid dependency on *contravariant* + +# 1.1.0.0 + +- Remove `Eq` and `Ord` for `Generically1` instances. + They are now available in *base* 4.18, and *base-orphans* 0.8.8 + for backwards compatibility. +- (Revisions) Also compatible with *base* 4.20 (GHC 9.10) and 4.19 (GHC 9.8) + +# 1.0.0.1 + +- Compatibility with *base* 4.18 (GHC 9.6) + +# 1.0.0.0 + +- `Generically` and `Generically1` are in *base* 4.17 (GHC 9.4.1)! + + + *generic-data* reexports `Generically` and `Generically1` if using *base* >= 4.17. + The following instances remain as orphans: `Eq`, `Ord`, `Read`, `Show`, + `Enum`, `Ix`, `Bounded`, `Foldable`, `Traversable`, `Read1`, `Show1`. + + base 4.17 includes instances for the non-stock-derivable classes: + `Semigroup` and `Monoid` for `Generically`; `Eq1`, `Ord1`, `Functor`, + `Applicative`, and `Alternative` for `Generically1`. + + Note: the `Semigroup` and `Monoid` instances of *base*'s `Generically` + are those of *generic-data*'s `GenericProduct` (which is subtly different + from `Generically`'s previous instance in *generic-data*). + + `Generically` and `Generically1` are no longer defined using record syntax, + so the `unGenerically`(`1`) field accessor no longer exists. + The field accessors for `FiniteEnumeration` and `GenericProduct` were also + removed for uniformity. + # 0.9.2.1 - No external changes. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,7 @@ -# Generic data types in Haskell [![Hackage](https://img.shields.io/hackage/v/generic-data.svg)](https://hackage.haskell.org/package/generic-data) [![GitHub CI](https://github.com/Lysxia/generic-data/workflows/CI/badge.svg)](https://github.com/Lysxia/generic-data/actions) +# Generic data types in Haskell + +[![Hackage](https://img.shields.io/hackage/v/generic-data.svg)](https://hackage.haskell.org/package/generic-data) +[![GitHub CI](https://github.com/Lysxia/generic-data/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/Lysxia/generic-data/actions) Utilities for `GHC.Generics`. diff --git a/generic-data.cabal b/generic-data.cabal --- a/generic-data.cabal +++ b/generic-data.cabal @@ -1,5 +1,5 @@ name: generic-data -version: 0.9.2.1 +version: 1.1.0.2 synopsis: Deriving instances with GHC.Generics and related utilities description: Generic implementations of standard type classes. @@ -15,8 +15,10 @@ build-type: Simple extra-source-files: README.md, CHANGELOG.md cabal-version: >=1.10 -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1, - GHC == 8.6.3, GHC == 8.6.5, GHC == 8.8.2 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, + GHC == 8.6.5, GHC == 8.10.7, GHC == 9.0.2, + GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, + GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.0 library hs-source-dirs: src @@ -41,11 +43,12 @@ Generic.Data.Internal.Utils build-depends: ap-normalize >= 0.1 && < 0.2, - base-orphans >= 0.8, - contravariant, + base-orphans >= 0.8.8, ghc-boot-th, show-combinators, - base >= 4.9 && < 5 + base >= 4.9 && < 4.22 + if impl(ghc < 9.6) + build-depends: contravariant hs-source-dirs: orphans exposed-modules: Generic.Data.Orphans @@ -124,28 +127,29 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 -test-suite generic-data-inspection-test +test-suite inspect hs-source-dirs: test main-is: inspection.hs other-modules: Inspection.Boilerplate - build-depends: - generic-data, - inspection-testing, - template-haskell, - unordered-containers, - base ghc-options: -Wall -threaded default-language: Haskell2010 type: exitcode-stdio-1.0 - if impl(ghc < 8.2) || os(windows) + if !flag(enable-inspect) buildable: False + else + build-depends: + generic-data, + inspection-testing, + template-haskell, + unordered-containers, + base benchmark bench hs-source-dirs: test main-is: bench.hs build-depends: - criterion, + tasty-bench, deepseq, generic-data, base @@ -154,6 +158,11 @@ type: exitcode-stdio-1.0 if !impl(ghc >= 8.6) buildable: False + +flag enable-inspect + description: Enable inspection tests (broken on ghc < 8.2 or >= 9.2) + default: False + manual: True source-repository head type: git diff --git a/orphans/Generic/Data/Orphans.hs b/orphans/Generic/Data/Orphans.hs --- a/orphans/Generic/Data/Orphans.hs +++ b/orphans/Generic/Data/Orphans.hs @@ -1,14 +1,20 @@ {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} --- | Orphan instances. They should probably be upstreamed. +-- | Orphan instances. +-- +-- The orphan instances in this module have been upstreamed in base 4.21 (GHC 9.12). +-- The base_orphans package includes these instances from version 0.9.3 onward. +-- This module is empty starting from that version. It remains for backwards compatiblity. module Generic.Data.Orphans where +#if __GLASGOW_HASKELL__ < 912 && !MIN_VERSION_base_orphans(0,9,3) import Data.Functor.Classes import Data.Orphans () import Data.Semigroup @@ -71,3 +77,4 @@ instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where liftCompare compare' (Comp1 x1) (Comp1 x2) = (liftCompare . liftCompare) compare' x1 x2 +#endif diff --git a/src/Generic/Data.hs b/src/Generic/Data.hs --- a/src/Generic/Data.hs +++ b/src/Generic/Data.hs @@ -1,18 +1,12 @@ -- | Generic combinators to derive type class instances. -- --- = Overview --- --- /base/ classes that GHC can not derive instances for, as of version 8.2: --- --- - 'Data.Semigroup.Semigroup', 'Monoid', 'Applicative', --- 'Control.Applicative.Alternative', 'Data.Functor.Classes.Eq1', --- 'Data.Functor.Classes.Ord1', 'Data.Functor.Classes.Show1'. +-- == Orphans -- --- On /base/ < 4.12 (i.e., GHC < 8.6), import "Generic.Data.Orphans" to obtain --- instances needed internally to derive those. +-- The 'Data.Generic.Orphans' module should be imported to derive the following +-- classes using this library: -- --- GHC can derive instances for other classes here, although there may be --- types supported by one method but not the other or vice versa. +-- - 'Eq1' and 'Ord1' +-- - 'Semigroup' and 'Monoid' on GHC 8.4 or older (base <= 4.11) -- -- == __Minor discrepancies__ -- @@ -61,9 +55,9 @@ -- -- This is due to a particular encoding choice of @GHC.Generics@, where -- composition are nested to the right instead of to the left. @f (g (h _))@ is --- represented by the functor @f ':.:' (g ':.:' 'Rec1' h)@, so one must use --- `fmap` on `f` to convert that back to `f (g (h _))`. A better choice would --- have been to encode it as @('Rec1' f ':.:' g) ':.:' h@, because that is +-- represented by the functor @f 'GHC.Generics.:.:' (g 'GHC.Generics.:.:' 'GHC.Generics.Rec1' h)@, so one must use +-- 'fmap' on @f@ to convert that back to @f (g (h _))@. A better choice would +-- have been to encode it as @('GHC.Generics.Rec1' f 'GHC.Generics.:.:' g) 'GHC.Generics.:.:' h@, because that is -- coercible back to @f (g (h _))@. module Generic.Data @@ -78,7 +72,7 @@ -- | Default implementations for classes indexed by types -- (kind @Type@). - -- ** 'Data.Semigroup.Semigroup' + -- ** 'Semigroup' , gmappend -- ** 'Monoid' @@ -105,7 +99,7 @@ -- ** 'Enum' , GEnum() - -- *** StandardEnum option + -- *** 'StandardEnum' option -- | Can also be derived by GHC as part of the standard. , StandardEnum() , gtoEnum @@ -114,7 +108,7 @@ , genumFromThen , genumFromTo , genumFromThenTo - -- *** FiniteEnum option + -- *** 'FiniteEnum' option , FiniteEnum() , gtoFiniteEnum , gfromFiniteEnum @@ -164,21 +158,21 @@ , gap , gliftA2 - -- ** 'Control.Applicative.Alternative' + -- ** 'Alternative' , gempty , galt - -- ** 'Data.Functor.Classes.Eq1' + -- ** 'Eq1' , gliftEq - -- ** 'Data.Functor.Classes.Ord1' + -- ** 'Ord1' , gliftCompare - -- ** 'Data.Functor.Classes.Read1' + -- ** 'Read1' , gliftReadPrec , GRead1 - -- ** 'Data.Functor.Classes.Show1' + -- ** 'Show1' , gliftShowsPrec , GShow1 @@ -266,3 +260,4 @@ import Generic.Data.Internal.Utils import GHC.Generics (Generic, Generic1) +import Data.Orphans () -- Eq and Ord of Generically1 diff --git a/src/Generic/Data/Internal/Error.hs b/src/Generic/Data/Internal/Error.hs --- a/src/Generic/Data/Internal/Error.hs +++ b/src/Generic/Data/Internal/Error.hs @@ -47,7 +47,7 @@ -- ... -- • Cannot derive Semigroup instance for AB due to sum type -- • When deriving the instance for (Semigroup AB) -type AssertNoSum (constraint :: * -> Constraint) a = +type AssertNoSum (constraint :: Type -> Constraint) a = Assert (Not (HasSum (Rep a))) ('Text "Cannot derive " ':<>: 'ShowType constraint ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text " due to sum type") diff --git a/src/Generic/Data/Internal/Generically.hs b/src/Generic/Data/Internal/Generically.hs --- a/src/Generic/Data/Internal/Generically.hs +++ b/src/Generic/Data/Internal/Generically.hs @@ -4,6 +4,10 @@ TypeFamilies, UndecidableInstances, UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-noncanonical-monoid-instances #-} +#if __GLASGOW_HASKELL__ >= 904 +{-# OPTIONS_GHC -Wno-orphans #-} +#endif -- | Newtypes with instances implemented using generic combinators. -- @@ -15,13 +19,15 @@ -- If something here seems useful, please report it or create a pull request to -- export it from an external module. -module Generic.Data.Internal.Generically where +module Generic.Data.Internal.Generically + ( Generically(..) + , Generically1(..) + , FiniteEnumeration(..) + , GenericProduct(..) ) where -import Control.Applicative +import GHC.Generics import Data.Functor.Classes -import Data.Semigroup import Data.Ix -import GHC.Generics import Text.Read import Generic.Data.Internal.Prelude hiding (gfoldMap, gtraverse, gsequenceA) @@ -31,10 +37,16 @@ import Generic.Data.Internal.Show import Generic.Data.Internal.Traversable (GFoldable, GTraversable, gfoldMap, gtraverse, gsequenceA) +#if __GLASGOW_HASKELL__ < 904 +import Control.Applicative +import Data.Semigroup +#endif + -- $setup -- >>> :set -XDerivingVia -XDeriveGeneric -- >>> import GHC.Generics (Generic, Generic1) +#if __GLASGOW_HASKELL__ < 904 -- | Type with instances derived via 'Generic'. -- -- === Examples @@ -68,12 +80,24 @@ -- deriving Generic -- deriving (Eq, Ord, Enum, Bounded) via (Generically V) -- :} -newtype Generically a = Generically { unGenerically :: a } +newtype Generically a = Generically a +instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (Generically a) where + (<>) = gmappend + +-- | This uses the 'Semigroup' instance of the wrapped type @a@ to define 'mappend'. +-- The purpose of this instance is to derive 'mempty', while remaining consistent +-- with possibly custom 'Semigroup' instances. +instance (AssertNoSum Semigroup a, Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (Generically a) where + mempty = gmempty + mappend (Generically x) (Generically y) = Generically (x <> y) +#endif + +-- | This is a hack to implicitly wrap/unwrap in the instances of 'Generically'. instance Generic a => Generic (Generically a) where type Rep (Generically a) = Rep a to = Generically . to - from = from . unGenerically + from (Generically x) = from x instance (Generic a, Eq (Rep a ())) => Eq (Generically a) where (==) = geq @@ -88,16 +112,6 @@ instance (Generic a, GShow0 (Rep a)) => Show (Generically a) where showsPrec = gshowsPrec -instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (Generically a) where - (<>) = gmappend - --- | This uses the 'Semigroup' instance of the wrapped type 'a' to define 'mappend'. --- The purpose of this instance is to derive 'mempty', while remaining consistent --- with possibly custom 'Semigroup' instances. -instance (AssertNoSum Semigroup a, Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (Generically a) where - mempty = gmempty - mappend (Generically x) (Generically y) = Generically (x <> y) - instance (Generic a, GEnum StandardEnum (Rep a)) => Enum (Generically a) where toEnum = gtoEnum fromEnum = gfromEnum @@ -115,6 +129,7 @@ minBound = gminBound maxBound = gmaxBound + -- | Type with 'Enum' instance derived via 'Generic' with 'FiniteEnum' option. -- This allows deriving 'Enum' for types whose constructors have fields. -- @@ -127,12 +142,12 @@ -- deriving Generic -- deriving (Enum, Bounded) via (FiniteEnumeration Booool) -- :} -newtype FiniteEnumeration a = FiniteEnumeration { unFiniteEnumeration :: a } +newtype FiniteEnumeration a = FiniteEnumeration a instance Generic a => Generic (FiniteEnumeration a) where type Rep (FiniteEnumeration a) = Rep a to = FiniteEnumeration . to - from = from . unFiniteEnumeration + from (FiniteEnumeration x) = from x instance (Generic a, GEnum FiniteEnum (Rep a)) => Enum (FiniteEnumeration a) where toEnum = gtoFiniteEnum @@ -147,6 +162,7 @@ minBound = gminBound maxBound = gmaxBound +#if __GLASGOW_HASKELL__ < 904 -- | Type with instances derived via 'Generic1'. -- -- === Examples @@ -195,30 +211,48 @@ -- deriving Generic1 -- deriving (Eq1, Ord1) via (Generically1 I) -- :} -newtype Generically1 f a = Generically1 { unGenerically1 :: f a } - -instance Generic (f a) => Generic (Generically1 f a) where - type Rep (Generically1 f a) = Rep (f a) - to = Generically1 . to - from = from . unGenerically1 - -instance Generic1 f => Generic1 (Generically1 f) where - type Rep1 (Generically1 f) = Rep1 f - to1 = Generically1 . to1 - from1 = from1 . unGenerically1 +newtype Generically1 f a = Generically1 (f a) instance (Generic1 f, Eq1 (Rep1 f)) => Eq1 (Generically1 f) where liftEq = gliftEq -instance (Generic1 f, Eq1 (Rep1 f), Eq a) => Eq (Generically1 f a) where - (==) = eq1 - instance (Generic1 f, Ord1 (Rep1 f)) => Ord1 (Generically1 f) where liftCompare = gliftCompare +instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where + fmap = gfmap + (<$) = gconstmap + +instance (Generic1 f, Applicative (Rep1 f)) => Applicative (Generically1 f) where + pure = gpure + (<*>) = gap +#if MIN_VERSION_base(4,10,0) + liftA2 = gliftA2 +#endif + +instance (Generic1 f, Alternative (Rep1 f)) => Alternative (Generically1 f) where + empty = gempty + (<|>) = galt + +instance (Generic1 f, Eq1 (Rep1 f), Eq a) => Eq (Generically1 f a) where + (==) = eq1 + instance (Generic1 f, Ord1 (Rep1 f), Ord a) => Ord (Generically1 f a) where compare = compare1 +#endif +-- | This is a hack to implicitly wrap/unwrap in the instances of 'Generically1'. +instance Generic (f a) => Generic (Generically1 f a) where + type Rep (Generically1 f a) = Rep (f a) + to = Generically1 . to + from (Generically1 x) = from x + +-- | This is a hack to implicitly wrap/unwrap in the instances of 'Generically1'. +instance Generic1 f => Generic1 (Generically1 f) where + type Rep1 (Generically1 f) = Rep1 f + to1 = Generically1 . to1 + from1 (Generically1 x) = from1 x + instance (Generic1 f, GRead1 (Rep1 f)) => Read1 (Generically1 f) where #if MIN_VERSION_base(4,10,0) liftReadPrec = gliftReadPrec @@ -242,21 +276,6 @@ instance (Generic1 f, GShow1 (Rep1 f), Show a) => Show (Generically1 f a) where showsPrec = showsPrec1 -instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where - fmap = gfmap - (<$) = gconstmap - -instance (Generic1 f, Applicative (Rep1 f)) => Applicative (Generically1 f) where - pure = gpure - (<*>) = gap -#if MIN_VERSION_base(4,10,0) - liftA2 = gliftA2 -#endif - -instance (Generic1 f, Alternative (Rep1 f)) => Alternative (Generically1 f) where - empty = gempty - (<|>) = galt - instance (Generic1 f, GFoldable (Rep1 f)) => Foldable (Generically1 f) where foldMap = gfoldMap foldr = gfoldr @@ -266,7 +285,6 @@ traverse = gtraverse sequenceA = gsequenceA - -- | Product type with generic instances of 'Semigroup' and 'Monoid'. -- -- This is similar to 'Generic.Data.Generically' in most cases, but @@ -290,12 +308,12 @@ -- @('<>')@ (the 'Semigroup' method), which might not exist, or might not be -- equivalent to @Vector@'s generic 'Semigroup' instance, which would be -- unlawful. -newtype GenericProduct a = GenericProduct { unGenericProduct :: a } +newtype GenericProduct a = GenericProduct a instance Generic a => Generic (GenericProduct a) where type Rep (GenericProduct a) = Rep a to = GenericProduct . to - from = from . unGenericProduct + from (GenericProduct x) = from x instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (GenericProduct a) where (<>) = gmappend diff --git a/src/Generic/Data/Internal/Meta.hs b/src/Generic/Data/Internal/Meta.hs --- a/src/Generic/Data/Internal/Meta.hs +++ b/src/Generic/Data/Internal/Meta.hs @@ -29,6 +29,7 @@ module Generic.Data.Internal.Meta where import Data.Proxy +import Data.Kind (Type) import GHC.Generics import GHC.TypeLits (Symbol, Nat, KnownNat, type (+), natVal, TypeError, ErrorMessage(..)) @@ -255,14 +256,14 @@ type GConIdNamed n f = GConIdNamed' n f 0 'Nothing -type family GConIdNamed' (n :: Symbol) (f :: k -> *) (i :: Nat) (o :: Maybe Nat) :: Maybe Nat where +type family GConIdNamed' (n :: Symbol) (f :: k -> Type) (i :: Nat) (o :: Maybe Nat) :: Maybe Nat where GConIdNamed' n (M1 D _c f) i r = GConIdNamed' n f i r GConIdNamed' n (f :+: g) i r = GConIdNamed' n f i (GConIdNamed' n g (i + NConstructors f) r) GConIdNamed' n (M1 C ('MetaCons n _f _s) _g) i _r = 'Just i GConIdNamed' n (M1 C ('MetaCons _n _f _s) _g) _i r = r GConIdNamed' _n V1 _i r = r -type family GConIdNamedIf (n :: Symbol) (t :: *) (o :: Maybe Nat) :: Nat where +type family GConIdNamedIf (n :: Symbol) (t :: Type) (o :: Maybe Nat) :: Nat where GConIdNamedIf _n _t ('Just i) = i GConIdNamedIf n t 'Nothing = TypeError ('Text "No constructor named " ':<>: 'ShowType n @@ -273,7 +274,7 @@ -- | Constraint that a generic type @a@ is not empty. -- Producing an error message otherwise. -- --- The 'Symbol' parameter 'fname' is used only for error messages. +-- The 'Symbol' parameter @fname@ is used only for error messages. -- -- It is implied by the simpler constraint @'IsEmptyType' a ~ 'False@ class NonEmptyType_ fname a => NonEmptyType fname a @@ -295,7 +296,7 @@ type NonEmptyType_ fname a = (ErrorIfEmpty fname a (IsEmptyType a) ~ '()) -- 'True' if the generic representation is @M1 D _ V1@. -type family GIsEmptyType (r :: k -> *) :: Bool where +type family GIsEmptyType (r :: k -> Type) :: Bool where GIsEmptyType (M1 D _d V1) = 'True GIsEmptyType (M1 D _d (M1 C _c _f)) = 'False GIsEmptyType (M1 D _d (_f :+: _g)) = 'False @@ -316,7 +317,7 @@ -- Error message: -- -- > The function 'conIdMin' cannot be used with the empty type E -type family ErrorIfEmpty (fname :: Symbol) (a :: *) (b :: Bool) :: () where +type family ErrorIfEmpty (fname :: Symbol) (a :: Type) (b :: Bool) :: () where ErrorIfEmpty fname a 'True = TypeError ('Text "The function '" ':<>: 'Text fname ':<>: 'Text "' cannot be used with the empty type " ':<>: 'ShowType a) @@ -325,7 +326,7 @@ -- * Type families -- | 'Meta' field of the 'M1' type constructor. -type family MetaOf (f :: * -> *) :: Meta where +type family MetaOf (f :: Type -> Type) :: Meta where MetaOf (M1 i d f) = d -- Variable names borrowed from the documentation on 'Meta'. @@ -382,5 +383,5 @@ type DummyMeta = 'MetaData "" "" "" 'False -- | Remove an 'M1' type constructor. -type family UnM1 (f :: k -> *) :: k -> * +type family UnM1 (f :: k -> Type) :: k -> Type type instance UnM1 (M1 i c f) = f diff --git a/src/Generic/Data/Internal/Microsurgery.hs b/src/Generic/Data/Internal/Microsurgery.hs --- a/src/Generic/Data/Internal/Microsurgery.hs +++ b/src/Generic/Data/Internal/Microsurgery.hs @@ -23,6 +23,7 @@ module Generic.Data.Internal.Microsurgery where import Data.Coerce (Coercible, coerce) +import Data.Kind (Type) import GHC.Generics import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) @@ -50,14 +51,20 @@ -- -- T won't be shown as a record: -- -- show (T {unT = 3}) == "T 3" -- @ -type Surgery (s :: *) (a :: *) = Generically (Surgery' s a) +type Surgery (s :: Type) (a :: Type) = Generically (Surgery' s a) -- | Apply a microsurgery @s@ to a type @a@ for @DerivingVia@ for the -- 'Data.Monoid.Monoid' class. -type ProductSurgery (s :: *) (a :: *) = GenericProduct (Surgery' s a) +type ProductSurgery (s :: Type) (a :: Type) = GenericProduct (Surgery' s a) +-- | Plural of 'Surgery'. Apply a list of microsurgeries. +type Surgeries (s :: [Type]) (a :: Type) = Surgery (Cat s) a + +-- | Plural of 'ProductSurgery'. Apply a list of microsurgeries. +type ProductSurgeries (s :: [Type]) (a :: Type) = ProductSurgery (Cat s) a + -- | See 'Surgery'. -newtype Surgery' (s :: *) (a :: *) = Surgery' { unSurgery' :: a } +newtype Surgery' (s :: Type) (a :: Type) = Surgery' { unSurgery' :: a } instance (Generic a, Coercible (GSurgery s (Rep a)) (Rep a)) => Generic (Surgery' s a) where type Rep (Surgery' s a) = GSurgery s (Rep a) @@ -66,7 +73,7 @@ -- | Apply a microsurgery represented by a symbol @s@ (declared as a dummy data -- type) to a generic representation @f@. -type family GSurgery (s :: *) (f :: k -> *) :: k -> * +type family GSurgery (s :: Type) (f :: k -> Type) :: k -> Type -- * Derecordify @@ -93,10 +100,10 @@ -- names. -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. -data Derecordify :: * +data Derecordify :: Type type instance GSurgery Derecordify f = GDerecordify f -type family GDerecordify (f :: k -> *) :: k -> * +type family GDerecordify (f :: k -> Type) :: k -> Type type instance GDerecordify (M1 D m f) = M1 D m (GDerecordify f) type instance GDerecordify (f :+: g) = GDerecordify f :+: GDerecordify g type instance GDerecordify (f :*: g) = GDerecordify f :*: GDerecordify g @@ -127,7 +134,7 @@ -- > data Foo = Bar Baz -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. -data Typeage :: * +data Typeage :: Type type instance GSurgery Typeage (M1 D ('MetaData nm md pk _nt) f) = M1 D ('MetaData nm md pk 'False) f -- * Renaming @@ -165,10 +172,10 @@ -- > data Foo = Bar { bag :: Zap } -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. -data RenameFields (rnm :: *) :: * +data RenameFields (rnm :: Type) :: Type type instance GSurgery (RenameFields rnm) f = GRenameFields rnm f -type family GRenameFields (rnm :: *) (f :: k -> *) :: k -> * +type family GRenameFields (rnm :: Type) (f :: k -> Type) :: k -> Type type instance GRenameFields rnm (M1 D m f) = M1 D m (GRenameFields rnm f) type instance GRenameFields rnm (f :+: g) = GRenameFields rnm f :+: GRenameFields rnm g type instance GRenameFields rnm (f :*: g) = GRenameFields rnm f :*: GRenameFields rnm g @@ -186,10 +193,10 @@ -- > data Foo = Car { baz :: Zap } -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. -data RenameConstrs (rnm :: *) :: * +data RenameConstrs (rnm :: Type) :: Type type instance GSurgery (RenameConstrs rnm) f = GRenameConstrs rnm f -type family GRenameConstrs (rnm :: *) (f :: k -> *) :: k -> * +type family GRenameConstrs (rnm :: Type) (f :: k -> Type) :: k -> Type type instance GRenameConstrs rnm (M1 D m f) = M1 D m (GRenameConstrs rnm f) type instance GRenameConstrs rnm (f :+: g) = GRenameConstrs rnm f :+: GRenameConstrs rnm g type instance GRenameConstrs rnm (f :*: g) = GRenameConstrs rnm f :*: GRenameConstrs rnm g @@ -207,7 +214,7 @@ -- data FooToBar -- type instance FooToBar '@@' \"foo\" = \"bar\" -- @ -type family (f :: *) @@ (s :: Symbol) :: Symbol +type family (f :: Type) @@ (s :: Symbol) :: Symbol -- | Identity function @'Symbol' -> 'Symbol'@. data SId @@ -222,11 +229,11 @@ type instance SConst z @@ _s = z -- | Define a function for a fixed set of strings, and fall back to @f@ for the others. -data SRename (xs :: [(Symbol, Symbol)]) (f :: *) +data SRename (xs :: [(Symbol, Symbol)]) (f :: Type) type instance SRename xs f @@ s = SRename' xs f s -- | Closed type family for 'SRename'. -type family SRename' (xs :: [(Symbol, Symbol)]) (f :: *) (s :: Symbol) where +type family SRename' (xs :: [(Symbol, Symbol)]) (f :: Type) (s :: Symbol) where SRename' '[] f s = f @@ s SRename' ('( s, t) ': _xs) _f s = t SRename' ('(_r, _t) ': xs) f s = SRename' xs f s @@ -237,7 +244,7 @@ -- | Unify the "spines" of two generic representations (the "spine" is -- everything except the field types). -class UnifyRep (f :: k -> *) (g :: k -> *) +class UnifyRep (f :: k -> Type) (g :: k -> Type) instance (g' ~ M1 s c g, UnifyRep f g) => UnifyRep (M1 s c f) g' instance (g' ~ (g1 :+: g2), UnifyRep f1 g1, UnifyRep f2 g2) => UnifyRep (f1 :+: f2) g' @@ -279,10 +286,10 @@ -- > , b :: f Int } -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. -data OnFields (f :: * -> *) :: * +data OnFields (f :: Type -> Type) :: Type type instance GSurgery (OnFields f) g = GOnFields f g -type family GOnFields (f :: * -> *) (g :: k -> *) :: k -> * +type family GOnFields (f :: Type -> Type) (g :: k -> Type) :: k -> Type type instance GOnFields f (M1 s m r) = M1 s m (GOnFields f r) type instance GOnFields f (r :+: s) = GOnFields f r :+: GOnFields f s type instance GOnFields f (r :*: s) = GOnFields f r :*: GOnFields f s @@ -290,12 +297,78 @@ type instance GOnFields f U1 = U1 type instance GOnFields f V1 = V1 --- | Apply a type constructor to every field type of a type @a@ to make a +-- | Apply a type constructor @f@ to every field type of a type @a@ to make a -- synthetic type. -type DOnFields (f :: * -> *) (a :: *) = Data (GSurgery (OnFields f) (Rep a)) () +type DOnFields (f :: Type -> Type) (a :: Type) = Data (GSurgery (OnFields f) (Rep a)) () +-- | Apply a type constructor @f@ to the field named @s@ in a generic record @r@. +-- +-- > data Vec a = Vec +-- > { len :: Int +-- > , contents :: [a] } +-- > +-- > -- with (OnField "len" Sum) becomes -- +-- > +-- > data Vec a = Vec +-- > { len :: Sum Int +-- > , contents :: [a] } +-- +-- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. +-- See also the synonym @('%~')@. +data OnField (s :: Symbol) (f :: Type -> Type) :: Type +type instance GSurgery (OnField s f) g = GOnField s f g + +type family GOnField (x :: Symbol) (f :: Type -> Type) (g :: k -> Type) :: k -> Type where + GOnField x f (M1 S ('MetaSel ('Just x) a b c) (K1 i t)) = M1 S ('MetaSel ('Just x) a b c) (K1 i (f t)) + GOnField x f (M1 S m r) = M1 S m r + GOnField x f (M1 C m r) = M1 C m (GOnField x f r) + GOnField x f (M1 D m r) = M1 D m (GOnField x f r) + GOnField x f (r :+: s) = GOnField x f r :+: GOnField x f s + GOnField x f (r :*: s) = GOnField x f r :*: GOnField x f s + GOnField x f (K1 i a) = K1 i (f a) + GOnField x f U1 = U1 + GOnField x f V1 = V1 + +-- | Infix name for 'OnField'. To be used with 'Surgeries' or 'Cat'. +-- +-- === __Examples__ +-- +-- Transform one @Int@ field into @'Data.Monoid.Sum' Int@ for deriving 'Monoid': +-- +-- @ +-- data Vec a = Vec +-- { len :: Int +-- , contents :: [a] } +-- deriving Generic +-- deriving (Eq, Show) via Generically (Vec a) +-- deriving (Semigroup, Monoid) via 'ProductSurgeries' '[\"len\" '%~' 'Data.Monoid.Sum'] (Vec a) +-- @ +-- +-- Wrap unshowable fields in 'Generic.Data.Opaque' for deriving 'Show': +-- +-- @ +-- data Unshowable = Unshowable +-- { fun :: Int -> Int +-- , io :: IO Bool +-- , int :: Int } +-- deriving Generic +-- deriving Show via 'Surgeries' '[\"fun\" '%~' 'Generic.Data.Opaque', \"io\" '%~' 'Generic.Data.Opaque'] Unshowable +-- +-- -- show (Unshowable id (pure True) 42) = \"Unshowable _ _ 42\" +-- @ +type (%~) = OnField +infixr 4 %~ + +-- | Compose surgeries together. +data Cat (ss :: [Type]) :: Type +type instance GSurgery (Cat '[]) g = g +type instance GSurgery (Cat (s ': ss)) g = GSurgery s (GSurgery (Cat ss) g) + +-- | Make a synthetic type ('Data') by chaining multiple surgeries. +type DCat (ss :: [Type]) (a :: Type) = Data (GSurgery (Cat ss) (Rep a)) () + -- | Change the generic representation to that of another type @a@. -data CopyRep (a :: *) :: * +data CopyRep (a :: Type) :: Type type instance GSurgery (CopyRep a) _ = Rep a copyRep :: forall a f p. diff --git a/src/Generic/Data/Internal/Newtype.hs b/src/Generic/Data/Internal/Newtype.hs --- a/src/Generic/Data/Internal/Newtype.hs +++ b/src/Generic/Data/Internal/Newtype.hs @@ -20,7 +20,7 @@ module Generic.Data.Internal.Newtype where import Data.Coerce (Coercible, coerce) -import Data.Kind (Constraint) +import Data.Kind (Constraint, Type) import GHC.Generics (Generic(..), D1, C1, S1, K1) import GHC.TypeLits (TypeError, ErrorMessage(..)) @@ -39,7 +39,7 @@ -- @ type Old a = GOld (Rep a) -type family GOld (f :: * -> *) where +type family GOld (f :: Type -> Type) where GOld (D1 _d (C1 _c (S1 _s (K1 _i b)))) = b -- | Use 'Newtype' instead. diff --git a/src/Generic/Data/Internal/Read.hs b/src/Generic/Data/Internal/Read.hs --- a/src/Generic/Data/Internal/Read.hs +++ b/src/Generic/Data/Internal/Read.hs @@ -38,8 +38,8 @@ -- -- @ -- instance 'Read' MyType where --- 'readPrec' = 'greadPrec' --- 'readListPrec' = 'readListPrecDefault' +-- 'readPrec' = 'Text.Read.greadPrec' +-- 'readListPrec' = 'Text.Read.readListPrecDefault' -- @ greadPrec :: (Generic a, GRead0 (Rep a)) => ReadPrec a greadPrec = to <$> gPrecRead Proxy diff --git a/src/Generic/Data/Microsurgery.hs b/src/Generic/Data/Microsurgery.hs --- a/src/Generic/Data/Microsurgery.hs +++ b/src/Generic/Data/Microsurgery.hs @@ -37,6 +37,8 @@ Surgery , ProductSurgery + , Surgeries + , ProductSurgeries , Surgery'(..) , GSurgery , Generically(..) @@ -105,8 +107,8 @@ -- ** Wrap every field in a type constructor -- | Give every field a type @f FieldType@ (where @f@ is a parameter), to - -- obtain a family of types with a shared structure. This - -- \"higher-kindification\" technique is presented in the following + -- obtain a family of types with a shared structure. Some applications of + -- this \"higher-kindification\" technique may be found in the following -- blogposts: -- -- - https://www.benjamin.pizza/posts/2017-12-15-functor-functors.html @@ -122,6 +124,15 @@ -- a product of 'Prelude.Num' types: -- -- @ + -- data TwoCounters = MkTwoCounters { c1 :: Int, c2 :: Int } + -- deriving 'GHC.Generics.Generic' + -- deriving ('Data.Semigroup.Semigroup', 'Data.Monoid.Monoid') + -- via ('ProductSurgery' ('OnFields' 'Data.Monoid.Sum') TwoCounters) -- Surgery here + -- @ + -- + -- ==== __Extensions and imports__ + -- + -- @ -- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} -- import "Data.Monoid" ('Data.Monoid.Sum'(..)) -- Constructors must be in scope -- import "GHC.Generics" ('GHC.Generics.Generic') @@ -131,15 +142,16 @@ -- , 'GenericProduct'(..) -- Constructors must be in scope -- , 'Surgery''(..) -- -- ) - -- - -- data TwoCounters = MkTwoCounters { c1 :: Int, c2 :: Int } - -- deriving 'GHC.Generics.Generic' - -- deriving ('Data.Semigroup.Semigroup', 'Data.Monoid.Monoid') - -- via ('ProductSurgery' ('OnFields' 'Data.Monoid.Sum') TwoCounters) -- Surgery here -- @ , OnFields() , DOnFields + + , OnField() + , type (%~) + + , Cat() + , DCat() -- ** Substitute a generic representation from another type diff --git a/test/bench.hs b/test/bench.hs --- a/test/bench.hs +++ b/test/bench.hs @@ -13,7 +13,7 @@ import Text.Show (showParen, showString) import Control.DeepSeq -import Criterion.Main +import Test.Tasty.Bench import Generic.Data import Generic.Data.Microsurgery diff --git a/test/microsurgery.hs b/test/microsurgery.hs --- a/test/microsurgery.hs +++ b/test/microsurgery.hs @@ -5,7 +5,10 @@ TypeApplications #-} #if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE + DerivingVia, + ExplicitNamespaces, + TypeOperators #-} #endif -- @DataKinds@ and @TypeApplications@ for @renameFields@ and @renameConstrs@ @@ -21,13 +24,15 @@ ) #if __GLASGOW_HASKELL__ >= 806 -import Data.Monoid (Sum(..), Product(..)) - -- DerivingVia test -- Constructors must be visible for Coercible +import Data.Monoid (Sum(..), Product(..)) + +import Generic.Data (Opaque(..)) import Generic.Data.Microsurgery - ( Surgery, ProductSurgery, Surgery'(..), Generically(..), GenericProduct(..) + ( Surgery, Surgeries, ProductSurgery, ProductSurgeries, Surgery'(..), Generically(..), GenericProduct(..) , Derecordify, OnFields, CopyRep + , type (%~) ) #endif @@ -58,6 +63,20 @@ deriving Generic deriving Show via (Surgery Derecordify (Polar a)) deriving (Semigroup, Monoid) via (ProductSurgery (CopyRep (Product a, Sum a)) (Polar a)) + +data Vec a = Vec + { len :: Int + , contents :: [a] } + deriving Generic + deriving (Eq, Show) via Generically (Vec a) + deriving (Semigroup, Monoid) via ProductSurgeries '["len" %~ Data.Monoid.Sum] (Vec a) + +data Unshowable = Unshowable + { fun :: Int -> Int + , io :: IO Bool + , int :: Int } + deriving Generic + deriving Show via Surgeries '["fun" %~ Opaque, "io" %~ Opaque] Unshowable #endif main :: IO () @@ -72,5 +91,7 @@ , testCase "Semigroup V" $ "V 5 6" @?= show (V 2 3 <> V 3 3) , testCase "Monoid Polar" $ "Exp 1 0" @?= show (mempty :: Polar Int) , testCase "Semigroup Polar" $ "Exp 9 6" @?= show (Exp 3 4 <> Exp 3 2 :: Polar Int) + , testCase "Vec" $ Vec 3 [1,2,3] @?= (Vec 1 [1 :: Int] <> Vec 2 [2,3]) + , testCase "Unshowable" $ "Unshowable {fun = _, io = _, int = 42}" @?= show (Unshowable id (pure True) 42) #endif ] diff --git a/test/one-liner-surgery.hs b/test/one-liner-surgery.hs --- a/test/one-liner-surgery.hs +++ b/test/one-liner-surgery.hs @@ -17,6 +17,7 @@ import Control.Applicative ((<|>)) import Data.Coerce (coerce) import Data.Functor.Identity (Identity(..)) +import Data.Kind (Type) import GHC.Generics (Generic) import Text.Read (readMaybe) import Test.Tasty @@ -69,7 +70,7 @@ instance (a ~ Maybe (UnMaybe a)) => IsMaybe a -- | Helper for 'IsMaybe' above. -type family UnMaybe (a :: *) :: * where +type family UnMaybe (a :: Type) :: Type where UnMaybe (Maybe b) = b -- | diff --git a/test/unit.hs b/test/unit.hs --- a/test/unit.hs +++ b/test/unit.hs @@ -21,7 +21,8 @@ deriving (Generic, Generic1) instance Semigroup a => Semigroup (P a) where - x <> y = unGenerically (Generically x <> Generically y) + x <> y = case Generically x <> Generically y of + Generically z -> z type PTy a = a -> a -> Generically (P a) @@ -137,12 +138,21 @@ showsPrec = gshowsPrec maybeModuleName :: String -#if MIN_VERSION_base(4,12,0) +#if MIN_VERSION_base(4,20,0) +maybeModuleName = "GHC.Internal.Maybe" +#elif MIN_VERSION_base(4,12,0) maybeModuleName = "GHC.Maybe" #else maybeModuleName = "GHC.Base" #endif +maybePackageName :: String +#if MIN_VERSION_base(4,20,0) +maybePackageName = "ghc-internal" +#else +maybePackageName = "base" +#endif + main :: IO () main = defaultMain test @@ -252,7 +262,7 @@ , testGroup "Meta" [ testCase "datatypeName" $ "Maybe" @=? gdatatypeName @(Maybe Int) , testCase "moduleName" $ maybeModuleName @=? gmoduleName @(Maybe Int) - , testCase "packageName" $ "base" @=? gpackageName @(Maybe Int) + , testCase "packageName" $ maybePackageName @=? gpackageName @(Maybe Int) , testCase "isNewtype" $ False @=? gisNewtype @(Maybe Int) , testCase "conName" $ "Just" @=? gconName (Just ()) , testCase "conFixity" $ Prefix @=? gconFixity (Just ())