packages feed

generic-data 0.9.2.1 → 1.1.0.2

raw patch · 16 files changed

Files

CHANGELOG.md view
@@ -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.
README.md view
@@ -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`.
generic-data.cabal view
@@ -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
orphans/Generic/Data/Orphans.hs view
@@ -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
src/Generic/Data.hs view
@@ -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
src/Generic/Data/Internal/Error.hs view
@@ -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")
src/Generic/Data/Internal/Generically.hs view
@@ -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
src/Generic/Data/Internal/Meta.hs view
@@ -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
src/Generic/Data/Internal/Microsurgery.hs view
@@ -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.
src/Generic/Data/Internal/Newtype.hs view
@@ -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.
src/Generic/Data/Internal/Read.hs view
@@ -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
src/Generic/Data/Microsurgery.hs view
@@ -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
test/bench.hs view
@@ -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
test/microsurgery.hs view
@@ -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   ]
test/one-liner-surgery.hs view
@@ -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  -- |
test/unit.hs view
@@ -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 ())