generic-data-1.1.0.0/0000755000000000000000000000000007346545000012363 5ustar0000000000000000generic-data-1.1.0.0/CHANGELOG.md0000644000000000000000000001213107346545000014172 0ustar0000000000000000# 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. # 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. - Use cabal-docspec instead of doctest # 0.9.2.0 - Add instance of `Bounded` for `FiniteEnumeration` (the same as `Generically`) # 0.9.1.0 - Fix `conIdToString` (it was completely broken) - Add `conIdMin` and `conIdMax` representing the leftmost and rightmost constructors of a data type. - Add `NonEmptyType` and `IsEmptyType` to express the constraint that a generic type must or must not be empty. - Reexport `Generic` and `Generic1` for convenience. # 0.9.0.0 - Improved definition of `gfoldMap`, `gtraverse`, and `sequenceA`. The optimized Core of `Traversable` instances eliminates all `GHC.Generic` instance boilerplate. In many cases, it is identical to the result of GHC's `DeriveFoldable` and `DeriveTraversable` extensions (note: this was already not a problem for `gfmap`). It's worth noting that there are currently issues with inlining which prevent optimizations that *generic-data* would ideally rely on. + The biggest issue is that GHC will not even inline the `to` and `from` methods of the `Generic` instance it derives for large types (this shows up at around 5 constructors and 10 fields, which is indeed not really big). This will be fixed by a patch for GHC (WIP): https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2965 + There appear to be some more inlining issues beyond that (issue #40). # 0.8.3.0 - Add generic `Read`. Thanks to RyanGlScott. # 0.8.2.0 - Add microsurgery `CopyRep`. - Improve documentation of `Microsurgery` module. - Fix a bug where `gshowsPrec` would incorrectly display prefix uses of symbol data constructors or record selectors (e.g., `data R = (:!:) Int Int` or `data S = MkS { (##) :: Int -> Int }`). Thanks to RyanGlScott. - Fix a bug where `gshowsPrec` would incorrectly display infix uses of alphanumeric data constructors (e.g., ```data T = Int `MkT` Int```). Thanks to RyanGlScott. # 0.8.1.0 - Add `Old` type family mapping newtypes to their underlying type. # 0.8.0.0 - Add `GenericProduct`, for deriving `via GenericProduct B` when `B` is not the type `A` you want the derived instance for. Note this used to be `Generically`'s behavior for `Monoid` before 0.7.0.0. - Add generic implementations for `Ix`. Thanks to Topsii. - Add `conIdNamed`, to get a `ConId` by its type-level name - Add instance `Show (ConId a)` - Improve type errors for deriving `Semigroup` and `Monoid` via `Generically`. Thanks to yairchu. # 0.7.0.0 - Change `Monoid` instance for `Generically`, to be compatible with users' non-generic instances of `Semigroup`. Thanks to yairchu. - Add `gcoerce`, `gcoerceBinop`. # 0.6.0.1 - Fix derivation of `Show1` for `(:.:)` # 0.6.0.0 - Add `Surgery` newtype for DerivingVia - `Derecordify`, `Typeage`, `RenameFields`, `RenameConstrs`, `OnFields` are no longer type families, but defunctionalized symbols to be applied using `GSurgery`. # 0.5.0.0 - Specialize `onData` to `Data` - Add some instances for `U1` and `V1` in `Microsurgery` - Add `OnFields` and `DOnFields` surgeries ("higher-kindification") # 0.4.0.0 - Created `Microsurgery` module. Initial set of surgeries: + `Derecordify` + `Typeage` + `RenameFields`, `RenameConstrs` + Some doc about using generic-lens for surgeries # 0.3.0.0 - Add generic implementations of `enumFrom`, `enumFromThen`, `enumFromTo`, `enumFromThenTo`. They are actually required to be explicit for correct `Enum` instances. Thanks to Topsii. - Parameterize `GEnum` by a type-level option, and add `FiniteEnum` option to allow `Enum` to be derived for composite types. Thanks to Topsii. # 0.2.0.0 - Remove `Generic.Data.Types.Map` - Add `Generic.Data.Data.Types.toData` and `fromData` - Remove `Defun` module (subsumed by `first-class-families` package) # 0.1.1.0 - Add `gconIndex` - Interface for constructor tags - Type-level `Meta` accessors - Add basic `Newtype` functions # 0.1.0.0 Released generic-data generic-data-1.1.0.0/LICENSE0000644000000000000000000000204507346545000013371 0ustar0000000000000000Copyright Li-yao Xia (c) 2018 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.generic-data-1.1.0.0/README.md0000644000000000000000000001235007346545000013643 0ustar0000000000000000# 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) Utilities for `GHC.Generics`. ## Generic deriving for standard classes ### Example: generically deriving Semigroup instances for products Semi-automatic method using `gmappend` ```haskell data Foo a = Bar [a] [a] deriving Generic instance Semigroup (Foo a) where (<>) = gmappend ``` This library also synergizes with the `DerivingVia` extension (introduced in GHC 8.6), thanks to the `Generically` newtype. ```haskell data Foo a = Bar [a] [a] deriving Generic deriving Semigroup via (Generically (Foo a)) ``` These examples can be found in `test/example.hs`. --- Note for completeness, the first example uses the following extensions and imports: ```haskell {-# LANGUAGE DeriveGeneric #-} -- base import Data.Semigroup (Semigroup(..)) -- generic-data import Generic.Data (Generic, gmappend) import Generic.Data.Orphans () ``` The second example makes these additions on top: ```haskell {-# LANGUAGE DerivingStrategies, DerivingVia #-} -- since GHC 8.6.1 -- In addition to the previous imports import Generic.Data (Generically(..)) ``` ### Supported classes Supported classes that GHC currently can't derive: `Semigroup`, `Monoid`, `Applicative`, `Alternative`, `Eq1`, `Ord1`, `Show1`. Other classes from base are also supported, even though GHC can already derive them: - `Eq`, `Ord`, `Enum`, `Bounded`, `Show`, `Read` (derivable by the standard); - `Functor`, `Foldable`, `Traversable` (derivable via extensions, `DeriveFunctor`, etc.). To derive type classes outside of the standard library, it might be worth taking a look at [one-liner](https://hackage.haskell.org/package/one-liner). ## Type metadata Extract type names, constructor names, number and arities of constructors, etc.. ## Type surgery generic-data offers simple operations (microsurgeries) on generic representations. More surgeries can be found in [generic-data-surgery](https://hackage.haskell.org/package/generic-data-surgery), and suprisingly, in [generic-lens](https://hackage.haskell.org/package/generic-lens) and [one-liner](https://hackage.haskell.org/package/one-liner). For more details, see also: - the module `Generic.Data.Microsurgery`; - the files `test/lens-surgery.hs` and `one-liner-surgery.hs`. ### Surgery example Derive an instance of `Show` generically for a record type, but as if it were not a record. ```haskell {-# LANGUAGE DeriveGeneric #-} import Generic.Data (Generic, gshowsPrec) import Generic.Data.Microsurgery (toData, derecordify) -- An example record type newtype T = T { unT :: Int } deriving Generic -- Naively deriving Show would result in this being shown: -- -- show (T 3) = "T {unT = 3}" -- -- But instead, with a simple surgery, unrecordify, we can forget T was -- declared as a record: -- -- show (T 3) = "T 3" instance Show T where showsPrec n = gshowsPrec n . derecordify . toData -- This example can be found in test/microsurgery.hs ``` Alternatively, using `DerivingVia`: ```haskell {-# LANGUAGE DeriveGeneric, DerivingVia #-} import Generic.Data (Generic) -- Reexported from GHC.Generics -- Constructors must be visible to use DerivingVia import Generic.Data.Microsurgery (Surgery, Surgery'(..), Generically(..), Derecordify) data V = V { v1 :: Int, v2 :: Int } deriving Generic deriving Show via (Surgery Derecordify V) -- show (V {v1 = 3, v2 = 4}) = "V 3 4" ``` --- ## Related links generic-data aims to subsume generic deriving features of the following packages: - [semigroups](https://hackage.haskell.org/package/semigroups): generic `Semigroup`, `Monoid`, but with a heavier dependency footprint. - [transformers-compat](https://hackage.haskell.org/package/transformers-compat): generic `Eq1`, `Ord1`, `Show1`. - [generic-deriving](https://hackage.haskell.org/package/generic-deriving): doesn't derive the classes in base (defines clones of these classes as a toy example); has Template Haskell code to derive `Generic` (not in generic-data). Other relevant links. - [deriving-compat](https://hackage.haskell.org/package/deriving-compat): deriving with Template Haskell. - [one-liner](https://hackage.haskell.org/package/one-liner): another approach to using `GHC.Generics` to derive instances of many type classes, including but not restricted to the above classes (this is done in [one-liner-instances](https://hackage.haskell.org/package/one-liner-instances)). - [singletons](https://hackage.haskell.org/package/singletons), [first-class-families](https://hackage.haskell.org/package/first-class-families) (second one written by me) libraries for dependently-typed programming in Haskell. - [coercible-utils](https://hackage.haskell.org/package/coercible-utils): utilities for coercible types. --- ## Internal module policy Modules under `Generic.Data.Internal` are not subject to any versioning policy. Breaking changes may apply to them at any time. If something in those modules seems useful, please report it or create a pull request to export it from an external module. --- All contributions are welcome. Open an issue or a pull request on Github! generic-data-1.1.0.0/Setup.hs0000644000000000000000000000005607346545000014020 0ustar0000000000000000import Distribution.Simple main = defaultMain generic-data-1.1.0.0/generic-data.cabal0000644000000000000000000000773707346545000015710 0ustar0000000000000000name: generic-data version: 1.1.0.0 synopsis: Deriving instances with GHC.Generics and related utilities description: Generic implementations of standard type classes. Operations on generic representations to help using "GHC.Generics". See README. homepage: https://github.com/Lysxia/generic-data#readme license: MIT license-file: LICENSE author: Li-yao Xia maintainer: lysxia@gmail.com copyright: 2018-2020 Li-yao Xia category: Generics 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.4, GHC == 8.6.5, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.7, GHC == 9.4.4, GHC == 9.6.1 library hs-source-dirs: src exposed-modules: Generic.Data Generic.Data.Types Generic.Data.Microsurgery Generic.Data.Internal.Compat Generic.Data.Internal.Data Generic.Data.Internal.Enum Generic.Data.Internal.Error Generic.Data.Internal.Functions Generic.Data.Internal.Generically Generic.Data.Internal.Meta Generic.Data.Internal.Microsurgery Generic.Data.Internal.Newtype Generic.Data.Internal.Prelude Generic.Data.Internal.Read Generic.Data.Internal.Resolvers Generic.Data.Internal.Show Generic.Data.Internal.Traversable Generic.Data.Internal.Utils build-depends: ap-normalize >= 0.1 && < 0.2, base-orphans >= 0.8.8, contravariant, ghc-boot-th, show-combinators, base >= 4.9 && < 4.19 hs-source-dirs: orphans exposed-modules: Generic.Data.Orphans ghc-options: -Wall default-language: Haskell2010 test-suite unit-test hs-source-dirs: test main-is: unit.hs build-depends: tasty, tasty-hunit, generic-data, show-combinators >= 0.2, base ghc-options: -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 test-suite record-test hs-source-dirs: test main-is: record.hs build-depends: generic-data, base ghc-options: -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 test-suite example-test hs-source-dirs: test main-is: example.hs build-depends: generic-data, base ghc-options: -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 test-suite microsurgery-test hs-source-dirs: test main-is: microsurgery.hs build-depends: tasty, tasty-hunit, generic-data, base ghc-options: -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 test-suite lens-surgery-test hs-source-dirs: test main-is: lens-surgery.hs build-depends: tasty, tasty-hunit, generic-data, generic-lens >= 1.1.0.0, base ghc-options: -Wall default-language: Haskell2010 type: exitcode-stdio-1.0 test-suite one-liner-surgery-test hs-source-dirs: test main-is: one-liner-surgery.hs build-depends: tasty, tasty-hunit, generic-data, generic-lens >= 1.1.0.0, one-liner >= 1.0, base ghc-options: -Wall -threaded default-language: Haskell2010 type: exitcode-stdio-1.0 test-suite inspect hs-source-dirs: test main-is: inspection.hs other-modules: Inspection.Boilerplate ghc-options: -Wall -threaded default-language: Haskell2010 type: exitcode-stdio-1.0 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: tasty-bench, deepseq, generic-data, base ghc-options: -Wall default-language: Haskell2010 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 location: https://github.com/Lysxia/generic-data generic-data-1.1.0.0/orphans/Generic/Data/0000755000000000000000000000000007346545000016262 5ustar0000000000000000generic-data-1.1.0.0/orphans/Generic/Data/Orphans.hs0000644000000000000000000000416507346545000020236 0ustar0000000000000000{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} -- | Orphan instances. They should probably be upstreamed. module Generic.Data.Orphans where import Data.Functor.Classes import Data.Orphans () import Data.Semigroup import GHC.Generics instance Eq1 V1 where liftEq _ v _ = case v of {} instance Ord1 V1 where liftCompare _ v _ = case v of {} instance Eq1 U1 where liftEq _ _ _ = True instance Ord1 U1 where liftCompare _ _ _ = EQ instance Eq c => Eq1 (K1 i c) where liftEq _ (K1 x1) (K1 x2) = x1 == x2 instance Ord c => Ord1 (K1 i c) where liftCompare _ (K1 x1) (K1 x2) = compare x1 x2 deriving instance Eq1 f => Eq1 (M1 i c f) deriving instance Ord1 f => Ord1 (M1 i c f) instance (Eq1 f, Eq1 g) => Eq1 (f :*: g) where liftEq (==.) (x1 :*: y1) (x2 :*: y2) = liftEq (==.) x1 x2 && liftEq (==.) y1 y2 instance (Ord1 f, Ord1 g) => Ord1 (f :*: g) where liftCompare compare' (x1 :*: y1) (x2 :*: y2) = liftCompare compare' x1 x2 <> liftCompare compare' y1 y2 instance (Eq1 f, Eq1 g) => Eq1 (f :+: g) where liftEq (==.) (L1 x1) (L1 x2) = liftEq (==.) x1 x2 liftEq (==.) (R1 y1) (R1 y2) = liftEq (==.) y1 y2 liftEq _ _ _ = False instance (Ord1 f, Ord1 g) => Ord1 (f :+: g) where liftCompare compare' (L1 x1) (L1 x2) = liftCompare compare' x1 x2 liftCompare compare' (R1 y1) (R1 y2) = liftCompare compare' y1 y2 liftCompare _ (L1 _) (R1 _) = LT liftCompare _ (R1 _) (L1 _) = GT instance Eq1 f => Eq1 (Rec1 f) where liftEq (==.) (Rec1 r1) (Rec1 r2) = liftEq (==.) r1 r2 instance Ord1 f => Ord1 (Rec1 f) where liftCompare compare' (Rec1 r1) (Rec1 r2) = liftCompare compare' r1 r2 instance Eq1 Par1 where liftEq (==.) (Par1 p1) (Par1 p2) = p1 ==. p2 instance Ord1 Par1 where liftCompare compare' (Par1 p1) (Par1 p2) = compare' p1 p2 instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where liftEq (==.) (Comp1 x1) (Comp1 x2) = (liftEq . liftEq) (==.) x1 x2 instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where liftCompare compare' (Comp1 x1) (Comp1 x2) = (liftCompare . liftCompare) compare' x1 x2 generic-data-1.1.0.0/src/Generic/0000755000000000000000000000000007346545000014526 5ustar0000000000000000generic-data-1.1.0.0/src/Generic/Data.hs0000644000000000000000000001526507346545000015744 0ustar0000000000000000-- | Generic combinators to derive type class instances. -- -- == Orphans -- -- The 'Data.Generic.Orphans' module should be imported to derive the following -- classes using this library: -- -- - 'Eq1' and 'Ord1' -- - 'Semigroup' and 'Monoid' on GHC 8.4 or older (base <= 4.11) -- -- == __Minor discrepancies__ -- -- Here are documented some corner cases of deriving, both by GHC and -- generic-data. They are all minor and unlikely to cause problems in -- practice. -- -- === Empty types -- -- - Some of the derived methods are lazy, which might result in errors -- being silenced, though unlikely. -- - The only generic-data implementation which differs from GHC stock -- instances is 'gfoldMap'. -- -- +------------------+-----------+--------------+-----------------------+ -- | Class method | GHC stock | generic-data | Comment | -- +------------------+-----------+--------------+-----------------------+ -- | @('==')@ | lazy | lazy | 'True' | -- +------------------+-----------+--------------+-----------------------+ -- | 'compare' | lazy | lazy | 'EQ' | -- +------------------+-----------+--------------+-----------------------+ -- | 'fmap' | strict | strict | must be bottom anyway | -- +------------------+-----------+--------------+-----------------------+ -- | 'foldMap' | lazy | strict | 'mempty' if lazy | -- +------------------+-----------+--------------+-----------------------+ -- | 'foldr' | lazy | lazy | returns accumulator | -- +------------------+-----------+--------------+-----------------------+ -- | 'traverse' | strict | strict | | -- +------------------+-----------+--------------+-----------------------+ -- | 'sequenceA' | strict | strict | | -- +------------------+-----------+--------------+-----------------------+ -- -- === Single-constructor single-field types -- -- @data@ types with one constructor and one field are extremely rare. -- @newtype@ is almost always more appropriate (for which there is no issue). -- -- That said, for @data@ types both strict and lazy, all generic-data -- implementations are lazy (they don't even force the constructor), -- whereas GHC stock implementations, when they exist, are strict. -- -- === Functor composition -- -- Fields of functors involving the composition of two or more functors -- @f (g (h a))@ result in some overhead using "GHC.Generics.Generic1". -- -- 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 '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 ( -- * Newtypes for Deriving Via Generically(..) , GenericProduct(..) , FiniteEnumeration(..) , Generically1(..) -- * Regular classes -- | Default implementations for classes indexed by types -- (kind @Type@). -- ** 'Semigroup' , gmappend -- ** 'Monoid' , gmempty , gmappend' -- ** 'Eq' -- | Can also be derived by GHC as part of the standard. , geq -- ** 'Ord' -- | Can also be derived by GHC as part of the standard. , gcompare -- ** 'Read' -- | Can also be derived by GHC as part of the standard. , greadPrec , GRead0 -- ** 'Show' -- | Can also be derived by GHC as part of the standard. , gshowsPrec , GShow0 -- ** 'Enum' , GEnum() -- *** 'StandardEnum' option -- | Can also be derived by GHC as part of the standard. , StandardEnum() , gtoEnum , gfromEnum , genumFrom , genumFromThen , genumFromTo , genumFromThenTo -- *** 'FiniteEnum' option , FiniteEnum() , gtoFiniteEnum , gfromFiniteEnum , gfiniteEnumFrom , gfiniteEnumFromThen , gfiniteEnumFromTo , gfiniteEnumFromThenTo -- ** 'Bounded' -- | Can also be derived by GHC as part of the standard. , gminBound , gmaxBound , GBounded() -- ** 'Ix' -- | Can also be derived by GHC as part of the standard. , grange , gindex , ginRange , GIx() , gunsafeIndex -- * Higher-kinded classes -- | Default implementations for classes indexed by type constructors -- (kind @Type -> Type@). -- ** 'Functor' -- | Can also be derived by GHC (@DeriveFunctor@ extension). , gfmap , gconstmap -- ** 'Foldable' -- | Can also be derived by GHC (@DeriveFoldable@ extension). , gfoldMap , gfoldr , GFoldable -- ** 'Traversable' -- | Can also be derived by GHC (@DeriveTraversable@ extension). , gtraverse , gsequenceA , GTraversable -- ** 'Applicative' , gpure , gap , gliftA2 -- ** 'Alternative' , gempty , galt -- ** 'Eq1' , gliftEq -- ** 'Ord1' , gliftCompare -- ** 'Read1' , gliftReadPrec , GRead1 -- ** 'Show1' , gliftShowsPrec , GShow1 -- * Fields wrappers for deriving , Id1(..) , Opaque(..) , Opaque1(..) -- * Newtype -- | Generic pack/unpack. , Newtype , Old , pack , unpack -- * Generic coercions , gcoerce , gcoerceBinop -- * Accessing metadata -- | Using @TypeApplications@. -- ** Datatype , gdatatypeName , gmoduleName , gpackageName , gisNewtype , GDatatype -- ** Constructor , gconName , gconFixity , gconIsRecord , gconNum , gconIndex , Constructors , GConstructors -- *** Constructor tags , ConId() , conId , conIdToInt , conIdToString , conIdEnum , conIdNamed , ConIdNamed , conIdMin , conIdMax , NonEmptyType , IsEmptyType -- ** Using type families , MetaOf , MetaDataName , MetaDataModule , MetaDataPackage , MetaDataNewtype , MetaConsName , MetaConsFixity , MetaConsRecord , MetaSelNameM , MetaSelName , MetaSelUnpack , MetaSelSourceStrictness , MetaSelStrictness -- * The @Generic@ class -- | Reexported from "GHC.Generics". , Generic() , Generic1() ) where import Generic.Data.Internal.Prelude hiding (gfoldMap, gtraverse, gsequenceA) import Generic.Data.Internal.Enum import Generic.Data.Internal.Generically import Generic.Data.Internal.Meta import Generic.Data.Internal.Read import Generic.Data.Internal.Show import Generic.Data.Internal.Traversable import Generic.Data.Internal.Newtype import Generic.Data.Internal.Resolvers import Generic.Data.Internal.Utils import GHC.Generics (Generic, Generic1) import Data.Orphans () -- Eq and Ord of Generically1 generic-data-1.1.0.0/src/Generic/Data/Internal/0000755000000000000000000000000007346545000017153 5ustar0000000000000000generic-data-1.1.0.0/src/Generic/Data/Internal/Compat.hs0000644000000000000000000000203207346545000020727 0ustar0000000000000000{-# LANGUAGE CPP, DataKinds, TypeFamilies, TypeOperators, UndecidableInstances #-} -- | Shim for backwards compatibility. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Compat ( readPrec1 , Div ) where import Data.Functor.Classes import GHC.TypeLits #if !MIN_VERSION_base(4,10,0) import Text.ParserCombinators.ReadPrec (ReadPrec, readS_to_Prec) import Text.Read (Read(..)) #endif #if !MIN_VERSION_base(4,10,0) readPrec1 :: (Read1 f, Read a) => ReadPrec (f a) readPrec1 = readS_to_Prec $ liftReadsPrec readsPrec readList #endif #if !MIN_VERSION_base(4,11,0) type Div m n = Div' (CmpNat m n) m n type family Div' (ord :: Ordering) (m :: Nat) (n :: Nat) :: Nat type instance Div' 'LT m n = 0 type instance Div' 'GT m n = 1 + Div (m-n) n type instance Div' 'EQ m n = 1 #endif generic-data-1.1.0.0/src/Generic/Data/Internal/Data.hs0000644000000000000000000000424307346545000020363 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | Generic representations as data types. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Data where import Control.Applicative import Control.Monad import Data.Functor.Classes import Data.Functor.Contravariant (Contravariant, phantom) import Data.Semigroup import GHC.Generics import Generic.Data.Internal.Enum import Generic.Data.Internal.Show -- | Synthetic data type. -- -- A wrapper to view a generic 'Rep' as the datatype it's supposed to -- represent, without needing a declaration. newtype Data r p = Data { unData :: r p } deriving ( Functor, Foldable, Traversable, Applicative, Alternative , Monad, MonadPlus, Contravariant , Eq, Ord, Eq1, Ord1, Semigroup, Monoid ) -- | Conversion between a generic type and the synthetic type made using its -- representation. Inverse of 'fromData'. toData :: Generic a => a -> Data (Rep a) p toData = Data . from -- | Inverse of 'toData'. fromData :: Generic a => Data (Rep a) p -> a fromData = to . unData instance (Functor r, Contravariant r) => Generic (Data r p) where type Rep (Data r p) = r to = Data . phantom from = phantom . unData instance Generic1 (Data r) where type Rep1 (Data r) = r to1 = Data from1 = unData instance (GShow1 r, Show p) => Show (Data r p) where showsPrec = flip (gLiftPrecShows showsPrec showList . unData) instance GShow1 r => Show1 (Data r) where liftShowsPrec = (fmap . fmap) (flip . (. unData)) gLiftPrecShows instance GEnum StandardEnum r => Enum (Data r p) where toEnum = Data . gToEnum @StandardEnum fromEnum = gFromEnum @StandardEnum . unData instance GBounded r => Bounded (Data r p) where minBound = Data gMinBound maxBound = Data gMaxBound generic-data-1.1.0.0/src/Generic/Data/Internal/Enum.hs0000644000000000000000000003225407346545000020421 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | Generic deriving for 'Enum', 'Bounded' and 'Ix'. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Enum where import GHC.Generics import Data.Ix -- | Generic 'toEnum' generated with the 'StandardEnum' option. -- -- @ -- instance 'Enum' MyType where -- 'toEnum' = 'gtoEnum' -- 'fromEnum' = 'gfromEnum' -- 'enumFrom' = 'genumFrom' -- 'enumFromThen' = 'genumFromThen' -- 'enumFromTo' = 'genumFromTo' -- 'enumFromThenTo' = 'genumFromThenTo' -- @ gtoEnum :: (Generic a, GEnum StandardEnum (Rep a)) => Int -> a gtoEnum = gtoEnum' @StandardEnum "gtoEnum" -- | Generic 'fromEnum' generated with the 'StandardEnum' option. -- -- See also 'gtoEnum'. gfromEnum :: (Generic a, GEnum StandardEnum (Rep a)) => a -> Int gfromEnum = gfromEnum' @StandardEnum -- | Generic 'enumFrom' generated with the 'StandardEnum' option. -- -- See also 'gtoEnum'. genumFrom :: (Generic a, GEnum StandardEnum (Rep a)) => a -> [a] genumFrom = genumFrom' @StandardEnum -- | Generic 'enumFromThen' generated with the 'StandardEnum' option. -- -- See also 'gtoEnum'. genumFromThen :: (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> [a] genumFromThen = genumFromThen' @StandardEnum -- | Generic 'enumFromTo' generated with the 'StandardEnum' option. -- -- See also 'gtoEnum'. genumFromTo :: (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> [a] genumFromTo = genumFromTo' @StandardEnum -- | Generic 'enumFromThenTo' generated with the 'StandardEnum' option. -- -- See also 'gtoEnum'. genumFromThenTo :: (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> a -> [a] genumFromThenTo = genumFromThenTo' @StandardEnum -- | Generic 'toEnum' generated with the 'FiniteEnum' option. -- -- @ -- instance 'Enum' MyType where -- 'toEnum' = 'gtoFiniteEnum' -- 'fromEnum' = 'gfromFiniteEnum' -- 'enumFrom' = 'gfiniteEnumFrom' -- 'enumFromThen' = 'gfiniteEnumFromThen' -- 'enumFromTo' = 'gfiniteEnumFromTo' -- 'enumFromThenTo' = 'gfiniteEnumFromThenTo' -- @ gtoFiniteEnum :: (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a gtoFiniteEnum = gtoEnum' @FiniteEnum "gtoFiniteEnum" -- | Generic 'fromEnum' generated with the 'FiniteEnum' option. -- -- See also 'gtoFiniteEnum'. gfromFiniteEnum :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> Int gfromFiniteEnum = gfromEnum' @FiniteEnum -- | Generic 'enumFrom' generated with the 'FiniteEnum' option. -- -- See also 'gtoFiniteEnum'. gfiniteEnumFrom :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> [a] gfiniteEnumFrom = genumFrom' @FiniteEnum -- | Generic 'enumFromThen' generated with the 'FiniteEnum' option. -- -- See also 'gtoFiniteEnum'. gfiniteEnumFromThen :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a] gfiniteEnumFromThen = genumFromThen' @FiniteEnum -- | Generic 'enumFromTo' generated with the 'FiniteEnum' option. -- -- See also 'gtoFiniteEnum'. gfiniteEnumFromTo :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a] gfiniteEnumFromTo = genumFromTo' @FiniteEnum -- | Generic 'enumFromThenTo' generated with the 'FiniteEnum' option. -- -- See also 'gtoFiniteEnum'. gfiniteEnumFromThenTo :: (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> a -> [a] gfiniteEnumFromThenTo = genumFromThenTo' @FiniteEnum -- | Unsafe generic 'toEnum'. Does not check whether the argument is within -- valid bounds. Use 'gtoEnum' or 'gtoFiniteEnum' instead. gtoEnumRaw' :: forall opts a. (Generic a, GEnum opts (Rep a)) => Int -> a gtoEnumRaw' = to . gToEnum @opts -- | Generic 'toEnum'. Use 'gfromEnum' or 'gfromFiniteEnum' instead. gtoEnum' :: forall opts a. (Generic a, GEnum opts (Rep a)) => String -> Int -> a gtoEnum' name n | 0 <= n && n < card = gtoEnumRaw' @opts n | otherwise = error $ name ++ ": out of bounds, index " ++ show n ++ ", cardinality " ++ show card where card = gCardinality @opts @(Rep a) -- | Generic 'fromEnum'. Use 'gfromEnum' or 'gfromFiniteEnum' instead. gfromEnum' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> Int gfromEnum' = gFromEnum @opts . from -- | > genumMin == gfromEnum gminBound genumMin :: Int genumMin = 0 -- | > genumMax == gfromEnum gmaxBound genumMax :: forall opts a. (Generic a, GEnum opts (Rep a)) => Int genumMax = gCardinality @opts @(Rep a) - 1 -- | Generic 'enumFrom'. Use 'genumFrom' or 'gfiniteEnumFrom' instead. genumFrom' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> [a] genumFrom' x = map toE [ i_x .. genumMax @opts @a ] where toE = gtoEnumRaw' @opts i_x = gfromEnum' @opts x -- | Generic 'enumFromThen'. Use 'genumFromThen' or 'gfiniteEnumFromThen' instead. genumFromThen' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> a -> [a] genumFromThen' x1 x2 = map toE [ i_x1, i_x2 .. bound ] where toE = gtoEnumRaw' @opts i_x1 = gfromEnum' @opts x1 i_x2 = gfromEnum' @opts x2 bound | i_x1 >= i_x2 = genumMin | otherwise = genumMax @opts @a -- | Generic 'enumFromTo'. Use 'genumFromTo' or 'gfiniteEnumFromTo' instead. genumFromTo' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> a -> [a] genumFromTo' x y = map toE [ i_x .. i_y ] where toE = gtoEnumRaw' @opts i_x = gfromEnum' @opts x i_y = gfromEnum' @opts y -- | Generic 'enumFromThenTo'. Use 'genumFromThenTo' or 'gfiniteEnumFromThenTo' instead. genumFromThenTo' :: forall opts a. (Generic a, GEnum opts (Rep a)) => a -> a -> a -> [a] genumFromThenTo' x1 x2 y = map toE [ i_x1, i_x2 .. i_y ] where toE = gtoEnumRaw' @opts i_x1 = gfromEnum' @opts x1 i_x2 = gfromEnum' @opts x2 i_y = gfromEnum' @opts y -- | Generic 'minBound'. -- -- @ -- instance 'Bounded' MyType where -- 'minBound' = 'gminBound' -- 'maxBound' = 'gmaxBound' -- @ gminBound :: (Generic a, GBounded (Rep a)) => a gminBound = to gMinBound -- | Generic 'maxBound'. -- -- See also 'gminBound'. gmaxBound :: (Generic a, GBounded (Rep a)) => a gmaxBound = to gMaxBound -- | Generic 'range'. -- -- @ -- import "Data.Ix" -- instance 'Ix' MyType where -- 'range' = 'grange' -- 'index' = 'gindex' -- 'inRange' = 'ginRange' -- @ grange :: (Generic a, GIx (Rep a)) => (a, a) -> [a] grange (m, n) = map to $ gRange (from m, from n) -- | Generic 'index'. -- -- See also 'grange'. gindex :: (Generic a, GIx (Rep a)) => (a, a) -> a -> Int gindex b i | ginRange b i = gunsafeIndex b i | otherwise = errorWithoutStackTrace "gindex: out of bounds" -- | Generic @unsafeIndex@. -- -- === __Details__ -- -- The functions @unsafeIndex@ and @unsafeRangeSize@ belong to 'Ix' but are -- internal to GHC and hence not exported from the module "Data.Ix". However they -- are exported from the module @GHC.Arr@. -- See 'grange' for how to define an instance of 'Ix' such that it does not -- depend on the stability of GHCs internal API. Unfortunately this results in -- additional (unnecessary) bound checks. -- With the danger of having no stability guarantees for GHC's internal API one -- can alternatively define an instance of 'Ix' as -- -- @ -- import GHC.Arr -- instance 'Ix' MyType where -- 'range' = 'grange' -- unsafeIndex = 'gunsafeIndex' -- 'inRange' = 'ginRange' -- @ gunsafeIndex :: (Generic a, GIx (Rep a)) => (a, a) -> a -> Int gunsafeIndex (m, n) i = gUnsafeIndex (from m, from n) (from i) -- | Generic 'inRange'. -- -- See also 'grange'. ginRange :: (Generic a, GIx (Rep a)) => (a, a) -> a -> Bool ginRange (m, n) i = gInRange (from m, from n) (from i) -- | Generic representation of 'Enum' types. -- -- The @opts@ parameter is a type-level option to select different -- implementations. class GEnum opts f where gCardinality :: Int gFromEnum :: f p -> Int gToEnum :: Int -> f p -- | Standard option for 'GEnum': derive 'Enum' for types with only nullary -- constructors (the same restrictions as in the [Haskell 2010 -- report](https://www.haskell.org/onlinereport/haskell2010/haskellch11.html#x18-18400011.2)). data StandardEnum -- | Extends the 'StandardEnum' option for 'GEnum' to allow all constructors to -- have arbitrary many fields. Each field type must be an instance of -- both 'Enum' and 'Bounded'. Avoid fields of types 'Int' and 'Word'. -- -- === __Details__ -- -- Two restrictions require the user's attention: -- -- * The 'Enum' instances of the field types need to start enumerating from 0. -- In particular, 'Int' is an unfit field type, because the enumeration of the -- negative values starts before 0. -- -- * There can only be up to @'maxBound' :: 'Int'@ values (because the implementation -- represents the cardinality explicitly as an 'Int'). This restriction makes -- 'Word' an invalid field type as well. Notably, it is insufficient for each -- individual field types to stay below this limit. Instead it applies to the -- generic type as a whole. -- -- Elements are numbered by 'toEnum', from @0@ up to @(cardinality - 1)@. -- The resulting ordering matches the generic 'Ord' instance defined by -- 'Generic.Data.gcompare'. -- The values from different constructors are enumerated sequentially. -- -- @ -- data Example = C0 Bool Bool | C1 Bool -- deriving ('Eq', 'Ord', 'Show', 'Generic') -- -- cardinality = 6 -- 2 * 2 + 2 -- -- Bool * Bool | Bool -- -- enumeration = -- [ C0 False False -- , C0 False True -- , C0 True False -- , C0 True True -- , C1 False -- , C1 True -- ] -- -- enumeration == map 'gtoFiniteEnum' [0 .. 5] -- [0 .. 5] == map 'gfromFiniteEnum' enumeration -- @ data FiniteEnum instance GEnum opts f => GEnum opts (M1 i c f) where gCardinality = gCardinality @opts @f gFromEnum = gFromEnum @opts . unM1 gToEnum = M1 . gToEnum @opts instance (GEnum opts f, GEnum opts g) => GEnum opts (f :+: g) where gCardinality = gCardinality @opts @f + gCardinality @opts @g gFromEnum (L1 x) = gFromEnum @opts x gFromEnum (R1 y) = cardF + gFromEnum @opts y where cardF = gCardinality @opts @f gToEnum n | n < cardF = L1 (gToEnum @opts n) | otherwise = R1 (gToEnum @opts (n - cardF)) where cardF = gCardinality @opts @f instance (GEnum FiniteEnum f, GEnum FiniteEnum g) => GEnum FiniteEnum (f :*: g) where gCardinality = gCardinality @FiniteEnum @f * gCardinality @FiniteEnum @g gFromEnum (x :*: y) = gFromEnum @FiniteEnum x * cardG + gFromEnum @FiniteEnum y where cardG = gCardinality @FiniteEnum @g gToEnum n = gToEnum @FiniteEnum x :*: gToEnum @FiniteEnum y where (x, y) = n `quotRem` cardG cardG = gCardinality @FiniteEnum @g instance GEnum opts U1 where gCardinality = 1 gFromEnum U1 = 0 gToEnum _ = U1 instance (Bounded c, Enum c) => GEnum FiniteEnum (K1 i c) where gCardinality = fromEnum (maxBound :: c) + 1 gFromEnum = fromEnum . unK1 gToEnum = K1 . toEnum -- | Generic representation of 'Bounded' types. class GBounded f where gMinBound :: f p gMaxBound :: f p deriving instance GBounded f => GBounded (M1 i c f) instance GBounded U1 where gMinBound = U1 gMaxBound = U1 instance Bounded c => GBounded (K1 i c) where gMinBound = K1 minBound gMaxBound = K1 maxBound instance (GBounded f, GBounded g) => GBounded (f :+: g) where gMinBound = L1 gMinBound gMaxBound = R1 gMaxBound instance (GBounded f, GBounded g) => GBounded (f :*: g) where gMinBound = gMinBound :*: gMinBound gMaxBound = gMaxBound :*: gMaxBound -- | Generic representation of 'Ix' types. -- class GIx f where gRange :: (f p, f p) -> [f p] gUnsafeIndex :: (f p, f p) -> f p -> Int gInRange :: (f p, f p) -> f p -> Bool instance GIx f => GIx (M1 i c f) where gRange (M1 m, M1 n) = map M1 $ gRange (m, n) gUnsafeIndex (M1 m, M1 n) (M1 i) = gUnsafeIndex (m, n) i gInRange (M1 m, M1 n) (M1 i) = gInRange (m, n) i instance (GEnum StandardEnum f, GEnum StandardEnum g) => GIx (f :+: g) where gRange (x, y) = map toE [ i_x .. i_y ] where toE = gToEnum @StandardEnum i_x = gFromEnum @StandardEnum x i_y = gFromEnum @StandardEnum y gUnsafeIndex (m, _) i = fromIntegral (i_i - i_m) where i_m = gFromEnum @StandardEnum m i_i = gFromEnum @StandardEnum i gInRange (m, n) i = i_m <= i_i && i_i <= i_n where i_m = gFromEnum @StandardEnum m i_n = gFromEnum @StandardEnum n i_i = gFromEnum @StandardEnum i instance (GIx f, GIx g) => GIx (f :*: g) where gRange (m1 :*: m2, n1 :*: n2) = [ i1 :*: i2 | i1 <- gRange (m1, n1), i2 <- gRange (m2, n2) ] gUnsafeIndex (m1 :*: m2, n1 :*: n2) (i1 :*: i2) = int1 * rangeSize2 + int2 where int1 = gUnsafeIndex (m1, n1) i1 int2 = gUnsafeIndex (m2, n2) i2 rangeSize2 = gUnsafeIndex (m2, n2) n2 + 1 gInRange (m1 :*: m2, n1 :*: n2) (i1 :*: i2) = gInRange (m1, n1) i1 && gInRange (m2, n2) i2 instance GIx U1 where gRange (U1, U1) = [U1] gUnsafeIndex (U1, U1) U1 = 0 gInRange (U1, U1) U1 = True instance (Ix c) => GIx (K1 i c) where gRange (K1 m, K1 n) = map K1 $ range (m, n) gUnsafeIndex (K1 m, K1 n) (K1 i) = index (m, n) i gInRange (K1 m, K1 n) (K1 i) = inRange (m, n) i generic-data-1.1.0.0/src/Generic/Data/Internal/Error.hs0000644000000000000000000000303607346545000020602 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | Error messages. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Error where import Data.Kind import Data.Type.Bool import GHC.Generics import GHC.TypeLits type family HasSum f where HasSum V1 = 'False HasSum U1 = 'False HasSum (K1 i c) = 'False HasSum (M1 i c f) = HasSum f HasSum (f :*: g) = HasSum f || HasSum g HasSum (f :+: g) = 'True class Assert (pred :: Bool) (msg :: ErrorMessage) instance Assert 'True msg instance (TypeError msg ~ '()) => Assert 'False msg -- | -- >>> :set -XDeriveGeneric -XDerivingVia -- >>> import Generic.Data (Generically(..)) -- >>> :{ -- data AB = A | B -- deriving stock Generic -- deriving Semigroup via Generically AB -- :} -- ... -- • Cannot derive Semigroup instance for AB due to sum type -- • When deriving the instance for (Semigroup AB) 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") generic-data-1.1.0.0/src/Generic/Data/Internal/Functions.hs0000644000000000000000000000273107346545000021462 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Type-level functions on generic representations. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Functions where import Data.Kind import Data.Proxy import GHC.Generics import GHC.TypeLits -- | Number of constructors of a data type. type family NConstructors (r :: k -> Type) :: Nat type instance NConstructors (M1 D c f) = NConstructors f type instance NConstructors (f :+: g) = NConstructors f + NConstructors g type instance NConstructors (M1 C c f) = 1 -- | Number of constructors of a data type. nconstructors :: forall r. KnownNat (NConstructors r) => Integer nconstructors = natVal @(NConstructors r) Proxy -- | Arity of a constructor. type family NFields (r :: k -> Type) :: Nat type instance NFields (M1 C c f) = NFields f type instance NFields (f :*: g) = NFields f + NFields g type instance NFields (M1 S c f) = 1 -- | Arity of a constructor. nfields :: forall r. KnownNat (NFields r) => Integer nfields = natVal @(NFields r) Proxy generic-data-1.1.0.0/src/Generic/Data/Internal/Generically.hs0000644000000000000000000002312707346545000021752 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleContexts, 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. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- 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 ( Generically(..) , Generically1(..) , FiniteEnumeration(..) , GenericProduct(..) ) where import GHC.Generics import Data.Functor.Classes import Data.Ix import Text.Read import Generic.Data.Internal.Prelude hiding (gfoldMap, gtraverse, gsequenceA) import Generic.Data.Internal.Enum import Generic.Data.Internal.Error import Generic.Data.Internal.Read 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 -- -- ==== __Deriving 'Eq', 'Ord', 'Show', 'Read'__ -- -- >>> :{ -- data T = C Int Bool -- deriving Generic -- deriving (Eq, Ord, Show, Read) via (Generically T) -- :} -- -- ==== __Deriving 'Semigroup', 'Monoid'__ -- -- The type must have only one constructor. -- -- >>> import Data.Monoid (Sum) -- >>> :{ -- data U = D [Int] (Sum Int) -- deriving Generic -- deriving (Semigroup, Monoid) via (Generically U) -- :} -- -- ==== __Deriving 'Enum', 'Bounded'__ -- -- The type must have only nullary constructors. -- To lift that restriction, see 'FiniteEnumeration'. -- -- >>> :{ -- data V = X | Y | Z -- deriving Generic -- deriving (Eq, Ord, Enum, Bounded) via (Generically V) -- :} 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 (Generically x) = from x instance (Generic a, Eq (Rep a ())) => Eq (Generically a) where (==) = geq instance (Generic a, Ord (Rep a ())) => Ord (Generically a) where compare = gcompare instance (Generic a, GRead0 (Rep a)) => Read (Generically a) where readPrec = greadPrec readListPrec = readListPrecDefault instance (Generic a, GShow0 (Rep a)) => Show (Generically a) where showsPrec = gshowsPrec instance (Generic a, GEnum StandardEnum (Rep a)) => Enum (Generically a) where toEnum = gtoEnum fromEnum = gfromEnum enumFrom = genumFrom enumFromThen = genumFromThen enumFromTo = genumFromTo enumFromThenTo = genumFromThenTo instance (Generic a, Ord (Rep a ()), GIx (Rep a)) => Ix (Generically a) where range = grange index = gindex inRange = ginRange instance (Generic a, GBounded (Rep a)) => Bounded (Generically a) where minBound = gminBound maxBound = gmaxBound -- | Type with 'Enum' instance derived via 'Generic' with 'FiniteEnum' option. -- This allows deriving 'Enum' for types whose constructors have fields. -- -- Some caution is advised; see details in 'FiniteEnum'. -- -- === __Example__ -- -- >>> :{ -- data Booool = Booool Bool Bool -- deriving Generic -- deriving (Enum, Bounded) via (FiniteEnumeration Booool) -- :} newtype FiniteEnumeration a = FiniteEnumeration a instance Generic a => Generic (FiniteEnumeration a) where type Rep (FiniteEnumeration a) = Rep a to = FiniteEnumeration . to from (FiniteEnumeration x) = from x instance (Generic a, GEnum FiniteEnum (Rep a)) => Enum (FiniteEnumeration a) where toEnum = gtoFiniteEnum fromEnum = gfromFiniteEnum enumFrom = gfiniteEnumFrom enumFromThen = gfiniteEnumFromThen enumFromTo = gfiniteEnumFromTo enumFromThenTo = gfiniteEnumFromThenTo -- | The same instance as 'Generically', for convenience. instance (Generic a, GBounded (Rep a)) => Bounded (FiniteEnumeration a) where minBound = gminBound maxBound = gmaxBound #if __GLASGOW_HASKELL__ < 904 -- | Type with instances derived via 'Generic1'. -- -- === Examples -- -- ==== __Deriving 'Functor', 'Applicative', 'Alternative'__ -- -- 'Applicative' can be derived for types with only one -- constructor, aka. products. -- -- >>> :{ -- data F a = F1 a | F2 (Maybe a) | F3 [Either Bool a] (Int, a) -- deriving Generic1 -- deriving Functor via (Generically1 F) -- :} -- -- >>> :{ -- data G a = G a (Maybe a) [a] (IO a) -- deriving Generic1 -- deriving (Functor, Applicative) via (Generically1 G) -- :} -- -- >>> import Control.Applicative (Alternative) -- >>> :{ -- data G' a = G' (Maybe a) [a] -- deriving Generic1 -- deriving (Functor, Applicative, Alternative) via (Generically1 G') -- :} -- -- ==== __Deriving 'Foldable'__ -- -- >>> import Generic.Data.Orphans () -- >>> :{ -- data H a = H1 a | H2 (Maybe a) -- deriving Generic1 -- deriving (Functor, Foldable) via (Generically1 H) -- :} -- -- Note: we can't use @DerivingVia@ for 'Traversable'. -- One may implement 'Traversable' explicitly using 'gtraverse'. -- -- ==== __Deriving 'Eq1', 'Ord1'__ -- -- >>> import Data.Functor.Classes (Eq1, Ord1) -- >>> :{ -- data I a = I [a] (Maybe a) -- deriving Generic1 -- deriving (Eq1, Ord1) via (Generically1 I) -- :} newtype Generically1 f a = Generically1 (f a) instance (Generic1 f, Eq1 (Rep1 f)) => Eq1 (Generically1 f) where liftEq = gliftEq 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 liftReadListPrec = liftReadListPrecDefault #else liftReadsPrec rp rl = readPrec_to_S $ gliftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl)) #endif instance (Generic1 f, GRead1 (Rep1 f), Read a) => Read (Generically1 f a) where #if MIN_VERSION_base(4,10,0) readPrec = readPrec1 readListPrec = readListPrecDefault #else readsPrec = readsPrec1 #endif instance (Generic1 f, GShow1 (Rep1 f)) => Show1 (Generically1 f) where liftShowsPrec = gliftShowsPrec instance (Generic1 f, GShow1 (Rep1 f), Show a) => Show (Generically1 f a) where showsPrec = showsPrec1 instance (Generic1 f, GFoldable (Rep1 f)) => Foldable (Generically1 f) where foldMap = gfoldMap foldr = gfoldr instance (Generic1 f, Functor (Rep1 f), GFoldable (Rep1 f), GTraversable (Rep1 f)) => Traversable (Generically1 f) where traverse = gtraverse sequenceA = gsequenceA -- | Product type with generic instances of 'Semigroup' and 'Monoid'. -- -- This is similar to 'Generic.Data.Generically' in most cases, but -- 'GenericProduct' also works for types @T@ with deriving -- @via 'GenericProduct' U@, where @U@ is a generic product type coercible to, -- but distinct from @T@. In particular, @U@ may not have an instance of -- 'Semigroup', which 'Generic.Data.Generically' requires. -- -- === __Example__ -- -- >>> import Data.Monoid (Sum(..)) -- >>> data Point a = Point a a deriving Generic -- >>> :{ -- newtype Vector a = Vector (Point a) -- deriving (Semigroup, Monoid) -- via GenericProduct (Point (Sum a)) -- :} -- -- If it were @via 'Generic.Data.Generically' (Point (Sum a))@ instead, then -- @Vector@'s 'mappend' (the 'Monoid' method) would be defined as @Point@'s -- @('<>')@ (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 a instance Generic a => Generic (GenericProduct a) where type Rep (GenericProduct a) = Rep a to = GenericProduct . to from (GenericProduct x) = from x instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (GenericProduct a) where (<>) = gmappend instance (AssertNoSum Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (GenericProduct a) where mempty = gmempty mappend = gmappend' generic-data-1.1.0.0/src/Generic/Data/Internal/Meta.hs0000644000000000000000000003012607346545000020377 0ustar0000000000000000{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Type metadata accessors -- -- Type names, constructor names... -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. 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(..)) import Generic.Data.Internal.Functions -- $setup -- >>> :set -XDataKinds -XTypeApplications -- >>> import Control.Applicative (ZipList) -- >>> import Data.Monoid (Sum(..)) -- | Name of the first data constructor in a type as a string. -- -- >>> gdatatypeName @(Maybe Int) -- "Maybe" gdatatypeName :: forall a. (Generic a, GDatatype (Rep a)) => String gdatatypeName = gDatatypeName @(Rep a) -- | Name of the module where the first type constructor is defined. -- -- >>> gmoduleName @(ZipList Int) -- "Control.Applicative" gmoduleName :: forall a. (Generic a, GDatatype (Rep a)) => String gmoduleName = gModuleName @(Rep a) -- | Name of the package where the first type constructor is defined. -- -- >>> gpackageName @(Maybe Int) -- "base" gpackageName :: forall a. (Generic a, GDatatype (Rep a)) => String gpackageName = gPackageName @(Rep a) -- | 'True' if the first type constructor is a newtype. -- -- >>> gisNewtype @[Int] -- False -- >>> gisNewtype @(ZipList Int) -- True gisNewtype :: forall a. (Generic a, GDatatype (Rep a)) => Bool gisNewtype = gIsNewtype @(Rep a) fromDatatype :: forall d r. Datatype d => (M1 D d Proxy () -> r) -> r fromDatatype f = f (M1 Proxy :: M1 D d Proxy ()) -- | Generic representations that contain datatype metadata. class GDatatype f where gDatatypeName :: String gModuleName :: String gPackageName :: String gIsNewtype :: Bool instance Datatype d => GDatatype (M1 D d f) where gDatatypeName = fromDatatype @d datatypeName gModuleName = fromDatatype @d moduleName gPackageName = fromDatatype @d packageName gIsNewtype = fromDatatype @d isNewtype -- | Name of the first constructor in a value. -- -- >>> gconName (Just 0) -- "Just" gconName :: forall a. Constructors a => a -> String gconName = conIdToString . conId -- | The fixity of the first constructor. -- -- >>> import GHC.Generics ((:*:)(..)) -- >>> gconFixity (Just 0) -- Prefix -- >>> gconFixity ([] :*: id) -- Infix RightAssociative 6 gconFixity :: forall a. Constructors a => a -> Fixity gconFixity = gConFixity . from -- | 'True' if the constructor is a record. -- -- >>> gconIsRecord (Just 0) -- False -- >>> gconIsRecord (Sum 0) -- Note: newtype Sum a = Sum { getSum :: a } -- True gconIsRecord :: forall a. Constructors a => a -> Bool gconIsRecord = gConIsRecord . from -- | Number of constructors. -- -- >>> gconNum @(Maybe Int) -- 2 gconNum :: forall a. Constructors a => Int gconNum = gConNum @(Rep a) -- | Index of a constructor. -- -- >>> gconIndex Nothing -- 0 -- >>> gconIndex (Just "test") -- 1 gconIndex :: forall a. Constructors a => a -> Int gconIndex = conIdToInt . conId -- | An opaque identifier for a constructor. newtype ConId a = ConId Int deriving (Eq, Ord, Show) -- | Identifier of a constructor. conId :: forall a. Constructors a => a -> ConId a conId = toConId . gConId . from -- | Index of a constructor, given its identifier. -- See also 'gconIndex'. conIdToInt :: forall a. ConId a -> Int conIdToInt (ConId i) = i -- | Name of a constructor. See also 'gconName'. conIdToString :: forall a. Constructors a => ConId a -> String conIdToString = gConIdToString . fromConId -- | All constructor identifiers. -- -- @ -- 'gconNum' \@a = length ('conIdEnum' \@a) -- @ conIdEnum :: forall a. Constructors a => [ConId a] conIdEnum = fmap ConId [0 .. n-1] where n = gConNum @(Rep a) -- | The first constructor. This must not be called on an empty type. conIdMin :: forall a. (Constructors a, NonEmptyType "conIdMin" a) => ConId a conIdMin = ConId 0 -- | The last constructor. This must not be called on an empty type. conIdMax :: forall a. (Constructors a, NonEmptyType "conIdMax" a) => ConId a conIdMax = toConId gConIdMax -- | Get a 'ConId' by name. -- -- >>> conIdNamed @"Nothing" :: ConId (Maybe Int) -- ConId 0 -- >>> conIdNamed @"Just" :: ConId (Maybe Int) -- ConId 1 conIdNamed :: forall s a. ConIdNamed s a => ConId a conIdNamed = ConId (fromInteger (natVal (Proxy @(ConIdNamed' s a)))) -- | Constraint synonym for 'Generic' and 'GConstructors'. class (Generic a, GConstructors (Rep a)) => Constructors a instance (Generic a, GConstructors (Rep a)) => Constructors a -- | Constraint synonym for generic types @a@ with a constructor named @n@. class (Generic a, KnownNat (ConIdNamed' n a)) => ConIdNamed n a instance (Generic a, KnownNat (ConIdNamed' n a)) => ConIdNamed n a -- *** Constructor information on generic representations newtype GConId r = GConId Int deriving (Eq, Ord) gConIdToInt :: GConId r -> Int gConIdToInt (GConId i) = i toConId :: forall a. Generic a => GConId (Rep a) -> ConId a toConId (GConId i) = ConId i fromConId :: forall a. Generic a => ConId a -> GConId (Rep a) fromConId (ConId i) = GConId i reGConId :: GConId r -> GConId s reGConId (GConId i) = GConId i gConIdMin :: forall r. GConstructors r => GConId r gConIdMin = GConId 0 gConIdMax :: forall r. GConstructors r => GConId r gConIdMax = GConId (gConNum @r - 1) -- | Generic representations that contain constructor metadata. class GConstructors r where gConIdToString :: GConId r -> String gConId :: r p -> GConId r gConNum :: Int gConFixity :: r p -> Fixity gConIsRecord :: r p -> Bool instance GConstructors f => GConstructors (M1 D c f) where gConIdToString = gConIdToString @f . reGConId gConId = reGConId . gConId . unM1 gConNum = gConNum @f gConFixity = gConFixity . unM1 gConIsRecord = gConIsRecord . unM1 instance (GConstructors f, GConstructors g) => GConstructors (f :+: g) where gConIdToString (GConId i) = if i < nf then gConIdToString @f (GConId i) else gConIdToString @g (GConId (i - nf)) where nf = gConNum @f gConId (L1 x) = reGConId (gConId x) gConId (R1 y) = let GConId i = gConId y in GConId (nf + 1 + i) where GConId nf = gConIdMax @f gConNum = gConNum @f + gConNum @g gConFixity (L1 x) = gConFixity x gConFixity (R1 y) = gConFixity y gConIsRecord (L1 x) = gConIsRecord x gConIsRecord (R1 y) = gConIsRecord y instance Constructor c => GConstructors (M1 C c f) where gConIdToString _ = conName (M1 Proxy :: M1 C c Proxy ()) gConId _ = GConId 0 gConNum = 1 gConFixity = conFixity gConIsRecord = conIsRecord instance GConstructors V1 where gConIdToString x = x `seq` error "gConIdToString: empty type" -- Input should be empty. gConId v = case v of {} gConNum = 0 gConFixity v = case v of {} gConIsRecord v = case v of {} -- *** Find a constructor tag by name type ConIdNamed' n t = GConIdNamedIf n t (GConIdNamed n (Rep t)) type GConIdNamed n f = GConIdNamed' n f 0 'Nothing 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 :: Type) (o :: Maybe Nat) :: Nat where GConIdNamedIf _n _t ('Just i) = i GConIdNamedIf n t 'Nothing = TypeError ('Text "No constructor named " ':<>: 'ShowType n ':<>: 'Text " in generic type " ':<>: 'ShowType t) -- *** Check that a type is not empty -- | Constraint that a generic type @a@ is not empty. -- Producing an error message otherwise. -- -- 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 instance NonEmptyType_ fname a => NonEmptyType fname a -- | Internal definition of 'NonEmptyType'. -- It is implied by the simpler constraint @'IsEmptyType' a ~ 'False@. -- -- >>> :set -XTypeFamilies -- >>> :{ -- conIdMin' :: (Constructors a, IsEmptyType a ~ 'False) => ConId a -- conIdMin' = conIdMin -- :} -- -- >>> :{ -- conIdMax' :: (Constructors a, IsEmptyType a ~ 'False) => ConId a -- conIdMax' = conIdMax -- :} type NonEmptyType_ fname a = (ErrorIfEmpty fname a (IsEmptyType a) ~ '()) -- 'True' if the generic representation is @M1 D _ V1@. 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 -- | 'True' if the generic type @a@ is empty. type IsEmptyType a = IsEmptyType_ a -- | Internal definition of 'IsEmptyType'. type IsEmptyType_ a = GIsEmptyType (Rep a) -- | Throw an error if the boolean @b@ is true, meaning that the type @a@ is empty. -- -- Example: -- -- > ghci> data E deriving Generic -- > ghci> conIdMin :: ConId E -- -- Error message: -- -- > The function 'conIdMin' cannot be used with the empty type E 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) ErrorIfEmpty fname a 'False = '() -- * Type families -- | 'Meta' field of the 'M1' type constructor. type family MetaOf (f :: Type -> Type) :: Meta where MetaOf (M1 i d f) = d -- Variable names borrowed from the documentation on 'Meta'. -- | Name of the data type ('MetaData'). type family MetaDataName (m :: Meta) :: Symbol where MetaDataName ('MetaData n _m _p _nt) = n -- | Name of the module where the data type is defined ('MetaData') type family MetaDataModule (m :: Meta) :: Symbol where MetaDataModule ('MetaData _n m _p _nt) = m -- | Name of the package where the data type is defined ('MetaData') type family MetaDataPackage (m :: Meta) :: Symbol where MetaDataPackage ('MetaData _n _m p _nt) = p -- | @True@ if the data type is a newtype ('MetaData'). type family MetaDataNewtype (m :: Meta) :: Bool where MetaDataNewtype ('MetaData _n _m _p nt) = nt -- | Name of the constructor ('MetaCons'). type family MetaConsName (m :: Meta) :: Symbol where MetaConsName ('MetaCons n _f _s) = n -- | Fixity of the constructor ('MetaCons'). type family MetaConsFixity (m :: Meta) :: FixityI where MetaConsFixity ('MetaCons _n f s) = f -- | @True@ for a record constructor ('MetaCons'). type family MetaConsRecord (m :: Meta) :: Bool where MetaConsRecord ('MetaCons _n _f s) = s -- | @Just@ the name of the record field, if it is one ('MetaSel'). type family MetaSelNameM (m :: Meta) :: Maybe Symbol where MetaSelNameM ('MetaSel mn _su _ss _ds) = mn -- | Name of the record field; undefined for non-record fields ('MetaSel'). type family MetaSelName (m :: Meta) :: Symbol where MetaSelName ('MetaSel ('Just n) _su _ss _ds) = n -- | Unpackedness annotation of a field ('MetaSel'). type family MetaSelUnpack (m :: Meta) :: SourceUnpackedness where MetaSelUnpack ('MetaSel _mn su _ss _ds) = su -- | Strictness annotation of a field ('MetaSel'). type family MetaSelSourceStrictness (m :: Meta) :: SourceStrictness where MetaSelSourceStrictness ('MetaSel _mn _su ss _ds) = ss -- | Inferred strictness of a field ('MetaSel'). type family MetaSelStrictness (m :: Meta) :: DecidedStrictness where MetaSelStrictness ('MetaSel _mn _su _ss ds) = ds -- | A placeholder for 'Meta' values. type DummyMeta = 'MetaData "" "" "" 'False -- | Remove an 'M1' type constructor. type family UnM1 (f :: k -> Type) :: k -> Type type instance UnM1 (M1 i c f) = f generic-data-1.1.0.0/src/Generic/Data/Internal/Microsurgery.hs0000644000000000000000000003077507346545000022215 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PolyKinds, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} -- | Surgeries that are just 'coerce'. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Microsurgery where import Data.Coerce (Coercible, coerce) import Data.Kind (Type) import GHC.Generics import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) import Generic.Data.Types (Data) import Generic.Data.Internal.Generically (Generically(..), GenericProduct(..)) -- * Surgery -- | Apply a microsurgery @s@ to a type @a@ for @DerivingVia@. -- -- For the 'Data.Monoid.Monoid' class, see 'ProductSurgery'. -- -- === Example -- -- @ -- {-\# LANGUAGE DerivingVia \#-} -- -- -- The constructors must be visible. -- import "Generic.Data.Microsurgery" -- ('Surgery', 'Surgery''(..), 'Generically'(..), 'Derecordify') -- -- data T = T { unT :: Int } -- deriving 'Show' via ('Surgery' 'Derecordify' T) -- -- -- T won't be shown as a record: -- -- show (T {unT = 3}) == "T 3" -- @ 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 :: 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 :: 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) from = (coerce :: forall x. (a -> Rep a x) -> Surgery' s a -> GSurgery s (Rep a) x) from to = (coerce :: forall x. (Rep a x -> a) -> GSurgery s (Rep a) x -> Surgery' s a) to -- | Apply a microsurgery represented by a symbol @s@ (declared as a dummy data -- type) to a generic representation @f@. type family GSurgery (s :: Type) (f :: k -> Type) :: k -> Type -- * Derecordify derecordify :: Coercible (GSurgery Derecordify f) f => -- Coercible is not symmetric!?? Data f p -> Data (GSurgery Derecordify f) p derecordify = coerce underecordify :: Coercible f (GSurgery Derecordify f) => Data (GSurgery Derecordify f) p -> Data f p underecordify = coerce -- | Forget that a type was declared using record syntax. -- -- > data Foo = Bar { baz :: Zap } -- > -- > -- becomes -- -- > -- > data Foo = Bar Zap -- -- Concretely, set the last field of 'MetaCons' to 'False' and forget field -- names. -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. data Derecordify :: Type type instance GSurgery Derecordify f = GDerecordify f 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 type instance GDerecordify (M1 C ('MetaCons nm fx _isRecord) f) = M1 C ('MetaCons nm fx 'False) (GDerecordify f) type instance GDerecordify (M1 S ('MetaSel _nm su ss ds) f) = M1 S ('MetaSel 'Nothing su ss ds) f type instance GDerecordify V1 = V1 type instance GDerecordify U1 = U1 -- * Type aging ("denewtypify") typeage :: Coercible (GSurgery Typeage f) f => Data f p -> Data (GSurgery Typeage f) p typeage = coerce untypeage :: Coercible f (GSurgery Typeage f) => Data (GSurgery Typeage f) p -> Data f p untypeage = coerce -- | Forget that a type is a @newtype@. (The pun is that \"aging\" a type makes -- it no longer \"new\".) -- -- > newtype Foo = Bar Baz -- > -- > -- becomes -- -- > -- > data Foo = Bar Baz -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. data Typeage :: Type type instance GSurgery Typeage (M1 D ('MetaData nm md pk _nt) f) = M1 D ('MetaData nm md pk 'False) f -- * Renaming renameFields :: forall rnm f p. Coercible (GSurgery (RenameFields rnm) f) f => Data f p -> Data (GSurgery (RenameFields rnm) f) p renameFields = coerce unrenameFields :: forall rnm f p. Coercible (GSurgery (RenameFields rnm) f) f => Data f p -> Data (GSurgery (RenameFields rnm) f) p unrenameFields = coerce renameConstrs :: forall rnm f p. Coercible (GSurgery (RenameConstrs rnm) f) f => Data f p -> Data (GSurgery (RenameConstrs rnm) f) p renameConstrs = coerce unrenameConstrs :: forall rnm f p. Coercible (GSurgery (RenameConstrs rnm) f) f => Data f p -> Data (GSurgery (RenameConstrs rnm) f) p unrenameConstrs = coerce -- | Rename fields using the function @rnm@ given as a parameter. -- -- > data Foo = Bar { baz :: Zap } -- > -- > -- becomes, renaming "baz" to "bag" -- -- > -- > data Foo = Bar { bag :: Zap } -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. data RenameFields (rnm :: Type) :: Type type instance GSurgery (RenameFields rnm) f = GRenameFields rnm f 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 type instance GRenameFields rnm (M1 C m f) = M1 C m (GRenameFields rnm f) type instance GRenameFields rnm (M1 S ('MetaSel ('Just nm) su ss ds) f) = M1 S ('MetaSel ('Just (rnm @@ nm)) su ss ds) f type instance GRenameFields rnm V1 = V1 type instance GRenameFields rnm U1 = U1 -- | Rename constructors using the function @rnm@ given as a parameter. -- -- > data Foo = Bar { baz :: Zap } -- > -- > -- becomes, renaming "Bar" to "Car" -- -- > -- > data Foo = Car { baz :: Zap } -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. data RenameConstrs (rnm :: Type) :: Type type instance GSurgery (RenameConstrs rnm) f = GRenameConstrs rnm f 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 type instance GRenameConstrs rnm (M1 C ('MetaCons nm fi ir) f) = M1 C ('MetaCons (rnm @@ nm) fi ir) f type instance GRenameConstrs rnm V1 = V1 -- ** Defining symbol functions -- | @f \@\@ s@ is the application of a type-level function symbolized by @f@ -- to a @s :: 'Symbol'@. -- -- A function @FooToBar@ can be defined as follows: -- -- @ -- data FooToBar -- type instance FooToBar '@@' \"foo\" = \"bar\" -- @ type family (f :: Type) @@ (s :: Symbol) :: Symbol -- | Identity function @'Symbol' -> 'Symbol'@. data SId type instance SId @@ s = s -- | Empty function (compile-time error when applied). data SError type instance SError @@ s = TypeError ('Text "Invalid name: " ':<>: 'ShowType s) -- | Constant function. data SConst (s :: Symbol) 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 :: Type) type instance SRename xs f @@ s = SRename' xs f s -- | Closed type family for 'SRename'. 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 -- * Other -- This can be used with generic-lens (see Generic.Data.Microsurgery) -- | Unify the "spines" of two generic representations (the "spine" is -- everything except the field types). 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' instance (g' ~ (g1 :*: g2), UnifyRep f1 g1, UnifyRep f2 g2) => UnifyRep (f1 :*: f2) g' instance (g' ~ K1 i b) => UnifyRep (K1 i a) g' instance (g' ~ U1) => UnifyRep U1 g' instance (g' ~ V1) => UnifyRep V1 g' -- | -- -- > onData :: _ => (Data r x -> Data s y) -> (Data r x -> Data s y) -- possible specialization -- -- Can be used with @generic-lens@ for type-changing field updates with @field_@ -- (and possibly other generic optics). -- -- A specialization of the identity function to be used to fix types -- of functions on 'Data', unifying the "spines" of input and output generic -- representations (the "spine" is everything except field types, which may -- thus change). onData :: (UnifyRep r s, UnifyRep s r) => p (Data r x) (Data s y) -> p (Data r x) (Data s y) onData = id -- | Apply a type constructor @f@ to every field type of a generic -- representation @r@. -- -- > data Color = RGB -- > { r :: Int -- > , g :: Int -- > , b :: Int } -- > -- > -- becomes -- -- > -- > data Color f = RGB -- > { r :: f Int -- > , g :: f Int -- > , b :: f Int } -- -- This is a defunctionalized symbol, applied using 'GSurgery' or 'Surgery'. data OnFields (f :: Type -> Type) :: Type type instance GSurgery (OnFields f) g = GOnFields f g 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 type instance GOnFields f (K1 i a) = K1 i (f a) type instance GOnFields f U1 = U1 type instance GOnFields f V1 = V1 -- | Apply a type constructor @f@ to every field type of a type @a@ to make a -- synthetic type. 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 :: Type) :: Type type instance GSurgery (CopyRep a) _ = Rep a copyRep :: forall a f p. Coercible (GSurgery (CopyRep a) f) f => Data f p -> Data (GSurgery (CopyRep a) f) p copyRep = coerce uncopyRep :: forall a f p. Coercible f (GSurgery (CopyRep a) f) => Data (GSurgery (CopyRep a) f) p -> Data f p uncopyRep = coerce generic-data-1.1.0.0/src/Generic/Data/Internal/Newtype.hs0000644000000000000000000000337407346545000021151 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -- | Pack/unpack newtypes. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Newtype where import Data.Coerce (Coercible, coerce) import Data.Kind (Constraint, Type) import GHC.Generics (Generic(..), D1, C1, S1, K1) import GHC.TypeLits (TypeError, ErrorMessage(..)) import Generic.Data.Internal.Meta (MetaDataNewtype, MetaOf) -- | Class of newtypes. There is an instance @'Newtype' a@ if and only if @a@ -- is a newtype and an instance of 'Generic'. class (Generic a, Coercible a (Old a), Newtype' a) => Newtype a instance (Generic a, Coercible a (Old a), Newtype' a) => Newtype a -- | The type wrapped by a newtype. -- -- @ -- newtype Foo = Foo { bar :: Bar } deriving 'Generic' -- -- Old Foo ~ Bar -- @ type Old a = GOld (Rep a) type family GOld (f :: Type -> Type) where GOld (D1 _d (C1 _c (S1 _s (K1 _i b)))) = b -- | Use 'Newtype' instead. type Newtype' a = NewtypeErr a (MetaDataNewtype (MetaOf (Rep a))) type family NewtypeErr a (b :: Bool) :: Constraint where NewtypeErr a 'True = () NewtypeErr a 'False = TypeError ('Text "The type " ':<>: 'ShowType a ':<>: 'Text " is not a newtype.") -- | Generic newtype destructor. unpack :: Newtype a => a -> Old a unpack = coerce -- | Generic newtype constructor. pack :: Newtype a => Old a -> a pack = coerce generic-data-1.1.0.0/src/Generic/Data/Internal/Prelude.hs0000644000000000000000000001151307346545000021110 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Generic deriving for standard classes in base -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Prelude where import Control.Applicative (liftA2, Alternative(..)) import Data.Function (on) import Data.Functor.Classes import Data.Semigroup import GHC.Generics import Generic.Data.Internal.Utils (from', to', liftG2) -- * 'Eq' -- | Generic @('==')@. -- -- @ -- instance 'Eq' MyType where -- ('==') = 'geq' -- @ geq :: (Generic a, Eq (Rep a ())) => a -> a -> Bool geq = (==) `on` from' -- * 'Ord' -- | Generic 'compare'. -- -- @ -- instance 'Ord' MyType where -- 'compare' = 'gcompare' -- @ gcompare :: (Generic a, Ord (Rep a ())) => a -> a -> Ordering gcompare = compare `on` from' -- * 'Semigroup' -- | Generic @('<>')@ (or 'mappend'). -- -- @ -- instance 'Semigroup' MyType where -- ('<>') = 'gmappend' -- @ -- -- See also 'gmempty'. gmappend :: (Generic a, Semigroup (Rep a ())) => a -> a -> a gmappend = \a b -> to (from' a <> from' b) -- * 'Monoid' -- | Generic 'mempty'. -- -- @ -- instance 'Monoid' MyType where -- 'mempty' = 'gmempty' -- @ gmempty :: (Generic a, Monoid (Rep a ())) => a gmempty = to' mempty -- | Generic @('<>')@ (or @'mappend'@). -- -- The difference from `gmappend' is the 'Monoid' constraint instead of -- 'Semigroup', for older versions of base where 'Semigroup' is not a -- superclass of 'Monoid'. gmappend' :: (Generic a, Monoid (Rep a ())) => a -> a -> a gmappend' = \a b -> to (from' a `mappend` from' b) -- * 'Functor' -- | Generic 'fmap'. -- -- @ -- instance 'Functor' MyTypeF where -- 'fmap' = 'gfmap' -- @ gfmap :: (Generic1 f, Functor (Rep1 f)) => (a -> b) -> f a -> f b gfmap = \f -> to1 . fmap f . from1 -- | Generic @('<$')@. -- -- See also 'gfmap'. gconstmap :: (Generic1 f, Functor (Rep1 f)) => a -> f b -> f a gconstmap = \a -> to1 . (a <$) . from1 -- * 'Applicative' -- | Generic 'pure'. -- -- @ -- instance 'Applicative' MyTypeF where -- 'pure' = 'gpure' -- ('<*>') = 'gap' -- @ gpure :: (Generic1 f, Applicative (Rep1 f)) => a -> f a gpure = to1 . pure -- | Generic @('<*>')@ (or 'Control.Monad.ap'). -- -- See also 'gpure'. gap :: (Generic1 f, Applicative (Rep1 f)) => f (a -> b) -> f a -> f b gap = liftG2 (<*>) -- | Generic 'liftA2'. -- -- See also 'gpure'. gliftA2 :: (Generic1 f, Applicative (Rep1 f)) => (a -> b -> c) -> f a -> f b -> f c gliftA2 = liftG2 . liftA2 -- * 'Alternative' -- | Generic 'empty'. -- -- @ -- instance 'Alternative' MyTypeF where -- 'empty' = 'gempty' -- ('<|>') = 'galt' -- @ gempty :: (Generic1 f, Alternative (Rep1 f)) => f a gempty = to1 empty -- | Generic ('<|>'). -- -- See also 'gempty'. galt :: (Generic1 f, Alternative (Rep1 f)) => f a -> f a -> f a galt = liftG2 (<|>) -- * 'Foldable' -- | Generic 'foldMap'. -- -- @ -- instance 'Foldable' MyTypeF where -- 'foldMap' = 'gfoldMap' -- @ -- -- This is deprecated but kept around just for reference. {-# DEPRECATED gfoldMap "This definition has been replaced with 'Generic.Data.Internal.gfoldMap'." #-} gfoldMap :: (Generic1 f, Foldable (Rep1 f), Monoid m) => (a -> m) -> f a -> m gfoldMap = \f -> foldMap f . from1 -- | Generic 'foldr'. -- -- @ -- instance 'Foldable' MyTypeF where -- 'foldr' = 'gfoldr' -- @ -- -- See also 'gfoldMap'. gfoldr :: (Generic1 f, Foldable (Rep1 f)) => (a -> b -> b) -> b -> f a -> b gfoldr = \f b -> foldr f b . from1 -- Note: this one is not deprecated because inlining Just Works. -- * 'Traversable' -- | Generic 'traverse'. -- -- @ -- instance 'Traversable' MyTypeF where -- 'traverse' = 'gtraverse' -- @ -- -- This is deprecated but kept around just for reference. {-# DEPRECATED gtraverse "This definition has been replaced with 'Generic.Data.Internal.gtraverse'." #-} gtraverse :: (Generic1 f, Traversable (Rep1 f), Applicative m) => (a -> m b) -> f a -> m (f b) gtraverse = \f -> fmap to1 . traverse f . from1 -- | Generic 'sequenceA'. -- -- @ -- instance 'Traversable' MyTypeF where -- 'sequenceA' = 'gsequenceA' -- @ -- -- See also 'gtraverse'. -- -- This is deprecated but kept around just for reference. {-# DEPRECATED gsequenceA "This definition has been replaced with 'Generic.Data.Internal.gsequenceA'." #-} gsequenceA :: (Generic1 f, Traversable (Rep1 f), Applicative m) => f (m a) -> m (f a) gsequenceA = fmap to1 . sequenceA . from1 -- * 'Eq1' -- | Generic 'liftEq'. gliftEq :: (Generic1 f, Eq1 (Rep1 f)) => (a -> b -> Bool) -> f a -> f b -> Bool gliftEq = \(==.) a b -> liftEq (==.) (from1 a) (from1 b) -- * 'Ord1' -- | Generic 'liftCompare'. gliftCompare :: (Generic1 f, Ord1 (Rep1 f)) => (a -> b -> Ordering) -> f a -> f b -> Ordering gliftCompare = \compare' a b -> liftCompare compare' (from1 a) (from1 b) generic-data-1.1.0.0/src/Generic/Data/Internal/Read.hs0000644000000000000000000001750207346545000020367 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} -- | Generic implementation of Read -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Read where import Data.Coerce import Data.Functor.Classes (Read1(..)) import Data.Functor.Identity import Data.Proxy import Generic.Data.Internal.Utils (isSymDataCon, isSymVar) import GHC.Generics hiding (prec) import GHC.Read (expectP, list) import GHC.Show (appPrec, appPrec1) import Text.ParserCombinators.ReadPrec import Text.Read (Read(..), parens) import Text.Read.Lex (Lexeme(..)) -- | Generic 'readPrec'. -- -- @ -- instance 'Read' MyType where -- 'readPrec' = 'Text.Read.greadPrec' -- 'readListPrec' = 'Text.Read.readListPrecDefault' -- @ greadPrec :: (Generic a, GRead0 (Rep a)) => ReadPrec a greadPrec = to <$> gPrecRead Proxy -- | Generic representation of 'Read' types. type GRead0 = GRead Proxy -- | Generic 'liftReadPrec'. gliftReadPrec :: (Generic1 f, GRead1 (Rep1 f)) => ReadPrec a -> ReadPrec [a] -> ReadPrec (f a) gliftReadPrec readPrec' readList' = to1 <$> gPrecRead (Identity (readPrec', readList')) -- | Generic representation of 'Data.Functor.Classes.Read1' types. type GRead1 = GRead Identity class GRead p f where gPrecRead :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a) instance (GRead p f, IsNullaryDataType f) => GRead p (M1 D d f) where gPrecRead p = coerceM1 (parensIfNonNullary (gPrecRead p)) where x :: f a x = undefined parensIfNonNullary :: ReadPrec a -> ReadPrec a parensIfNonNullary = if isNullaryDataType x then id else parens instance (GRead p f, GRead p g) => GRead p (f :+: g) where gPrecRead p = fmap L1 (gPrecRead p) +++ fmap R1 (gPrecRead p) instance (Constructor c, GReadC p c f) => GRead p (M1 C c f) where gPrecRead p = gPrecReadC p (conName x) (conFixity x) where x :: M1 C c f a x = undefined instance GRead p V1 where gPrecRead _ = pfail class IsNullaryDataType f where isNullaryDataType :: f a -> Bool instance IsNullaryDataType (f :+: g) where isNullaryDataType _ = False instance IsNullaryDataType (C1 c f) where isNullaryDataType _ = False instance IsNullaryDataType V1 where isNullaryDataType _ = True class GReadC p c f where gPrecReadC :: p (ReadPrec a, ReadPrec [a]) -> String -> Fixity -> ReadPrec (M1 C c f a) instance GReadFields p f => GReadC p ('MetaCons s y 'False) f where gPrecReadC :: forall a. p (ReadPrec a, ReadPrec [a]) -> String -> Fixity -> ReadPrec (M1 C ('MetaCons s y 'False) f a) gPrecReadC p name fixity | Infix _ fy <- fixity, Branch k1 k2 <- fields = coerceM1 $ prec fy $ do k1' <- toReadPrec k1 if isSymDataCon name then expectP (Symbol name) else mapM_ expectP ([Punc "`"] ++ identHLexemes name ++ [Punc "`"]) k2' <- toReadPrec k2 pure (k1' :*: k2') | otherwise = coerceM1 $ prec appPrec $ do readPrefixCon name toReadPrec fields where fields :: ReadPrecTree (f a) fields = gPrecReadFields p instance GReadNamed p f => GReadC p ('MetaCons s y 'True) f where gPrecReadC p name _fixity = coerceM1 $ prec appPrec1 $ do readPrefixCon name readSurround '{' fields '}' where fields = gPrecReadNamed p class GReadFields p f where gPrecReadFields :: p (ReadPrec a, ReadPrec [a]) -> ReadPrecTree (f a) instance (GReadFields p f, GReadFields p g) => GReadFields p (f :*: g) where gPrecReadFields p = Branch (gPrecReadFields p) (gPrecReadFields p) instance GReadSingle p f => GReadFields p (M1 S c f) where gPrecReadFields p = M1Leaf (step (gPrecReadSingle p)) instance GReadFields p U1 where gPrecReadFields _ = U1Leaf class GReadNamed p f where gPrecReadNamed :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a) instance (GReadNamed p f, GReadNamed p g) => GReadNamed p (f :*: g) where gPrecReadNamed p = do l <- gPrecReadNamed p expectP (Punc ",") r <- gPrecReadNamed p pure (l :*: r) instance (Selector c, GReadSingle p f) => GReadNamed p (M1 S c f) where gPrecReadNamed p = coerceM1 $ do mapM_ expectP snameLexemes expectP (Punc "=") reset (gPrecReadSingle p) where x :: M1 S c f a x = undefined sname :: String sname = selName x snameLexemes :: [Lexeme] snameLexemes | isSymVar sname = [Punc "(", Symbol sname, Punc ")"] | otherwise = identHLexemes sname instance GReadNamed p U1 where gPrecReadNamed _ = pure U1 class GReadSingle p f where gPrecReadSingle :: p (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a) instance Read a => GReadSingle p (K1 i a) where gPrecReadSingle _ = coerceK1 readPrec where coerceK1 :: ReadPrec a -> ReadPrec (K1 i a x) coerceK1 = coerce instance Read1 f => GReadSingle Identity (Rec1 f) where gPrecReadSingle (Identity p) = coerceRec1 (liftReadPrecCompat p) where coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a) coerceRec1 = coerce instance GReadSingle Identity Par1 where gPrecReadSingle (Identity (readPrec', _)) = coercePar1 readPrec' where coercePar1 :: ReadPrec p -> ReadPrec (Par1 p) coercePar1 = coerce instance (Read1 f, GReadSingle p g) => GReadSingle p (f :.: g) where gPrecReadSingle :: forall a. p (ReadPrec a, ReadPrec [a]) -> ReadPrec ((f :.: g) a) gPrecReadSingle p = coerceComp1 (liftReadPrecCompat (readPrec_, readList_)) where readPrec_ :: ReadPrec (g a) readPrec_ = gPrecReadSingle p readList_ :: ReadPrec [g a] readList_ = list readPrec_ coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((f :.: g) a) coerceComp1 = coerce -- Helpers coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p) coerceM1 = coerce -- | A backwards-compatible version of 'liftReadPrec'. This is needed for -- compatibility with @base-4.9@, where 'Read1' only offers 'liftReadsPrec', -- not 'liftReadPrec'. liftReadPrecCompat :: Read1 f => (ReadPrec a, ReadPrec [a]) -> ReadPrec (f a) liftReadPrecCompat (readPrec', readList') = #if MIN_VERSION_base(4,10,0) liftReadPrec readPrec' readList' #else readS_to_Prec (liftReadsPrec (readPrec_to_S readPrec') (readPrec_to_S readList' 0)) #endif data ReadPrecTree a where U1Leaf :: ReadPrecTree (U1 a) M1Leaf :: ReadPrec (f a) -> ReadPrecTree (M1 i c f a) Branch :: ReadPrecTree (f a) -> ReadPrecTree (g a) -> ReadPrecTree ((f :*: g) a) toReadPrec :: ReadPrecTree a -> ReadPrec a toReadPrec U1Leaf = pure U1 toReadPrec (M1Leaf f) = coerceM1 f toReadPrec (Branch f g) = (:*:) <$> toReadPrec f <*> toReadPrec g identHLexemes :: String -> [Lexeme] identHLexemes s | Just (ss, '#') <- snocView s = [Ident ss, Symbol "#"] | otherwise = [Ident s] readPrefixCon :: String -> ReadPrec () readPrefixCon name | isSymDataCon name = readSurround '(' (expectP (Symbol name)) ')' | otherwise = mapM_ expectP (identHLexemes name) readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a readSurround c1 r c2 = do expectP (Punc [c1]) r' <- r expectP (Punc [c2]) pure r' -- Split off the last element. snocView :: [a] -> Maybe ([a], a) snocView [] = Nothing snocView xs = go [] xs where -- Invariant: second arg is non-empty go acc [a] = Just (reverse acc, a) go acc (a:as) = go (a:acc) as go _ [] = error "Util: snocView" generic-data-1.1.0.0/src/Generic/Data/Internal/Resolvers.hs0000644000000000000000000000446407346545000021503 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Newtypes with special instances for deriving. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Resolvers where import Data.Bifunctor (first) import Data.Functor.Classes import Data.Function (on) import Text.Read (Read(..)) import Generic.Data.Internal.Compat(readPrec1) -- | A newtype whose instances for simple classes ('Eq', 'Ord', 'Read', 'Show') -- use higher-kinded class instances for @f@ (`Eq1`, `Ord1`, `Read1`, `Show1`). newtype Id1 f a = Id1 { unId1 :: f a } deriving (Eq1, Ord1, Read1, Show1) instance (Eq1 f, Eq a) => Eq (Id1 f a) where (==) = eq1 `on` unId1 instance (Ord1 f, Ord a) => Ord (Id1 f a) where compare = compare1 `on` unId1 instance (Read1 f, Read a) => Read (Id1 f a) where readsPrec = (fmap . fmap . fmap . first) Id1 readsPrec1 readPrec = fmap Id1 readPrec1 instance (Show1 f, Show a) => Show (Id1 f a) where showsPrec d = showsPrec1 d . unId1 -- | A newtype with trivial instances, that considers -- every value equivalent to every other one, -- and shows as just @"_"@. newtype Opaque a = Opaque { unOpaque :: a } -- | All equal. instance Eq (Opaque a) where (==) _ _ = True -- | All equal. instance Ord (Opaque a) where compare _ _ = EQ -- | Shown as @"_"@. instance Show (Opaque a) where showsPrec _ _ = showString "_" -- | All equal. instance Eq1 Opaque where liftEq _ _ _ = True -- | All equal. instance Ord1 Opaque where liftCompare _ _ _ = EQ -- | Shown as @"_"@. instance Show1 Opaque where liftShowsPrec _ _ _ _ = showString "_" -- | A higher-kinded version of 'Opaque'. newtype Opaque1 f a = Opaque1 { unOpaque1 :: f a } -- | All equal. instance Eq (Opaque1 f a) where (==) _ _ = True -- | All equal. instance Ord (Opaque1 f a) where compare _ _ = EQ -- | Shown as @"_"@. instance Show (Opaque1 f a) where showsPrec _ _ = showString "_" -- | All equal. instance Eq1 (Opaque1 f) where liftEq _ _ _ = True -- | All equal. instance Ord1 (Opaque1 f) where liftCompare _ _ _ = EQ -- | Shown as @"_"@. instance Show1 (Opaque1 f) where liftShowsPrec _ _ _ _ = showString "_" generic-data-1.1.0.0/src/Generic/Data/Internal/Show.hs0000644000000000000000000001141607346545000020432 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} -- | Generic implementation of Show -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Show where import Data.Foldable (foldl') import Data.Functor.Classes (Show1(..)) import Data.Functor.Identity import Data.Proxy import Generic.Data.Internal.Utils (isSymDataCon, isSymVar) import GHC.Generics import Text.Show.Combinators -- | Generic 'showsPrec'. -- -- @ -- instance 'Show' MyType where -- 'showsPrec' = 'gshowsPrec' -- @ gshowsPrec :: (Generic a, GShow0 (Rep a)) => Int -> a -> ShowS gshowsPrec = flip gprecShows gprecShows :: (Generic a, GShow0 (Rep a)) => a -> PrecShowS gprecShows = gPrecShows Proxy . from -- | Generic representation of 'Show' types. type GShow0 = GShow Proxy -- | Generic 'liftShowsPrec'. gliftShowsPrec :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS gliftShowsPrec showsPrec' showList' = flip (gLiftPrecShows showsPrec' showList' . from1) gLiftPrecShows :: GShow1 f => (Int -> a -> ShowS) -> ([a] -> ShowS) -> f a -> PrecShowS gLiftPrecShows = curry (gPrecShows . Identity) type ShowsPrec a = (Int -> a -> ShowS, [a] -> ShowS) -- | Generic representation of 'Data.Functor.Classes.Show1' types. type GShow1 = GShow Identity class GShow p f where gPrecShows :: p (ShowsPrec a) -> f a -> PrecShowS instance GShow p f => GShow p (M1 D d f) where gPrecShows p (M1 x) = gPrecShows p x instance (GShow p f, GShow p g) => GShow p (f :+: g) where gPrecShows p (L1 x) = gPrecShows p x gPrecShows p (R1 y) = gPrecShows p y instance (Constructor c, GShowC p c f) => GShow p (M1 C c f) where gPrecShows p x = gPrecShowsC p (conName x) (conFixity x) x instance GShow p V1 where gPrecShows _ v = case v of {} class GShowC p c f where gPrecShowsC :: p (ShowsPrec a) -> String -> Fixity -> M1 C c f a -> PrecShowS instance GShowFields p f => GShowC p ('MetaCons s y 'False) f where gPrecShowsC p name fixity (M1 x) | Infix _ fy <- fixity, k1 : k2 : ks <- fields = foldl' showApp (showInfix cname fy k1 k2) ks | otherwise = foldl' showApp (showCon cname) fields where cname = surroundConName fixity name fields = gPrecShowsFields p x instance GShowNamed p f => GShowC p ('MetaCons s y 'True) f where gPrecShowsC p name fixity (M1 x) = showRecord cname fields where cname = surroundConName fixity name fields = gPrecShowsNamed p x class GShowFields p f where gPrecShowsFields :: p (ShowsPrec a) -> f a -> [PrecShowS] instance (GShowFields p f, GShowFields p g) => GShowFields p (f :*: g) where gPrecShowsFields p (x :*: y) = gPrecShowsFields p x ++ gPrecShowsFields p y instance GShowSingle p f => GShowFields p (M1 S c f) where gPrecShowsFields p (M1 x) = [gPrecShowsSingle p x] instance GShowFields p U1 where gPrecShowsFields _ U1 = [] class GShowNamed p f where gPrecShowsNamed :: p (ShowsPrec a) -> f a -> ShowFields instance (GShowNamed p f, GShowNamed p g) => GShowNamed p (f :*: g) where gPrecShowsNamed p (x :*: y) = gPrecShowsNamed p x &| gPrecShowsNamed p y instance (Selector c, GShowSingle p f) => GShowNamed p (M1 S c f) where gPrecShowsNamed p x'@(M1 x) = snameParen `showField` gPrecShowsSingle p x where sname = selName x' snameParen | isSymVar sname = "(" ++ sname ++ ")" | otherwise = sname instance GShowNamed p U1 where gPrecShowsNamed _ U1 = noFields class GShowSingle p f where gPrecShowsSingle :: p (ShowsPrec a) -> f a -> PrecShowS instance Show a => GShowSingle p (K1 i a) where gPrecShowsSingle _ (K1 x) = flip showsPrec x instance Show1 f => GShowSingle Identity (Rec1 f) where gPrecShowsSingle (Identity sp) (Rec1 r) = flip (uncurry liftShowsPrec sp) r instance GShowSingle Identity Par1 where gPrecShowsSingle (Identity (showsPrec', _)) (Par1 a) = flip showsPrec' a instance (Show1 f, GShowSingle p g) => GShowSingle p (f :.: g) where gPrecShowsSingle p (Comp1 c) = flip (liftShowsPrec showsPrec_ showList_) c where showsPrec_ = flip (gPrecShowsSingle p) showList_ = showListWith (showsPrec_ 0) -- Helpers surroundConName :: Fixity -> String -> String surroundConName fixity name = case fixity of Prefix | isSymName -> "(" ++ name ++ ")" | otherwise -> name Infix _ _ | isSymName -> name | otherwise -> "`" ++ name ++ "`" where isSymName = isSymDataCon name generic-data-1.1.0.0/src/Generic/Data/Internal/Traversable.hs0000644000000000000000000001513507346545000021766 0ustar0000000000000000-- | Generic implementation of 'Foldable' and 'Traversable'. -- -- There is already a naive implementation using the generic @'Rep'@'s -- own instances of 'Foldable' and 'Traversable'. However, deriving then -- generates a lot of code that may not be simplified away by GHC, -- that results in unnecessary run-time overhead. -- -- In contrast, this implementation guarantees that the generated code is -- identical to stock-derived instances of 'Foldable' and 'Traversable', -- which have the following syntactic properties: -- -- - constructors with zero fields use 'pure' once; -- - constructors with one field use 'fmap' once; -- - constructors with n >= 2 fields use 'liftA2' once and @('<*>')@ n-2 times. -- -- The heavy lifting is actually done by the ap-normalize library. {-# LANGUAGE DataKinds, EmptyCase, FlexibleContexts, FlexibleInstances, GADTs, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeOperators, UndecidableInstances, UndecidableSuperClasses #-} module Generic.Data.Internal.Traversable where import Control.Applicative (liftA2) import Data.Kind (Type) import Data.Monoid import GHC.Generics import ApNormalize -- * Library -- | Generic 'foldMap'. -- -- @ -- instance 'Foldable' MyTypeF where -- 'foldMap' = 'gfoldMap' -- @ gfoldMap :: (Generic1 f, GFoldable (Rep1 f), Monoid m) => (a -> m) -> f a -> m gfoldMap = \f -> lowerEndoM . gfoldMap_ f . from1 {-# INLINE gfoldMap #-} -- | Generic 'traverse'. -- -- @ -- instance 'Traversable' MyTypeF where -- 'traverse' = 'gtraverse' -- @ gtraverse :: (Generic1 f, GTraversable (Rep1 f), Applicative m) => (a -> m b) -> f a -> m (f b) gtraverse = \f -> lowerAps . fmap to1 . gtraverse_ (Kleisli f) . from1 {-# INLINE gtraverse #-} -- | Generic 'sequenceA'. -- -- @ -- instance 'Traversable' MyTypeF where -- 'sequenceA' = 'gsequenceA' -- @ -- -- See also 'gtraverse'. -- gsequenceA :: (Generic1 f, GTraversable (Rep1 f), Applicative m) => f (m a) -> m (f a) gsequenceA = lowerAps . fmap to1 . gtraverse_ Refl . from1 {-# INLINE gsequenceA #-} -- | Class of generic representations for which 'Foldable' can be derived. class GFoldable_ t => GFoldable t instance GFoldable_ t => GFoldable t -- | Class of generic representations for which 'Traversable' can be derived. class GTraversable_ t => GTraversable t instance GTraversable_ t => GTraversable t -- | Internal definition of 'GFoldable'. class (GFoldMap t, Foldable t) => GFoldable_ t instance (GFoldMap t, Foldable t) => GFoldable_ t -- | Internal definition of 'GTraversable'. class (GTraverse Kleisli t, GTraverse Equal t) => GTraversable_ t instance (GTraverse Kleisli t, GTraverse Equal t) => GTraversable_ t -- Implementation -- ** Foldable -- | Isomorphic to @Maybe m@, but we need to micromanage the -- use of Monoid vs Semigroup to match exactly the output -- of stock deriving, for inspection testing. data Maybe' m = Nothing' | Just' m type EndoM m = Endo (Maybe' m) liftEndoM :: Monoid m => m -> EndoM m liftEndoM x = Endo app where app Nothing' = Just' x app (Just' y) = Just' (x `mappend` y) {-# INLINE liftEndoM #-} lowerEndoM :: Monoid m => EndoM m -> m lowerEndoM (Endo app) = lowerMaybe (app Nothing') {-# INLINE lowerEndoM #-} lowerMaybe :: Monoid m => Maybe' m -> m lowerMaybe Nothing' = mempty lowerMaybe (Just' x) = x {-# INLINE lowerMaybe #-} class GFoldMap t where gfoldMap_ :: Monoid m => (a -> m) -> t a -> EndoM m instance GFoldMap f => GFoldMap (M1 i c f) where gfoldMap_ f (M1 x) = gfoldMap_ f x {-# INLINE gfoldMap_ #-} instance (GFoldMap f, GFoldMap g) => GFoldMap (f :+: g) where gfoldMap_ f (L1 x) = gfoldMap_ f x gfoldMap_ f (R1 y) = gfoldMap_ f y {-# INLINE gfoldMap_ #-} instance (GFoldMap f, GFoldMap g) => GFoldMap (f :*: g) where gfoldMap_ f (x :*: y) = gfoldMap_ f x `mappend` gfoldMap_ f y {-# INLINE gfoldMap_ #-} instance GFoldMap U1 where gfoldMap_ _ _ = mempty {-# INLINE gfoldMap_ #-} instance GFoldMap V1 where gfoldMap_ _ v = case v of {} {-# INLINE gfoldMap_ #-} instance GFoldMap (K1 i a) where gfoldMap_ _ (K1 _) = mempty {-# INLINE gfoldMap_ #-} instance GFoldMap Par1 where gfoldMap_ f (Par1 x) = liftEndoM (f x) {-# INLINE gfoldMap_ #-} instance Foldable t => GFoldMap (Rec1 t) where gfoldMap_ f (Rec1 x) = liftEndoM (foldMap f x) {-# INLINE gfoldMap_ #-} instance (Foldable t, Foldable f) => GFoldMap (t :.: f) where gfoldMap_ f (Comp1 x) = liftEndoM (foldMap (foldMap f) x) {-# INLINE gfoldMap_ #-} -- ** Traversable data Equal (f :: Type -> Type) a b where Refl :: Equal f (f b) b newtype Kleisli f a b = Kleisli (a -> f b) class GTraverse arr t where gtraverse_ :: Applicative f => arr f a b -> t a -> Aps f (t b) instance GTraverse arr f => GTraverse arr (M1 i c f) where gtraverse_ f (M1 x) = M1 <$> gtraverse_ f x {-# INLINE gtraverse_ #-} instance (GTraverse arr f, GTraverse arr g) => GTraverse arr (f :+: g) where gtraverse_ f (L1 x) = L1 <$> gtraverse_ f x gtraverse_ f (R1 y) = R1 <$> gtraverse_ f y {-# INLINE gtraverse_ #-} instance (GTraverse arr f, GTraverse arr g) => GTraverse arr (f :*: g) where gtraverse_ f (x :*: y) = liftA2 (:*:) (gtraverse_ f x) (gtraverse_ f y) {-# INLINE gtraverse_ #-} instance GTraverse arr U1 where gtraverse_ _ _ = pure U1 {-# INLINE gtraverse_ #-} instance GTraverse arr V1 where gtraverse_ _ v = case v of {} {-# INLINE gtraverse_ #-} instance GTraverse arr (K1 i a) where gtraverse_ _ (K1 x) = pure (K1 x) {-# INLINE gtraverse_ #-} -- traverse instance GTraverse Kleisli Par1 where gtraverse_ (Kleisli f) (Par1 x) = Par1 <$> liftAps (f x) {-# INLINE gtraverse_ #-} instance Traversable t => GTraverse Kleisli (Rec1 t) where gtraverse_ (Kleisli f) (Rec1 x) = Rec1 <$> liftAps (traverse f x) {-# INLINE gtraverse_ #-} -- Oh no, the encoding with @(':.:')@ is quite broken. -- -- @t1 (... (tn (t a)) ...)@ is represented as: -- @(t1 :.: (... :.: (tn :.: Rec1 t) ...)) a@ -- but it would be more efficient to associate to the left: -- @(((... (Rec1 t1 :.: t2) :.: ...) :.: tn) :.: t) a instance (Traversable t, Traversable f) => GTraverse Kleisli (t :.: f) where gtraverse_ (Kleisli f) (Comp1 x) = Comp1 <$> liftAps (traverse (traverse f) x) {-# INLINE gtraverse_ #-} -- sequenceA instance GTraverse Equal Par1 where gtraverse_ Refl (Par1 x) = Par1 <$> liftAps x {-# INLINE gtraverse_ #-} instance Traversable t => GTraverse Equal (Rec1 t) where gtraverse_ Refl (Rec1 x) = Rec1 <$> liftAps (sequenceA x) {-# INLINE gtraverse_ #-} instance (Traversable t, Traversable f) => GTraverse Equal (t :.: f) where gtraverse_ Refl (Comp1 x) = Comp1 <$> liftAps (traverse sequenceA x) {-# INLINE gtraverse_ #-} generic-data-1.1.0.0/src/Generic/Data/Internal/Utils.hs0000644000000000000000000000356507346545000020620 0ustar0000000000000000{-# LANGUAGE BangPatterns, EmptyCase, FlexibleContexts, PolyKinds, Trustworthy #-} -- | Utilities. -- -- === Warning -- -- This is an internal module: it is not subject to any versioning policy, -- breaking changes can happen at any time. -- -- If something here seems useful, please report it or create a pull request to -- export it from an external module. module Generic.Data.Internal.Utils where import Data.Coerce import GHC.Generics import GHC.Lexeme (startsConSym, startsVarSym) -- | Convert between types with representationally equivalent generic -- representations. gcoerce :: (Generic a, Generic b, Coercible (Rep a) (Rep b)) => a -> b gcoerce = to . coerce1 . from -- | Compose 'gcoerce' with a binary operation. gcoerceBinop :: (Generic a, Generic b, Coercible (Rep a) (Rep b)) => (a -> a -> a) -> (b -> b -> b) gcoerceBinop f x y = gcoerce (f (gcoerce x) (gcoerce y)) -- | Coerce while preserving the type index. coerce' :: Coercible (f x) (g x) => f x -> g x coerce' = coerce coerce1 :: Coercible f g => f x -> g x coerce1 = coerce -- | Elimination of @V1@. absurd1 :: V1 x -> a absurd1 x = case x of {} -- | A helper for better type inference. from' :: Generic a => a -> Rep a () from' = from -- | A helper for better type inference. to' :: Generic a => Rep a () -> a to' = to -- | Lift binary combinators generically. liftG2 :: Generic1 f => (Rep1 f a -> Rep1 f b -> Rep1 f c) -> f a -> f b -> f c liftG2 = \() a b -> to1 (from1 a from1 b) -- | Returns 'True' if the argument is a symbolic data constructor name -- (e.g., @(:+:)@). Returns 'False' otherwise. isSymDataCon :: String -> Bool isSymDataCon "" = False isSymDataCon (c:_) = startsConSym c -- | Returns 'True' if the argument is a symbolic value name (e.g., @(+++)@). -- Returns 'False' otherwise. isSymVar :: String -> Bool isSymVar "" = False isSymVar (c:_) = startsVarSym c generic-data-1.1.0.0/src/Generic/Data/0000755000000000000000000000000007346545000015377 5ustar0000000000000000generic-data-1.1.0.0/src/Generic/Data/Microsurgery.hs0000644000000000000000000002037707346545000020436 0ustar0000000000000000{-# LANGUAGE ExplicitNamespaces #-} -- | Simple operations on generic representations: -- modify 'GHC.Generics.Generic' instances to tweak the behavior of generic -- implementations as if you had declared a slightly different type. -- -- This module provides the following microsurgeries: -- -- - 'RenameFields': rename the fields of a record type. -- - 'RenameConstrs': rename the constructors. -- - 'OnFields': apply a type constructor @f :: Type -> Type@ to every field. -- - 'CopyRep': use the generic representation of another type of the same shape. -- - 'Typeage': treat a @newtype@ as a @data@ type. -- - 'Derecordify': treat a type as if it weren't a record. -- -- More complex surgeries can be found in -- -- but also, perhaps surprisingly, -- in -- (read more about this just below) and -- . -- -- Surgeries can be used: -- -- - to derive type class instances with the @DerivingVia@ extension, -- using the 'Surgery' or 'ProductSurgery' type synonyms -- (for classes with instances for 'Generically' or 'GenericProduct'); -- - with the 'Data' \"synthetic type\" for more involved transformations, -- for example using lenses in the next section. module Generic.Data.Microsurgery ( -- * Surgeries with generic-lens -- $lens-surgery -- * Deriving via Surgery , ProductSurgery , Surgeries , ProductSurgeries , Surgery'(..) , GSurgery , Generically(..) , GenericProduct(..) -- * Synthetic types , Data , toData , fromData , onData -- * Microsurgeries -- -- | Each microsurgery consists of a type family @F@ to modify metadata in -- GHC Generic representations, and two mappings (that are just -- 'Data.Coerce.coerce'): -- -- @ -- f :: 'Data' ('GHC.Generics.Rep' a) p -> 'Data' (F ('GHC.Generics.Rep' a)) p -- unf :: 'Data' (F ('GHC.Generics.Rep' a)) p -> 'Data' ('GHC.Generics.Rep' a) p -- @ -- -- Use @f@ with 'toData' for generic functions that consume generic values, -- and @unf@ with 'fromData' for generic functions that produce generic -- values. Abstract example: -- -- @ -- genericSerialize . f . 'toData' -- 'fromData' . unf . genericDeserialize -- @ -- ** Renaming of fields and constructors -- | These surgeries require @DataKinds@ and @TypeApplications@. -- -- ==== Examples -- -- @ -- {-# LANGUAGE -- DataKinds, -- TypeApplications #-} -- -- -- Rename all fields to \"foo\" -- 'renameFields' \@('SConst' \"foo\") -- -- -- Rename constructor \"Bar\" to \"Baz\", and leave all others the same -- 'renameConstrs' \@('SRename' '[ '(\"Bar\", \"Baz\") ] 'SId') -- @ , RenameFields() , renameFields , unrenameFields , RenameConstrs() , renameConstrs , unrenameConstrs -- *** Renaming functions , type (@@) , SId , SError , SConst , SRename -- ** 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. 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 -- - https://reasonablypolymorphic.com/blog/higher-kinded-data/ -- -- See also the file @test/one-liner-surgery.hs@ in this package for an -- example of using one-liner and generic-lens with a synthetic type -- constructed with 'DOnFields'. -- -- === Example -- -- Derive 'Data.Semigroup.Semigroup' and 'Data.Monoid.Monoid' for -- 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') -- import "Generic.Data.Microsurgery" -- ( 'ProductSurgery' -- , 'OnFields' -- , 'GenericProduct'(..) -- Constructors must be in scope -- , 'Surgery''(..) -- -- ) -- @ , OnFields() , DOnFields , OnField() , type (%~) , Cat() , DCat() -- ** Substitute a generic representation from another type -- | -- === Example -- -- Derive 'Data.Semigroup.Semigroup' and 'Data.Monoid.Monoid' for -- a product of 'Prelude.Num' types, but using 'Data.Monoid.Sum' for one -- field and 'Data.Monoid.Product' for the other. -- In other words, we use the fact that @Polar a@ below is isomorphic to -- the monoid @('Data.Monoid.Product' a, 'Data.Monoid.Sum' a)@. -- -- @ -- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} -- import "Data.Monoid" ('Data.Monoid.Sum'(..), 'Data.Monoid.Product'(..)) -- Constructors must be in scope -- import "GHC.Generics" ('GHC.Generics.Generic') -- import "Generic.Data.Microsurgery" -- ( 'ProductSurgery' -- , 'CopyRep' -- , 'GenericProduct'(..) -- Constructors must be in scope -- , 'Surgery''(..) -- -- ) -- -- data Polar a = Exp { modulus :: a, argument :: a } -- deriving 'GHC.Generics.Generic' -- deriving ('Data.Semigroup.Semigroup', 'Data.Monoid.Monoid') -- via ('ProductSurgery' ('CopyRep' ('Data.Monoid.Product' a, 'Data.Monoid.Sum' a)) (Polar a)) -- Surgery here -- @ -- -- That is the polar representation of a complex number: -- -- > z = modulus * exp(i * argument) -- -- The product of complex numbers defines a monoid isomorphic to -- the monoid product @(Product Double, Sum Double)@ -- (multiply the moduli, add the arguments). -- -- @ -- z1 'Data.Semigroup.<>' z2 -- = z1 'Prelude.*' z2 -- = Exp (modulus z1 'Prelude.*' modulus z2) (argument z1 'Prelude.+' argument z2) -- -- 'Data.Monoid.mempty' = 1 = Exp 1 0 -- @ , CopyRep , copyRep , uncopyRep -- ** Type aging ("denewtypify") , Typeage() , typeage , untypeage -- ** Derecordify , Derecordify() , derecordify , underecordify ) where import Generic.Data.Internal.Data import Generic.Data.Internal.Generically import Generic.Data.Internal.Microsurgery -- $lens-surgery -- One common and simple situation is to modify the type of some fields, -- for example wrapping them in a newtype. -- -- We can leverage the @generic-lens@ library, with the two functions below. -- -- @ -- -- Lens to a field named @fd@ in a Generic record. -- field_ :: HasField_ fd s t a b => Lens s t a b -- from generic-lens -- -- -- Update a value through a lens (ASetter is a specialization of Lens). -- over :: ASetter s t a b -> (a -> b) -> s -> t -- from lens or microlens -- @ -- -- For example, here is a record type: -- -- @ -- data R = R { myField :: Int } deriving 'GHC.Generics.Generic' -- @ -- -- The function @over (field_ \@\"myField\") 'Generic.Data.Opaque'@ -- applies the newtype constructor 'Generic.Data.Opaque' to the field -- @\"myField\"@, but this actually doesn't typecheck as-is. With a bit of help -- from this module, we can wrap that function as follows: -- -- @ -- 'onData' (over (field_ \@\"myField\") 'Generic.Data.Opaque') . 'toData' -- :: R -> 'Data' _ _ -- type arguments hidden -- @ -- -- The result has a type @'Data' _ _@, that from the point of view of "GHC.Generics" -- looks just like @R@ but with the field @\"myField\"@ wrapped in -- 'Generic.Data.Opaque', as if we had defined: -- -- @ -- data R = R { myField :: 'Generic.Data.Opaque' Int } deriving 'GHC.Generics.Generic' -- @ -- -- ==== Example usage -- -- We derive an instance of 'Show' that hides the @\"myField\"@ field, -- whatever its type. -- -- @ -- instance 'Show' R where -- 'showsPrec' n = 'Generic.Data.gshowsPrec' n -- . 'onData' (over (field_ \@\"myField\") 'Generic.Data.Opaque') -- . 'toData' -- -- 'show' (R 3) = \"R {myField = _}\" -- @ generic-data-1.1.0.0/src/Generic/Data/Types.hs0000644000000000000000000000030307346545000017033 0ustar0000000000000000-- | Utilities to derive and transform generic types. {-# LANGUAGE TypeOperators #-} module Generic.Data.Types ( Data(..) , toData , fromData ) where import Generic.Data.Internal.Data generic-data-1.1.0.0/test/Inspection/0000755000000000000000000000000007346545000015455 5ustar0000000000000000generic-data-1.1.0.0/test/Inspection/Boilerplate.hs0000644000000000000000000000672607346545000020266 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} module Inspection.Boilerplate where import Control.Applicative (liftA2) import Language.Haskell.TH import Generic.Data {- Example output this generates (modulo reordering): eqEmptyR, eqEmptyS, eqEmptyG :: Empty a -> Empty a -> Bool eqEmptyR = \_ _ -> True eqEmptyS = (==) eqEmptyG = geq -} class AppendQ q where ($++) :: q -> DecsQ -> DecsQ infixr 2 $++ instance AppendQ (Q Dec) where ($++) = liftA2 (:) instance AppendQ (Q [Dec]) where ($++) = liftA2 (++) instance AppendQ q => AppendQ [q] where ps $++ qs = foldr ($++) qs ps type Top = Name -> ExpQ -> DecsQ mk_ :: String -> Maybe Name -> Name -> (TypeQ -> TypeQ) -> Top mk_ bname fname_ gname ty_ tname ref = do nameR <- newName (bname ++ nameBase tname ++ "R") -- Reference nameS <- newName (bname ++ nameBase tname ++ "S") -- Stock nameG <- newName (bname ++ nameBase tname ++ "G") -- Generic let ty = ty_ (conT tname) stock = case fname_ of Nothing -> pure [] Just fname -> sigD nameS ty $++ funD' nameS (varE fname) $++ pure [] ( sigD nameR ty $++ sigD nameG ty $++ funD' nameR ref $++ funD' nameG (varE gname) $++ stock $++ pure [] ) funD' :: Name -> ExpQ -> DecQ funD' name body = funD name [clause [] (normalB body) []] -- newVar :: String -> Q TypeQ newVar x = varT <$> newName x -- Eq and Ord -- Sometimes there isn't an Eq constraint on the parameter. mk_eq_ :: (TypeQ -> TypeQ) -> Top mk_eq_ = mk_ "eq" (Just '(==)) 'geq mk_eq :: Top mk_eq = mk_eq_ ty where ty f = do a <- newVar "a" [t| Eq $a => $f $a -> $f $a -> Bool |] mk_eq' :: Top mk_eq' = mk_eq_ ty where ty f = do a <- newVar "a" [t| $f $a -> $f $a -> Bool |] -- Sometimes there isn't an Ord constraint on the parameter. mk_compare_ :: (TypeQ -> TypeQ) -> Top mk_compare_ = mk_ "compare" (Just 'compare) 'gcompare mk_compare :: Top mk_compare = mk_compare_ ty where ty f = do a <- newVar "a" [t| Ord $a => $f $a -> $f $a -> Ordering |] mk_compare' :: Top mk_compare' = mk_compare_ ty where ty f = do a <- newVar "a" [t| $f $a -> $f $a -> Ordering |] -- Functor, Foldable, Traversable mk_fmap :: Top mk_fmap = mk_ "fmap" (Just 'fmap) 'gfmap ty where ty f = do a <- newVar "a" b <- newVar "b" [t| ($a -> $b) -> $f $a -> $f $b |] mk_foldMap :: Top mk_foldMap = mk_ "foldMap" (Just 'foldMap) 'gfoldMap ty where ty f = do a <- newVar "a" m <- newVar "m" [t| Monoid $m => ($a -> $m) -> $f $a -> $m |] mk_foldr :: Top mk_foldr = mk_ "foldr" (Just 'foldr) 'gfoldr ty where ty f = do a <- newVar "a" b <- newVar "b" [t| ($a -> $b -> $b) -> $b -> $f $a -> $b |] mk_traverse :: Top mk_traverse = mk_ "traverse" (Just 'traverse) 'gtraverse ty where ty f = do a <- newVar "a" b <- newVar "b" g <- newVar "g" [t| Applicative $g => ($a -> $g $b) -> $f $a -> $g ($f $b) |] mk_sequenceA :: Top mk_sequenceA = mk_ "sequenceA" (Just 'sequenceA) 'gsequenceA ty where ty f = do a <- newVar "a" g <- newVar "g" [t| Applicative $g => $f ($g $a) -> $g ($f $a) |] -- Applicative (no stock deriving) mk_ap :: Top mk_ap = mk_ "ap" Nothing 'gap ty where ty f = do a <- newVar "a" b <- newVar "b" [t| $f ($a -> $b) -> $f $a -> $f $b |] mk_liftA2 :: Top mk_liftA2 = mk_ "liftA2" Nothing 'gliftA2 ty where ty f = do a <- newVar "a" b <- newVar "b" c <- newVar "c" [t| ($a -> $b -> $c) -> $f $a -> $f $b -> $f $c |] generic-data-1.1.0.0/test/0000755000000000000000000000000007346545000013342 5ustar0000000000000000generic-data-1.1.0.0/test/bench.hs0000644000000000000000000000274407346545000014764 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingVia, DerivingStrategies, FlexibleInstances, ScopedTypeVariables, StandaloneDeriving, TypeApplications #-} import Data.Semigroup (Sum(..)) import Text.Show (showParen, showString) import Control.DeepSeq import Test.Tasty.Bench import Generic.Data import Generic.Data.Microsurgery data H -- handwritten data G -- generic data S -- surgery data T x = C { _a :: Sum Int, _b :: [Int] } deriving stock Generic deriving via (Surgery Derecordify (T S)) instance Show (T S) instance Show (T H) where showsPrec n (C a b) = showParen (n > 10) (showString "C " . showsPrec 11 a . showString " " . showsPrec 11 b) deriving via (Generically (T G)) instance Semigroup (T G) instance Semigroup (T H) where C a1 b1 <> C a2 b2 = C (a1 <> a2) (b1 <> b2) deriving anyclass instance NFData (T G) instance NFData (T H) where rnf (C a b) = rnf a `seq` rnf b `seq` () u :: forall x. T x u = C 33 [99] v :: forall x. T x v = C 13 [14] main :: IO () main = defaultMain [ bgroup "Show" [ bench "handwri" (nf show (u @H)) , bench "surgery" (nf show (u @S)) ] , bgroup "NFData" [ bench "handwri" (nf id (u @H)) , bench "generic" (nf id (u @G)) ] , bgroup "Semigroup" [ bench "baselin" (nf (uncurry (++)) ([99], [14 :: Int])) , bench "handwri" (nf (uncurry (<>)) (u @H, v)) , bench "generic" (nf (uncurry (<>)) (u @G, v)) ] ] generic-data-1.1.0.0/test/example.hs0000644000000000000000000000101407346545000015325 0ustar0000000000000000{-# LANGUAGE CPP, DeriveGeneric #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE DerivingStrategies, DerivingVia #-} #endif import Data.Semigroup (Semigroup(..)) import Generic.Data (Generic, gmappend, Generically(..)) import Generic.Data.Orphans () data Foo a = Bar [a] [a] deriving Generic instance Semigroup (Foo a) where (<>) = gmappend #if __GLASGOW_HASKELL__ >= 806 data Foo2 a = Bar2 [a] [a] deriving Generic deriving Semigroup via (Generically (Foo2 a)) #endif main :: IO () main = pure () generic-data-1.1.0.0/test/inspection.hs0000644000000000000000000003732007346545000016056 0ustar0000000000000000{-# OPTIONS_GHC -dsuppress-all #-} {-# LANGUAGE BangPatterns, CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, DerivingVia, EmptyCase, EmptyDataDeriving, TemplateHaskell #-} {-# LANGUAGE TypeOperators, TypeFamilies #-} import Control.Applicative (liftA2) import GHC.Generics import Data.Coerce (coerce) import Data.Semigroup (Sum(..), All(..)) import Test.Inspection import Generic.Data import Generic.Data.Microsurgery ( ProductSurgery , CopyRep , Surgery'(..) ) import Inspection.Boilerplate -- Test cases data T = T Int Bool deriving Generic deriving (Semigroup, Monoid) via ProductSurgery (CopyRep (Sum Int, All)) T deriving (Eq, Ord) via Generically T mappendT, mappendTG :: T -> T -> T mappendT (T a1 b1) (T a2 b2) = T (a1 + a2) (b1 && b2) mappendTG x y = x <> y memptyT, memptyTG :: T memptyT = T 0 True memptyTG = mempty eqT, eqTG :: T -> T -> Bool eqT (T a1 b1) (T a2 b2) = a1 == a2 && b1 == b2 eqTG = (==) compareT, compareTG :: T -> T -> Ordering compareT (T a1 b1) (T a2 b2) = compare a1 a2 <> compare b1 b2 compareTG = compare inspect $ 'mappendT ==- 'mappendTG inspect $ 'memptyT ==- 'memptyTG inspect $ 'eqT ==- 'eqTG inspect $ 'compareT ==- 'compareTG data Empty a deriving (Generic, Generic1, Eq, Ord, Functor, Foldable, Traversable) -- Arity 0 (nullary) data Ary0 a = Ary0 deriving (Generic, Generic1, Eq, Ord, Functor, Foldable, Traversable) -- Arity 1 (unary) (Lazy, Strict, Newtype) data Ary1 a = Ary1 a deriving (Generic, Generic1, Eq, Ord, Functor, Foldable, Traversable) data Ary1' a = Ary1' !a deriving (Generic, Generic1, Eq, Ord, Functor, Foldable, Traversable) newtype Ary1NT a = Ary1NT a deriving (Generic, Generic1, Eq, Ord, Functor, Foldable, Traversable) -- Arity 2 (binary) data Ary2 a = Ary2 a a deriving (Generic, Generic1, Eq, Ord, Functor, Foldable, Traversable) -- Arity 4 (quaternary) data Ary4 a = Ary4 a a [Int] [a] deriving (Generic, Generic1, Eq, Ord, Functor, Foldable, Traversable) -- A big sum of stuff data Big a = Big0 | Big1 a | Big2 a a | Big4 a a a a | Big8 Int a [a] [Int] [a] a a a deriving (Generic1, Eq, Ord, Functor, Foldable, Traversable) -- Handwritten to add INLINE pragmas. TODO: get GHC to do this instance Generic (Big a) where type Rep (Big a) = U1 :+: K1 () a :+: (K1 () a :*: K1 () a) :+: (K1 () a :*: K1 () a :*: K1 () a :*: K1 () a) :+: ( K1 () Int :*: K1 () a :*: K1 () [a] :*: K1 () [Int] :*: K1 () ([a]) :*: K1 () a :*: K1 () a :*: K1 () a) from Big0 = L1 U1 from (Big1 x) = R1 (L1 (K1 x)) from (Big2 x1 x2) = R1 (R1 (L1 (K1 x1 :*: K1 x2))) from (Big4 x1 x2 x3 x4) = R1 (R1 (R1 (L1 (K1 x1 :*: K1 x2 :*: K1 x3 :*: K1 x4)))) from (Big8 x1 x2 x3 x4 x5 x6 x7 x8) = R1 (R1 (R1 (R1 (K1 x1 :*: K1 x2 :*: K1 x3 :*: K1 x4 :*: K1 x5 :*: K1 x6 :*: K1 x7 :*: K1 x8)))) {-# INLINE from #-} to (L1 _) = Big0 to (R1 (L1 (K1 x))) = Big1 x to (R1 (R1 (L1 (K1 x1 :*: K1 x2)))) = Big2 x1 x2 to (R1 (R1 (R1 (L1 (K1 x1 :*: K1 x2 :*: K1 x3 :*: K1 x4))))) = Big4 x1 x2 x3 x4 to (R1 (R1 (R1 (R1 (K1 x1 :*: K1 x2 :*: K1 x3 :*: K1 x4 :*: K1 x5 :*: K1 x6 :*: K1 x7 :*: K1 x8))))) = Big8 x1 x2 x3 x4 x5 x6 x7 x8 {-# INLINE to #-} -- Empty -- Stock deriving of fmap does not use an EmptyCase. fmapEmptyRS :: (a -> b) -> Empty a -> Empty b fmapEmptyRS _ = coerce foldMapEmptyRS :: Monoid m => (a -> m) -> Empty a -> m foldMapEmptyRS _ _ = mempty -- mk_eq' ''Empty [| \ _ _ -> True |] inspect $ 'eqEmptyR ==- 'eqEmptyS inspect $ 'eqEmptyR ==- 'eqEmptyG mk_compare' ''Empty [| \ _ _ -> EQ |] inspect $ 'compareEmptyR ==- 'compareEmptyS inspect $ 'compareEmptyR ==- 'compareEmptyG mk_fmap ''Empty [| \ _ v -> case v of {} |] inspect $ 'fmapEmptyRS ==- 'fmapEmptyS inspect $ 'fmapEmptyR ==- 'fmapEmptyG mk_foldMap ''Empty [| \ _ v -> case v of {} |] inspect $ 'foldMapEmptyRS ==- 'foldMapEmptyS inspect $ 'foldMapEmptyR ==- 'foldMapEmptyG -- No EmptyCase! mk_foldr ''Empty [| \_ b _ -> b |] inspect $ 'foldrEmptyR ==- 'foldrEmptyS inspect $ 'foldrEmptyR ==- 'foldrEmptyG mk_traverse ''Empty [| \ _ v -> case v of {} |] inspect $ 'traverseEmptyS ==- 'traverseEmptyS inspect $ 'traverseEmptyR ==- 'traverseEmptyG mk_sequenceA ''Empty [| \ v -> case v of {} |] inspect $ 'sequenceAEmptyS ==- 'sequenceAEmptyS inspect $ 'sequenceAEmptyR ==- 'sequenceAEmptyG -- Ary0 eqAry0RS :: Ary0 a -> Ary0 a -> Bool eqAry0RS Ary0 Ary0 = True compareAry0RS :: Ary0 a -> Ary0 a -> Ordering compareAry0RS Ary0 Ary0 = EQ fmapAry0RS :: (a -> b) -> Ary0 a -> Ary0 b fmapAry0RS _ = coerce mk_eq' ''Ary0 [| \ _ _ -> True |] inspect $ 'eqAry0RS ==- 'eqAry0S inspect $ 'eqAry0R ==- 'eqAry0G mk_compare' ''Ary0 [| \ _ _ -> EQ |] inspect $ 'compareAry0RS ==- 'compareAry0S inspect $ 'compareAry0R ==- 'compareAry0G mk_fmap ''Ary0 [| \ _ _ -> Ary0 |] inspect $ 'fmapAry0RS ==- 'fmapAry0S inspect $ 'fmapAry0R ==- 'fmapAry0G mk_foldMap ''Ary0 [| \ _ _ -> mempty |] inspect $ 'foldMapAry0R ==- 'foldMapAry0S inspect $ 'foldMapAry0R ==- 'foldMapAry0G mk_foldr ''Ary0 [| \_ b _ -> b |] inspect $ 'foldrAry0R ==- 'foldrAry0S inspect $ 'foldrAry0R ==- 'foldrAry0G mk_traverse ''Ary0 [| \ _ _ -> pure Ary0 |] inspect $ 'traverseAry0S ==- 'traverseAry0S inspect $ 'traverseAry0R ==- 'traverseAry0G mk_sequenceA ''Ary0 [| \ _ -> pure Ary0 |] inspect $ 'sequenceAAry0S ==- 'sequenceAAry0S inspect $ 'sequenceAAry0R ==- 'sequenceAAry0G -- Ary1 eqAry1RS :: Eq a => Ary1 a -> Ary1 a -> Bool eqAry1RS (Ary1 x1) (Ary1 y1) = x1 == y1 compareAry1RS :: Ord a => Ary1 a -> Ary1 a -> Ordering compareAry1RS (Ary1 x1) (Ary1 y1) = compare x1 y1 fmapAry1RS :: (a -> b) -> Ary1 a -> Ary1 b fmapAry1RS f (Ary1 x) = Ary1 (f x) foldMapAry1RS :: Monoid m => (a -> m) -> Ary1 a -> m foldMapAry1RS f (Ary1 x) = f x foldrAry1RS :: (a -> b -> b) -> b -> Ary1 a -> b foldrAry1RS f b (Ary1 x) = f x b traverseAry1RS :: Applicative f => (a -> f b) -> Ary1 a -> f (Ary1 b) traverseAry1RS f (Ary1 x) = Ary1 <$> f x sequenceAAry1RS :: Applicative f => Ary1 (f a) -> f (Ary1 a) sequenceAAry1RS (Ary1 x) = Ary1 <$> x mk_eq ''Ary1 [| \ ~(Ary1 x1) ~(Ary1 y1) -> x1 == y1 |] inspect $ 'eqAry1RS ==- 'eqAry1S inspect $ 'eqAry1R ==- 'eqAry1G mk_compare ''Ary1 [| \ ~(Ary1 x1) ~(Ary1 y1) -> compare x1 y1 |] inspect $ 'compareAry1RS ==- 'compareAry1S inspect $ 'compareAry1R ==- 'compareAry1G mk_fmap ''Ary1 [| \ f ~(Ary1 x) -> Ary1 (f x) |] inspect $ 'fmapAry1RS ==- 'fmapAry1S inspect $ 'fmapAry1R ==- 'fmapAry1G mk_foldMap ''Ary1 [| \ f ~(Ary1 x) -> f x |] inspect $ 'foldMapAry1RS ==- 'foldMapAry1S inspect $ 'foldMapAry1R ==- 'foldMapAry1G mk_foldr ''Ary1 [| \ f r ~(Ary1 x) -> f x r |] inspect $ 'foldrAry1RS ==- 'foldrAry1S inspect $ 'foldrAry1R ==- 'foldrAry1G mk_traverse ''Ary1 [| \ f ~(Ary1 x) -> Ary1 <$> f x |] inspect $ 'traverseAry1RS ==- 'traverseAry1S inspect $ 'traverseAry1R ==- 'traverseAry1G mk_sequenceA ''Ary1 [| \ ~(Ary1 x) -> Ary1 <$> x |] inspect $ 'sequenceAAry1RS ==- 'sequenceAAry1S inspect $ 'sequenceAAry1R ==- 'sequenceAAry1G -- Generic @to@ seems to be lazy here mk_ap ''Ary1 [| \ ~(Ary1 f1) ~(Ary1 x1) -> Ary1 (f1 x1) |] inspect $ 'apAry1R ==- 'apAry1G mk_liftA2 ''Ary1 [| \ f ~(Ary1 x1) ~(Ary1 x2) -> Ary1 (f x1 x2) |] inspect $ 'liftA2Ary1R ==- 'liftA2Ary1G -- Ary1' (strict, this is entirely the same as Ary1) eqAry1'RS :: Eq a => Ary1' a -> Ary1' a -> Bool eqAry1'RS (Ary1' x1) (Ary1' y1) = x1 == y1 compareAry1'RS :: Ord a => Ary1' a -> Ary1' a -> Ordering compareAry1'RS (Ary1' x1) (Ary1' y1) = compare x1 y1 fmapAry1'RS :: (a -> b) -> Ary1' a -> Ary1' b fmapAry1'RS f (Ary1' x) = Ary1' (f x) foldMapAry1'RS :: Monoid m => (a -> m) -> Ary1' a -> m foldMapAry1'RS f (Ary1' x) = f x foldrAry1'RS :: (a -> b -> b) -> b -> Ary1' a -> b foldrAry1'RS f b (Ary1' x) = f x b traverseAry1'RS :: Applicative f => (a -> f b) -> Ary1' a -> f (Ary1' b) traverseAry1'RS f (Ary1' x) = Ary1' <$> f x sequenceAAry1'RS :: Applicative f => Ary1' (f a) -> f (Ary1' a) sequenceAAry1'RS (Ary1' x) = Ary1' <$> x mk_eq ''Ary1' [| \ ~(Ary1' x1) ~(Ary1' y1) -> x1 == y1 |] inspect $ 'eqAry1'RS ==- 'eqAry1'S inspect $ 'eqAry1'R ==- 'eqAry1'G mk_compare ''Ary1' [| \ ~(Ary1' x1) ~(Ary1' y1) -> compare x1 y1 |] inspect $ 'compareAry1'RS ==- 'compareAry1'S inspect $ 'compareAry1'R ==- 'compareAry1'G mk_fmap ''Ary1' [| \ f ~(Ary1' x) -> Ary1' (f x) |] inspect $ 'fmapAry1'RS ==- 'fmapAry1'S inspect $ 'fmapAry1'R ==- 'fmapAry1'G mk_foldMap ''Ary1' [| \ f ~(Ary1' x) -> f x |] inspect $ 'foldMapAry1'RS ==- 'foldMapAry1'S inspect $ 'foldMapAry1'R ==- 'foldMapAry1'G mk_foldr ''Ary1' [| \ f r ~(Ary1' x) -> f x r |] inspect $ 'foldrAry1'RS ==- 'foldrAry1'S inspect $ 'foldrAry1'R ==- 'foldrAry1'G -- TODO: These tests fail because of a difference in how the Functor -- dictionary is accessed via the Applicative dictionary. -- The rest looks alright. #if __GLASGOW_HASKELL__ >= 810 mk_traverse ''Ary1' [| \ f ~(Ary1' x) -> Ary1' <$> f x |] inspect $ 'traverseAry1'RS ==- 'traverseAry1'S inspect $ 'traverseAry1'R ==- 'traverseAry1'G mk_sequenceA ''Ary1' [| \ ~(Ary1' x) -> Ary1' <$> x |] inspect $ 'sequenceAAry1'RS ==- 'sequenceAAry1'S inspect $ 'sequenceAAry1'R ==- 'sequenceAAry1'G #endif -- Generic @to@ seems to be lazy here mk_ap ''Ary1' [| \ ~(Ary1' f1) ~(Ary1' x1) -> Ary1' (f1 x1) |] inspect $ 'apAry1'R ==- 'apAry1'G mk_liftA2 ''Ary1' [| \ f ~(Ary1' x1) ~(Ary1' x2) -> Ary1' (f x1 x2) |] inspect $ 'liftA2Ary1'R ==- 'liftA2Ary1'G -- Ary1NT eqAry1NTRS :: Eq a => Ary1NT a -> Ary1NT a -> Bool eqAry1NTRS = (coerce :: (a -> a -> Bool) -> Ary1NT a -> Ary1NT a -> Bool) (==) compareAry1NTRS :: Ord a => Ary1NT a -> Ary1NT a -> Ordering compareAry1NTRS = (coerce :: (a -> a -> Ordering) -> Ary1NT a -> Ary1NT a -> Ordering) compare mk_eq ''Ary1NT [| \ (Ary1NT x1) (Ary1NT y1) -> x1 == y1 |] inspect $ 'eqAry1NTRS ==- 'eqAry1NTS inspect $ 'eqAry1NTR ==- 'eqAry1NTG mk_compare ''Ary1NT [| \ (Ary1NT x1) (Ary1NT y1) -> compare x1 y1 |] inspect $ 'compareAry1NTRS ==- 'compareAry1NTS inspect $ 'compareAry1NTR ==- 'compareAry1NTG mk_fmap ''Ary1NT [| \ f (Ary1NT x) -> Ary1NT (f x) |] inspect $ 'fmapAry1NTR ==- 'fmapAry1NTS inspect $ 'fmapAry1NTR ==- 'fmapAry1NTG mk_foldMap ''Ary1NT [| \ f (Ary1NT x) -> f x |] inspect $ 'foldMapAry1NTR ==- 'foldMapAry1NTS inspect $ 'foldMapAry1NTR ==- 'foldMapAry1NTG mk_foldr ''Ary1NT [| \ f r (Ary1NT x) -> f x r |] inspect $ 'foldrAry1NTR ==- 'foldrAry1NTS inspect $ 'foldrAry1NTR ==- 'foldrAry1NTG mk_traverse ''Ary1NT [| \ f (Ary1NT x) -> fmap Ary1NT (f x) |] inspect $ 'traverseAry1NTR ==- 'traverseAry1NTS inspect $ 'traverseAry1NTR ==- 'traverseAry1NTG mk_ap ''Ary1NT [| \ (Ary1NT f1) (Ary1NT x1) -> Ary1NT (f1 x1) |] inspect $ 'apAry1NTR ==- 'apAry1NTG mk_liftA2 ''Ary1NT [| \ f (Ary1NT x1) (Ary1NT x2) -> Ary1NT (f x1 x2) |] inspect $ 'liftA2Ary1NTR ==- 'liftA2Ary1NTG -- Ary2 mk_eq ''Ary2 [| \ (Ary2 x1 x2) (Ary2 y1 y2) -> x1 == y1 && x2 == y2 |] inspect $ 'eqAry2R ==- 'eqAry2S inspect $ 'eqAry2R ==- 'eqAry2G mk_compare ''Ary2 [| \ (Ary2 x1 x2) (Ary2 y1 y2) -> compare x1 y1 <> compare x2 y2 |] inspect $ 'compareAry2R ==- 'compareAry2S inspect $ 'compareAry2R ==- 'compareAry2G mk_fmap ''Ary2 [| \ f (Ary2 x y) -> Ary2 (f x) (f y) |] inspect $ 'fmapAry2R ==- 'fmapAry2S inspect $ 'fmapAry2R ==- 'fmapAry2G mk_foldMap ''Ary2 [| \ f (Ary2 x y) -> f x `mappend` f y |] inspect $ 'foldMapAry2R ==- 'foldMapAry2S inspect $ 'foldMapAry2R ==- 'foldMapAry2G mk_foldr ''Ary2 [| \ f r (Ary2 x y) -> f x (f y r) |] inspect $ 'foldrAry2R ==- 'foldrAry2S inspect $ 'foldrAry2R ==- 'foldrAry2G mk_traverse ''Ary2 [| \ f (Ary2 x y) -> liftA2 Ary2 (f x) (f y) |] inspect $ 'traverseAry2R ==- 'traverseAry2S inspect $ 'traverseAry2R ==- 'traverseAry2G mk_sequenceA ''Ary2 [| \ (Ary2 x y) -> liftA2 Ary2 x y |] inspect $ 'sequenceAAry2R ==- 'sequenceAAry2S inspect $ 'sequenceAAry2R ==- 'sequenceAAry2G mk_ap ''Ary2 [| \ (Ary2 f1 f2) (Ary2 x1 x2) -> Ary2 (f1 x1) (f2 x2) |] inspect $ 'apAry2R ==- 'apAry2G mk_liftA2 ''Ary2 [| \ f (Ary2 x1 y1) (Ary2 x2 y2) -> Ary2 (f x1 x2) (f y1 y2) |] inspect $ 'liftA2Ary2R ==- 'liftA2Ary2G -- Ary4 sequenceAAry4RS :: Applicative f => Ary4 (f a) -> f (Ary4 a) sequenceAAry4RS = traverse id -- The simplifier is good enough to reassociate (&&) mk_eq ''Ary4 [| \ (Ary4 x1 x2 x3 x4) (Ary4 y1 y2 y3 y4) -> x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4 |] inspect $ 'eqAry4R ==- 'eqAry4S inspect $ 'eqAry4R ==- 'eqAry4G -- The simplifier is good enough to reassociate (<>) mk_compare ''Ary4 [| \ (Ary4 x1 x2 x3 x4) (Ary4 y1 y2 y3 y4) -> compare x1 y1 <> compare x2 y2 <> compare x3 y3 <> compare x4 y4 |] inspect $ 'compareAry4R ==- 'compareAry4S inspect $ 'compareAry4R ==- 'compareAry4G mk_fmap ''Ary4 [| \ f (Ary4 x y z t) -> Ary4 (f x) (f y) z (fmap f t) |] inspect $ 'fmapAry4R ==- 'fmapAry4S inspect $ 'fmapAry4R ==- 'fmapAry4G mk_foldMap ''Ary4 [| \ f (Ary4 x y _ z) -> f x `mappend` (f y `mappend` foldMap f z) |] inspect $ 'foldMapAry4R ==- 'foldMapAry4S inspect $ 'foldMapAry4R ==- 'foldMapAry4G mk_foldr ''Ary4 [| \ f r (Ary4 x y _ t) -> f x (f y (foldr f r t)) |] inspect $ 'foldrAry4R ==- 'foldrAry4S inspect $ 'foldrAry4R ==- 'foldrAry4G mk_traverse ''Ary4 [| \ f (Ary4 x y z t) -> liftA2 (\x' y' -> Ary4 x' y' z) (f x) (f y) <*> traverse f t |] inspect $ 'traverseAry4R ==- 'traverseAry4S inspect $ 'traverseAry4R ==- 'traverseAry4G mk_sequenceA ''Ary4 [| \ (Ary4 x y z t) -> liftA2 (\x' y' -> Ary4 x' y' z) x y <*> sequenceA t |] inspect $ 'sequenceAAry4RS ==- 'sequenceAAry4S inspect $ 'sequenceAAry4R ==- 'sequenceAAry4G mk_ap ''Ary4 [| \ (Ary4 f1 f2 fz f3) (Ary4 x1 x2 xz x3) -> Ary4 (f1 x1) (f2 x2) (fz <> xz) (f3 <*> x3) |] inspect $ 'apAry4R ==- 'apAry4G mk_liftA2 ''Ary4 [| \ f (Ary4 x1 y1 fz z1) (Ary4 x2 y2 xz z2) -> Ary4 (f x1 x2) (f y1 y2) (fz <> xz) (liftA2 f z1 z2) |] inspect $ 'liftA2Ary4R ==- 'liftA2Ary4G -- Big -- The simplifier is good enough to reassociate (&&) mk_eq ''Big [| \ x y -> case (x, y) of (Big0, Big0) -> True (Big1 x1, Big1 y1) -> x1 == y1 (Big2 x1 x2, Big2 y1 y2) -> x1 == y1 && x2 == y2 (Big4 x1 x2 x3 x4, Big4 y1 y2 y3 y4) -> x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4 (Big8 x1 x2 x3 x4 x5 x6 x7 x8, Big8 y1 y2 y3 y4 y5 y6 y7 y8) -> x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4 && x5 == y5 && x6 == y6 && x7 == y7 && x8 == y8 (_, _) -> False |] inspect $ 'eqBigR === 'eqBigS inspect $ 'eqBigR =/= 'eqBigG -- TODO make this test pass {- TODO Update the rest, after figuring out the above test case -- The simplifier is good enough to reassociate (<>) mk_compare ''Big [| \ (Big4 x1 x2 x3 x4) (Big4 y1 y2 y3 y4) -> compare x1 y1 <> compare x2 y2 <> compare x3 y3 <> compare x4 y4 |] inspect $ 'compareBigR === 'compareBigS inspect $ 'compareBigR === 'compareBigG mk_fmap ''Big [| \ f (Big4 x y z t) -> Big (f x) (f y) z (fmap f t) |] inspect $ 'fmapBigR ==- 'fmapBigS inspect $ 'fmapBigR ==- 'fmapBigG mk_foldMap ''Big [| \ f (Big4 x y _ z) -> f x `mappend` (f y `mappend` foldMap f z) |] inspect $ 'foldMapBigR ==- 'foldMapBigS inspect $ 'foldMapBigR ==- 'foldMapBigG mk_foldr ''Big [| \ f r (Big4 x y _ t) -> f x (f y (foldr f r t)) |] inspect $ 'foldrBigR ==- 'foldrBigS inspect $ 'foldrBigR ==- 'foldrBigG mk_traverse ''Big [| \ f (Big4 x y z t) -> liftA2 (\x' y' -> Big x' y' z) (f x) (f y) <*> (traverse f t) |] inspect $ 'traverseBigR ==- 'traverseBigS inspect $ 'traverseBigR ==- 'traverseBigG mk_sequenceA ''Big [| \ (Big4 x y z t) -> liftA2 (\x' y' -> Big x' y' z) x y <*> sequenceA t |] inspect $ 'sequenceABigRS ==- 'sequenceABigS inspect $ 'sequenceABigR ==- 'sequenceABigG mk_ap ''Big [| \ (Big4 f1 f2 fz f3) (Big4 x1 x2 xz x3) -> Big (f1 x1) (f2 x2) (fz <> xz) (f3 <*> x3) |] inspect $ 'apBigR ==- 'apBigG mk_liftA2 ''Big [| \ f (Big4 x1 y1 fz z1) (Big4 x2 y2 xz z2) -> Big (f x1 x2) (f y1 y2) (fz <> xz) (liftA2 f z1 z2) |] inspect $ 'liftA2BigR ==- 'liftA2BigG -} -- dummy main :: IO () main = pure () generic-data-1.1.0.0/test/lens-surgery.hs0000644000000000000000000000142007346545000016332 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications, TypeOperators #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} import Data.Coerce (coerce) import Data.Functor.Identity (Identity(..)) import Test.Tasty import Test.Tasty.HUnit import Data.Generics.Product (field_) import Generic.Data (Generic, gshowsPrec, Opaque(Opaque)) import Generic.Data.Microsurgery (onData, toData) data T = R { f :: Int -> Int } deriving Generic instance Show T where showsPrec n = gshowsPrec n . onData (field_ @"f" %~ Opaque) . toData (%~) :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t (%~) = coerce main :: IO () main = defaultMain test test :: TestTree test = testGroup "lens-surgery" [ testCase "update" $ "R {f = _}" @?= show (R id) ] generic-data-1.1.0.0/test/microsurgery.hs0000644000000000000000000000542507346545000016436 0ustar0000000000000000{-# LANGUAGE CPP, DeriveGeneric, DataKinds, TypeApplications #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE DerivingVia, ExplicitNamespaces, TypeOperators #-} #endif -- @DataKinds@ and @TypeApplications@ for @renameFields@ and @renameConstrs@ import Test.Tasty import Test.Tasty.HUnit import Generic.Data (Generic, gshowsPrec) import Generic.Data.Microsurgery ( toData , derecordify, typeage, renameFields, renameConstrs , SConst, SError, SRename ) #if __GLASGOW_HASKELL__ >= 806 -- DerivingVia test -- Constructors must be visible for Coercible import Data.Monoid (Sum(..), Product(..)) import Generic.Data (Opaque(..)) import Generic.Data.Microsurgery ( Surgery, Surgeries, ProductSurgery, ProductSurgeries, Surgery'(..), Generically(..), GenericProduct(..) , Derecordify, OnFields, CopyRep , type (%~) ) #endif -- From https://stackoverflow.com/questions/53864911/derive-positional-show newtype T = T { _unT :: Int } deriving Generic instance Show T where showsPrec n = gshowsPrec n . derecordify . toData newtype U = U { _unU :: Int } deriving Generic instance Show U where showsPrec n = gshowsPrec n . renameFields @(SRename '[ '("_unU", "unV")] SError) . renameConstrs @(SConst "V") . typeage -- doesn't change anything, just a sanity check. . toData #if __GLASGOW_HASKELL__ >= 806 data V = V { v1 :: Int, v2 :: Int } deriving Generic deriving Show via (Surgery Derecordify V) deriving (Semigroup, Monoid) via (ProductSurgery (OnFields Sum) V) data Polar a = Exp { modulus :: a, argument :: a } 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 () main = defaultMain test test :: TestTree test = testGroup "microsurgery" [ testCase "Show T" $ "T 3" @?= show (T 3) , testCase "Show U" $ "V {unV = 3}" @?= show (U 3) #if __GLASGOW_HASKELL__ >= 806 , testCase "Show V" $ "V 3 4" @?= show (V 3 4) , 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 ] generic-data-1.1.0.0/test/one-liner-surgery.hs0000644000000000000000000000730707346545000017273 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveGeneric, FlexibleInstances, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -- Example using one-liner and generic-lens -- on a synthetic type obtained by surgery. 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 import Test.Tasty.HUnit import Data.Generics.Product (field_) -- generic-lens import Generics.OneLiner (nullaryOp, binaryOp) -- one-liner import Generics.OneLiner.Binary (gtraverse) import Generic.Data.Microsurgery (DOnFields) -- | Toy configuration record type. data Config = C { a :: Int, b :: Int, c :: String } deriving (Eq, Generic, Show) -- | Applying the 'DOnFields' surgery to get a type isomorphic to: -- -- > data Config = C { -- > a :: Maybe Int, -- > b :: Maybe Int, -- > c :: Maybe String -- > } -- -- See also "Functor functors" and "Higher-kinded data" for a more general pattern: -- -- - https://www.benjamin.pizza/posts/2017-12-15-functor-functors.html -- - https://reasonablypolymorphic.com/blog/higher-kinded-data/ -- type PartialConfig = DOnFields Maybe Config -- | Example file1 :: [String] file1 = [ "a=11", "b=33" ] -- | Example file2 :: [String] file2 = [ "b=2", "c=Hello" ] -- | Helper for 'emptyOM' and 'mergeOM' below. class (a ~ Maybe (UnMaybe a)) => IsMaybe a instance (a ~ Maybe (UnMaybe a)) => IsMaybe a -- | Helper for 'IsMaybe' above. type family UnMaybe (a :: Type) :: Type where UnMaybe (Maybe b) = b -- | -- > emptyOM = C { -- > a = Nothing, -- > b = Nothing, -- > c = Nothing -- > } emptyOM :: PartialConfig emptyOM = nullaryOp @IsMaybe Nothing -- | Helper for 'parseOM' (actually a function from lens). -- -- @(l .~ b) s@: set the field of record @s@ focused by lens @l@ to @b@. -- -- > let f = (field_ @"a" .~ v) in -- > f (C {a = x, b = y, c = z}) -- > -- > -- equals -- -- > -- > C {a = v, b = y, c = z} -- (.~) :: forall s t a b. ((a -> Identity b) -> s -> Identity t) -> b -> s -> t (.~) l b = coerce l (const b :: a -> b) -- | Parse lines of a config file. parseOM :: [String] -> PartialConfig parseOM = foldr ($) emptyOM . map (\case 'a' : '=' : n -> field_ @"a" .~ readMaybe n 'b' : '=' : n -> field_ @"b" .~ readMaybe n 'c' : '=' : s -> field_ @"c" .~ Just s _ -> id) -- | Merge two records of 'Maybe' fields, keeping the leftmost 'Just' for each -- field. mergeOM :: PartialConfig -> PartialConfig -> PartialConfig mergeOM = binaryOp @IsMaybe (<|>) -- | Example parsedOpts12 :: PartialConfig parsedOpts12 = parseOM file1 `mergeOM` parseOM file2 -- | Helper for 'validateOM' below. class (a ~ Maybe b) => FstIsMaybe a b instance (a ~ Maybe b) => FstIsMaybe a b -- | Check that all fields are populated with 'Just' and create a plain -- 'Config' record. If any field is 'Nothing', returns 'Nothing'. validateOM :: PartialConfig -> Maybe Config validateOM = gtraverse @FstIsMaybe id -- | Example opts12 :: Maybe Config opts12 = validateOM parsedOpts12 main :: IO () main = defaultMain test test :: TestTree test = testGroup "one-liner-surgery" [ testCase "opts1" $ "C {a = Just 11, b = Just 33, c = Nothing}" @=? show (parseOM file1) , testCase "opts2" $ "C {a = Nothing, b = Just 2, c = Just \"Hello\"}" @=? show (parseOM file2) , testCase "opts12" $ Just C {a = 11, b = 33, c = "Hello"} @=? opts12 , testCase "opts1-incomplete" $ Nothing @=? validateOM (parseOM file1) , testCase "empty" $ "C {a = Nothing, b = Nothing, c = Nothing}" @=? show emptyOM ] generic-data-1.1.0.0/test/record.hs0000644000000000000000000000235107346545000015155 0ustar0000000000000000-- Deriving instances for a "functor-functor"-style record. -- (https://www.benjamin.pizza/posts/2017-12-15-functor-functors.html) {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} import Control.Applicative (Alternative) import Data.Coerce import Data.Functor.Classes import Data.Semigroup import Data.Monoid (Alt(..)) import Text.Read import Generic.Data import Generic.Data.Orphans () data MyRecord f = MyRecord { _field1 :: f Int , _field2 :: f Bool } deriving Generic instance Read1 f => Read (MyRecord f) where readPrec = coerce (greadPrec @(MyRecord (Id1 f))) readListPrec = readListPrecDefault instance Show1 f => Show (MyRecord f) where showsPrec = coerce (gshowsPrec @(MyRecord (Id1 f))) instance Eq1 f => Eq (MyRecord f) where (==) = coerce (geq @(MyRecord (Id1 f))) instance Ord1 f => Ord (MyRecord f) where compare = coerce (gcompare @(MyRecord (Id1 f))) instance Alternative f => Semigroup (MyRecord f) where (<>) = coerce (gmappend @(MyRecord (Alt f))) instance Alternative f => Monoid (MyRecord f) where mempty = coerce (gmempty @(MyRecord (Alt f))) mappend = (<>) main :: IO () main = return () -- Just make this compile generic-data-1.1.0.0/test/unit.hs0000644000000000000000000002115507346545000014661 0ustar0000000000000000{-# LANGUAGE CPP, DataKinds, DeriveGeneric, TypeApplications #-} import Control.Applicative import Data.Ix import Data.Semigroup import Data.Monoid (Sum(..)) import Data.Functor.Classes import Test.Tasty import Test.Tasty.HUnit import Text.Read import GHC.Generics (Fixity(Prefix)) import Generic.Data import Generic.Data.Orphans () data P a = P a a deriving (Generic, Generic1) instance Semigroup a => Semigroup (P a) where x <> y = case Generically x <> Generically y of Generically z -> z type PTy a = a -> a -> Generically (P a) p :: PTy a p a b = Generically (P a b) p' :: PTy Int p' = p pl :: PTy [Int] pl = p data P1 f a = P1 (f a) (f a) deriving Generic1 type PTy1 a = [a] -> [a] -> Generically1 (P1 []) a p1 :: PTy1 a p1 a b = Generically1 (P1 a b) p1' :: PTy1 Int p1' = p1 pl1 :: PTy1 [Int] pl1 = p1 data E = E0 | E1 | E2 | E3 deriving (Eq, Ord, Show, Generic, Ix) data FiniteE = SE0 Bool Bool | SE1 Bool deriving (Eq, Ord, Show, Generic) data TupleE = T E E deriving (Eq, Ord, Show, Generic) data Unit = Unit deriving (Eq, Ord, Show, Generic) e0, e1, eLast :: FiniteE e0 = allEs !! 0 e1 = allEs !! 1 eLast = last allEs allEs :: [FiniteE] allEs = [ SE0 False False , SE0 False True , SE0 True False , SE0 True True , SE1 False , SE1 True ] -- Deriving Show1 newtype MyCompose f g a = MyCompose (f (g a)) deriving Generic1 instance (Functor f, Eq1 f, Eq1 g) => Eq1 (MyCompose f g) where liftEq = gliftEq instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (MyCompose f g a) where (==) = eq1 instance (Functor f, Read1 f, Read1 g) => Read1 (MyCompose f g) where #if MIN_VERSION_base(4,10,0) liftReadPrec = gliftReadPrec liftReadListPrec = liftReadListPrecDefault #else liftReadsPrec rp rl = readPrec_to_S $ gliftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl)) #endif instance (Functor f, Read1 f, Read1 g, Read a) => Read (MyCompose f g a) where #if MIN_VERSION_base(4,10,0) readPrec = readPrec1 readListPrec = readListPrecDefault #else readsPrec = readsPrec1 #endif instance (Functor f, Show1 f, Show1 g) => Show1 (MyCompose f g) where liftShowsPrec = gliftShowsPrec instance (Functor f, Show1 f, Show1 g, Show a) => Show (MyCompose f g a) where showsPrec = showsPrec1 -- Regression tests for T30 data T30a = MkT30a { (##) :: () } deriving Generic data T30b = (:!:) () () | () `MkT30b` () deriving Generic instance Eq T30a where (==) = geq instance Read T30a where readPrec = greadPrec readListPrec = readListPrecDefault instance Show T30a where showsPrec = gshowsPrec instance Eq T30b where (==) = geq instance Read T30b where readPrec = greadPrec readListPrec = readListPrecDefault instance Show T30b where showsPrec = gshowsPrec maybeModuleName :: String #if MIN_VERSION_base(4,12,0) maybeModuleName = "GHC.Maybe" #else maybeModuleName = "GHC.Base" #endif main :: IO () main = defaultMain test test :: TestTree test = testGroup "unit" [ testGroup "Eq" [ testCase "(==)" $ p' 1 2 @=? p' 1 2 , testCase "(/=)" $ False @=? (p' 1 2 == p' 1 1) ] , testGroup "Ord" [ testCase "compare" $ LT @=? compare (p' 1 2) (p' 2 1) , testCase "(<=)" $ True @=? (p' 1 1 <= p' 1 1) ] , testGroup "Semigroup" [ testCase "(<>)" $ pl [1, 5] [2, 3] @=? (pl [1] [2] <> pl [5] [3]) ] , testGroup "Monoid" [ testCase "mempty" $ pl [] [] @=? mempty ] , testGroup "Functor" [ testCase "fmap" $ p1' [1] [2] @=? fmap (+ 1) (p1 [0] [1]) ] , testGroup "Applicative" [ testCase "pure" $ p1' [3] [3] @=? pure 3 , testCase "ap" $ p1' [1, 3] [2] @=? (p1 [id, (+2)] [(+2)] <*> p1 [1] [0]) ] , testGroup "Alternative" [ testCase "empty" $ p1' [] [] @=? empty , testCase "(<|>)" $ p1' [1, 5] [2, 3] @=? (p1 [1] [2] <|> p1 [5] [3]) ] , testGroup "Foldable" [ testCase "foldMap" $ Sum 3 @=? foldMap Sum (p1' [1] [2]) , testCase "foldr" $ 3 @=? foldr (+) 0 (p1' [1] [2]) ] , testGroup "Traversable" [ testCase "traverse" $ [p1 [1] [2], p1 [1] [3], p1 [2] [2], p1 [2] [3]] @=? traverse (\y -> [y, y+1]) (p1' [1] [2]) , testCase "sequenceA" $ [p1 [1] [2], p1 [2] [2]] @=? sequenceA (pl1 [[1, 2]] [[2]]) ] , testGroup "Bounded" [ testCase "minBound @E" $ E0 @=? gminBound , testCase "maxBound @E" $ E3 @=? gmaxBound , testCase "minBound @(P Int)" $ p' minBound minBound @=? gminBound , testCase "maxBound @(P Int)" $ p' maxBound maxBound @=? gmaxBound ] , testGroup "Enum" [ testGroup "StandardEnum" [ testCase "toEnum" $ [E0, E1, E2, E3] @=? fmap gtoEnum [0, 1, 2, 3] , testCase "fromEnum" $ [0, 1, 2, 3] @=? fmap gfromEnum [E0, E1, E2, E3] , testCase "enumFrom" $ [E0, E1, E2, E3] @=? genumFrom E0 , testCase "enumFromThen" $ [E0, E1, E2, E3] @=? genumFromThen E0 E1 , testCase "enumFromTo" $ [E0, E1, E2, E3] @=? genumFromTo E0 E3 , testCase "enumFromThenTo" $ [E0, E1, E2, E3] @=? genumFromThenTo E0 E1 E3 ] , testGroup "FiniteEnum" [ testCase "toEnum" $ allEs @=? fmap gtoFiniteEnum [0 .. 5] , testCase "fromEnum" $ [0 .. 5] @=? fmap gfromFiniteEnum allEs , testCase "enumFrom" $ allEs @=? gfiniteEnumFrom e0 , testCase "enumFromThen" $ allEs @=? gfiniteEnumFromThen e0 e1 , testCase "enumFromTo" $ allEs @=? gfiniteEnumFromTo e0 eLast , testCase "enumFromThenTo" $ allEs @=? gfiniteEnumFromThenTo e0 e1 eLast ] ] , testGroup "Ix" [ testGroup "only nullary constructors" [ testCase "range" $ [E0, E1, E2] @=? grange (E0, E2) , testCase "index" $ 1 @=? gindex (E1, E3) E2 , testCase "inRange (within)" $ True @=? ginRange (E1, E3) E2 , testCase "inRange (outside)" $ False @=? ginRange (E1, E3) E0 ] , testGroup "single constructor" [ testCase "range" $ [T E1 E2, T E1 E3, T E2 E2, T E2 E3] @=? grange (T E1 E2, T E2 E3) , testCase "index" $ 2 @=? gindex (T E1 E2, T E2 E3) (T E2 E2) , testCase "inRange (within)" $ True @=? ginRange (T E1 E2, T E2 E3) (T E1 E3) , testCase "inRange (outside)" $ False @=? ginRange (T E1 E2, T E2 E3) (T E2 E1) ] , testCase "single nullary constructor" $ 0 @=? gindex (Unit, Unit) Unit ] , testGroup "Read" [ testCase "read" $ p' 1 2 @=? read "(P 1 2)" , testGroup "T30" [ testCase "MkT30a" $ MkT30a {(##) = ()} @=? read "(MkT30a {(##) = ()})" , testCase "(:!:)" $ (:!:) () () @=? read "(:!:) () ()" , testCase "MkT30b" $ (() `MkT30b` ()) @=? read "() `MkT30b` ()" ] ] , testGroup "Show" [ testCase "show" $ "P 1 2" @=? show (p' 1 2) , testCase "showsPrec" $ "(P 1 2)" @=? showsPrec 11 (p' 1 2) "" , testGroup "T30" [ testCase "MkT30a" $ "(MkT30a {(##) = ()})" @=? showsPrec 11 (MkT30a {(##) = ()}) "" , testCase "(:!:)" $ "(:!:) () ()" @=? show ((:!:) () ()) , testCase "MkT30b" $ "() `MkT30b` ()" @=? show (() `MkT30b` ()) ] ] , testGroup "Read1" [ testCase "read1" $ MyCompose (Just [()]) @?= read "(MyCompose (Just [()]))" ] , testGroup "Show1" [ testCase "show1" $ "MyCompose (Just [()])" @?= show (MyCompose (Just [()])) ] , testGroup "Meta" [ testCase "datatypeName" $ "Maybe" @=? gdatatypeName @(Maybe Int) , testCase "moduleName" $ maybeModuleName @=? gmoduleName @(Maybe Int) , testCase "packageName" $ "base" @=? gpackageName @(Maybe Int) , testCase "isNewtype" $ False @=? gisNewtype @(Maybe Int) , testCase "conName" $ "Just" @=? gconName (Just ()) , testCase "conFixity" $ Prefix @=? gconFixity (Just ()) , testCase "conIsRecord" $ False @=? gconIsRecord (Just ()) , testCase "conNum" $ 2 @=? gconNum @(Maybe Int) ] , testGroup "ConId" [ testCase "conIdEnum" $ [conId Nothing, conId (Just ())] @?= conIdEnum @(Maybe ()) , testCase "conIdMin" $ conId (Nothing :: Maybe ()) @?= conIdMin , testCase "conIdMax" $ conId (Just ()) @?= conIdMax ] , let i = conId (Nothing :: Maybe ()) in testGroup "ConId (Nothing)" [ testCase "conId" $ "ConId 0" @?= show i , testCase "conIdToInt" $ 0 @?= conIdToInt i , testCase "conIdToString" $ "Nothing" @?= conIdToString i , testCase "conIdNamed" $ i @?= conIdNamed @"Nothing" ] , let i = conId (Just ()) in testGroup "ConId (Just)" [ testCase "conId" $ "ConId 1" @?= show i , testCase "conIdToInt" $ 1 @?= conIdToInt i , testCase "conIdToString" $ "Just" @?= conIdToString i , testCase "conIdNamed" $ i @?= conIdNamed @"Just" ] ]