generic-deriving 1.14.4 → 1.14.5
raw patch · 35 files changed
+13574/−13263 lines, 35 filesdep ~basedep ~containersdep ~template-haskellsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers, template-haskell, th-abstraction
API changes (from Hackage documentation)
Files
- CHANGELOG.md +228/−220
- LICENSE +28/−28
- README.md +86/−86
- Setup.hs +6/−6
- generic-deriving.cabal +162/−159
- src/Generics/Deriving.hs +24/−24
- src/Generics/Deriving/Base.hs +12/−12
- src/Generics/Deriving/Base/Internal.hs +1136/−1136
- src/Generics/Deriving/ConNames.hs +72/−72
- src/Generics/Deriving/Copoint.hs +179/−179
- src/Generics/Deriving/Default.hs +281/−281
- src/Generics/Deriving/Enum.hs +1143/−1144
- src/Generics/Deriving/Eq.hs +626/−626
- src/Generics/Deriving/Foldable.hs +326/−326
- src/Generics/Deriving/Functor.hs +242/−242
- src/Generics/Deriving/Instances.hs +3585/−3585
- src/Generics/Deriving/Monoid.hs +27/−27
- src/Generics/Deriving/Monoid/Internal.hs +276/−276
- src/Generics/Deriving/Semigroup.hs +20/−20
- src/Generics/Deriving/Semigroup/Internal.hs +215/−215
- src/Generics/Deriving/Show.hs +666/−666
- src/Generics/Deriving/TH.hs +1228/−1227
- src/Generics/Deriving/TH/Internal.hs +1251/−951
- src/Generics/Deriving/TH/Post4_9.hs +137/−137
- src/Generics/Deriving/TH/Pre4_9.hs +241/−241
- src/Generics/Deriving/Traversable.hs +244/−244
- src/Generics/Deriving/Uniplate.hs +392/−392
- tests/DefaultSpec.hs +161/−161
- tests/EmptyCaseSpec.hs +27/−27
- tests/ExampleSpec.hs +421/−421
- tests/Spec.hs +1/−1
- tests/T68Spec.hs +23/−23
- tests/T80Spec.hs +22/−22
- tests/T82Spec.hs +29/−29
- tests/TypeInTypeSpec.hs +57/−57
CHANGELOG.md view
@@ -1,220 +1,228 @@-# 1.14.4 [2023.04.30] -* Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined, - such as the WASM backend. -* Place `INLINE [1]` pragmas on `from` and `to` implementations when types - don't have too many constructors or fields, following the heuristics that GHC - 9.2+ uses for `Generic` deriving. - -# 1.14.3 [2023.02.27] -* Support `th-abstraction-0.5.*`. - -# 1.14.2 [2022.07.23] -* Fix a bug in which `deriveAll1` could generate ill kinded code when using - `kindSigOptions=False`, or when using GHC 8.0 or earlier. -* Fix a bug in which `deriveAll1` would reject data types whose last type - variable has a kind besides `Type` or `k` on GHC 8.2 or later. - -# 1.14.1 [2021.08.30] -* Backport the `Generic(1)` instances introduced for tuples (8 through 15) in - `base-4.16`. -* Make the test suite compile on GHC 9.2 or later. -* Always import `Data.List` qualified to fix the build with recent GHCs. - -# 1.14 [2020.09.30] -* Remove instances for `Data.Semigroup.Option`, which is deprecated as of - `base-4.15.0.0`. -* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). -* Fix a bug in which `deriveAll1` would needlessly reject data types whose last - type parameter appears as an oversaturated argument to a type family. - -# 1.13.1 [2019.11.26] -* Backport the `Generic(1)` instances for `Kleisli` introduced in `base-4.14`. - -# 1.13 [2019.08.27] -* Make `GSemigroup` a superclass of `GMonoid`. Similarly, make - `GSemigroup'` a superclass of `GMonoid'`. -* In the instance `GMonoid (Maybe a)`, relax the constraint on `a` from - `GMonoid` to `GSemigroup`. - -# 1.12.4 [2019.04.26] -* Support `th-abstraction-0.3.0.0` or later. - -# 1.12.3 [2019.02.09] -* Support `template-haskell-2.15`. -* Add a `gshowList` method to `GShow`, which lets us avoid the need for - `OverlappingInstances` in `Generics.Deriving.TH`. As a consequence, the - `GShow String` instance has been removed, as it is now fully subsumed by - the `GShow [a]` instance (with which it previously overlapped). -* Functions in `Generics.Deriving.TH` now balance groups of `(:*:)` and `(:+:)` - as much as possible (`deriving Generic` was already performing this - optimization, and now `generic-deriving` does too). -* Add a `Generics.Deriving.Default` module demonstrating and explaining - how and why to use `DerivingVia`. There is also a test suite with - further examples. - -# 1.12.2 [2018.06.28] -* Backport the `Generic(1)` instances for `Data.Ord.Down`, introduced in - `base-4.12`. Add `GEq`, `GShow`, `GSemigroup`, `GMonoid`, `GFunctor`, - `GFoldable`, `GTraversable`, and `GCopoint` instances for `Down`. -* Refactor internals using `th-abstraction`. -* Adapt to `Maybe` moving to `GHC.Maybe` in GHC 8.6. - -# 1.12.1 [2018.01.11] -* Remove a test that won't work on GHC 8.4. - -# 1.12 [2017.12.07] -* Adapt to the `EmptyDataDeriving` proposal (introduced in GHC 8.4): - * `Generics.Deriving.TH` now derives `to(1)` and `from(1)` implementations - for empty data types that are strict in the argument. - * Introduce an `EmptyCaseOptions` field to `Options` in - `Generics.Deriving.TH`, which controls whether generated `from(1)`/`to(1)` - implementations for empty data types should use the `EmptyCase` extension - or not (as is the case in GHC 8.4). - * Add `mkFrom0Options`, `mkFrom1Options`, `mkTo0Options`, and `mkTo1Options` - functions to `Generics.Deriving.TH`, which take `EmptyCaseOptions` as - arguments. - * The backported instances for `V1` are now maximally lazy, as per - `EmptyDataDeriving`. (Previously, some instances would unnecessarily force - their argument, such as the `Eq` and `Ord` instances.) - * Add instances for `V1` in `Generics.Deriving.Copoint`, `.Eq`, `.Foldable`, - `.Functor`, `.Show`, and `.Traversable`. -* Remove the bitrotting `simplInstance` function from `Generics.Deriving.TH`. - -# 1.11.2 [2017.04.10] -* Add `GEq`, `GShow`, `GEnum`, and `GIx` instances for the new data types - in `Foreign.C.Types` (`CBool`) and `System.Posix.Types` (`CBlkSize`, - `CBlkCnt`, `CClockId`, `CFsBlkCnt`, `CFsFilCnt`, `CId`, `CKey`, and `CTimer`) - introduced in `base-4.10.0.0` - -# 1.11.1 [2016.09.10] -* Fix Template Haskell regression involving data families -* Convert examples to test suite -* Backport missing `Data` and `Typeable` instances for `Rec1`, `M1`, `(:*:)`, - `(:+:)`, and `(:.:)` - -# 1.11 -* The behavior of functions in `Generics.Deriving.TH` have changed with respect - to when type synonyms are generated for `Rep(1)` definitions. In particular: - - * By default, `deriveRepresentable(1)` will no longer define its `Rep(1)` - type family instance in terms of the type synonym that has to be generated - with `deriveRep(1)`. Similarly, `deriveAll(1)` and `deriveAll0And1` will no - longer generate a type synonym. Instead, they will generate `Generic(1)` - instances that directly define the `Rep(1)` instance inline. If you wish - to revert to the old behavior, you will need to use the variants of those - functions suffixed with `-Options`. - * New functions `makeRep0Inline` and `makeRep1Inline` have been added which, - for most purposes, should replace uses of `makeRep0`/`makeRep0FromType` - and `makeRep1`/`makeRep1FromType` (but see the next bullet point for a - caveat). - * The use of `deriveRep(1)`, `makeRep0`/`makeRep0FromType`, and - `makeRep1`/`makeRep1FromType` are now discouraged, but those functions are - still available. The reason is that on GHC 7.0/7.2/7.4, it is impossible to use - `makeRep0Inline`/`makeRep1Inline` due to a GHC bug. Therefore, you must use - `makeRep0`/`makeRep1` and `deriveRep(1)` on GHC 7.0/7.2/7.4 out of necessity. - - These changes make dealing with `Generic` instances that involve `PolyKinds` - and `TypeInType` much easier. -* All functions suffixed in `-WithKindSigs` in `Generics.Deriving.TH` have been - removed in favor of a more sensible `-Options` suffixing scheme. The ability to - toggle whether explicit kind signatures are used on type variable binders has - been folded into `KindSigOptions`, which is an explicit argument to - `deriveRep0Options`/`deriveRep1Options` and also a field in the more general - 'Options' data type. -* Furthermore, the behavior of derived instances' kind signatures has changed. - By default, the TH code will now _always_ use explicit kind signatures - whenever possible, regardless of whether you're working with plain data types - or data family instances. This makes working with `TypeInType` less - surprising, but at the cost of making it slightly more awkward to work with - derived `Generic1` instances that constrain kinds to `*` by means of `(:.:)`. -* Since `Generic1` is polykinded on GHC 8.2 and later, the functions in - `Generics.Deriving.TH` will no longer unify the kind of the last type - parameter to be `*`. -* Fix a bug in which `makeRep` (and similarly named functions) would not check - whether the argument type can actually have a well kinded `Generic(1)` - instance. -* Backport missing `Foldable` and `Traversable` instances for `Rec1` - -# 1.10.7 -* Renamed internal modules to avoid using apostrophes (averting this bug: - https://github.com/haskell/cabal/issues/3631) - -# 1.10.6 -* A new `base-4-9` Cabal flag was added to more easily facilitate installing - `generic-deriving` with manually installed versions of `template-haskell`. - -# 1.10.5 -* Apply an optimization to generated `to(1)`/`from(1)` instances that factors out - common occurrences of `M1`. See - http://git.haskell.org/ghc.git/commit/9649fc0ae45e006c2ed54cc5ea2414158949fadb -* Export internal typeclass names -* Fix Haddock issues with GHC 7.8 - -# 1.10.4.1 -* Fix Haddock parsing issue on GHC 8.0 - -# 1.10.4 -* Backported `MonadPlus` and `MonadZip` instances for `U1`, and made the - `Functor`, `Foldable`, `Traversable`, `Alternative`, and `Monad` instances - for `U1` lazier to correspond with `base-4.9` - -# 1.10.3 -* Backported `Enum`, `Bounded`, `Ix`, `Functor`, `Applicative`, `Monad`, - `MonadFix`, `MonadPlus`, `MonadZip`, `Foldable`, `Traversable`, and - `Data` instances (introduced in `base-4.9`) for datatypes in the - `Generics.Deriving.Base` module - -# 1.10.2 -* Fix TH regression on GHC 7.0 - -# 1.10.1 -* Added `Generics.Deriving.Semigroup` -* Added `GMonoid` instance for `Data.Monoid.Alt` -* Fixed a bug in the `GEnum` instances for unsigned `Integral` types -* Added `Safe`/`Trustworthy` pragmas -* Made instances polykinded where possible - -# 1.10.0 -* On GHC 8.0 and up, `Generics.Deriving.TH` uses the new type literal-based - machinery -* Rewrote the Template Haskell code to be robust. Among other things, this fixes - a bug with deriving Generic1 instances on GHC 7.8, and makes it easier to - derive Generic1 instances for datatypes that utilize GHC 8.0's `-XTypeInType` - extension. -* Added `deriveAll0` and `makeRep0` for symmetry with `deriveAll1` and - `makeRep1` -* Added`makeRep0FromType` and `makeRep1FromType` to make it easier to pass - in the type instance (instead of having to pass each individual type - variable, which can be error-prone) -* Added functions with the suffix `-WithKindSigs` to allow generating type - synonyms with explicit kind signatures in the presence of kind-polymorphic - type variables. This is necessary for some datatypes that use - `-XTypeInType` to have derived `Generic(1)` instances, but is not turned on - by default since the TH kind inference is not perfect and would cause - otherwise valid code to be rejected. Use only if you know what you are doing. -* Fixed bug where a datatype with a single, nullary constructor would generate - incorrect `Generic` instances -* More sensible `GEnum` instances for fixed-size integral types -* Added `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GMonoid`, - `GShow`, and `GTraversable` instances for datatypes introduced in GHC 8.0 -* Backported `Generic(1)` instances added in GHC 8.0. Specifically, `Generic` - instances for `Complex` (`base-4.4` and later) `ExitCode`, and `Version`; and - `Generic1` instances for `Complex` (`base-4.4` and later) and `Proxy` - (`base-4.7` and later). Added `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, - `GShow`, and `GTraversable` instances for these datatypes where appropriate. - -# 1.9.0 -* Allow deriving of Generic1 using Template Haskell -* Allow deriving of Generic(1) for data families -* Allow deriving of Generic(1) for constructor-less plain datatypes (but not - data families, due to technical restrictions) -* Support for unboxed representation types on GHC 7.11+ -* More `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GMonoid`, - `GShow`, and `GTraversable` instances -* The field accessors for the `(:+:)` type in `Generics.Deriving.Base` have - been removed to be consistent with `GHC.Generics` -* Ensure that TH generates definitions for isNewtype and packageName, if a - recent-enough version of GHC is used -* Ensure that TH-generated names are unique for a given data type's module and - package (similar in spirit to Trac #10487) -* Allow building on stage-1 compilers +# 1.14.5 [2023.08.06]+* Support building with `template-haskell-2.21.*` (GHC 9.8).+* The Template Haskell machinery now uses `TemplateHaskellQuotes` when+ building with GHC 8.0+ instead of manually constructing each Template Haskell+ `Name`. A consequence of this is that `generic-deriving` will now build with+ GHC 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template+ Haskell changes introduced in 9.8.++# 1.14.4 [2023.04.30]+* Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined,+ such as the WASM backend.+* Place `INLINE [1]` pragmas on `from` and `to` implementations when types+ don't have too many constructors or fields, following the heuristics that GHC+ 9.2+ uses for `Generic` deriving.++# 1.14.3 [2023.02.27]+* Support `th-abstraction-0.5.*`.++# 1.14.2 [2022.07.23]+* Fix a bug in which `deriveAll1` could generate ill kinded code when using+ `kindSigOptions=False`, or when using GHC 8.0 or earlier.+* Fix a bug in which `deriveAll1` would reject data types whose last type+ variable has a kind besides `Type` or `k` on GHC 8.2 or later.++# 1.14.1 [2021.08.30]+* Backport the `Generic(1)` instances introduced for tuples (8 through 15) in+ `base-4.16`.+* Make the test suite compile on GHC 9.2 or later.+* Always import `Data.List` qualified to fix the build with recent GHCs.++# 1.14 [2020.09.30]+* Remove instances for `Data.Semigroup.Option`, which is deprecated as of+ `base-4.15.0.0`.+* Allow building with `template-haskell-2.17.0.0` (GHC 9.0).+* Fix a bug in which `deriveAll1` would needlessly reject data types whose last+ type parameter appears as an oversaturated argument to a type family.++# 1.13.1 [2019.11.26]+* Backport the `Generic(1)` instances for `Kleisli` introduced in `base-4.14`.++# 1.13 [2019.08.27]+* Make `GSemigroup` a superclass of `GMonoid`. Similarly, make+ `GSemigroup'` a superclass of `GMonoid'`.+* In the instance `GMonoid (Maybe a)`, relax the constraint on `a` from+ `GMonoid` to `GSemigroup`.++# 1.12.4 [2019.04.26]+* Support `th-abstraction-0.3.0.0` or later.++# 1.12.3 [2019.02.09]+* Support `template-haskell-2.15`.+* Add a `gshowList` method to `GShow`, which lets us avoid the need for+ `OverlappingInstances` in `Generics.Deriving.TH`. As a consequence, the+ `GShow String` instance has been removed, as it is now fully subsumed by+ the `GShow [a]` instance (with which it previously overlapped).+* Functions in `Generics.Deriving.TH` now balance groups of `(:*:)` and `(:+:)`+ as much as possible (`deriving Generic` was already performing this+ optimization, and now `generic-deriving` does too).+* Add a `Generics.Deriving.Default` module demonstrating and explaining+ how and why to use `DerivingVia`. There is also a test suite with+ further examples.++# 1.12.2 [2018.06.28]+* Backport the `Generic(1)` instances for `Data.Ord.Down`, introduced in+ `base-4.12`. Add `GEq`, `GShow`, `GSemigroup`, `GMonoid`, `GFunctor`,+ `GFoldable`, `GTraversable`, and `GCopoint` instances for `Down`.+* Refactor internals using `th-abstraction`.+* Adapt to `Maybe` moving to `GHC.Maybe` in GHC 8.6.++# 1.12.1 [2018.01.11]+* Remove a test that won't work on GHC 8.4.++# 1.12 [2017.12.07]+* Adapt to the `EmptyDataDeriving` proposal (introduced in GHC 8.4):+ * `Generics.Deriving.TH` now derives `to(1)` and `from(1)` implementations+ for empty data types that are strict in the argument.+ * Introduce an `EmptyCaseOptions` field to `Options` in+ `Generics.Deriving.TH`, which controls whether generated `from(1)`/`to(1)`+ implementations for empty data types should use the `EmptyCase` extension+ or not (as is the case in GHC 8.4).+ * Add `mkFrom0Options`, `mkFrom1Options`, `mkTo0Options`, and `mkTo1Options`+ functions to `Generics.Deriving.TH`, which take `EmptyCaseOptions` as+ arguments.+ * The backported instances for `V1` are now maximally lazy, as per+ `EmptyDataDeriving`. (Previously, some instances would unnecessarily force+ their argument, such as the `Eq` and `Ord` instances.)+ * Add instances for `V1` in `Generics.Deriving.Copoint`, `.Eq`, `.Foldable`,+ `.Functor`, `.Show`, and `.Traversable`.+* Remove the bitrotting `simplInstance` function from `Generics.Deriving.TH`.++# 1.11.2 [2017.04.10]+* Add `GEq`, `GShow`, `GEnum`, and `GIx` instances for the new data types+ in `Foreign.C.Types` (`CBool`) and `System.Posix.Types` (`CBlkSize`,+ `CBlkCnt`, `CClockId`, `CFsBlkCnt`, `CFsFilCnt`, `CId`, `CKey`, and `CTimer`)+ introduced in `base-4.10.0.0`++# 1.11.1 [2016.09.10]+* Fix Template Haskell regression involving data families+* Convert examples to test suite+* Backport missing `Data` and `Typeable` instances for `Rec1`, `M1`, `(:*:)`,+ `(:+:)`, and `(:.:)`++# 1.11+* The behavior of functions in `Generics.Deriving.TH` have changed with respect+ to when type synonyms are generated for `Rep(1)` definitions. In particular:++ * By default, `deriveRepresentable(1)` will no longer define its `Rep(1)`+ type family instance in terms of the type synonym that has to be generated+ with `deriveRep(1)`. Similarly, `deriveAll(1)` and `deriveAll0And1` will no+ longer generate a type synonym. Instead, they will generate `Generic(1)`+ instances that directly define the `Rep(1)` instance inline. If you wish+ to revert to the old behavior, you will need to use the variants of those+ functions suffixed with `-Options`.+ * New functions `makeRep0Inline` and `makeRep1Inline` have been added which,+ for most purposes, should replace uses of `makeRep0`/`makeRep0FromType`+ and `makeRep1`/`makeRep1FromType` (but see the next bullet point for a+ caveat).+ * The use of `deriveRep(1)`, `makeRep0`/`makeRep0FromType`, and+ `makeRep1`/`makeRep1FromType` are now discouraged, but those functions are+ still available. The reason is that on GHC 7.0/7.2/7.4, it is impossible to use+ `makeRep0Inline`/`makeRep1Inline` due to a GHC bug. Therefore, you must use+ `makeRep0`/`makeRep1` and `deriveRep(1)` on GHC 7.0/7.2/7.4 out of necessity.++ These changes make dealing with `Generic` instances that involve `PolyKinds`+ and `TypeInType` much easier.+* All functions suffixed in `-WithKindSigs` in `Generics.Deriving.TH` have been+ removed in favor of a more sensible `-Options` suffixing scheme. The ability to+ toggle whether explicit kind signatures are used on type variable binders has+ been folded into `KindSigOptions`, which is an explicit argument to+ `deriveRep0Options`/`deriveRep1Options` and also a field in the more general+ 'Options' data type.+* Furthermore, the behavior of derived instances' kind signatures has changed.+ By default, the TH code will now _always_ use explicit kind signatures+ whenever possible, regardless of whether you're working with plain data types+ or data family instances. This makes working with `TypeInType` less+ surprising, but at the cost of making it slightly more awkward to work with+ derived `Generic1` instances that constrain kinds to `*` by means of `(:.:)`.+* Since `Generic1` is polykinded on GHC 8.2 and later, the functions in+ `Generics.Deriving.TH` will no longer unify the kind of the last type+ parameter to be `*`.+* Fix a bug in which `makeRep` (and similarly named functions) would not check+ whether the argument type can actually have a well kinded `Generic(1)`+ instance.+* Backport missing `Foldable` and `Traversable` instances for `Rec1`++# 1.10.7+* Renamed internal modules to avoid using apostrophes (averting this bug:+ https://github.com/haskell/cabal/issues/3631)++# 1.10.6+* A new `base-4-9` Cabal flag was added to more easily facilitate installing+ `generic-deriving` with manually installed versions of `template-haskell`.++# 1.10.5+* Apply an optimization to generated `to(1)`/`from(1)` instances that factors out+ common occurrences of `M1`. See+ http://git.haskell.org/ghc.git/commit/9649fc0ae45e006c2ed54cc5ea2414158949fadb+* Export internal typeclass names+* Fix Haddock issues with GHC 7.8++# 1.10.4.1+* Fix Haddock parsing issue on GHC 8.0++# 1.10.4+* Backported `MonadPlus` and `MonadZip` instances for `U1`, and made the+ `Functor`, `Foldable`, `Traversable`, `Alternative`, and `Monad` instances+ for `U1` lazier to correspond with `base-4.9`++# 1.10.3+* Backported `Enum`, `Bounded`, `Ix`, `Functor`, `Applicative`, `Monad`,+ `MonadFix`, `MonadPlus`, `MonadZip`, `Foldable`, `Traversable`, and+ `Data` instances (introduced in `base-4.9`) for datatypes in the+ `Generics.Deriving.Base` module++# 1.10.2+* Fix TH regression on GHC 7.0++# 1.10.1+* Added `Generics.Deriving.Semigroup`+* Added `GMonoid` instance for `Data.Monoid.Alt`+* Fixed a bug in the `GEnum` instances for unsigned `Integral` types+* Added `Safe`/`Trustworthy` pragmas+* Made instances polykinded where possible++# 1.10.0+* On GHC 8.0 and up, `Generics.Deriving.TH` uses the new type literal-based+ machinery+* Rewrote the Template Haskell code to be robust. Among other things, this fixes+ a bug with deriving Generic1 instances on GHC 7.8, and makes it easier to+ derive Generic1 instances for datatypes that utilize GHC 8.0's `-XTypeInType`+ extension.+* Added `deriveAll0` and `makeRep0` for symmetry with `deriveAll1` and+ `makeRep1`+* Added`makeRep0FromType` and `makeRep1FromType` to make it easier to pass+ in the type instance (instead of having to pass each individual type+ variable, which can be error-prone)+* Added functions with the suffix `-WithKindSigs` to allow generating type+ synonyms with explicit kind signatures in the presence of kind-polymorphic+ type variables. This is necessary for some datatypes that use+ `-XTypeInType` to have derived `Generic(1)` instances, but is not turned on+ by default since the TH kind inference is not perfect and would cause+ otherwise valid code to be rejected. Use only if you know what you are doing.+* Fixed bug where a datatype with a single, nullary constructor would generate+ incorrect `Generic` instances+* More sensible `GEnum` instances for fixed-size integral types+* Added `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GMonoid`,+ `GShow`, and `GTraversable` instances for datatypes introduced in GHC 8.0+* Backported `Generic(1)` instances added in GHC 8.0. Specifically, `Generic`+ instances for `Complex` (`base-4.4` and later) `ExitCode`, and `Version`; and+ `Generic1` instances for `Complex` (`base-4.4` and later) and `Proxy`+ (`base-4.7` and later). Added `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`,+ `GShow`, and `GTraversable` instances for these datatypes where appropriate.++# 1.9.0+* Allow deriving of Generic1 using Template Haskell+* Allow deriving of Generic(1) for data families+* Allow deriving of Generic(1) for constructor-less plain datatypes (but not+ data families, due to technical restrictions)+* Support for unboxed representation types on GHC 7.11++* More `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GMonoid`,+ `GShow`, and `GTraversable` instances+* The field accessors for the `(:+:)` type in `Generics.Deriving.Base` have+ been removed to be consistent with `GHC.Generics`+* Ensure that TH generates definitions for isNewtype and packageName, if a+ recent-enough version of GHC is used+* Ensure that TH-generated names are unique for a given data type's module and+ package (similar in spirit to Trac #10487)+* Allow building on stage-1 compilers
LICENSE view
@@ -1,28 +1,28 @@-Copyright (c) 2010 Universiteit Utrecht -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -3. Neither the name of Universiteit Utrecht nor the names of its contributors - may be used to endorse or promote products derived from this software without - specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +Copyright (c) 2010 Universiteit Utrecht+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of Universiteit Utrecht nor the names of its contributors+ may be used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
README.md view
@@ -1,86 +1,86 @@-## `generic-deriving`: Generic programming library for generalised deriving -[][Hackage: generic-deriving] -[](http://packdeps.haskellers.com/reverse/generic-deriving) -[][Haskell.org] -[][tl;dr Legal: BSD3] -[](https://github.com/dreixel/generic-deriving/actions?query=workflow%3AHaskell-CI) - -[Hackage: generic-deriving]: - http://hackage.haskell.org/package/generic-deriving - "generic-deriving package on Hackage" -[Haskell.org]: - http://www.haskell.org - "The Haskell Programming Language" -[tl;dr Legal: BSD3]: - https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 - "BSD 3-Clause License (Revised)" - -This package provides functionality for generalising the deriving mechanism -in Haskell to arbitrary classes. It was first described in the paper: - -* [A generic deriving mechanism for Haskell](http://dreixel.net/research/pdf/gdmh.pdf). - Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10. - -The current implementation integrates with the new GHC Generics. See -http://www.haskell.org/haskellwiki/GHC.Generics for more information. -Template Haskell code is provided for supporting older GHCs. - -This library is organized as follows: - -* `Generics.Deriving.Base` defines the core functionality for GHC generics, - including the `Generic(1)` classes and representation data types. - On modern versions of GHC, this simply re-exports `GHC.Generics` from - `base`. On older versions of GHC, this module backports parts of - `GHC.Generics` that were not included at the time, including `Generic(1)` - instances. - -* `Generics.Deriving.TH` implements Template Haskell functionality for - deriving instances of `Generic(1)`. - -* Educational code: in order to provide examples of how to define and use - `GHC.Generics`-based defaults, this library offers a number of modules - which define examples of type classes along with default implementations - for the classes' methods. Currently, the following modules are provided: - - * `Generics.Deriving.Copoint` - - * `Generics.Deriving.ConNames` - - * `Generics.Deriving.Enum` - - * `Generics.Deriving.Eq` - - * `Generics.Deriving.Foldable` - - * `Generics.Deriving.Functor` - - * `Generics.Deriving.Monoid` - - * `Generics.Deriving.Semigroup` - - * `Generics.Deriving.Show` - - * `Generics.Deriving.Traversable` - - * `Generics.Deriving.Uniplate` - - It is worth emphasizing that these modules are primarly intended for - educational purposes. Many of the classes in these modules resemble other - commonly used classes—for example, `GShow` from `Generics.Deriving.Show` - resembles `Show` from `base`—but in general, the classes that - `generic-deriving` defines are not drop-in replacements. Moreover, the - generic defaults that `generic-deriving` provide often make simplifying - assumptions that may violate expectations of how these classes might work - elsewhere. For example, the generic default for `GShow` does not behave - exactly like `deriving Show` would. - - If you are seeking `GHC.Generics`-based defaults for type classes in - `base`, consider using the - [`generic-data`](http://hackage.haskell.org/package/generic-data) library. - -* `Generics.Deriving.Default` provides newtypes that allow leveraging the - generic defaults in this library using the `DerivingVia` GHC language - extension. - -* `Generics.Deriving` re-exports `Generics.Deriving.Base`, - `Generics.Deriving.Default`, and a selection of educational modules. +## `generic-deriving`: Generic programming library for generalised deriving+[][Hackage: generic-deriving]+[](http://packdeps.haskellers.com/reverse/generic-deriving)+[][Haskell.org]+[][tl;dr Legal: BSD3]+[](https://github.com/dreixel/generic-deriving/actions?query=workflow%3AHaskell-CI)++[Hackage: generic-deriving]:+ http://hackage.haskell.org/package/generic-deriving+ "generic-deriving package on Hackage"+[Haskell.org]:+ http://www.haskell.org+ "The Haskell Programming Language"+[tl;dr Legal: BSD3]:+ https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29+ "BSD 3-Clause License (Revised)"++This package provides functionality for generalising the deriving mechanism+in Haskell to arbitrary classes. It was first described in the paper:++* [A generic deriving mechanism for Haskell](http://dreixel.net/research/pdf/gdmh.pdf).+ Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10.++The current implementation integrates with the new GHC Generics. See+http://www.haskell.org/haskellwiki/GHC.Generics for more information.+Template Haskell code is provided for supporting older GHCs.++This library is organized as follows:++* `Generics.Deriving.Base` defines the core functionality for GHC generics,+ including the `Generic(1)` classes and representation data types.+ On modern versions of GHC, this simply re-exports `GHC.Generics` from+ `base`. On older versions of GHC, this module backports parts of+ `GHC.Generics` that were not included at the time, including `Generic(1)`+ instances.++* `Generics.Deriving.TH` implements Template Haskell functionality for+ deriving instances of `Generic(1)`.++* Educational code: in order to provide examples of how to define and use+ `GHC.Generics`-based defaults, this library offers a number of modules+ which define examples of type classes along with default implementations+ for the classes' methods. Currently, the following modules are provided:++ * `Generics.Deriving.Copoint`++ * `Generics.Deriving.ConNames`++ * `Generics.Deriving.Enum`++ * `Generics.Deriving.Eq`++ * `Generics.Deriving.Foldable`++ * `Generics.Deriving.Functor`++ * `Generics.Deriving.Monoid`++ * `Generics.Deriving.Semigroup`++ * `Generics.Deriving.Show`++ * `Generics.Deriving.Traversable`++ * `Generics.Deriving.Uniplate`++ It is worth emphasizing that these modules are primarly intended for+ educational purposes. Many of the classes in these modules resemble other+ commonly used classes—for example, `GShow` from `Generics.Deriving.Show`+ resembles `Show` from `base`—but in general, the classes that+ `generic-deriving` defines are not drop-in replacements. Moreover, the+ generic defaults that `generic-deriving` provide often make simplifying+ assumptions that may violate expectations of how these classes might work+ elsewhere. For example, the generic default for `GShow` does not behave+ exactly like `deriving Show` would.++ If you are seeking `GHC.Generics`-based defaults for type classes in+ `base`, consider using the+ [`generic-data`](http://hackage.haskell.org/package/generic-data) library.++* `Generics.Deriving.Default` provides newtypes that allow leveraging the+ generic defaults in this library using the `DerivingVia` GHC language+ extension.++* `Generics.Deriving` re-exports `Generics.Deriving.Base`,+ `Generics.Deriving.Default`, and a selection of educational modules.
Setup.hs view
@@ -1,6 +1,6 @@-module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain +module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
generic-deriving.cabal view
@@ -1,159 +1,162 @@-name: generic-deriving -version: 1.14.4 -synopsis: Generic programming library for generalised deriving. -description: - - This package provides functionality for generalising the deriving mechanism - in Haskell to arbitrary classes. It was first described in the paper: - . - * /A generic deriving mechanism for Haskell/. - Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. - Haskell'10. - . - The current implementation integrates with the new GHC Generics. See - <http://www.haskell.org/haskellwiki/GHC.Generics> for more information. - Template Haskell code is provided for supporting older GHCs. - . - This library is organized as follows: - . - * "Generics.Deriving.Base" defines the core functionality for GHC generics, - including the @Generic(1)@ classes and representation data types. - On modern versions of GHC, this simply re-exports "GHC.Generics" from - @base@. On older versions of GHC, this module backports parts of - "GHC.Generics" that were not included at the time, including @Generic(1)@ - instances. - . - * "Generics.Deriving.TH" implements Template Haskell functionality for - deriving instances of @Generic(1)@. - . - * Educational code: in order to provide examples of how to define and use - "GHC.Generics"-based defaults, this library offers a number of modules - which define examples of type classes along with default implementations - for the classes' methods. Currently, the following modules are provided: - "Generics.Deriving.Copoint", "Generics.Deriving.ConNames", - "Generics.Deriving.Enum", "Generics.Deriving.Eq", - "Generics.Deriving.Foldable", "Generics.Deriving.Functor", - "Generics.Deriving.Monoid", "Generics.Deriving.Semigroup", - "Generics.Deriving.Show", "Generics.Deriving.Traversable", - and "Generics.Deriving.Uniplate". - . - It is worth emphasizing that these modules are primarly intended for - educational purposes. Many of the classes in these modules resemble other - commonly used classes—for example, @GShow@ from "Generics.Deriving.Show" - resembles @Show@ from @base@—but in general, the classes that - @generic-deriving@ defines are not drop-in replacements. Moreover, the - generic defaults that @generic-deriving@ provide often make simplifying - assumptions that may violate expectations of how these classes might work - elsewhere. For example, the generic default for @GShow@ does not behave - exactly like @deriving Show@ would. - . - If you are seeking "GHC.Generics"-based defaults for type classes in - @base@, consider using the - @<http://hackage.haskell.org/package/generic-data generic-data>@ library. - . - * "Generics.Deriving.Default" provides newtypes that allow leveraging the - generic defaults in this library using the @DerivingVia@ GHC language - extension. - . - * "Generics.Deriving" re-exports "Generics.Deriving.Base", - "Generics.Deriving.Default", and a selection of educational modules. - -homepage: https://github.com/dreixel/generic-deriving -bug-reports: https://github.com/dreixel/generic-deriving/issues -category: Generics -copyright: 2011-2013 Universiteit Utrecht, University of Oxford -license: BSD3 -license-file: LICENSE -author: José Pedro Magalhães -maintainer: generics@haskell.org -stability: experimental -build-type: Simple -cabal-version: >= 1.10 -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 - , GHC == 8.10.7 - , GHC == 9.0.2 - , GHC == 9.2.7 - , GHC == 9.4.4 - , GHC == 9.6.1 -extra-source-files: CHANGELOG.md - , README.md - -source-repository head - type: git - location: https://github.com/dreixel/generic-deriving - -flag base-4-9 - description: Use base-4.9 or later. This version of base uses a - DataKinds-based encoding of GHC generics metadata. - default: True - -library - hs-source-dirs: src - exposed-modules: Generics.Deriving - Generics.Deriving.Base - Generics.Deriving.Instances - Generics.Deriving.Copoint - Generics.Deriving.ConNames - Generics.Deriving.Default - Generics.Deriving.Enum - Generics.Deriving.Eq - Generics.Deriving.Foldable - Generics.Deriving.Functor - Generics.Deriving.Monoid - Generics.Deriving.Semigroup - Generics.Deriving.Show - Generics.Deriving.Traversable - Generics.Deriving.Uniplate - - Generics.Deriving.TH - - other-modules: Generics.Deriving.Base.Internal - Generics.Deriving.Monoid.Internal - Generics.Deriving.Semigroup.Internal - Generics.Deriving.TH.Internal - Paths_generic_deriving - if flag(base-4-9) - build-depends: base >= 4.9 && < 5 - other-modules: Generics.Deriving.TH.Post4_9 - else - build-depends: base >= 4.3 && < 4.9 - other-modules: Generics.Deriving.TH.Pre4_9 - - build-depends: containers >= 0.1 && < 0.7 - , ghc-prim < 1 - , template-haskell >= 2.4 && < 2.21 - , th-abstraction >= 0.4 && < 0.6 - - default-language: Haskell2010 - ghc-options: -Wall - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: DefaultSpec - EmptyCaseSpec - ExampleSpec - T68Spec - T80Spec - T82Spec - TypeInTypeSpec - build-depends: base >= 4.3 && < 5 - , generic-deriving - , hspec >= 2 && < 3 - , template-haskell >= 2.4 && < 2.21 - build-tool-depends: hspec-discover:hspec-discover - hs-source-dirs: tests - default-language: Haskell2010 - ghc-options: -Wall -threaded -rtsopts - if impl(ghc >= 8.6) - ghc-options: -Wno-star-is-type +name: generic-deriving+version: 1.14.5+synopsis: Generic programming library for generalised deriving.+description:++ This package provides functionality for generalising the deriving mechanism+ in Haskell to arbitrary classes. It was first described in the paper:+ .+ * /A generic deriving mechanism for Haskell/.+ Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh.+ Haskell'10.+ .+ The current implementation integrates with the new GHC Generics. See+ <http://www.haskell.org/haskellwiki/GHC.Generics> for more information.+ Template Haskell code is provided for supporting older GHCs.+ .+ This library is organized as follows:+ .+ * "Generics.Deriving.Base" defines the core functionality for GHC generics,+ including the @Generic(1)@ classes and representation data types.+ On modern versions of GHC, this simply re-exports "GHC.Generics" from+ @base@. On older versions of GHC, this module backports parts of+ "GHC.Generics" that were not included at the time, including @Generic(1)@+ instances.+ .+ * "Generics.Deriving.TH" implements Template Haskell functionality for+ deriving instances of @Generic(1)@.+ .+ * Educational code: in order to provide examples of how to define and use+ "GHC.Generics"-based defaults, this library offers a number of modules+ which define examples of type classes along with default implementations+ for the classes' methods. Currently, the following modules are provided:+ "Generics.Deriving.Copoint", "Generics.Deriving.ConNames",+ "Generics.Deriving.Enum", "Generics.Deriving.Eq",+ "Generics.Deriving.Foldable", "Generics.Deriving.Functor",+ "Generics.Deriving.Monoid", "Generics.Deriving.Semigroup",+ "Generics.Deriving.Show", "Generics.Deriving.Traversable",+ and "Generics.Deriving.Uniplate".+ .+ It is worth emphasizing that these modules are primarly intended for+ educational purposes. Many of the classes in these modules resemble other+ commonly used classes—for example, @GShow@ from "Generics.Deriving.Show"+ resembles @Show@ from @base@—but in general, the classes that+ @generic-deriving@ defines are not drop-in replacements. Moreover, the+ generic defaults that @generic-deriving@ provide often make simplifying+ assumptions that may violate expectations of how these classes might work+ elsewhere. For example, the generic default for @GShow@ does not behave+ exactly like @deriving Show@ would.+ .+ If you are seeking "GHC.Generics"-based defaults for type classes in+ @base@, consider using the+ @<http://hackage.haskell.org/package/generic-data generic-data>@ library.+ .+ * "Generics.Deriving.Default" provides newtypes that allow leveraging the+ generic defaults in this library using the @DerivingVia@ GHC language+ extension.+ .+ * "Generics.Deriving" re-exports "Generics.Deriving.Base",+ "Generics.Deriving.Default", and a selection of educational modules.++homepage: https://github.com/dreixel/generic-deriving+bug-reports: https://github.com/dreixel/generic-deriving/issues+category: Generics+copyright: 2011-2013 Universiteit Utrecht, University of Oxford+license: BSD3+license-file: LICENSE+author: José Pedro Magalhães+maintainer: generics@haskell.org+stability: experimental+build-type: Simple+cabal-version: >= 1.10+tested-with: GHC == 7.0.4+ , GHC == 7.2.2+ , GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.5+ , GHC == 9.6.2+extra-source-files: CHANGELOG.md+ , README.md++source-repository head+ type: git+ location: https://github.com/dreixel/generic-deriving++flag base-4-9+ description: Use base-4.9 or later. This version of base uses a+ DataKinds-based encoding of GHC generics metadata.+ default: True++library+ hs-source-dirs: src+ exposed-modules: Generics.Deriving+ Generics.Deriving.Base+ Generics.Deriving.Instances+ Generics.Deriving.Copoint+ Generics.Deriving.ConNames+ Generics.Deriving.Default+ Generics.Deriving.Enum+ Generics.Deriving.Eq+ Generics.Deriving.Foldable+ Generics.Deriving.Functor+ Generics.Deriving.Monoid+ Generics.Deriving.Semigroup+ Generics.Deriving.Show+ Generics.Deriving.Traversable+ Generics.Deriving.Uniplate++ Generics.Deriving.TH++ other-modules: Generics.Deriving.Base.Internal+ Generics.Deriving.Monoid.Internal+ Generics.Deriving.Semigroup.Internal+ Generics.Deriving.TH.Internal+ Paths_generic_deriving+ if flag(base-4-9)+ build-depends: base >= 4.9 && < 5+ other-modules: Generics.Deriving.TH.Post4_9+ else+ build-depends: base >= 4.3 && < 4.9+ other-modules: Generics.Deriving.TH.Pre4_9++ build-depends: containers >= 0.1 && < 0.7+ , ghc-prim < 1+ , template-haskell >= 2.4 && < 2.22+ -- TODO: Eventually, we should bump the lower version+ -- bounds to >=0.6 so that we can remove some CPP in+ -- Generics.Deriving.TH.Internal.+ , th-abstraction >= 0.4 && < 0.7++ default-language: Haskell2010+ ghc-options: -Wall++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: DefaultSpec+ EmptyCaseSpec+ ExampleSpec+ T68Spec+ T80Spec+ T82Spec+ TypeInTypeSpec+ build-depends: base >= 4.3 && < 5+ , generic-deriving+ , hspec >= 2 && < 3+ , template-haskell >= 2.4 && < 2.22+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: tests+ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts+ if impl(ghc >= 8.6)+ ghc-options: -Wno-star-is-type
src/Generics/Deriving.hs view
@@ -1,24 +1,24 @@- -module Generics.Deriving ( - - module Generics.Deriving.Base, - module Generics.Deriving.Copoint, - module Generics.Deriving.ConNames, - module Generics.Deriving.Default, - module Generics.Deriving.Enum, - module Generics.Deriving.Eq, - module Generics.Deriving.Functor, - module Generics.Deriving.Show, - module Generics.Deriving.Uniplate - - ) where - -import Generics.Deriving.Base -import Generics.Deriving.Copoint -import Generics.Deriving.ConNames -import Generics.Deriving.Default -import Generics.Deriving.Enum -import Generics.Deriving.Eq -import Generics.Deriving.Functor -import Generics.Deriving.Show -import Generics.Deriving.Uniplate ++module Generics.Deriving (++ module Generics.Deriving.Base,+ module Generics.Deriving.Copoint,+ module Generics.Deriving.ConNames,+ module Generics.Deriving.Default,+ module Generics.Deriving.Enum,+ module Generics.Deriving.Eq,+ module Generics.Deriving.Functor,+ module Generics.Deriving.Show,+ module Generics.Deriving.Uniplate++ ) where++import Generics.Deriving.Base+import Generics.Deriving.Copoint+import Generics.Deriving.ConNames+import Generics.Deriving.Default+import Generics.Deriving.Enum+import Generics.Deriving.Eq+import Generics.Deriving.Functor+import Generics.Deriving.Show+import Generics.Deriving.Uniplate
src/Generics/Deriving/Base.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Base (module Generics.Deriving.Base.Internal) where - -import Generics.Deriving.Base.Internal -import Generics.Deriving.Instances () +{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Base (module Generics.Deriving.Base.Internal) where++import Generics.Deriving.Base.Internal+import Generics.Deriving.Instances ()
src/Generics/Deriving/Base/Internal.hs view
@@ -1,1136 +1,1136 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Base.Internal ( --- * Introduction --- --- | --- --- Datatype-generic functions are are based on the idea of converting values of --- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. --- The type @'Rep' T@ is --- built from a limited set of type constructors, all provided by this module. A --- datatype-generic function is then an overloaded function with instances --- for most of these type constructors, together with a wrapper that performs --- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need --- a few generic instances in order to implement functionality that works for any --- representable type. --- --- Representable types are collected in the 'Generic' class, which defines the --- associated type 'Rep' as well as conversion functions 'from' and 'to'. --- Typically, you will not define 'Generic' instances by hand, but have the compiler --- derive them for you. - --- ** Representing datatypes --- --- | --- --- The key to defining your own datatype-generic functions is to understand how to --- represent datatypes using the given set of type constructors. --- --- Let us look at an example first: --- --- @ --- data Tree a = Leaf a | Node (Tree a) (Tree a) --- deriving 'Generic' --- @ --- --- The above declaration (which requires the language pragma @DeriveGeneric@) --- causes the following representation to be generated: --- --- @ --- class 'Generic' (Tree a) where --- type 'Rep' (Tree a) = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' ('Par0' a)) --- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec0' (Tree a)) --- ':*:' --- 'S1' 'NoSelector' ('Rec0' (Tree a)))) --- ... --- @ --- --- /Hint:/ You can obtain information about the code being generated from GHC by passing --- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using --- the @:kind!@ command. --- -#if 0 --- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will --- use 'Rec0' everywhere. --- -#endif --- This is a lot of information! However, most of it is actually merely meta-information --- that makes names of datatypes and constructors and more available on the type level. --- --- Here is a reduced representation for 'Tree' with nearly all meta-information removed, --- for now keeping only the most essential aspects: --- --- @ --- instance 'Generic' (Tree a) where --- type 'Rep' (Tree a) = --- 'Par0' a --- ':+:' --- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) --- @ --- --- The @Tree@ datatype has two constructors. The representation of individual constructors --- is combined using the binary type constructor ':+:'. --- --- The first constructor consists of a single field, which is the parameter @a@. This is --- represented as @'Par0' a@. --- --- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, --- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using --- the binary type constructor ':*:'. --- --- Now let us explain the additional tags being used in the complete representation: --- --- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with --- this field of the constructor. --- --- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is --- the representation of the first and second constructor of datatype @Tree@, respectively. --- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of --- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful --- because they are instances of the type class 'Constructor'. This type class can be used --- to obtain information about the constructor in question, such as its name --- or infix priority. --- --- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the --- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a --- proxy type, and is useful by being an instance of class 'Datatype', which --- can be used to obtain the name of a datatype, the module it has been defined in, and --- whether it has been defined using @data@ or @newtype@. - --- ** Derived and fundamental representation types --- --- | --- --- There are many datatype-generic functions that do not distinguish between positions that --- are parameters or positions that are recursive calls. There are also many datatype-generic --- functions that do not care about the names of datatypes and constructors at all. To keep --- the number of cases to consider in generic functions in such a situation to a minimum, --- it turns out that many of the type constructors introduced above are actually synonyms, --- defining them to be variants of a smaller set of constructors. - --- *** Individual fields of constructors: 'K1' --- --- | --- --- The type constructors 'Par0' and 'Rec0' are variants of 'K1': --- --- @ --- type 'Par0' = 'K1' 'P' --- type 'Rec0' = 'K1' 'R' --- @ --- --- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. - --- *** Meta information: 'M1' --- --- | --- --- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1': --- --- @ --- type 'S1' = 'M1' 'S' --- type 'C1' = 'M1' 'C' --- type 'D1' = 'M1' 'D' --- @ --- --- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create --- several variants of 'M1'. - --- *** Additional generic representation type constructors --- --- | --- --- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur --- in the representations of other datatypes. - --- **** Empty datatypes: 'V1' --- --- | --- --- For empty datatypes, 'V1' is used as a representation. For example, --- --- @ --- data Empty deriving 'Generic' --- @ --- --- yields --- --- @ --- instance 'Generic' Empty where --- type 'Rep' Empty = 'D1' D1Empty 'V1' --- @ - --- **** Constructors without fields: 'U1' --- --- | --- --- If a constructor has no arguments, then 'U1' is used as its representation. For example --- the representation of 'Bool' is --- --- @ --- instance 'Generic' Bool where --- type 'Rep' Bool = --- 'D1' D1Bool --- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') --- @ - --- *** Representation of types with many constructors or many fields --- --- | --- --- As ':+:' and ':*:' are just binary operators, one might ask what happens if the --- datatype has more than two constructors, or a constructor with more than two --- fields. The answer is simple: the operators are used several times, to combine --- all the constructors and fields as needed. However, users /should not rely on --- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is --- free to choose any nesting it prefers. (In practice, the current implementation --- tries to produce a more or less balanced nesting, so that the traversal of the --- structure of the datatype from the root to a particular component can be performed --- in logarithmic rather than linear time.) - --- ** Defining datatype-generic functions --- --- | --- --- A datatype-generic function comprises two parts: --- --- 1. /Generic instances/ for the function, implementing it for most of the representation --- type constructors introduced above. --- --- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion --- between the original value and its `Rep`-based representation and then invokes the --- generic instances. --- --- As an example, let us look at a function 'encode' that produces a naive, but lossless --- bit encoding of values of various datatypes. So we are aiming to define a function --- --- @ --- encode :: 'Generic' a => a -> [Bool] --- @ --- --- where we use 'Bool' as our datatype for bits. --- --- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized --- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation --- type constructors operate with kind @* -> *@ as base kind. But the type argument is never --- being used. This may be changed at some point in the future. The class has a single method, --- and we use the type we want our final function to have, but we replace the occurrences of --- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used). --- --- > class Encode' f where --- > encode' :: f p -> [Bool] --- --- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define --- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'. - --- *** Definition of the generic representation types --- --- | --- --- In order to be able to do this, we need to know the actual definitions of these types: --- --- @ --- data 'V1' p -- lifted version of Empty --- data 'U1' p = 'U1' -- lifted version of () --- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either' --- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,) --- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c --- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper --- @ --- --- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either', --- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value --- of a specific type @c@, and 'M1' wraps a value of the generic type argument, --- which in the lifted world is an @f p@ (where we do not care about @p@). - --- *** Generic instances --- --- | --- --- The instance for 'V1' is slightly awkward (but also rarely used): --- --- @ --- instance Encode' 'V1' where --- encode' x = undefined --- @ --- --- There are no values of type @V1 p@ to pass (except undefined), so this is --- actually impossible. One can ask why it is useful to define an instance for --- 'V1' at all in this case? Well, an empty type can be used as an argument to --- a non-empty type, and you might still want to encode the resulting type. --- As a somewhat contrived example, consider @[Empty]@, which is not an empty --- type, but contains just the empty list. The 'V1' instance ensures that we --- can call the generic function on such types. --- --- There is exactly one value of type 'U1', so encoding it requires no --- knowledge, and we can use zero bits: --- --- @ --- instance Encode' 'U1' where --- encode' 'U1' = [] --- @ --- --- In the case for ':+:', we produce 'False' or 'True' depending on whether --- the constructor of the value provided is located on the left or on the right: --- --- @ --- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where --- encode' ('L1' x) = False : encode' x --- encode' ('R1' x) = True : encode' x --- @ --- --- In the case for ':*:', we append the encodings of the two subcomponents: --- --- @ --- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where --- encode' (x ':*:' y) = encode' x ++ encode' y --- @ --- --- The case for 'K1' is rather interesting. Here, we call the final function --- 'encode' that we yet have to define, recursively. We will use another type --- class 'Encode' for that function: --- --- @ --- instance (Encode c) => Encode' ('K1' i c) where --- encode' ('K1' x) = encode x --- @ --- --- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define --- a uniform instance here. --- --- Similarly, we can define a uniform instance for 'M1', because we completely --- disregard all meta-information: --- --- @ --- instance (Encode' f) => Encode' ('M1' i t f) where --- encode' ('M1' x) = encode' x --- @ --- --- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. - --- *** The wrapper and generic default --- --- | --- --- We now define class 'Encode' for the actual 'encode' function: --- --- @ --- class Encode a where --- encode :: a -> [Bool] --- default encode :: ('Generic' a) => a -> [Bool] --- encode x = encode' ('from' x) --- @ --- --- The incoming 'x' is converted using 'from', then we dispatch to the --- generic instances using 'encode''. We use this as a default definition --- for 'encode'. We need the 'default encode' signature because ordinary --- Haskell default methods must not introduce additional class constraints, --- but our generic default does. --- --- Defining a particular instance is now as simple as saying --- --- @ --- instance (Encode a) => Encode (Tree a) --- @ --- -#if 0 --- /TODO:/ Add usage example? --- -#endif --- The generic default is being used. In the future, it will hopefully be --- possible to use @deriving Encode@ as well, but GHC does not yet support --- that syntax for this situation. --- --- Having 'Encode' as a class has the advantage that we can define --- non-generic special cases, which is particularly useful for abstract --- datatypes that have no structural representation. For example, given --- a suitable integer encoding function 'encodeInt', we can define --- --- @ --- instance Encode Int where --- encode = encodeInt --- @ - --- *** Omitting generic instances --- --- | --- --- It is not always required to provide instances for all the generic --- representation types, but omitting instances restricts the set of --- datatypes the functions will work for: --- --- * If no ':+:' instance is given, the function may still work for --- empty datatypes or datatypes that have a single constructor, --- but will fail on datatypes with more than one constructor. --- --- * If no ':*:' instance is given, the function may still work for --- datatypes where each constructor has just zero or one field, --- in particular for enumeration types. --- --- * If no 'K1' instance is given, the function may still work for --- enumeration types, where no constructor has any fields. --- --- * If no 'V1' instance is given, the function may still work for --- any datatype that is not empty. --- --- * If no 'U1' instance is given, the function may still work for --- any datatype where each constructor has at least one field. --- --- An 'M1' instance is always required (but it can just ignore the --- meta-information, as is the case for 'encode' above). -#if 0 --- *** Using meta-information --- --- | --- --- TODO -#endif --- ** Generic constructor classes --- --- | --- --- Datatype-generic functions as defined above work for a large class --- of datatypes, including parameterized datatypes. (We have used 'Tree' --- as our example above, which is of kind @* -> *@.) However, the --- 'Generic' class ranges over types of kind @*@, and therefore, the --- resulting generic functions (such as 'encode') must be parameterized --- by a generic type argument of kind @*@. --- --- What if we want to define generic classes that range over type --- constructors (such as 'Functor', 'Traversable', or 'Foldable')? - --- *** The 'Generic1' class --- --- | --- --- Like 'Generic', there is a class 'Generic1' that defines a --- representation 'Rep1' and conversion functions 'from1' and 'to1', --- only that 'Generic1' ranges over types of kind @* -> *@. --- The 'Generic1' class is also derivable. --- --- The representation 'Rep1' is ever so slightly different from 'Rep'. --- Let us look at 'Tree' as an example again: --- --- @ --- data Tree a = Leaf a | Node (Tree a) (Tree a) --- deriving 'Generic1' --- @ --- --- The above declaration causes the following representation to be generated: --- --- class 'Generic1' Tree where --- type 'Rep1' Tree = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' 'Par1') --- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec1' Tree) --- ':*:' --- 'S1' 'NoSelector' ('Rec1' Tree))) --- ... --- --- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well --- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we --- carry around the dummy type argument for kind-@*@-types, but there are --- already enough different names involved without duplicating each of --- these.) --- --- What's different is that we now use 'Par1' to refer to the parameter --- (and that parameter, which used to be @a@), is not mentioned explicitly --- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@. - --- *** Representation of @* -> *@ types --- --- | --- --- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not --- map to 'K1'. They are defined directly, as follows: --- --- @ --- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p --- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper --- @ --- --- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply --- wraps an application of @f@ to @p@. --- --- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation, --- namely when the datatype has a field that does not mention the parameter. --- --- The declaration --- --- @ --- data WithInt a = WithInt Int a --- deriving 'Generic1' --- @ --- --- yields --- --- @ --- class 'Rep1' WithInt where --- type 'Rep1' WithInt = --- 'D1' D1WithInt --- ('C1' C1_0WithInt --- ('S1' 'NoSelector' ('Rec0' Int) --- ':*:' --- 'S1' 'NoSelector' 'Par1')) --- @ --- --- If the parameter @a@ appears underneath a composition of other type constructors, --- then the representation involves composition, too: --- --- @ --- data Rose a = Fork a [Rose a] --- @ --- --- yields --- --- @ --- class 'Rep1' Rose where --- type 'Rep1' Rose = --- 'D1' D1Rose --- ('C1' C1_0Rose --- ('S1' 'NoSelector' 'Par1' --- ':*:' --- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) --- @ --- --- where --- --- @ --- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } --- @ - --- *** Representation of unlifted types --- --- | --- --- If one were to attempt to derive a Generic instance for a datatype with an --- unlifted argument (for example, 'Int#'), one might expect the occurrence of --- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, --- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. --- In fact, polymorphism over unlifted types is disallowed completely. --- --- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' --- instead. With this approach, however, the programmer has no way of knowing --- whether the 'Int' is actually an 'Int#' in disguise. --- --- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark --- occurrences of common unlifted types: --- --- @ --- data family URec a p --- --- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } --- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } --- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } --- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } --- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } --- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } --- @ --- --- Several type synonyms are provided for convenience: --- --- @ --- type 'UAddr' = 'URec' ('Ptr' ()) --- type 'UChar' = 'URec' 'Char' --- type 'UDouble' = 'URec' 'Double' --- type 'UFloat' = 'URec' 'Float' --- type 'UInt' = 'URec' 'Int' --- type 'UWord' = 'URec' 'Word' --- @ --- --- The declaration --- --- @ --- data IntHash = IntHash Int# --- deriving 'Generic' --- @ --- --- yields --- --- @ --- instance 'Generic' IntHash where --- type 'Rep' IntHash = --- 'D1' D1IntHash --- ('C1' C1_0IntHash --- ('S1' 'NoSelector' 'UInt')) --- @ --- --- Currently, only the six unlifted types listed above are generated, but this --- may be extended to encompass more unlifted types in the future. -#if 0 --- *** Limitations --- --- | --- --- /TODO/ --- --- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion. --- -#endif -#if !(MIN_VERSION_base(4,4,0)) - -- * Generic representation types - V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) - , (:+:)(..), (:*:)(..), (:.:)(..) - - -- ** Synonyms for convenience - , Rec0, Par0, R, P - , D1, C1, S1, D, C, S - - -- * Meta-information - , Datatype(..), Constructor(..), Selector(..), NoSelector - , Fixity(..), Associativity(..), Arity(..), prec - - -- * Generic type classes - , Generic(..), Generic1(..), - -#else - module GHC.Generics, -#endif -#if !(MIN_VERSION_base(4,9,0)) - -- ** Unboxed representation types - URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord -#endif - ) where - - -#if MIN_VERSION_base(4,4,0) -import GHC.Generics -#else -import Control.Applicative ( Alternative(..) ) -import Control.Monad ( MonadPlus(..) ) -import Control.Monad.Fix ( MonadFix(..), fix ) -import Data.Data ( Data(..), DataType, constrIndex, mkDataType ) -import Data.Ix ( Ix ) -import Text.ParserCombinators.ReadPrec (pfail) -import Text.Read ( Read(..), parens, readListDefault, readListPrecDefault ) -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ( Applicative(..) ) -import Data.Foldable ( Foldable(..) ) -import Data.Monoid ( Monoid(..) ) -import Data.Traversable ( Traversable(..) ) -import Data.Word ( Word ) -#endif - -#if !(MIN_VERSION_base(4,9,0)) -import Data.Typeable -import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) -import GHC.Ptr ( Ptr ) -#endif - -#if !(MIN_VERSION_base(4,4,0)) --------------------------------------------------------------------------------- --- Representation types --------------------------------------------------------------------------------- - --- | Void: used for datatypes without constructors -data V1 p deriving Typeable - --- Implement these instances by hand to get the desired, maximally lazy behavior. -instance Functor V1 where - fmap _ !_ = error "Void fmap" - -instance Foldable V1 where - foldr _ z _ = z - foldMap _ _ = mempty - -instance Traversable V1 where - traverse _ x = pure (case x of !_ -> error "Void traverse") - -instance Eq (V1 p) where - _ == _ = True - -instance Data p => Data (V1 p) where - gfoldl _ _ !_ = error "Void gfoldl" - gunfold _ _ c = case constrIndex c of - _ -> error "Void gunfold" - toConstr !_ = error "Void toConstr" - dataTypeOf _ = v1DataType - dataCast1 f = gcast1 f - -v1DataType :: DataType -v1DataType = mkDataType "V1" [] - -instance Ord (V1 p) where - compare _ _ = EQ - -instance Show (V1 p) where - showsPrec _ !_ = error "Void showsPrec" - --- Implement Read instance manually to get around an old GHC bug --- (Trac #7931) -instance Read (V1 p) where - readPrec = parens pfail - readList = readListDefault - readListPrec = readListPrecDefault - --- | Unit: used for constructors without arguments -data U1 p = U1 - deriving (Eq, Ord, Read, Show, Data, Typeable) - -instance Functor U1 where - fmap _ _ = U1 - -instance Applicative U1 where - pure _ = U1 - _ <*> _ = U1 - -instance Alternative U1 where - empty = U1 - _ <|> _ = U1 - -instance Monad U1 where - return _ = U1 - _ >>= _ = U1 - -instance MonadPlus U1 where - mzero = U1 - mplus _ _ = U1 - -instance Foldable U1 where - foldMap _ _ = mempty - {-# INLINE foldMap #-} - fold _ = mempty - {-# INLINE fold #-} - foldr _ z _ = z - {-# INLINE foldr #-} - foldl _ z _ = z - {-# INLINE foldl #-} - foldl1 _ _ = error "foldl1: U1" - foldr1 _ _ = error "foldr1: U1" - -instance Traversable U1 where - traverse _ _ = pure U1 - {-# INLINE traverse #-} - sequenceA _ = pure U1 - {-# INLINE sequenceA #-} - mapM _ _ = return U1 - {-# INLINE mapM #-} - sequence _ = return U1 - {-# INLINE sequence #-} - --- | Used for marking occurrences of the parameter -newtype Par1 p = Par1 { unPar1 :: p } - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Typeable) - -instance Applicative Par1 where - pure a = Par1 a - Par1 f <*> Par1 x = Par1 (f x) - -instance Monad Par1 where - return a = Par1 a - Par1 x >>= f = f x - -instance MonadFix Par1 where - mfix f = Par1 (fix (unPar1 . f)) - --- | Recursive calls of kind * -> * -newtype Rec1 f p = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) - -instance Typeable1 f => Typeable1 (Rec1 f) where - typeOf1 t = mkTyConApp rec1TyCon [typeOf1 (f t)] - where - f :: Rec1 f a -> f a - f = undefined - -rec1TyCon :: TyCon -rec1TyCon = mkTyCon "Generics.Deriving.Base.Internal.Rec1" - -instance Applicative f => Applicative (Rec1 f) where - pure a = Rec1 (pure a) - Rec1 f <*> Rec1 x = Rec1 (f <*> x) - -instance Alternative f => Alternative (Rec1 f) where - empty = Rec1 empty - Rec1 l <|> Rec1 r = Rec1 (l <|> r) - -instance Monad f => Monad (Rec1 f) where - return a = Rec1 (return a) - Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a)) - -instance MonadFix f => MonadFix (Rec1 f) where - mfix f = Rec1 (mfix (unRec1 . f)) - -instance MonadPlus f => MonadPlus (Rec1 f) where - mzero = Rec1 mzero - mplus (Rec1 a) (Rec1 b) = Rec1 (mplus a b) - --- | Constants, additional parameters and recursion of kind * -newtype K1 i c p = K1 { unK1 :: c } - deriving (Eq, Ord, Read, Show, Functor, Data, Typeable) - -instance Foldable (K1 i c) where - foldr _ z K1{} = z - foldMap _ K1{} = mempty - -instance Traversable (K1 i c) where - traverse _ (K1 c) = pure (K1 c) - --- | Meta-information (constructor names, etc.) -newtype M1 i c f p = M1 { unM1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) - -instance (Typeable i, Typeable c, Typeable1 f) => Typeable1 (M1 i c f) where - typeOf1 t = mkTyConApp m1TyCon [typeOf (i t), typeOf (c t), typeOf1 (f t)] - where - i :: M1 i c f p -> i - i = undefined - - c :: M1 i c f p -> c - c = undefined - - f :: M1 i c f p -> f p - f = undefined - -m1TyCon :: TyCon -m1TyCon = mkTyCon "Generics.Deriving.Base.Internal.M1" - -instance Applicative f => Applicative (M1 i c f) where - pure a = M1 (pure a) - M1 f <*> M1 x = M1 (f <*> x) - -instance Alternative f => Alternative (M1 i c f) where - empty = M1 empty - M1 l <|> M1 r = M1 (l <|> r) - -instance Monad f => Monad (M1 i c f) where - return a = M1 (return a) - M1 x >>= f = M1 (x >>= \a -> unM1 (f a)) - -instance MonadPlus f => MonadPlus (M1 i c f) where - mzero = M1 mzero - mplus (M1 a) (M1 b) = M1 (mplus a b) - -instance MonadFix f => MonadFix (M1 i c f) where - mfix f = M1 (mfix (unM1. f)) - --- | Sums: encode choice between constructors -infixr 5 :+: -data (:+:) f g p = L1 (f p) | R1 (g p) - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) - -instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where - typeOf1 t = mkTyConApp conSumTyCon [typeOf1 (f t), typeOf1 (g t)] - where - f :: (f :+: g) p -> f p - f = undefined - - g :: (f :+: g) p -> g p - g = undefined - -conSumTyCon :: TyCon -conSumTyCon = mkTyCon "Generics.Deriving.Base.Internal.:+:" - --- | Products: encode multiple arguments to constructors -infixr 6 :*: -data (:*:) f g p = f p :*: g p - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) - -instance (Typeable1 f, Typeable1 g) => Typeable1 (f :*: g) where - typeOf1 t = mkTyConApp conProductTyCon [typeOf1 (f t), typeOf1 (g t)] - where - f :: (f :*: g) p -> f p - f = undefined - - g :: (f :*: g) p -> g p - g = undefined - -conProductTyCon :: TyCon -conProductTyCon = mkTyCon "Generics.Deriving.Base.Internal.:*:" - -instance (Applicative f, Applicative g) => Applicative (f :*: g) where - pure a = pure a :*: pure a - (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y) - -instance (Alternative f, Alternative g) => Alternative (f :*: g) where - empty = empty :*: empty - (x1 :*: y1) <|> (x2 :*: y2) = (x1 <|> x2) :*: (y1 <|> y2) - -instance (Monad f, Monad g) => Monad (f :*: g) where - return a = return a :*: return a - (m :*: n) >>= f = (m >>= \a -> fstP (f a)) :*: (n >>= \a -> sndP (f a)) - where - fstP (a :*: _) = a - sndP (_ :*: b) = b - -instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where - mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f)) - where - fstP (a :*: _) = a - sndP (_ :*: b) = b - -instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) where - mzero = mzero :*: mzero - (x1 :*: y1) `mplus` (x2 :*: y2) = (x1 `mplus` x2) :*: (y1 `mplus` y2) - --- | Composition of functors -infixr 7 :.: -newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } - deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) - -instance (Typeable1 f, Typeable1 g) => Typeable1 (f :.: g) where - typeOf1 t = mkTyConApp conComposeTyCon [typeOf1 (f t), typeOf1 (g t)] - where - f :: (f :.: g) p -> f p - f = undefined - - g :: (f :.: g) p -> g p - g = undefined - -conComposeTyCon :: TyCon -conComposeTyCon = mkTyCon "Generics.Deriving.Base.Internal.:.:" - -instance (Applicative f, Applicative g) => Applicative (f :.: g) where - pure x = Comp1 (pure (pure x)) - Comp1 f <*> Comp1 x = Comp1 (fmap (<*>) f <*> x) - -instance (Alternative f, Applicative g) => Alternative (f :.: g) where - empty = Comp1 empty - Comp1 x <|> Comp1 y = Comp1 (x <|> y) - --- | Tag for K1: recursion (of kind *) -data R - deriving Typeable --- | Tag for K1: parameters (other than the last) -data P - deriving Typeable - --- | Type synonym for encoding recursion (of kind *) -type Rec0 = K1 R --- | Type synonym for encoding parameters (other than the last) -type Par0 = K1 P - --- | Tag for M1: datatype -data D - deriving Typeable --- | Tag for M1: constructor -data C - deriving Typeable --- | Tag for M1: record selector -data S - deriving Typeable - --- | Type synonym for encoding meta-information for datatypes -type D1 = M1 D - --- | Type synonym for encoding meta-information for constructors -type C1 = M1 C - --- | Type synonym for encoding meta-information for record selectors -type S1 = M1 S - --- | Class for datatypes that represent datatypes -class Datatype d where - -- | The name of the datatype, fully qualified - datatypeName :: t d (f :: * -> *) a -> String - moduleName :: t d (f :: * -> *) a -> String - --- | Class for datatypes that represent records -class Selector s where - -- | The name of the selector - selName :: t s (f :: * -> *) a -> String - --- | Used for constructor fields without a name -data NoSelector - deriving Typeable - -instance Selector NoSelector where selName _ = "" - --- | Class for datatypes that represent data constructors -class Constructor c where - -- | The name of the constructor - conName :: t c (f :: * -> *) a -> String - - -- | The fixity of the constructor - conFixity :: t c (f :: * -> *) a -> Fixity - conFixity = const Prefix - - -- | Marks if this constructor is a record - conIsRecord :: t c (f :: * -> *) a -> Bool - conIsRecord = const False - - --- | Datatype to represent the arity of a tuple. -data Arity = NoArity | Arity Int - deriving (Eq, Show, Ord, Read, Typeable) - --- | Datatype to represent the fixity of a constructor. An infix --- | declaration directly corresponds to an application of 'Infix'. -data Fixity = Prefix | Infix Associativity Int - deriving (Eq, Show, Ord, Read, Data, Typeable) - --- | Get the precedence of a fixity value. -prec :: Fixity -> Int -prec Prefix = 10 -prec (Infix _ n) = n - --- | Datatype to represent the associativity of a constructor -data Associativity = LeftAssociative - | RightAssociative - | NotAssociative - deriving (Eq, Show, Ord, Read, Bounded, Enum, Ix, Data, Typeable) - --- | Representable types of kind * -class Generic a where - type Rep a :: * -> * - -- | Convert from the datatype to its representation - from :: a -> Rep a x - -- | Convert from the representation to the datatype - to :: Rep a x -> a - --- | Representable types of kind * -> * -class Generic1 f where - type Rep1 f :: * -> * - -- | Convert from the datatype to its representation - from1 :: f a -> Rep1 f a - -- | Convert from the representation to the datatype - to1 :: Rep1 f a -> f a - -#endif - -#if !(MIN_VERSION_base(4,9,0)) --- | Constants of kind @#@ -data family URec (a :: *) (p :: *) - -# if MIN_VERSION_base(4,7,0) -deriving instance Typeable URec -# else -instance Typeable2 URec where - typeOf2 _ = -# if MIN_VERSION_base(4,4,0) - mkTyConApp (mkTyCon3 "generic-deriving" - "Generics.Deriving.Base.Internal" - "URec") [] -# else - mkTyConApp (mkTyCon "Generics.Deriving.Base.Internal.URec") [] -# endif -# endif - --- | Used for marking occurrences of 'Addr#' -data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } - deriving (Eq, Ord) - -instance Functor (URec (Ptr ())) where - fmap _ (UAddr a) = UAddr a - -instance Foldable (URec (Ptr ())) where - foldr _ z UAddr{} = z - foldMap _ UAddr{} = mempty - -instance Traversable (URec (Ptr ())) where - traverse _ (UAddr a) = pure (UAddr a) - --- | Used for marking occurrences of 'Char#' -data instance URec Char p = UChar { uChar# :: Char# } - deriving (Eq, Ord, Show) - -instance Functor (URec Char) where - fmap _ (UChar c) = UChar c - -instance Foldable (URec Char) where - foldr _ z UChar{} = z - foldMap _ UChar{} = mempty - -instance Traversable (URec Char) where - traverse _ (UChar c) = pure (UChar c) - --- | Used for marking occurrences of 'Double#' -data instance URec Double p = UDouble { uDouble# :: Double# } - deriving (Eq, Ord, Show) - -instance Functor (URec Double) where - fmap _ (UDouble d) = UDouble d - -instance Foldable (URec Double) where - foldr _ z UDouble{} = z - foldMap _ UDouble{} = mempty - -instance Traversable (URec Double) where - traverse _ (UDouble d) = pure (UDouble d) - --- | Used for marking occurrences of 'Float#' -data instance URec Float p = UFloat { uFloat# :: Float# } - deriving (Eq, Ord, Show) - -instance Functor (URec Float) where - fmap _ (UFloat f) = UFloat f - -instance Foldable (URec Float) where - foldr _ z UFloat{} = z - foldMap _ UFloat{} = mempty - -instance Traversable (URec Float) where - traverse _ (UFloat f) = pure (UFloat f) - --- | Used for marking occurrences of 'Int#' -data instance URec Int p = UInt { uInt# :: Int# } - deriving (Eq, Ord, Show) - -instance Functor (URec Int) where - fmap _ (UInt i) = UInt i - -instance Foldable (URec Int) where - foldr _ z UInt{} = z - foldMap _ UInt{} = mempty - -instance Traversable (URec Int) where - traverse _ (UInt i) = pure (UInt i) - --- | Used for marking occurrences of 'Word#' -data instance URec Word p = UWord { uWord# :: Word# } - deriving (Eq, Ord, Show) - -instance Functor (URec Word) where - fmap _ (UWord w) = UWord w - -instance Foldable (URec Word) where - foldr _ z UWord{} = z - foldMap _ UWord{} = mempty - -instance Traversable (URec Word) where - traverse _ (UWord w) = pure (UWord w) - --- | Type synonym for 'URec': 'Addr#' -type UAddr = URec (Ptr ()) --- | Type synonym for 'URec': 'Char#' -type UChar = URec Char --- | Type synonym for 'URec': 'Double#' -type UDouble = URec Double --- | Type synonym for 'URec': 'Float#' -type UFloat = URec Float --- | Type synonym for 'URec': 'Int#' -type UInt = URec Int --- | Type synonym for 'URec': 'Word#' -type UWord = URec Word -#endif +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 711+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Base.Internal (+-- * Introduction+--+-- |+--+-- Datatype-generic functions are are based on the idea of converting values of+-- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@.+-- The type @'Rep' T@ is+-- built from a limited set of type constructors, all provided by this module. A+-- datatype-generic function is then an overloaded function with instances+-- for most of these type constructors, together with a wrapper that performs+-- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need+-- a few generic instances in order to implement functionality that works for any+-- representable type.+--+-- Representable types are collected in the 'Generic' class, which defines the+-- associated type 'Rep' as well as conversion functions 'from' and 'to'.+-- Typically, you will not define 'Generic' instances by hand, but have the compiler+-- derive them for you.++-- ** Representing datatypes+--+-- |+--+-- The key to defining your own datatype-generic functions is to understand how to+-- represent datatypes using the given set of type constructors.+--+-- Let us look at an example first:+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- deriving 'Generic'+-- @+--+-- The above declaration (which requires the language pragma @DeriveGeneric@)+-- causes the following representation to be generated:+--+-- @+-- class 'Generic' (Tree a) where+-- type 'Rep' (Tree a) =+-- 'D1' D1Tree+-- ('C1' C1_0Tree+-- ('S1' 'NoSelector' ('Par0' a))+-- ':+:'+-- 'C1' C1_1Tree+-- ('S1' 'NoSelector' ('Rec0' (Tree a))+-- ':*:'+-- 'S1' 'NoSelector' ('Rec0' (Tree a))))+-- ...+-- @+--+-- /Hint:/ You can obtain information about the code being generated from GHC by passing+-- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using+-- the @:kind!@ command.+--+#if 0+-- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will+-- use 'Rec0' everywhere.+--+#endif+-- This is a lot of information! However, most of it is actually merely meta-information+-- that makes names of datatypes and constructors and more available on the type level.+--+-- Here is a reduced representation for 'Tree' with nearly all meta-information removed,+-- for now keeping only the most essential aspects:+--+-- @+-- instance 'Generic' (Tree a) where+-- type 'Rep' (Tree a) =+-- 'Par0' a+-- ':+:'+-- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a))+-- @+--+-- The @Tree@ datatype has two constructors. The representation of individual constructors+-- is combined using the binary type constructor ':+:'.+--+-- The first constructor consists of a single field, which is the parameter @a@. This is+-- represented as @'Par0' a@.+--+-- The second constructor consists of two fields. Each is a recursive field of type @Tree a@,+-- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using+-- the binary type constructor ':*:'.+--+-- Now let us explain the additional tags being used in the complete representation:+--+-- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with+-- this field of the constructor.+--+-- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is+-- the representation of the first and second constructor of datatype @Tree@, respectively.+-- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of+-- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful+-- because they are instances of the type class 'Constructor'. This type class can be used+-- to obtain information about the constructor in question, such as its name+-- or infix priority.+--+-- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the+-- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a+-- proxy type, and is useful by being an instance of class 'Datatype', which+-- can be used to obtain the name of a datatype, the module it has been defined in, and+-- whether it has been defined using @data@ or @newtype@.++-- ** Derived and fundamental representation types+--+-- |+--+-- There are many datatype-generic functions that do not distinguish between positions that+-- are parameters or positions that are recursive calls. There are also many datatype-generic+-- functions that do not care about the names of datatypes and constructors at all. To keep+-- the number of cases to consider in generic functions in such a situation to a minimum,+-- it turns out that many of the type constructors introduced above are actually synonyms,+-- defining them to be variants of a smaller set of constructors.++-- *** Individual fields of constructors: 'K1'+--+-- |+--+-- The type constructors 'Par0' and 'Rec0' are variants of 'K1':+--+-- @+-- type 'Par0' = 'K1' 'P'+-- type 'Rec0' = 'K1' 'R'+-- @+--+-- Here, 'P' and 'R' are type-level proxies again that do not have any associated values.++-- *** Meta information: 'M1'+--+-- |+--+-- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1':+--+-- @+-- type 'S1' = 'M1' 'S'+-- type 'C1' = 'M1' 'C'+-- type 'D1' = 'M1' 'D'+-- @+--+-- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create+-- several variants of 'M1'.++-- *** Additional generic representation type constructors+--+-- |+--+-- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur+-- in the representations of other datatypes.++-- **** Empty datatypes: 'V1'+--+-- |+--+-- For empty datatypes, 'V1' is used as a representation. For example,+--+-- @+-- data Empty deriving 'Generic'+-- @+--+-- yields+--+-- @+-- instance 'Generic' Empty where+-- type 'Rep' Empty = 'D1' D1Empty 'V1'+-- @++-- **** Constructors without fields: 'U1'+--+-- |+--+-- If a constructor has no arguments, then 'U1' is used as its representation. For example+-- the representation of 'Bool' is+--+-- @+-- instance 'Generic' Bool where+-- type 'Rep' Bool =+-- 'D1' D1Bool+-- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1')+-- @++-- *** Representation of types with many constructors or many fields+--+-- |+--+-- As ':+:' and ':*:' are just binary operators, one might ask what happens if the+-- datatype has more than two constructors, or a constructor with more than two+-- fields. The answer is simple: the operators are used several times, to combine+-- all the constructors and fields as needed. However, users /should not rely on+-- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is+-- free to choose any nesting it prefers. (In practice, the current implementation+-- tries to produce a more or less balanced nesting, so that the traversal of the+-- structure of the datatype from the root to a particular component can be performed+-- in logarithmic rather than linear time.)++-- ** Defining datatype-generic functions+--+-- |+--+-- A datatype-generic function comprises two parts:+--+-- 1. /Generic instances/ for the function, implementing it for most of the representation+-- type constructors introduced above.+--+-- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion+-- between the original value and its `Rep`-based representation and then invokes the+-- generic instances.+--+-- As an example, let us look at a function 'encode' that produces a naive, but lossless+-- bit encoding of values of various datatypes. So we are aiming to define a function+--+-- @+-- encode :: 'Generic' a => a -> [Bool]+-- @+--+-- where we use 'Bool' as our datatype for bits.+--+-- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized+-- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation+-- type constructors operate with kind @* -> *@ as base kind. But the type argument is never+-- being used. This may be changed at some point in the future. The class has a single method,+-- and we use the type we want our final function to have, but we replace the occurrences of+-- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used).+--+-- > class Encode' f where+-- > encode' :: f p -> [Bool]+--+-- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define+-- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'.++-- *** Definition of the generic representation types+--+-- |+--+-- In order to be able to do this, we need to know the actual definitions of these types:+--+-- @+-- data 'V1' p -- lifted version of Empty+-- data 'U1' p = 'U1' -- lifted version of ()+-- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either'+-- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,)+-- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c+-- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper+-- @+--+-- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either',+-- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value+-- of a specific type @c@, and 'M1' wraps a value of the generic type argument,+-- which in the lifted world is an @f p@ (where we do not care about @p@).++-- *** Generic instances+--+-- |+--+-- The instance for 'V1' is slightly awkward (but also rarely used):+--+-- @+-- instance Encode' 'V1' where+-- encode' x = undefined+-- @+--+-- There are no values of type @V1 p@ to pass (except undefined), so this is+-- actually impossible. One can ask why it is useful to define an instance for+-- 'V1' at all in this case? Well, an empty type can be used as an argument to+-- a non-empty type, and you might still want to encode the resulting type.+-- As a somewhat contrived example, consider @[Empty]@, which is not an empty+-- type, but contains just the empty list. The 'V1' instance ensures that we+-- can call the generic function on such types.+--+-- There is exactly one value of type 'U1', so encoding it requires no+-- knowledge, and we can use zero bits:+--+-- @+-- instance Encode' 'U1' where+-- encode' 'U1' = []+-- @+--+-- In the case for ':+:', we produce 'False' or 'True' depending on whether+-- the constructor of the value provided is located on the left or on the right:+--+-- @+-- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where+-- encode' ('L1' x) = False : encode' x+-- encode' ('R1' x) = True : encode' x+-- @+--+-- In the case for ':*:', we append the encodings of the two subcomponents:+--+-- @+-- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where+-- encode' (x ':*:' y) = encode' x ++ encode' y+-- @+--+-- The case for 'K1' is rather interesting. Here, we call the final function+-- 'encode' that we yet have to define, recursively. We will use another type+-- class 'Encode' for that function:+--+-- @+-- instance (Encode c) => Encode' ('K1' i c) where+-- encode' ('K1' x) = encode x+-- @+--+-- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define+-- a uniform instance here.+--+-- Similarly, we can define a uniform instance for 'M1', because we completely+-- disregard all meta-information:+--+-- @+-- instance (Encode' f) => Encode' ('M1' i t f) where+-- encode' ('M1' x) = encode' x+-- @+--+-- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'.++-- *** The wrapper and generic default+--+-- |+--+-- We now define class 'Encode' for the actual 'encode' function:+--+-- @+-- class Encode a where+-- encode :: a -> [Bool]+-- default encode :: ('Generic' a) => a -> [Bool]+-- encode x = encode' ('from' x)+-- @+--+-- The incoming 'x' is converted using 'from', then we dispatch to the+-- generic instances using 'encode''. We use this as a default definition+-- for 'encode'. We need the 'default encode' signature because ordinary+-- Haskell default methods must not introduce additional class constraints,+-- but our generic default does.+--+-- Defining a particular instance is now as simple as saying+--+-- @+-- instance (Encode a) => Encode (Tree a)+-- @+--+#if 0+-- /TODO:/ Add usage example?+--+#endif+-- The generic default is being used. In the future, it will hopefully be+-- possible to use @deriving Encode@ as well, but GHC does not yet support+-- that syntax for this situation.+--+-- Having 'Encode' as a class has the advantage that we can define+-- non-generic special cases, which is particularly useful for abstract+-- datatypes that have no structural representation. For example, given+-- a suitable integer encoding function 'encodeInt', we can define+--+-- @+-- instance Encode Int where+-- encode = encodeInt+-- @++-- *** Omitting generic instances+--+-- |+--+-- It is not always required to provide instances for all the generic+-- representation types, but omitting instances restricts the set of+-- datatypes the functions will work for:+--+-- * If no ':+:' instance is given, the function may still work for+-- empty datatypes or datatypes that have a single constructor,+-- but will fail on datatypes with more than one constructor.+--+-- * If no ':*:' instance is given, the function may still work for+-- datatypes where each constructor has just zero or one field,+-- in particular for enumeration types.+--+-- * If no 'K1' instance is given, the function may still work for+-- enumeration types, where no constructor has any fields.+--+-- * If no 'V1' instance is given, the function may still work for+-- any datatype that is not empty.+--+-- * If no 'U1' instance is given, the function may still work for+-- any datatype where each constructor has at least one field.+--+-- An 'M1' instance is always required (but it can just ignore the+-- meta-information, as is the case for 'encode' above).+#if 0+-- *** Using meta-information+--+-- |+--+-- TODO+#endif+-- ** Generic constructor classes+--+-- |+--+-- Datatype-generic functions as defined above work for a large class+-- of datatypes, including parameterized datatypes. (We have used 'Tree'+-- as our example above, which is of kind @* -> *@.) However, the+-- 'Generic' class ranges over types of kind @*@, and therefore, the+-- resulting generic functions (such as 'encode') must be parameterized+-- by a generic type argument of kind @*@.+--+-- What if we want to define generic classes that range over type+-- constructors (such as 'Functor', 'Traversable', or 'Foldable')?++-- *** The 'Generic1' class+--+-- |+--+-- Like 'Generic', there is a class 'Generic1' that defines a+-- representation 'Rep1' and conversion functions 'from1' and 'to1',+-- only that 'Generic1' ranges over types of kind @* -> *@.+-- The 'Generic1' class is also derivable.+--+-- The representation 'Rep1' is ever so slightly different from 'Rep'.+-- Let us look at 'Tree' as an example again:+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- deriving 'Generic1'+-- @+--+-- The above declaration causes the following representation to be generated:+--+-- class 'Generic1' Tree where+-- type 'Rep1' Tree =+-- 'D1' D1Tree+-- ('C1' C1_0Tree+-- ('S1' 'NoSelector' 'Par1')+-- ':+:'+-- 'C1' C1_1Tree+-- ('S1' 'NoSelector' ('Rec1' Tree)+-- ':*:'+-- 'S1' 'NoSelector' ('Rec1' Tree)))+-- ...+--+-- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well+-- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we+-- carry around the dummy type argument for kind-@*@-types, but there are+-- already enough different names involved without duplicating each of+-- these.)+--+-- What's different is that we now use 'Par1' to refer to the parameter+-- (and that parameter, which used to be @a@), is not mentioned explicitly+-- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@.++-- *** Representation of @* -> *@ types+--+-- |+--+-- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not+-- map to 'K1'. They are defined directly, as follows:+--+-- @+-- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p+-- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper+-- @+--+-- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply+-- wraps an application of @f@ to @p@.+--+-- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation,+-- namely when the datatype has a field that does not mention the parameter.+--+-- The declaration+--+-- @+-- data WithInt a = WithInt Int a+-- deriving 'Generic1'+-- @+--+-- yields+--+-- @+-- class 'Rep1' WithInt where+-- type 'Rep1' WithInt =+-- 'D1' D1WithInt+-- ('C1' C1_0WithInt+-- ('S1' 'NoSelector' ('Rec0' Int)+-- ':*:'+-- 'S1' 'NoSelector' 'Par1'))+-- @+--+-- If the parameter @a@ appears underneath a composition of other type constructors,+-- then the representation involves composition, too:+--+-- @+-- data Rose a = Fork a [Rose a]+-- @+--+-- yields+--+-- @+-- class 'Rep1' Rose where+-- type 'Rep1' Rose =+-- 'D1' D1Rose+-- ('C1' C1_0Rose+-- ('S1' 'NoSelector' 'Par1'+-- ':*:'+-- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose)+-- @+--+-- where+--+-- @+-- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) }+-- @++-- *** Representation of unlifted types+--+-- |+--+-- If one were to attempt to derive a Generic instance for a datatype with an+-- unlifted argument (for example, 'Int#'), one might expect the occurrence of+-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work,+-- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@.+-- In fact, polymorphism over unlifted types is disallowed completely.+--+-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int'+-- instead. With this approach, however, the programmer has no way of knowing+-- whether the 'Int' is actually an 'Int#' in disguise.+--+-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark+-- occurrences of common unlifted types:+--+-- @+-- data family URec a p+--+-- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' }+-- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' }+-- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' }+-- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' }+-- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' }+-- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' }+-- @+--+-- Several type synonyms are provided for convenience:+--+-- @+-- type 'UAddr' = 'URec' ('Ptr' ())+-- type 'UChar' = 'URec' 'Char'+-- type 'UDouble' = 'URec' 'Double'+-- type 'UFloat' = 'URec' 'Float'+-- type 'UInt' = 'URec' 'Int'+-- type 'UWord' = 'URec' 'Word'+-- @+--+-- The declaration+--+-- @+-- data IntHash = IntHash Int#+-- deriving 'Generic'+-- @+--+-- yields+--+-- @+-- instance 'Generic' IntHash where+-- type 'Rep' IntHash =+-- 'D1' D1IntHash+-- ('C1' C1_0IntHash+-- ('S1' 'NoSelector' 'UInt'))+-- @+--+-- Currently, only the six unlifted types listed above are generated, but this+-- may be extended to encompass more unlifted types in the future.+#if 0+-- *** Limitations+--+-- |+--+-- /TODO/+--+-- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion.+--+#endif+#if !(MIN_VERSION_base(4,4,0))+ -- * Generic representation types+ V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..)+ , (:+:)(..), (:*:)(..), (:.:)(..)++ -- ** Synonyms for convenience+ , Rec0, Par0, R, P+ , D1, C1, S1, D, C, S++ -- * Meta-information+ , Datatype(..), Constructor(..), Selector(..), NoSelector+ , Fixity(..), Associativity(..), Arity(..), prec++ -- * Generic type classes+ , Generic(..), Generic1(..),++#else+ module GHC.Generics,+#endif+#if !(MIN_VERSION_base(4,9,0))+ -- ** Unboxed representation types+ URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord+#endif+ ) where+++#if MIN_VERSION_base(4,4,0)+import GHC.Generics+#else+import Control.Applicative ( Alternative(..) )+import Control.Monad ( MonadPlus(..) )+import Control.Monad.Fix ( MonadFix(..), fix )+import Data.Data ( Data(..), DataType, constrIndex, mkDataType )+import Data.Ix ( Ix )+import Text.ParserCombinators.ReadPrec (pfail)+import Text.Read ( Read(..), parens, readListDefault, readListPrecDefault )+#endif++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ( Applicative(..) )+import Data.Foldable ( Foldable(..) )+import Data.Monoid ( Monoid(..) )+import Data.Traversable ( Traversable(..) )+import Data.Word ( Word )+#endif++#if !(MIN_VERSION_base(4,9,0))+import Data.Typeable+import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )+import GHC.Ptr ( Ptr )+#endif++#if !(MIN_VERSION_base(4,4,0))+--------------------------------------------------------------------------------+-- Representation types+--------------------------------------------------------------------------------++-- | Void: used for datatypes without constructors+data V1 p deriving Typeable++-- Implement these instances by hand to get the desired, maximally lazy behavior.+instance Functor V1 where+ fmap _ !_ = error "Void fmap"++instance Foldable V1 where+ foldr _ z _ = z+ foldMap _ _ = mempty++instance Traversable V1 where+ traverse _ x = pure (case x of !_ -> error "Void traverse")++instance Eq (V1 p) where+ _ == _ = True++instance Data p => Data (V1 p) where+ gfoldl _ _ !_ = error "Void gfoldl"+ gunfold _ _ c = case constrIndex c of+ _ -> error "Void gunfold"+ toConstr !_ = error "Void toConstr"+ dataTypeOf _ = v1DataType+ dataCast1 f = gcast1 f++v1DataType :: DataType+v1DataType = mkDataType "V1" []++instance Ord (V1 p) where+ compare _ _ = EQ++instance Show (V1 p) where+ showsPrec _ !_ = error "Void showsPrec"++-- Implement Read instance manually to get around an old GHC bug+-- (Trac #7931)+instance Read (V1 p) where+ readPrec = parens pfail+ readList = readListDefault+ readListPrec = readListPrecDefault++-- | Unit: used for constructors without arguments+data U1 p = U1+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance Functor U1 where+ fmap _ _ = U1++instance Applicative U1 where+ pure _ = U1+ _ <*> _ = U1++instance Alternative U1 where+ empty = U1+ _ <|> _ = U1++instance Monad U1 where+ return _ = U1+ _ >>= _ = U1++instance MonadPlus U1 where+ mzero = U1+ mplus _ _ = U1++instance Foldable U1 where+ foldMap _ _ = mempty+ {-# INLINE foldMap #-}+ fold _ = mempty+ {-# INLINE fold #-}+ foldr _ z _ = z+ {-# INLINE foldr #-}+ foldl _ z _ = z+ {-# INLINE foldl #-}+ foldl1 _ _ = error "foldl1: U1"+ foldr1 _ _ = error "foldr1: U1"++instance Traversable U1 where+ traverse _ _ = pure U1+ {-# INLINE traverse #-}+ sequenceA _ = pure U1+ {-# INLINE sequenceA #-}+ mapM _ _ = return U1+ {-# INLINE mapM #-}+ sequence _ = return U1+ {-# INLINE sequence #-}++-- | Used for marking occurrences of the parameter+newtype Par1 p = Par1 { unPar1 :: p }+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Typeable)++instance Applicative Par1 where+ pure a = Par1 a+ Par1 f <*> Par1 x = Par1 (f x)++instance Monad Par1 where+ return a = Par1 a+ Par1 x >>= f = f x++instance MonadFix Par1 where+ mfix f = Par1 (fix (unPar1 . f))++-- | Recursive calls of kind * -> *+newtype Rec1 f p = Rec1 { unRec1 :: f p }+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data)++instance Typeable1 f => Typeable1 (Rec1 f) where+ typeOf1 t = mkTyConApp rec1TyCon [typeOf1 (f t)]+ where+ f :: Rec1 f a -> f a+ f = undefined++rec1TyCon :: TyCon+rec1TyCon = mkTyCon "Generics.Deriving.Base.Internal.Rec1"++instance Applicative f => Applicative (Rec1 f) where+ pure a = Rec1 (pure a)+ Rec1 f <*> Rec1 x = Rec1 (f <*> x)++instance Alternative f => Alternative (Rec1 f) where+ empty = Rec1 empty+ Rec1 l <|> Rec1 r = Rec1 (l <|> r)++instance Monad f => Monad (Rec1 f) where+ return a = Rec1 (return a)+ Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a))++instance MonadFix f => MonadFix (Rec1 f) where+ mfix f = Rec1 (mfix (unRec1 . f))++instance MonadPlus f => MonadPlus (Rec1 f) where+ mzero = Rec1 mzero+ mplus (Rec1 a) (Rec1 b) = Rec1 (mplus a b)++-- | Constants, additional parameters and recursion of kind *+newtype K1 i c p = K1 { unK1 :: c }+ deriving (Eq, Ord, Read, Show, Functor, Data, Typeable)++instance Foldable (K1 i c) where+ foldr _ z K1{} = z+ foldMap _ K1{} = mempty++instance Traversable (K1 i c) where+ traverse _ (K1 c) = pure (K1 c)++-- | Meta-information (constructor names, etc.)+newtype M1 i c f p = M1 { unM1 :: f p }+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data)++instance (Typeable i, Typeable c, Typeable1 f) => Typeable1 (M1 i c f) where+ typeOf1 t = mkTyConApp m1TyCon [typeOf (i t), typeOf (c t), typeOf1 (f t)]+ where+ i :: M1 i c f p -> i+ i = undefined++ c :: M1 i c f p -> c+ c = undefined++ f :: M1 i c f p -> f p+ f = undefined++m1TyCon :: TyCon+m1TyCon = mkTyCon "Generics.Deriving.Base.Internal.M1"++instance Applicative f => Applicative (M1 i c f) where+ pure a = M1 (pure a)+ M1 f <*> M1 x = M1 (f <*> x)++instance Alternative f => Alternative (M1 i c f) where+ empty = M1 empty+ M1 l <|> M1 r = M1 (l <|> r)++instance Monad f => Monad (M1 i c f) where+ return a = M1 (return a)+ M1 x >>= f = M1 (x >>= \a -> unM1 (f a))++instance MonadPlus f => MonadPlus (M1 i c f) where+ mzero = M1 mzero+ mplus (M1 a) (M1 b) = M1 (mplus a b)++instance MonadFix f => MonadFix (M1 i c f) where+ mfix f = M1 (mfix (unM1. f))++-- | Sums: encode choice between constructors+infixr 5 :+:+data (:+:) f g p = L1 (f p) | R1 (g p)+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data)++instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where+ typeOf1 t = mkTyConApp conSumTyCon [typeOf1 (f t), typeOf1 (g t)]+ where+ f :: (f :+: g) p -> f p+ f = undefined++ g :: (f :+: g) p -> g p+ g = undefined++conSumTyCon :: TyCon+conSumTyCon = mkTyCon "Generics.Deriving.Base.Internal.:+:"++-- | Products: encode multiple arguments to constructors+infixr 6 :*:+data (:*:) f g p = f p :*: g p+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data)++instance (Typeable1 f, Typeable1 g) => Typeable1 (f :*: g) where+ typeOf1 t = mkTyConApp conProductTyCon [typeOf1 (f t), typeOf1 (g t)]+ where+ f :: (f :*: g) p -> f p+ f = undefined++ g :: (f :*: g) p -> g p+ g = undefined++conProductTyCon :: TyCon+conProductTyCon = mkTyCon "Generics.Deriving.Base.Internal.:*:"++instance (Applicative f, Applicative g) => Applicative (f :*: g) where+ pure a = pure a :*: pure a+ (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y)++instance (Alternative f, Alternative g) => Alternative (f :*: g) where+ empty = empty :*: empty+ (x1 :*: y1) <|> (x2 :*: y2) = (x1 <|> x2) :*: (y1 <|> y2)++instance (Monad f, Monad g) => Monad (f :*: g) where+ return a = return a :*: return a+ (m :*: n) >>= f = (m >>= \a -> fstP (f a)) :*: (n >>= \a -> sndP (f a))+ where+ fstP (a :*: _) = a+ sndP (_ :*: b) = b++instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where+ mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))+ where+ fstP (a :*: _) = a+ sndP (_ :*: b) = b++instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) where+ mzero = mzero :*: mzero+ (x1 :*: y1) `mplus` (x2 :*: y2) = (x1 `mplus` x2) :*: (y1 `mplus` y2)++-- | Composition of functors+infixr 7 :.:+newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) }+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data)++instance (Typeable1 f, Typeable1 g) => Typeable1 (f :.: g) where+ typeOf1 t = mkTyConApp conComposeTyCon [typeOf1 (f t), typeOf1 (g t)]+ where+ f :: (f :.: g) p -> f p+ f = undefined++ g :: (f :.: g) p -> g p+ g = undefined++conComposeTyCon :: TyCon+conComposeTyCon = mkTyCon "Generics.Deriving.Base.Internal.:.:"++instance (Applicative f, Applicative g) => Applicative (f :.: g) where+ pure x = Comp1 (pure (pure x))+ Comp1 f <*> Comp1 x = Comp1 (fmap (<*>) f <*> x)++instance (Alternative f, Applicative g) => Alternative (f :.: g) where+ empty = Comp1 empty+ Comp1 x <|> Comp1 y = Comp1 (x <|> y)++-- | Tag for K1: recursion (of kind *)+data R+ deriving Typeable+-- | Tag for K1: parameters (other than the last)+data P+ deriving Typeable++-- | Type synonym for encoding recursion (of kind *)+type Rec0 = K1 R+-- | Type synonym for encoding parameters (other than the last)+type Par0 = K1 P++-- | Tag for M1: datatype+data D+ deriving Typeable+-- | Tag for M1: constructor+data C+ deriving Typeable+-- | Tag for M1: record selector+data S+ deriving Typeable++-- | Type synonym for encoding meta-information for datatypes+type D1 = M1 D++-- | Type synonym for encoding meta-information for constructors+type C1 = M1 C++-- | Type synonym for encoding meta-information for record selectors+type S1 = M1 S++-- | Class for datatypes that represent datatypes+class Datatype d where+ -- | The name of the datatype, fully qualified+ datatypeName :: t d (f :: * -> *) a -> String+ moduleName :: t d (f :: * -> *) a -> String++-- | Class for datatypes that represent records+class Selector s where+ -- | The name of the selector+ selName :: t s (f :: * -> *) a -> String++-- | Used for constructor fields without a name+data NoSelector+ deriving Typeable++instance Selector NoSelector where selName _ = ""++-- | Class for datatypes that represent data constructors+class Constructor c where+ -- | The name of the constructor+ conName :: t c (f :: * -> *) a -> String++ -- | The fixity of the constructor+ conFixity :: t c (f :: * -> *) a -> Fixity+ conFixity = const Prefix++ -- | Marks if this constructor is a record+ conIsRecord :: t c (f :: * -> *) a -> Bool+ conIsRecord = const False+++-- | Datatype to represent the arity of a tuple.+data Arity = NoArity | Arity Int+ deriving (Eq, Show, Ord, Read, Typeable)++-- | Datatype to represent the fixity of a constructor. An infix+-- | declaration directly corresponds to an application of 'Infix'.+data Fixity = Prefix | Infix Associativity Int+ deriving (Eq, Show, Ord, Read, Data, Typeable)++-- | Get the precedence of a fixity value.+prec :: Fixity -> Int+prec Prefix = 10+prec (Infix _ n) = n++-- | Datatype to represent the associativity of a constructor+data Associativity = LeftAssociative+ | RightAssociative+ | NotAssociative+ deriving (Eq, Show, Ord, Read, Bounded, Enum, Ix, Data, Typeable)++-- | Representable types of kind *+class Generic a where+ type Rep a :: * -> *+ -- | Convert from the datatype to its representation+ from :: a -> Rep a x+ -- | Convert from the representation to the datatype+ to :: Rep a x -> a++-- | Representable types of kind * -> *+class Generic1 f where+ type Rep1 f :: * -> *+ -- | Convert from the datatype to its representation+ from1 :: f a -> Rep1 f a+ -- | Convert from the representation to the datatype+ to1 :: Rep1 f a -> f a++#endif++#if !(MIN_VERSION_base(4,9,0))+-- | Constants of kind @#@+data family URec (a :: *) (p :: *)++# if MIN_VERSION_base(4,7,0)+deriving instance Typeable URec+# else+instance Typeable2 URec where+ typeOf2 _ =+# if MIN_VERSION_base(4,4,0)+ mkTyConApp (mkTyCon3 "generic-deriving"+ "Generics.Deriving.Base.Internal"+ "URec") []+# else+ mkTyConApp (mkTyCon "Generics.Deriving.Base.Internal.URec") []+# endif+# endif++-- | Used for marking occurrences of 'Addr#'+data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# }+ deriving (Eq, Ord)++instance Functor (URec (Ptr ())) where+ fmap _ (UAddr a) = UAddr a++instance Foldable (URec (Ptr ())) where+ foldr _ z UAddr{} = z+ foldMap _ UAddr{} = mempty++instance Traversable (URec (Ptr ())) where+ traverse _ (UAddr a) = pure (UAddr a)++-- | Used for marking occurrences of 'Char#'+data instance URec Char p = UChar { uChar# :: Char# }+ deriving (Eq, Ord, Show)++instance Functor (URec Char) where+ fmap _ (UChar c) = UChar c++instance Foldable (URec Char) where+ foldr _ z UChar{} = z+ foldMap _ UChar{} = mempty++instance Traversable (URec Char) where+ traverse _ (UChar c) = pure (UChar c)++-- | Used for marking occurrences of 'Double#'+data instance URec Double p = UDouble { uDouble# :: Double# }+ deriving (Eq, Ord, Show)++instance Functor (URec Double) where+ fmap _ (UDouble d) = UDouble d++instance Foldable (URec Double) where+ foldr _ z UDouble{} = z+ foldMap _ UDouble{} = mempty++instance Traversable (URec Double) where+ traverse _ (UDouble d) = pure (UDouble d)++-- | Used for marking occurrences of 'Float#'+data instance URec Float p = UFloat { uFloat# :: Float# }+ deriving (Eq, Ord, Show)++instance Functor (URec Float) where+ fmap _ (UFloat f) = UFloat f++instance Foldable (URec Float) where+ foldr _ z UFloat{} = z+ foldMap _ UFloat{} = mempty++instance Traversable (URec Float) where+ traverse _ (UFloat f) = pure (UFloat f)++-- | Used for marking occurrences of 'Int#'+data instance URec Int p = UInt { uInt# :: Int# }+ deriving (Eq, Ord, Show)++instance Functor (URec Int) where+ fmap _ (UInt i) = UInt i++instance Foldable (URec Int) where+ foldr _ z UInt{} = z+ foldMap _ UInt{} = mempty++instance Traversable (URec Int) where+ traverse _ (UInt i) = pure (UInt i)++-- | Used for marking occurrences of 'Word#'+data instance URec Word p = UWord { uWord# :: Word# }+ deriving (Eq, Ord, Show)++instance Functor (URec Word) where+ fmap _ (UWord w) = UWord w++instance Foldable (URec Word) where+ foldr _ z UWord{} = z+ foldMap _ UWord{} = mempty++instance Traversable (URec Word) where+ traverse _ (UWord w) = pure (UWord w)++-- | Type synonym for 'URec': 'Addr#'+type UAddr = URec (Ptr ())+-- | Type synonym for 'URec': 'Char#'+type UChar = URec Char+-- | Type synonym for 'URec': 'Double#'+type UDouble = URec Double+-- | Type synonym for 'URec': 'Float#'+type UFloat = URec Float+-- | Type synonym for 'URec': 'Int#'+type UInt = URec Int+-- | Type synonym for 'URec': 'Word#'+type UWord = URec Word+#endif
src/Generics/Deriving/ConNames.hs view
@@ -1,72 +1,72 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -{- | -Module : Generics.Deriving.ConNames -Copyright : (c) 2012 University of Oxford -License : BSD3 - -Maintainer : generics@haskell.org -Stability : experimental -Portability : non-portable - -Summary: Return the name of all the constructors of a type. --} - -module Generics.Deriving.ConNames ( - - -- * Functionality for retrieving the names of the possible contructors - -- of a type or the constructor name of a given value - ConNames(..), conNames, conNameOf - - ) where - -import Generics.Deriving.Base - - -class ConNames f where - gconNames :: f a -> [String] - gconNameOf :: f a -> String - -instance (ConNames f, ConNames g) => ConNames (f :+: g) where - gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++ - gconNames (undefined :: g a) - - gconNameOf (L1 x) = gconNameOf x - gconNameOf (R1 x) = gconNameOf x - -instance (ConNames f) => ConNames (D1 c f) where - gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a) - - gconNameOf (M1 x) = gconNameOf x - -instance (Constructor c) => ConNames (C1 c f) where - gconNames x = [conName x] - - gconNameOf x = conName x - - --- We should never need any other instances. - - --- | Return the name of all the constructors of the type of the given term. -conNames :: (Generic a, ConNames (Rep a)) => a -> [String] -conNames x = gconNames (undefined `asTypeOf` (from x)) - --- | Return the name of the constructor of the given term -conNameOf :: (ConNames (Rep a), Generic a) => a -> String -conNameOf x = gconNameOf (from x) +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++{- |+Module : Generics.Deriving.ConNames+Copyright : (c) 2012 University of Oxford+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Summary: Return the name of all the constructors of a type.+-}++module Generics.Deriving.ConNames (++ -- * Functionality for retrieving the names of the possible contructors+ -- of a type or the constructor name of a given value+ ConNames(..), conNames, conNameOf++ ) where++import Generics.Deriving.Base+++class ConNames f where+ gconNames :: f a -> [String]+ gconNameOf :: f a -> String++instance (ConNames f, ConNames g) => ConNames (f :+: g) where+ gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) +++ gconNames (undefined :: g a)++ gconNameOf (L1 x) = gconNameOf x+ gconNameOf (R1 x) = gconNameOf x++instance (ConNames f) => ConNames (D1 c f) where+ gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a)++ gconNameOf (M1 x) = gconNameOf x++instance (Constructor c) => ConNames (C1 c f) where+ gconNames x = [conName x]++ gconNameOf x = conName x+++-- We should never need any other instances.+++-- | Return the name of all the constructors of the type of the given term.+conNames :: (Generic a, ConNames (Rep a)) => a -> [String]+conNames x = gconNames (undefined `asTypeOf` (from x))++-- | Return the name of the constructor of the given term+conNameOf :: (ConNames (Rep a), Generic a) => a -> String+conNameOf x = gconNameOf (from x)
src/Generics/Deriving/Copoint.hs view
@@ -1,179 +1,179 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Copoint ( - -- * GCopoint class - GCopoint(..) - - -- * Default method - , gcopointdefault - - -- * Internal class - , GCopoint'(..) - - ) where - -import Control.Applicative (WrappedMonad) - -import Data.Monoid (Dual) -import qualified Data.Monoid as Monoid (Sum) - -import Generics.Deriving.Base - -#if MIN_VERSION_base(4,6,0) -import Data.Ord (Down) -#else -import GHC.Exts (Down) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Functor.Sum as Functor (Sum) -import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid) -#endif - --------------------------------------------------------------------------------- --- Generic copoint --------------------------------------------------------------------------------- - --- General copoint may return 'Nothing' - -class GCopoint' t where - gcopoint' :: t a -> Maybe a - -instance GCopoint' V1 where - gcopoint' _ = Nothing - -instance GCopoint' U1 where - gcopoint' U1 = Nothing - -instance GCopoint' Par1 where - gcopoint' (Par1 a) = Just a - -instance GCopoint' (K1 i c) where - gcopoint' _ = Nothing - -instance GCopoint' f => GCopoint' (M1 i c f) where - gcopoint' (M1 a) = gcopoint' a - -instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where - gcopoint' (L1 a) = gcopoint' a - gcopoint' (R1 a) = gcopoint' a - --- Favours left "hole" for copoint -instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where - gcopoint' (a :*: b) = case (gcopoint' a) of - Just x -> Just x - Nothing -> gcopoint' b - -instance (GCopoint f) => GCopoint' (Rec1 f) where - gcopoint' (Rec1 a) = Just $ gcopoint a - -instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where - gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x - -class GCopoint d where - gcopoint :: d a -> a -#if __GLASGOW_HASKELL__ >= 701 - default gcopoint :: (Generic1 d, GCopoint' (Rep1 d)) - => (d a -> a) - gcopoint = gcopointdefault -#endif - -gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d)) - => d a -> a -gcopointdefault x = case (gcopoint' . from1 $ x) of - Just x' -> x' - Nothing -> error "Data type is not copointed" - --- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d - --- Base types instances -instance GCopoint ((,) a) where - gcopoint = gcopointdefault - -instance GCopoint ((,,) a b) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,) a b c) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,) a b c d) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,,) a b c d e) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,,,) a b c d e f) where - gcopoint = gcopointdefault - -#if MIN_VERSION_base(4,8,0) -instance GCopoint f => GCopoint (Alt f) where - gcopoint = gcopointdefault -#endif - -#if MIN_VERSION_base(4,9,0) -instance GCopoint (Arg a) where - gcopoint = gcopointdefault -#endif - -instance GCopoint Down where - gcopoint = gcopointdefault - -instance GCopoint Dual where - gcopoint = gcopointdefault - -#if MIN_VERSION_base(4,9,0) -instance GCopoint First where - gcopoint = gcopointdefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GCopoint Identity where - gcopoint = gcopointdefault -#endif - -#if MIN_VERSION_base(4,9,0) -instance GCopoint Last where - gcopoint = gcopointdefault - -instance GCopoint Max where - gcopoint = gcopointdefault - -instance GCopoint Min where - gcopoint = gcopointdefault - -instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where - gcopoint = gcopointdefault -#endif - -instance GCopoint Monoid.Sum where - gcopoint = gcopointdefault - -instance GCopoint m => GCopoint (WrappedMonad m) where - gcopoint = gcopointdefault - -#if MIN_VERSION_base(4,9,0) -instance GCopoint WrappedMonoid where - gcopoint = gcopointdefault -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Copoint (+ -- * GCopoint class+ GCopoint(..)++ -- * Default method+ , gcopointdefault++ -- * Internal class+ , GCopoint'(..)++ ) where++import Control.Applicative (WrappedMonad)++import Data.Monoid (Dual)+import qualified Data.Monoid as Monoid (Sum)++import Generics.Deriving.Base++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic copoint+--------------------------------------------------------------------------------++-- General copoint may return 'Nothing'++class GCopoint' t where+ gcopoint' :: t a -> Maybe a++instance GCopoint' V1 where+ gcopoint' _ = Nothing++instance GCopoint' U1 where+ gcopoint' U1 = Nothing++instance GCopoint' Par1 where+ gcopoint' (Par1 a) = Just a++instance GCopoint' (K1 i c) where+ gcopoint' _ = Nothing++instance GCopoint' f => GCopoint' (M1 i c f) where+ gcopoint' (M1 a) = gcopoint' a++instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where+ gcopoint' (L1 a) = gcopoint' a+ gcopoint' (R1 a) = gcopoint' a++-- Favours left "hole" for copoint+instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where+ gcopoint' (a :*: b) = case (gcopoint' a) of+ Just x -> Just x+ Nothing -> gcopoint' b++instance (GCopoint f) => GCopoint' (Rec1 f) where+ gcopoint' (Rec1 a) = Just $ gcopoint a++instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where+ gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x++class GCopoint d where+ gcopoint :: d a -> a+#if __GLASGOW_HASKELL__ >= 701+ default gcopoint :: (Generic1 d, GCopoint' (Rep1 d))+ => (d a -> a)+ gcopoint = gcopointdefault+#endif++gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d))+ => d a -> a+gcopointdefault x = case (gcopoint' . from1 $ x) of+ Just x' -> x'+ Nothing -> error "Data type is not copointed"++-- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d++-- Base types instances+instance GCopoint ((,) a) where+ gcopoint = gcopointdefault++instance GCopoint ((,,) a b) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,) a b c) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,,) a b c d) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,,,) a b c d e) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,,,,) a b c d e f) where+ gcopoint = gcopointdefault++#if MIN_VERSION_base(4,8,0)+instance GCopoint f => GCopoint (Alt f) where+ gcopoint = gcopointdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GCopoint (Arg a) where+ gcopoint = gcopointdefault+#endif++instance GCopoint Down where+ gcopoint = gcopointdefault++instance GCopoint Dual where+ gcopoint = gcopointdefault++#if MIN_VERSION_base(4,9,0)+instance GCopoint First where+ gcopoint = gcopointdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GCopoint Identity where+ gcopoint = gcopointdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GCopoint Last where+ gcopoint = gcopointdefault++instance GCopoint Max where+ gcopoint = gcopointdefault++instance GCopoint Min where+ gcopoint = gcopointdefault++instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where+ gcopoint = gcopointdefault+#endif++instance GCopoint Monoid.Sum where+ gcopoint = gcopointdefault++instance GCopoint m => GCopoint (WrappedMonad m) where+ gcopoint = gcopointdefault++#if MIN_VERSION_base(4,9,0)+instance GCopoint WrappedMonoid where+ gcopoint = gcopointdefault+#endif
src/Generics/Deriving/Default.hs view
@@ -1,281 +1,281 @@--- | --- Module : Generics.Deriving.Default --- Description : Default implementations of generic classes --- License : BSD-3-Clause --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- GHC 8.6 introduced the --- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@ --- language extension, which means a typeclass instance can be derived from --- an existing instance for an isomorphic type. Any newtype is isomorphic --- to the underlying type. By implementing a typeclass once for the newtype, --- it is possible to derive any typeclass for any type with a 'Generic' instance. --- --- For a number of classes, there are sensible default instantiations. In --- older GHCs, these can be supplied in the class definition, using the --- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=defaultsignatures#extension-DefaultSignatures DefaultSignatures>@ --- extension. However, only one default can be provided! With --- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@ --- it is now possible to choose from many --- default instantiations. --- --- This package contains a number of such classes. This module demonstrates --- how one might create a family of newtypes ('Default', 'Default1') for --- which such instances are defined. --- --- One might then use --- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@ --- as follows. The implementations of the data types are elided here (they --- are irrelevant). For most cases, either the deriving clause with the --- data type definition or the standalone clause will work (for some types --- it is necessary to supply the context explicitly using the latter form). --- See the source of this module for the implementations of instances for --- the 'Default' family of newtypes and the source of the test suite for --- some types which derive instances via these wrappers. - -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -# if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -# else -{-# LANGUAGE Trustworthy #-} -# endif -#endif -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -module Generics.Deriving.Default - ( -- * Kind @*@ (aka @Type@) - - -- $default - - Default(..) - - , -- * Kind @* -> *@ (aka @Type -> Type@) - - -- $default1 - - Default1(..) - - -- * Other kinds - - -- $other-kinds - ) where - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>)) -#endif -import Control.Monad (liftM) - -import Generics.Deriving.Base -import Generics.Deriving.Copoint -import Generics.Deriving.Enum -import Generics.Deriving.Eq -import Generics.Deriving.Foldable -import Generics.Deriving.Functor -import Generics.Deriving.Monoid -import Generics.Deriving.Semigroup -import Generics.Deriving.Show -import Generics.Deriving.Traversable -import Generics.Deriving.Uniplate - --- $default --- --- For classes which take an argument of kind 'Data.Kind.Type', use --- 'Default'. An example of this class from @base@ would be 'Eq', or --- 'Generic'. --- --- These examples use 'GShow' and 'GEq'; they are interchangeable. --- --- @ --- data MyType = … --- deriving ('Generic') --- deriving ('GEq') via ('Default' MyType) --- --- deriving via ('Default' MyType) instance 'GShow' MyType --- @ --- --- Instances may be parameterized by type variables. --- --- @ --- data MyType1 a = … --- deriving ('Generic') --- deriving ('GShow') via ('Default' (MyType1 a)) --- --- deriving via 'Default' (MyType1 a) instance 'GEq' a => 'GEq' (MyType1 a) --- @ --- --- These types both require instances for 'Generic'. This is because the --- implementations of 'geq' and 'gshowsPrec' for @'Default' b@ have a @'Generic' --- b@ constraint, i.e. the type corresponding to @b@ require a 'Generic' --- instance. For these two types, that means instances for @'Generic' MyType@ --- and @'Generic' (MyType1 a)@ respectively. --- --- It also means the 'Generic' instance is not needed when there is already --- a generic instance for the type used to derive the relevant instances. --- For an example, see the documentation of the 'GShow' instance for --- 'Default', below. - --- | This newtype wrapper can be used to derive default instances for --- classes taking an argument of kind 'Data.Kind.Type'. -newtype Default a = Default { unDefault :: a } - --- $default1 --- --- For classes which take an argument of kind @'Data.Kind.Type' -> --- 'Data.Kind.Type'@, use 'Default1'. An example of this class from @base@ --- would be 'Data.Functor.Classes.Eq1', or 'Generic1'. --- --- Unlike for @MyType1@, there can be no implementation of these classes for @MyType :: 'Data.Kind.Type'@. --- --- @ --- data MyType1 a = … --- deriving ('Generic1') --- deriving ('GFunctor') via ('Default1' MyType1) --- --- deriving via ('Default1' MyType1) instance 'GFoldable' MyType1 --- @ --- --- Note that these instances require a @'Generic1' MyType1@ constraint as --- 'gmap' and 'gfoldMap' have @'Generic1' a@ constraints on the --- implementations for @'Default1' a@. - --- | This newtype wrapper can be used to derive default instances for --- classes taking an argument of kind @'Data.Kind.Type' -> 'Data.Kind.Type'@. -newtype Default1 f a = Default1 { unDefault1 :: f a } - --- $other-kinds --- --- These principles extend to classes taking arguments of other kinds. - --------------------------------------------------------------------------------- --- Eq --------------------------------------------------------------------------------- - -instance (Generic a, GEq' (Rep a)) => GEq (Default a) where - -- geq :: Default a -> Default a -> Bool - Default x `geq` Default y = x `geqdefault` y - --------------------------------------------------------------------------------- --- Enum --------------------------------------------------------------------------------- - --- | The 'Enum' class in @base@ is slightly different; it comprises 'toEnum' and --- 'fromEnum'. "Generics.Deriving.Enum" provides functions 'toEnumDefault' --- and 'fromEnumDefault'. -instance (Generic a, GEq a, Enum' (Rep a)) => GEnum (Default a) where - -- genum :: [Default a] - genum = Default . to <$> enum' - --------------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------------- - --- | For example, with this type: --- --- @ --- newtype TestShow = TestShow 'Bool' --- deriving ('GShow') via ('Default' 'Bool') --- @ --- --- 'gshow' for @TestShow@ would produce the same string as `gshow` for --- 'Bool'. --- --- In this example, @TestShow@ requires no 'Generic' instance, as the --- constraint on 'gshowsPrec' from @'Default' 'Bool'@ is @'Generic' 'Bool'@. --- --- In general, when using a newtype wrapper, the instance can be derived --- via the wrapped type, as here (via @'Default' 'Bool'@ rather than @'Default' --- TestShow@). -instance (Generic a, GShow' (Rep a)) => GShow (Default a) where - -- gshowsPrec :: Int -> Default a -> ShowS - gshowsPrec n (Default x) = gshowsPrecdefault n x - --------------------------------------------------------------------------------- --- Semigroup --------------------------------------------------------------------------------- - --- | Semigroups often have many sensible implementations of --- 'Data.Semigroup.<>' / 'gsappend', and therefore no sensible default. --- Indeed, there is no 'GSemigroup'' instance for representations of sum --- types. --- --- In other cases, one may wish to use the existing wrapper newtypes in --- @base@, such as the following (using 'Data.Semigroup.First'): --- --- @ --- newtype FirstSemigroup = FirstSemigroup 'Bool' --- deriving stock ('Eq', 'Show') --- deriving ('GSemigroup') via ('Data.Semigroup.First' 'Bool') --- @ --- -instance (Generic a, GSemigroup' (Rep a)) => GSemigroup (Default a) where - -- gsappend :: Default a -> Default a -> Default a - Default x `gsappend` Default y = Default $ x `gsappenddefault` y - --------------------------------------------------------------------------------- --- Monoid --------------------------------------------------------------------------------- - -instance (Generic a, GMonoid' (Rep a)) => GMonoid (Default a) where - -- gmempty :: Default a - gmempty = Default gmemptydefault - - -- gmappend :: Default a -> Default a -> Default a - Default x `gmappend` Default y = Default $ x `gmappenddefault` y - --------------------------------------------------------------------------------- --- Uniplate --------------------------------------------------------------------------------- - -instance (Generic a, Uniplate' (Rep a) a, Context' (Rep a) a) => Uniplate (Default a) where - - -- children :: Default a -> [Default a] - -- context :: Default a -> [Default a] -> Default a - -- descend :: (Default a -> Default a) -> Default a -> Default a - -- descendM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a) - -- transform :: (Default a -> Default a) -> Default a -> Default a - -- transformM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a) - - children (Default x) = Default <$> childrendefault x - context (Default x) ys = Default $ contextdefault x (unDefault <$> ys) - descend f (Default x) = Default $ descenddefault (unDefault . f . Default) x - descendM f (Default x) = liftM Default $ descendMdefault (liftM unDefault . f . Default) x - transform f (Default x) = Default $ transformdefault (unDefault . f . Default) x - transformM f (Default x) = liftM Default $ transformMdefault (liftM unDefault . f . Default) x - --------------------------------------------------------------------------------- --- Functor --------------------------------------------------------------------------------- - -instance (Generic1 f, GFunctor' (Rep1 f)) => GFunctor (Default1 f) where - -- gmap :: (a -> b) -> (Default1 f) a -> (Default1 f) b - gmap f (Default1 fx) = Default1 $ gmapdefault f fx - --------------------------------------------------- --- Copoint --------------------------------------------------- - -instance (Generic1 f, GCopoint' (Rep1 f)) => GCopoint (Default1 f) where - -- gcopoint :: Default1 f a -> a - gcopoint = gcopointdefault . unDefault1 - --------------------------------------------------- --- Foldable --------------------------------------------------- - -instance (Generic1 t, GFoldable' (Rep1 t)) => GFoldable (Default1 t) where - -- gfoldMap :: Monoid m => (a -> m) -> Default1 t a -> m - gfoldMap f (Default1 tx) = gfoldMapdefault f tx - --------------------------------------------------- --- Traversable --------------------------------------------------- - -instance (Generic1 t, GFunctor' (Rep1 t), GFoldable' (Rep1 t), GTraversable' (Rep1 t)) => GTraversable (Default1 t) where - -- gtraverse :: Applicative f => (a -> f b) -> Default1 t a -> f (Default1 t b) - gtraverse f (Default1 fx) = Default1 <$> gtraversedefault f fx +-- |+-- Module : Generics.Deriving.Default+-- Description : Default implementations of generic classes+-- License : BSD-3-Clause+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- GHC 8.6 introduced the+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@+-- language extension, which means a typeclass instance can be derived from+-- an existing instance for an isomorphic type. Any newtype is isomorphic+-- to the underlying type. By implementing a typeclass once for the newtype,+-- it is possible to derive any typeclass for any type with a 'Generic' instance.+--+-- For a number of classes, there are sensible default instantiations. In+-- older GHCs, these can be supplied in the class definition, using the+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=defaultsignatures#extension-DefaultSignatures DefaultSignatures>@+-- extension. However, only one default can be provided! With+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@+-- it is now possible to choose from many+-- default instantiations.+--+-- This package contains a number of such classes. This module demonstrates+-- how one might create a family of newtypes ('Default', 'Default1') for+-- which such instances are defined.+--+-- One might then use+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@+-- as follows. The implementations of the data types are elided here (they+-- are irrelevant). For most cases, either the deriving clause with the+-- data type definition or the standalone clause will work (for some types+-- it is necessary to supply the context explicitly using the latter form).+-- See the source of this module for the implementations of instances for+-- the 'Default' family of newtypes and the source of the test suite for+-- some types which derive instances via these wrappers.++{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+# else+{-# LANGUAGE Trustworthy #-}+# endif+#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Generics.Deriving.Default+ ( -- * Kind @*@ (aka @Type@)++ -- $default++ Default(..)++ , -- * Kind @* -> *@ (aka @Type -> Type@)++ -- $default1++ Default1(..)++ -- * Other kinds++ -- $other-kinds+ ) where++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ((<$>))+#endif+import Control.Monad (liftM)++import Generics.Deriving.Base+import Generics.Deriving.Copoint+import Generics.Deriving.Enum+import Generics.Deriving.Eq+import Generics.Deriving.Foldable+import Generics.Deriving.Functor+import Generics.Deriving.Monoid+import Generics.Deriving.Semigroup+import Generics.Deriving.Show+import Generics.Deriving.Traversable+import Generics.Deriving.Uniplate++-- $default+--+-- For classes which take an argument of kind 'Data.Kind.Type', use+-- 'Default'. An example of this class from @base@ would be 'Eq', or+-- 'Generic'.+--+-- These examples use 'GShow' and 'GEq'; they are interchangeable.+--+-- @+-- data MyType = …+-- deriving ('Generic')+-- deriving ('GEq') via ('Default' MyType)+--+-- deriving via ('Default' MyType) instance 'GShow' MyType+-- @+--+-- Instances may be parameterized by type variables.+--+-- @+-- data MyType1 a = …+-- deriving ('Generic')+-- deriving ('GShow') via ('Default' (MyType1 a))+--+-- deriving via 'Default' (MyType1 a) instance 'GEq' a => 'GEq' (MyType1 a)+-- @+--+-- These types both require instances for 'Generic'. This is because the+-- implementations of 'geq' and 'gshowsPrec' for @'Default' b@ have a @'Generic'+-- b@ constraint, i.e. the type corresponding to @b@ require a 'Generic'+-- instance. For these two types, that means instances for @'Generic' MyType@+-- and @'Generic' (MyType1 a)@ respectively.+--+-- It also means the 'Generic' instance is not needed when there is already+-- a generic instance for the type used to derive the relevant instances.+-- For an example, see the documentation of the 'GShow' instance for+-- 'Default', below.++-- | This newtype wrapper can be used to derive default instances for+-- classes taking an argument of kind 'Data.Kind.Type'.+newtype Default a = Default { unDefault :: a }++-- $default1+--+-- For classes which take an argument of kind @'Data.Kind.Type' ->+-- 'Data.Kind.Type'@, use 'Default1'. An example of this class from @base@+-- would be 'Data.Functor.Classes.Eq1', or 'Generic1'.+--+-- Unlike for @MyType1@, there can be no implementation of these classes for @MyType :: 'Data.Kind.Type'@.+--+-- @+-- data MyType1 a = …+-- deriving ('Generic1')+-- deriving ('GFunctor') via ('Default1' MyType1)+--+-- deriving via ('Default1' MyType1) instance 'GFoldable' MyType1+-- @+--+-- Note that these instances require a @'Generic1' MyType1@ constraint as+-- 'gmap' and 'gfoldMap' have @'Generic1' a@ constraints on the+-- implementations for @'Default1' a@.++-- | This newtype wrapper can be used to derive default instances for+-- classes taking an argument of kind @'Data.Kind.Type' -> 'Data.Kind.Type'@.+newtype Default1 f a = Default1 { unDefault1 :: f a }++-- $other-kinds+--+-- These principles extend to classes taking arguments of other kinds.++--------------------------------------------------------------------------------+-- Eq+--------------------------------------------------------------------------------++instance (Generic a, GEq' (Rep a)) => GEq (Default a) where+ -- geq :: Default a -> Default a -> Bool+ Default x `geq` Default y = x `geqdefault` y++--------------------------------------------------------------------------------+-- Enum+--------------------------------------------------------------------------------++-- | The 'Enum' class in @base@ is slightly different; it comprises 'toEnum' and+-- 'fromEnum'. "Generics.Deriving.Enum" provides functions 'toEnumDefault'+-- and 'fromEnumDefault'.+instance (Generic a, GEq a, Enum' (Rep a)) => GEnum (Default a) where+ -- genum :: [Default a]+ genum = Default . to <$> enum'++--------------------------------------------------------------------------------+-- Show+--------------------------------------------------------------------------------++-- | For example, with this type:+--+-- @+-- newtype TestShow = TestShow 'Bool'+-- deriving ('GShow') via ('Default' 'Bool')+-- @+--+-- 'gshow' for @TestShow@ would produce the same string as `gshow` for+-- 'Bool'.+--+-- In this example, @TestShow@ requires no 'Generic' instance, as the+-- constraint on 'gshowsPrec' from @'Default' 'Bool'@ is @'Generic' 'Bool'@.+--+-- In general, when using a newtype wrapper, the instance can be derived+-- via the wrapped type, as here (via @'Default' 'Bool'@ rather than @'Default'+-- TestShow@).+instance (Generic a, GShow' (Rep a)) => GShow (Default a) where+ -- gshowsPrec :: Int -> Default a -> ShowS+ gshowsPrec n (Default x) = gshowsPrecdefault n x++--------------------------------------------------------------------------------+-- Semigroup+--------------------------------------------------------------------------------++-- | Semigroups often have many sensible implementations of+-- 'Data.Semigroup.<>' / 'gsappend', and therefore no sensible default.+-- Indeed, there is no 'GSemigroup'' instance for representations of sum+-- types.+--+-- In other cases, one may wish to use the existing wrapper newtypes in+-- @base@, such as the following (using 'Data.Semigroup.First'):+--+-- @+-- newtype FirstSemigroup = FirstSemigroup 'Bool'+-- deriving stock ('Eq', 'Show')+-- deriving ('GSemigroup') via ('Data.Semigroup.First' 'Bool')+-- @+--+instance (Generic a, GSemigroup' (Rep a)) => GSemigroup (Default a) where+ -- gsappend :: Default a -> Default a -> Default a+ Default x `gsappend` Default y = Default $ x `gsappenddefault` y++--------------------------------------------------------------------------------+-- Monoid+--------------------------------------------------------------------------------++instance (Generic a, GMonoid' (Rep a)) => GMonoid (Default a) where+ -- gmempty :: Default a+ gmempty = Default gmemptydefault++ -- gmappend :: Default a -> Default a -> Default a+ Default x `gmappend` Default y = Default $ x `gmappenddefault` y++--------------------------------------------------------------------------------+-- Uniplate+--------------------------------------------------------------------------------++instance (Generic a, Uniplate' (Rep a) a, Context' (Rep a) a) => Uniplate (Default a) where++ -- children :: Default a -> [Default a]+ -- context :: Default a -> [Default a] -> Default a+ -- descend :: (Default a -> Default a) -> Default a -> Default a+ -- descendM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a)+ -- transform :: (Default a -> Default a) -> Default a -> Default a+ -- transformM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a)++ children (Default x) = Default <$> childrendefault x+ context (Default x) ys = Default $ contextdefault x (unDefault <$> ys)+ descend f (Default x) = Default $ descenddefault (unDefault . f . Default) x+ descendM f (Default x) = liftM Default $ descendMdefault (liftM unDefault . f . Default) x+ transform f (Default x) = Default $ transformdefault (unDefault . f . Default) x+ transformM f (Default x) = liftM Default $ transformMdefault (liftM unDefault . f . Default) x++--------------------------------------------------------------------------------+-- Functor+--------------------------------------------------------------------------------++instance (Generic1 f, GFunctor' (Rep1 f)) => GFunctor (Default1 f) where+ -- gmap :: (a -> b) -> (Default1 f) a -> (Default1 f) b+ gmap f (Default1 fx) = Default1 $ gmapdefault f fx++--------------------------------------------------+-- Copoint+--------------------------------------------------++instance (Generic1 f, GCopoint' (Rep1 f)) => GCopoint (Default1 f) where+ -- gcopoint :: Default1 f a -> a+ gcopoint = gcopointdefault . unDefault1++--------------------------------------------------+-- Foldable+--------------------------------------------------++instance (Generic1 t, GFoldable' (Rep1 t)) => GFoldable (Default1 t) where+ -- gfoldMap :: Monoid m => (a -> m) -> Default1 t a -> m+ gfoldMap f (Default1 tx) = gfoldMapdefault f tx++--------------------------------------------------+-- Traversable+--------------------------------------------------++instance (Generic1 t, GFunctor' (Rep1 t), GFoldable' (Rep1 t), GTraversable' (Rep1 t)) => GTraversable (Default1 t) where+ -- gtraverse :: Applicative f => (a -> f b) -> Default1 t a -> f (Default1 t b)+ gtraverse f (Default1 fx) = Default1 <$> gtraversedefault f fx
src/Generics/Deriving/Enum.hs view
@@ -1,1144 +1,1143 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#include "HsBaseConfig.h" - -module Generics.Deriving.Enum ( - - -- * Generic enum class - GEnum(..) - - -- * Default definitions for GEnum - , genumDefault, toEnumDefault, fromEnumDefault - - -- * Internal enum class - , Enum'(..) - - -- * Generic Ix class - , GIx(..) - - -- * Default definitions for GIx - , rangeDefault, indexDefault, inRangeDefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Int -import Data.Monoid (All, Any, Dual, Product, Sum) -import qualified Data.Monoid as Monoid (First, Last) -import Data.Word - -import Foreign.C.Types -import Foreign.Ptr - -import Generics.Deriving.Base -import Generics.Deriving.Eq - -import System.Exit (ExitCode) -import System.Posix.Types - -#if MIN_VERSION_base(4,4,0) -import Data.Complex (Complex) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Coerce (coerce) -import Data.Proxy (Proxy) -#else -import Unsafe.Coerce (unsafeCoerce) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Numeric.Natural (Natural) -#endif - -#if MIN_VERSION_base(4,9,0) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Semigroup as Semigroup (First, Last) -import Data.Semigroup (Arg, Max, Min, WrappedMonoid) -#endif - ------------------------------------------------------------------------------ --- Utility functions for Enum' ------------------------------------------------------------------------------ - -infixr 5 ||| - --- | Interleave elements from two lists. Similar to (++), but swap left and --- right arguments on every recursive application. --- --- From Mark Jones' talk at AFP2008 -(|||) :: [a] -> [a] -> [a] -[] ||| ys = ys -(x:xs) ||| ys = x : ys ||| xs - --- | Diagonalization of nested lists. Ensure that some elements from every --- sublist will be included. Handles infinite sublists. --- --- From Mark Jones' talk at AFP2008 -diag :: [[a]] -> [a] -diag = concat . foldr skew [] . map (map (\x -> [x])) - -skew :: [[a]] -> [[a]] -> [[a]] -skew [] ys = ys -skew (x:xs) ys = x : combine (++) xs ys - -combine :: (a -> a -> a) -> [a] -> [a] -> [a] -combine _ xs [] = xs -combine _ [] ys = ys -combine f (x:xs) (y:ys) = f x y : combine f xs ys - -findIndex :: (a -> Bool) -> [a] -> Maybe Int -findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] - in if (null l) - then Nothing - else Just (head l) - --------------------------------------------------------------------------------- --- Generic enum --------------------------------------------------------------------------------- - -class Enum' f where - enum' :: [f a] - -instance Enum' U1 where - enum' = [U1] - -instance (GEnum c) => Enum' (K1 i c) where - enum' = map K1 genum - -instance (Enum' f) => Enum' (M1 i c f) where - enum' = map M1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :+: g) where - enum' = map L1 enum' ||| map R1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :*: g) where - enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] - -genumDefault :: (Generic a, Enum' (Rep a)) => [a] -genumDefault = map to enum' - -toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a -toEnumDefault i = let l = enum' - in if (length l > i) - then to (l !! i) - else error "toEnum: invalid index" - -fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a)) - => a -> Int -fromEnumDefault x = case findIndex (geq x) (map to enum') of - Nothing -> error "fromEnum: no corresponding index" - Just i -> i - - -class GEnum a where - genum :: [a] - -#if __GLASGOW_HASKELL__ >= 701 - default genum :: (Generic a, Enum' (Rep a)) => [a] - genum = genumDefault -#endif - -genumNumUnbounded :: Num a => [a] -genumNumUnbounded = pos 0 ||| neg 0 where - pos n = n : pos (n + 1) - neg n = (n-1) : neg (n - 1) - -genumNumSigned :: (Bounded a, Enum a, Num a) => [a] -genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound] - -genumNumUnsigned :: (Enum a, Num a) => [a] -genumNumUnsigned = [0 ..] - -#if !(MIN_VERSION_base(4,7,0)) -coerce :: a -> b -coerce = unsafeCoerce -#endif - --- Base types instances -instance GEnum () where - genum = genumDefault - -instance (GEnum a, GEnum b) => GEnum (a, b) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f) - => GEnum (a, b, c, d, e, f) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g) - => GEnum (a, b, c, d, e, f, g) where - genum = genumDefault - -instance GEnum a => GEnum [a] where - genum = genumDefault - -instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where - genum = genumDefault - -instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where - genum = genumDefault - -instance GEnum (f (g p)) => GEnum ((f :.: g) p) where - genum = genumDefault - -instance GEnum All where - genum = genumDefault - -#if MIN_VERSION_base(4,8,0) -instance GEnum (f a) => GEnum (Alt f a) where - genum = genumDefault -#endif - -instance GEnum Any where - genum = genumDefault - -#if MIN_VERSION_base(4,9,0) -instance (GEnum a, GEnum b) => GEnum (Arg a b) where - genum = genumDefault -#endif - -#if !(MIN_VERSION_base(4,9,0)) -instance GEnum Arity where - genum = genumDefault -#endif - -instance GEnum Associativity where - genum = genumDefault - -instance GEnum Bool where - genum = genumDefault - -#if defined(HTYPE_CC_T) -instance GEnum CCc where - genum = coerce (genum :: [HTYPE_CC_T]) -#endif - -instance GEnum CChar where - genum = coerce (genum :: [HTYPE_CHAR]) - -instance GEnum CClock where - genum = coerce (genum :: [HTYPE_CLOCK_T]) - -#if defined(HTYPE_DEV_T) -instance GEnum CDev where - genum = coerce (genum :: [HTYPE_DEV_T]) -#endif - -instance GEnum CDouble where - genum = coerce (genum :: [HTYPE_DOUBLE]) - -instance GEnum CFloat where - genum = coerce (genum :: [HTYPE_FLOAT]) - -#if defined(HTYPE_GID_T) -instance GEnum CGid where - genum = coerce (genum :: [HTYPE_GID_T]) -#endif - -#if defined(HTYPE_INO_T) -instance GEnum CIno where - genum = coerce (genum :: [HTYPE_INO_T]) -#endif - -instance GEnum CInt where - genum = coerce (genum :: [HTYPE_INT]) - -instance GEnum CIntMax where - genum = coerce (genum :: [HTYPE_INTMAX_T]) - -instance GEnum CIntPtr where - genum = coerce (genum :: [HTYPE_INTPTR_T]) - -instance GEnum CLLong where - genum = coerce (genum :: [HTYPE_LONG_LONG]) - -instance GEnum CLong where - genum = coerce (genum :: [HTYPE_LONG]) - -#if defined(HTYPE_MODE_T) -instance GEnum CMode where - genum = coerce (genum :: [HTYPE_MODE_T]) -#endif - -#if defined(HTYPE_NLINK_T) -instance GEnum CNlink where - genum = coerce (genum :: [HTYPE_NLINK_T]) -#endif - -#if defined(HTYPE_OFF_T) -instance GEnum COff where - genum = coerce (genum :: [HTYPE_OFF_T]) -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEnum a => GEnum (Complex a) where - genum = genumDefault -#endif - -instance GEnum a => GEnum (Const a b) where - genum = genumDefault - -#if defined(HTYPE_PID_T) -instance GEnum CPid where - genum = coerce (genum :: [HTYPE_PID_T]) -#endif - -instance GEnum CPtrdiff where - genum = coerce (genum :: [HTYPE_PTRDIFF_T]) - -#if defined(HTYPE_RLIM_T) -instance GEnum CRLim where - genum = coerce (genum :: [HTYPE_RLIM_T]) -#endif - -instance GEnum CSChar where - genum = coerce (genum :: [HTYPE_SIGNED_CHAR]) - -#if defined(HTYPE_SPEED_T) -instance GEnum CSpeed where - genum = coerce (genum :: [HTYPE_SPEED_T]) -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEnum CSUSeconds where - genum = coerce (genum :: [HTYPE_SUSECONDS_T]) -#endif - -instance GEnum CShort where - genum = coerce (genum :: [HTYPE_SHORT]) - -instance GEnum CSigAtomic where -#if defined(HTYPE_SIG_ATOMIC_T) - genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T]) -#else - genum = coerce (genum :: [Int32]) -#endif - -instance GEnum CSize where - genum = coerce (genum :: [HTYPE_SIZE_T]) - -#if defined(HTYPE_SSIZE_T) -instance GEnum CSsize where - genum = coerce (genum :: [HTYPE_SSIZE_T]) -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GEnum CTcflag where - genum = coerce (genum :: [HTYPE_TCFLAG_T]) -#endif - -instance GEnum CTime where - genum = coerce (genum :: [HTYPE_TIME_T]) - -instance GEnum CUChar where - genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR]) - -#if defined(HTYPE_UID_T) -instance GEnum CUid where - genum = coerce (genum :: [HTYPE_UID_T]) -#endif - -instance GEnum CUInt where - genum = coerce (genum :: [HTYPE_UNSIGNED_INT]) - -instance GEnum CUIntMax where - genum = coerce (genum :: [HTYPE_UINTMAX_T]) - -instance GEnum CUIntPtr where - genum = coerce (genum :: [HTYPE_UINTPTR_T]) - -instance GEnum CULLong where - genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG]) - -instance GEnum CULong where - genum = coerce (genum :: [HTYPE_UNSIGNED_LONG]) - -#if MIN_VERSION_base(4,4,0) -instance GEnum CUSeconds where - genum = coerce (genum :: [HTYPE_USECONDS_T]) -#endif - -instance GEnum CUShort where - genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT]) - -instance GEnum CWchar where - genum = coerce (genum :: [HTYPE_WCHAR_T]) - -instance GEnum Double where - genum = genumNumUnbounded - -instance GEnum a => GEnum (Dual a) where - genum = genumDefault - -instance (GEnum a, GEnum b) => GEnum (Either a b) where - genum = genumDefault - -instance GEnum ExitCode where - genum = genumDefault - -instance GEnum Fd where - genum = coerce (genum :: [CInt]) - -instance GEnum a => GEnum (Monoid.First a) where - genum = genumDefault - -#if MIN_VERSION_base(4,9,0) -instance GEnum a => GEnum (Semigroup.First a) where - genum = genumDefault -#endif - -instance GEnum Fixity where - genum = genumDefault - -instance GEnum Float where - genum = genumNumUnbounded - -#if MIN_VERSION_base(4,8,0) -instance GEnum a => GEnum (Identity a) where - genum = genumDefault -#endif - -instance GEnum Int where - genum = genumNumSigned - -instance GEnum Int8 where - genum = genumNumSigned - -instance GEnum Int16 where - genum = genumNumSigned - -instance GEnum Int32 where - genum = genumNumSigned - -instance GEnum Int64 where - genum = genumNumSigned - -instance GEnum Integer where - genum = genumNumUnbounded - -instance GEnum IntPtr where - genum = genumNumSigned - -instance GEnum c => GEnum (K1 i c p) where - genum = genumDefault - -instance GEnum a => GEnum (Monoid.Last a) where - genum = genumDefault - -#if MIN_VERSION_base(4,9,0) -instance GEnum a => GEnum (Semigroup.Last a) where - genum = genumDefault -#endif - -instance GEnum (f p) => GEnum (M1 i c f p) where - genum = genumDefault - -#if MIN_VERSION_base(4,9,0) -instance GEnum a => GEnum (Max a) where - genum = genumDefault -#endif - -instance GEnum a => GEnum (Maybe a) where - genum = genumDefault - -#if MIN_VERSION_base(4,9,0) -instance GEnum a => GEnum (Min a) where - genum = genumDefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GEnum Natural where - genum = genumNumUnsigned -#endif - -#if MIN_VERSION_base(4,9,0) -instance GEnum a => GEnum (NonEmpty a) where - genum = genumDefault -#endif - -instance GEnum Ordering where - genum = genumDefault - -instance GEnum p => GEnum (Par1 p) where - genum = genumDefault - -instance GEnum a => GEnum (Product a) where - genum = genumDefault - -#if MIN_VERSION_base(4,7,0) -instance GEnum -# if MIN_VERSION_base(4,9,0) - (Proxy s) -# else - (Proxy (s :: *)) -# endif - where - genum = genumDefault -#endif - -instance GEnum (f p) => GEnum (Rec1 f p) where - genum = genumDefault - -instance GEnum a => GEnum (Sum a) where - genum = genumDefault - -instance GEnum (U1 p) where - genum = genumDefault - -instance GEnum Word where - genum = genumNumUnsigned - -instance GEnum Word8 where - genum = genumNumUnsigned - -instance GEnum Word16 where - genum = genumNumUnsigned - -instance GEnum Word32 where - genum = genumNumUnsigned - -instance GEnum Word64 where - genum = genumNumUnsigned - -instance GEnum WordPtr where - genum = genumNumUnsigned - -#if MIN_VERSION_base(4,9,0) -instance GEnum m => GEnum (WrappedMonoid m) where - genum = genumDefault -#endif - -instance GEnum a => GEnum (ZipList a) where - genum = genumDefault - -#if MIN_VERSION_base(4,10,0) -instance GEnum CBool where - genum = coerce (genum :: [HTYPE_BOOL]) - -# if defined(HTYPE_BLKSIZE_T) -instance GEnum CBlkSize where - genum = coerce (genum :: [HTYPE_BLKSIZE_T]) -# endif - -# if defined(HTYPE_BLKCNT_T) -instance GEnum CBlkCnt where - genum = coerce (genum :: [HTYPE_BLKCNT_T]) -# endif - -# if defined(HTYPE_CLOCKID_T) -instance GEnum CClockId where - genum = coerce (genum :: [HTYPE_CLOCKID_T]) -# endif - -# if defined(HTYPE_FSBLKCNT_T) -instance GEnum CFsBlkCnt where - genum = coerce (genum :: [HTYPE_FSBLKCNT_T]) -# endif - -# if defined(HTYPE_FSFILCNT_T) -instance GEnum CFsFilCnt where - genum = coerce (genum :: [HTYPE_FSFILCNT_T]) -# endif - -# if defined(HTYPE_ID_T) -instance GEnum CId where - genum = coerce (genum :: [HTYPE_ID_T]) -# endif - -# if defined(HTYPE_KEY_T) -instance GEnum CKey where - genum = coerce (genum :: [HTYPE_KEY_T]) -# endif -#endif - --------------------------------------------------------------------------------- --- Generic Ix --------------------------------------------------------------------------------- - --- Minimal complete instance: 'range', 'index' and 'inRange'. -class (Ord a) => GIx a where - -- | The list of values in the subrange defined by a bounding pair. - range :: (a,a) -> [a] - -- | The position of a subscript in the subrange. - index :: (a,a) -> a -> Int - -- | Returns 'True' the given subscript lies in the range defined - -- the bounding pair. - inRange :: (a,a) -> a -> Bool -#if __GLASGOW_HASKELL__ >= 701 - default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] - range = rangeDefault - - default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int - index = indexDefault - - default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool - inRange = inRangeDefault -#endif - -rangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> [a] -rangeDefault = t (map to enum') where - t l (x,y) = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "rangeDefault: no corresponding index" - (_, Nothing) -> error "rangeDefault: no corresponding index" - (Just i, Just j) -> take (j-i) (drop i l) - -indexDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Int -indexDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of - Nothing -> error "indexDefault: index out of range" - Just k -> k - -inRangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Bool -inRangeDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> maybe False (const True) - (findIndex (geq z) (take (j-i) (drop i l))) - -rangeEnum :: Enum a => (a, a) -> [a] -rangeEnum (m,n) = [m..n] - -indexIntegral :: Integral a => (a, a) -> a -> Int -indexIntegral (m,_n) i = fromIntegral (i - m) - -inRangeOrd :: Ord a => (a, a) -> a -> Bool -inRangeOrd (m,n) i = m <= i && i <= n - --- Base types instances -instance GIx () where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c) - => GIx (a, b, c) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d) - => GIx (a, b, c, d) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e) - => GIx (a, b, c, d, e) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f) - => GIx (a, b, c, d, e, f) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f, - GEq g, GEnum g, GIx g) - => GIx (a, b, c, d, e, f, g) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx [a] where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx All where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Any where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,9,0) -instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -#if !(MIN_VERSION_base(4,9,0)) -instance GIx Arity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Associativity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Bool where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx CChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_GID_T) -instance GIx CGid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_INO_T) -instance GIx CIno where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CInt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CIntMax where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CIntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CLLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_MODE_T) -instance GIx CMode where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_NLINK_T) -instance GIx CNlink where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_OFF_T) -instance GIx COff where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_PID_T) -instance GIx CPid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CPtrdiff where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_RLIM_T) -instance GIx CRLim where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CSChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CShort where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CSigAtomic where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CSize where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_SSIZE_T) -instance GIx CSsize where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GIx CTcflag where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CUChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_UID_T) -instance GIx CUid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CUInt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUIntMax where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUIntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CULLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CULong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUShort where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CWchar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx ExitCode where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Fd where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,9,0) -instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Fixity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Int where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int8 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int16 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int32 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int64 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Integer where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx IntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,9,0) -instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -#if MIN_VERSION_base(4,9,0) -instance (GEq a, GEnum a, GIx a) => GIx (Max a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,9,0) -instance (GEq a, GEnum a, GIx a) => GIx (Min a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GIx Natural where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if MIN_VERSION_base(4,9,0) -instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Ordering where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx (Product a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,7,0) -instance GIx -# if MIN_VERSION_base(4,9,0) - (Proxy s) -# else - (Proxy (s :: *)) -# endif - where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Word where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word8 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word16 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word32 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word64 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx WordPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if MIN_VERSION_base(4,9,0) -instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -#if MIN_VERSION_base(4,10,0) -instance GIx CBool where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -# if defined(HTYPE_BLKSIZE_T) -instance GIx CBlkSize where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -# endif - -# if defined(HTYPE_BLKCNT_T) -instance GIx CBlkCnt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -# endif - -# if defined(HTYPE_CLOCKID_T) -instance GIx CClockId where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -# endif - -# if defined(HTYPE_FSBLKCNT_T) -instance GIx CFsBlkCnt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -# endif - -# if defined(HTYPE_FSFILCNT_T) -instance GIx CFsFilCnt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -# endif - -# if defined(HTYPE_ID_T) -instance GIx CId where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -# endif - -# if defined(HTYPE_KEY_T) -instance GIx CKey where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -# endif -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#include "HsBaseConfig.h"++module Generics.Deriving.Enum (++ -- * Generic enum class+ GEnum(..)++ -- * Default definitions for GEnum+ , genumDefault, toEnumDefault, fromEnumDefault++ -- * Internal enum class+ , Enum'(..)++ -- * Generic Ix class+ , GIx(..)++ -- * Default definitions for GIx+ , rangeDefault, indexDefault, inRangeDefault++ ) where++import Control.Applicative (Const, ZipList)++import Data.Int+import Data.Maybe (listToMaybe)+import Data.Monoid (All, Any, Dual, Product, Sum)+import qualified Data.Monoid as Monoid (First, Last)+import Data.Word++import Foreign.C.Types+import Foreign.Ptr++import Generics.Deriving.Base+import Generics.Deriving.Eq++import System.Exit (ExitCode)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Coerce (coerce)+import Data.Proxy (Proxy)+#else+import Unsafe.Coerce (unsafeCoerce)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++-----------------------------------------------------------------------------+-- Utility functions for Enum'+-----------------------------------------------------------------------------++infixr 5 |||++-- | Interleave elements from two lists. Similar to (++), but swap left and+-- right arguments on every recursive application.+--+-- From Mark Jones' talk at AFP2008+(|||) :: [a] -> [a] -> [a]+[] ||| ys = ys+(x:xs) ||| ys = x : ys ||| xs++-- | Diagonalization of nested lists. Ensure that some elements from every+-- sublist will be included. Handles infinite sublists.+--+-- From Mark Jones' talk at AFP2008+diag :: [[a]] -> [a]+diag = concat . foldr skew [] . map (map (\x -> [x]))++skew :: [[a]] -> [[a]] -> [[a]]+skew [] ys = ys+skew (x:xs) ys = x : combine (++) xs ys++combine :: (a -> a -> a) -> [a] -> [a] -> [a]+combine _ xs [] = xs+combine _ [] ys = ys+combine f (x:xs) (y:ys) = f x y : combine f xs ys++findIndex :: (a -> Bool) -> [a] -> Maybe Int+findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]+ in listToMaybe l++--------------------------------------------------------------------------------+-- Generic enum+--------------------------------------------------------------------------------++class Enum' f where+ enum' :: [f a]++instance Enum' U1 where+ enum' = [U1]++instance (GEnum c) => Enum' (K1 i c) where+ enum' = map K1 genum++instance (Enum' f) => Enum' (M1 i c f) where+ enum' = map M1 enum'++instance (Enum' f, Enum' g) => Enum' (f :+: g) where+ enum' = map L1 enum' ||| map R1 enum'++instance (Enum' f, Enum' g) => Enum' (f :*: g) where+ enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]++genumDefault :: (Generic a, Enum' (Rep a)) => [a]+genumDefault = map to enum'++toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a+toEnumDefault i = let l = enum'+ in if (length l > i)+ then to (l !! i)+ else error "toEnum: invalid index"++fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a))+ => a -> Int+fromEnumDefault x = case findIndex (geq x) (map to enum') of+ Nothing -> error "fromEnum: no corresponding index"+ Just i -> i+++class GEnum a where+ genum :: [a]++#if __GLASGOW_HASKELL__ >= 701+ default genum :: (Generic a, Enum' (Rep a)) => [a]+ genum = genumDefault+#endif++genumNumUnbounded :: Num a => [a]+genumNumUnbounded = pos 0 ||| neg 0 where+ pos n = n : pos (n + 1)+ neg n = (n-1) : neg (n - 1)++genumNumSigned :: (Bounded a, Enum a, Num a) => [a]+genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound]++genumNumUnsigned :: (Enum a, Num a) => [a]+genumNumUnsigned = [0 ..]++#if !(MIN_VERSION_base(4,7,0))+coerce :: a -> b+coerce = unsafeCoerce+#endif++-- Base types instances+instance GEnum () where+ genum = genumDefault++instance (GEnum a, GEnum b) => GEnum (a, b) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f)+ => GEnum (a, b, c, d, e, f) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g)+ => GEnum (a, b, c, d, e, f, g) where+ genum = genumDefault++instance GEnum a => GEnum [a] where+ genum = genumDefault++instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where+ genum = genumDefault++instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where+ genum = genumDefault++instance GEnum (f (g p)) => GEnum ((f :.: g) p) where+ genum = genumDefault++instance GEnum All where+ genum = genumDefault++#if MIN_VERSION_base(4,8,0)+instance GEnum (f a) => GEnum (Alt f a) where+ genum = genumDefault+#endif++instance GEnum Any where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance (GEnum a, GEnum b) => GEnum (Arg a b) where+ genum = genumDefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GEnum Arity where+ genum = genumDefault+#endif++instance GEnum Associativity where+ genum = genumDefault++instance GEnum Bool where+ genum = genumDefault++#if defined(HTYPE_CC_T)+instance GEnum CCc where+ genum = coerce (genum :: [HTYPE_CC_T])+#endif++instance GEnum CChar where+ genum = coerce (genum :: [HTYPE_CHAR])++instance GEnum CClock where+ genum = coerce (genum :: [HTYPE_CLOCK_T])++#if defined(HTYPE_DEV_T)+instance GEnum CDev where+ genum = coerce (genum :: [HTYPE_DEV_T])+#endif++instance GEnum CDouble where+ genum = coerce (genum :: [HTYPE_DOUBLE])++instance GEnum CFloat where+ genum = coerce (genum :: [HTYPE_FLOAT])++#if defined(HTYPE_GID_T)+instance GEnum CGid where+ genum = coerce (genum :: [HTYPE_GID_T])+#endif++#if defined(HTYPE_INO_T)+instance GEnum CIno where+ genum = coerce (genum :: [HTYPE_INO_T])+#endif++instance GEnum CInt where+ genum = coerce (genum :: [HTYPE_INT])++instance GEnum CIntMax where+ genum = coerce (genum :: [HTYPE_INTMAX_T])++instance GEnum CIntPtr where+ genum = coerce (genum :: [HTYPE_INTPTR_T])++instance GEnum CLLong where+ genum = coerce (genum :: [HTYPE_LONG_LONG])++instance GEnum CLong where+ genum = coerce (genum :: [HTYPE_LONG])++#if defined(HTYPE_MODE_T)+instance GEnum CMode where+ genum = coerce (genum :: [HTYPE_MODE_T])+#endif++#if defined(HTYPE_NLINK_T)+instance GEnum CNlink where+ genum = coerce (genum :: [HTYPE_NLINK_T])+#endif++#if defined(HTYPE_OFF_T)+instance GEnum COff where+ genum = coerce (genum :: [HTYPE_OFF_T])+#endif++#if MIN_VERSION_base(4,4,0)+instance GEnum a => GEnum (Complex a) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (Const a b) where+ genum = genumDefault++#if defined(HTYPE_PID_T)+instance GEnum CPid where+ genum = coerce (genum :: [HTYPE_PID_T])+#endif++instance GEnum CPtrdiff where+ genum = coerce (genum :: [HTYPE_PTRDIFF_T])++#if defined(HTYPE_RLIM_T)+instance GEnum CRLim where+ genum = coerce (genum :: [HTYPE_RLIM_T])+#endif++instance GEnum CSChar where+ genum = coerce (genum :: [HTYPE_SIGNED_CHAR])++#if defined(HTYPE_SPEED_T)+instance GEnum CSpeed where+ genum = coerce (genum :: [HTYPE_SPEED_T])+#endif++#if MIN_VERSION_base(4,4,0)+instance GEnum CSUSeconds where+ genum = coerce (genum :: [HTYPE_SUSECONDS_T])+#endif++instance GEnum CShort where+ genum = coerce (genum :: [HTYPE_SHORT])++instance GEnum CSigAtomic where+#if defined(HTYPE_SIG_ATOMIC_T)+ genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T])+#else+ genum = coerce (genum :: [Int32])+#endif++instance GEnum CSize where+ genum = coerce (genum :: [HTYPE_SIZE_T])++#if defined(HTYPE_SSIZE_T)+instance GEnum CSsize where+ genum = coerce (genum :: [HTYPE_SSIZE_T])+#endif++#if defined(HTYPE_TCFLAG_T)+instance GEnum CTcflag where+ genum = coerce (genum :: [HTYPE_TCFLAG_T])+#endif++instance GEnum CTime where+ genum = coerce (genum :: [HTYPE_TIME_T])++instance GEnum CUChar where+ genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR])++#if defined(HTYPE_UID_T)+instance GEnum CUid where+ genum = coerce (genum :: [HTYPE_UID_T])+#endif++instance GEnum CUInt where+ genum = coerce (genum :: [HTYPE_UNSIGNED_INT])++instance GEnum CUIntMax where+ genum = coerce (genum :: [HTYPE_UINTMAX_T])++instance GEnum CUIntPtr where+ genum = coerce (genum :: [HTYPE_UINTPTR_T])++instance GEnum CULLong where+ genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG])++instance GEnum CULong where+ genum = coerce (genum :: [HTYPE_UNSIGNED_LONG])++#if MIN_VERSION_base(4,4,0)+instance GEnum CUSeconds where+ genum = coerce (genum :: [HTYPE_USECONDS_T])+#endif++instance GEnum CUShort where+ genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT])++instance GEnum CWchar where+ genum = coerce (genum :: [HTYPE_WCHAR_T])++instance GEnum Double where+ genum = genumNumUnbounded++instance GEnum a => GEnum (Dual a) where+ genum = genumDefault++instance (GEnum a, GEnum b) => GEnum (Either a b) where+ genum = genumDefault++instance GEnum ExitCode where+ genum = genumDefault++instance GEnum Fd where+ genum = coerce (genum :: [CInt])++instance GEnum a => GEnum (Monoid.First a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Semigroup.First a) where+ genum = genumDefault+#endif++instance GEnum Fixity where+ genum = genumDefault++instance GEnum Float where+ genum = genumNumUnbounded++#if MIN_VERSION_base(4,8,0)+instance GEnum a => GEnum (Identity a) where+ genum = genumDefault+#endif++instance GEnum Int where+ genum = genumNumSigned++instance GEnum Int8 where+ genum = genumNumSigned++instance GEnum Int16 where+ genum = genumNumSigned++instance GEnum Int32 where+ genum = genumNumSigned++instance GEnum Int64 where+ genum = genumNumSigned++instance GEnum Integer where+ genum = genumNumUnbounded++instance GEnum IntPtr where+ genum = genumNumSigned++instance GEnum c => GEnum (K1 i c p) where+ genum = genumDefault++instance GEnum a => GEnum (Monoid.Last a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Semigroup.Last a) where+ genum = genumDefault+#endif++instance GEnum (f p) => GEnum (M1 i c f p) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Max a) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (Maybe a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Min a) where+ genum = genumDefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GEnum Natural where+ genum = genumNumUnsigned+#endif++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (NonEmpty a) where+ genum = genumDefault+#endif++instance GEnum Ordering where+ genum = genumDefault++instance GEnum p => GEnum (Par1 p) where+ genum = genumDefault++instance GEnum a => GEnum (Product a) where+ genum = genumDefault++#if MIN_VERSION_base(4,7,0)+instance GEnum+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ genum = genumDefault+#endif++instance GEnum (f p) => GEnum (Rec1 f p) where+ genum = genumDefault++instance GEnum a => GEnum (Sum a) where+ genum = genumDefault++instance GEnum (U1 p) where+ genum = genumDefault++instance GEnum Word where+ genum = genumNumUnsigned++instance GEnum Word8 where+ genum = genumNumUnsigned++instance GEnum Word16 where+ genum = genumNumUnsigned++instance GEnum Word32 where+ genum = genumNumUnsigned++instance GEnum Word64 where+ genum = genumNumUnsigned++instance GEnum WordPtr where+ genum = genumNumUnsigned++#if MIN_VERSION_base(4,9,0)+instance GEnum m => GEnum (WrappedMonoid m) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (ZipList a) where+ genum = genumDefault++#if MIN_VERSION_base(4,10,0)+instance GEnum CBool where+ genum = coerce (genum :: [HTYPE_BOOL])++# if defined(HTYPE_BLKSIZE_T)+instance GEnum CBlkSize where+ genum = coerce (genum :: [HTYPE_BLKSIZE_T])+# endif++# if defined(HTYPE_BLKCNT_T)+instance GEnum CBlkCnt where+ genum = coerce (genum :: [HTYPE_BLKCNT_T])+# endif++# if defined(HTYPE_CLOCKID_T)+instance GEnum CClockId where+ genum = coerce (genum :: [HTYPE_CLOCKID_T])+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GEnum CFsBlkCnt where+ genum = coerce (genum :: [HTYPE_FSBLKCNT_T])+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GEnum CFsFilCnt where+ genum = coerce (genum :: [HTYPE_FSFILCNT_T])+# endif++# if defined(HTYPE_ID_T)+instance GEnum CId where+ genum = coerce (genum :: [HTYPE_ID_T])+# endif++# if defined(HTYPE_KEY_T)+instance GEnum CKey where+ genum = coerce (genum :: [HTYPE_KEY_T])+# endif+#endif++--------------------------------------------------------------------------------+-- Generic Ix+--------------------------------------------------------------------------------++-- Minimal complete instance: 'range', 'index' and 'inRange'.+class (Ord a) => GIx a where+ -- | The list of values in the subrange defined by a bounding pair.+ range :: (a,a) -> [a]+ -- | The position of a subscript in the subrange.+ index :: (a,a) -> a -> Int+ -- | Returns 'True' the given subscript lies in the range defined+ -- the bounding pair.+ inRange :: (a,a) -> a -> Bool+#if __GLASGOW_HASKELL__ >= 701+ default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a]+ range = rangeDefault++ default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int+ index = indexDefault++ default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool+ inRange = inRangeDefault+#endif++rangeDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> [a]+rangeDefault = t (map to enum') where+ t l (x,y) =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "rangeDefault: no corresponding index"+ (_, Nothing) -> error "rangeDefault: no corresponding index"+ (Just i, Just j) -> take (j-i) (drop i l)++indexDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> a -> Int+indexDefault = t (map to enum') where+ t l (x,y) z =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "indexDefault: no corresponding index"+ (_, Nothing) -> error "indexDefault: no corresponding index"+ (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of+ Nothing -> error "indexDefault: index out of range"+ Just k -> k++inRangeDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> a -> Bool+inRangeDefault = t (map to enum') where+ t l (x,y) z =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "indexDefault: no corresponding index"+ (_, Nothing) -> error "indexDefault: no corresponding index"+ (Just i, Just j) -> maybe False (const True)+ (findIndex (geq z) (take (j-i) (drop i l)))++rangeEnum :: Enum a => (a, a) -> [a]+rangeEnum (m,n) = [m..n]++indexIntegral :: Integral a => (a, a) -> a -> Int+indexIntegral (m,_n) i = fromIntegral (i - m)++inRangeOrd :: Ord a => (a, a) -> a -> Bool+inRangeOrd (m,n) i = m <= i && i <= n++-- Base types instances+instance GIx () where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c)+ => GIx (a, b, c) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d)+ => GIx (a, b, c, d) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e)+ => GIx (a, b, c, d, e) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f)+ => GIx (a, b, c, d, e, f) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f,+ GEq g, GEnum g, GIx g)+ => GIx (a, b, c, d, e, f, g) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a) => GIx [a] where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx All where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,8,0)+instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Any where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GIx Arity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Associativity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Bool where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx CChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_GID_T)+instance GIx CGid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_INO_T)+instance GIx CIno where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CInt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CIntMax where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CIntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CLLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_MODE_T)+instance GIx CMode where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_NLINK_T)+instance GIx CNlink where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_OFF_T)+instance GIx COff where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_PID_T)+instance GIx CPid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CPtrdiff where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_RLIM_T)+instance GIx CRLim where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CSChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CShort where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CSigAtomic where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CSize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_SSIZE_T)+instance GIx CSsize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_TCFLAG_T)+instance GIx CTcflag where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CUChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_UID_T)+instance GIx CUid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CUInt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUIntMax where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUIntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CULLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CULong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUShort where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CWchar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx ExitCode where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Fd where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Fixity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,8,0)+instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Int where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int8 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int16 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int32 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int64 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Integer where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx IntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Max a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Min a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GIx Natural where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Ordering where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a) => GIx (Product a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,7,0)+instance GIx+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Word where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word8 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word16 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word32 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word64 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx WordPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if MIN_VERSION_base(4,9,0)+instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,10,0)+instance GIx CBool where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++# if defined(HTYPE_BLKSIZE_T)+instance GIx CBlkSize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_BLKCNT_T)+instance GIx CBlkCnt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_CLOCKID_T)+instance GIx CClockId where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GIx CFsBlkCnt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GIx CFsFilCnt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_ID_T)+instance GIx CId where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_KEY_T)+instance GIx CKey where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif+#endif
src/Generics/Deriving/Eq.hs view
@@ -1,626 +1,626 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MagicHash #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#include "HsBaseConfig.h" - -module Generics.Deriving.Eq ( - -- * Generic Eq class - GEq(..) - - -- * Default definition - , geqdefault - - -- * Internal Eq class - , GEq'(..) - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Char (GeneralCategory) -import Data.Int -import qualified Data.Monoid as Monoid (First, Last) -import Data.Monoid (All, Any, Dual, Product, Sum) -import Data.Version (Version) -import Data.Word - -import Foreign.C.Error -import Foreign.C.Types -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.Ptr -import Foreign.StablePtr (StablePtr) - -import Generics.Deriving.Base - -import GHC.Exts hiding (Any) - -import System.Exit (ExitCode) -import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) -import System.IO.Error (IOErrorType) -import System.Posix.Types - -#if MIN_VERSION_base(4,4,0) -import Data.Complex (Complex) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Data.Void (Void) -import Numeric.Natural (Natural) -#endif - -#if MIN_VERSION_base(4,9,0) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Semigroup as Semigroup (First, Last) -import Data.Semigroup (Arg(..), Max, Min, WrappedMonoid) -#endif - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -class GEq' f where - geq' :: f a -> f a -> Bool - -instance GEq' V1 where - geq' _ _ = True - -instance GEq' U1 where - geq' _ _ = True - -instance (GEq c) => GEq' (K1 i c) where - geq' (K1 a) (K1 b) = geq a b - --- No instances for P or Rec because geq is only applicable to types of kind * - -instance (GEq' a) => GEq' (M1 i c a) where - geq' (M1 a) (M1 b) = geq' a b - -instance (GEq' a, GEq' b) => GEq' (a :+: b) where - geq' (L1 a) (L1 b) = geq' a b - geq' (R1 a) (R1 b) = geq' a b - geq' _ _ = False - -instance (GEq' a, GEq' b) => GEq' (a :*: b) where - geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2 - --- Unboxed types -instance GEq' UAddr where - geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2) -instance GEq' UChar where - geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2) -instance GEq' UDouble where - geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2) -instance GEq' UFloat where - geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2) -instance GEq' UInt where - geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2) -instance GEq' UWord where - geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) - -#if !(MIN_VERSION_base(4,7,0)) -isTrue# :: Bool -> Bool -isTrue# = id -#endif - - -class GEq a where - geq :: a -> a -> Bool - - -#if __GLASGOW_HASKELL__ >= 701 - default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool - geq = geqdefault -#endif - -geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool -geqdefault x y = geq' (from x) (from y) - --- Base types instances -instance GEq () where - geq = geqdefault - -instance (GEq a, GEq b) => GEq (a, b) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f) - => GEq (a, b, c, d, e, f) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g) - => GEq (a, b, c, d, e, f, g) where - geq = geqdefault - -instance GEq a => GEq [a] where - geq = geqdefault - -instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where - geq = geqdefault - -instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where - geq = geqdefault - -instance GEq (f (g p)) => GEq ((f :.: g) p) where - geq = geqdefault - -instance GEq All where - geq = geqdefault - -#if MIN_VERSION_base(4,8,0) -instance GEq (f a) => GEq (Alt f a) where - geq = geqdefault -#endif - -instance GEq Any where - geq = geqdefault - -#if !(MIN_VERSION_base(4,9,0)) -instance GEq Arity where - geq = geqdefault -#endif - -#if MIN_VERSION_base(4,9,0) -instance GEq a => GEq (Arg a b) where - geq (Arg a _) (Arg b _) = geq a b -#endif - -instance GEq Associativity where - geq = geqdefault - -instance GEq Bool where - geq = geqdefault - -instance GEq BufferMode where - geq = (==) - -#if defined(HTYPE_CC_T) -instance GEq CCc where - geq = (==) -#endif - -instance GEq CChar where - geq = (==) - -instance GEq CClock where - geq = (==) - -#if defined(HTYPE_DEV_T) -instance GEq CDev where - geq = (==) -#endif - -instance GEq CDouble where - geq = (==) - -instance GEq CFloat where - geq = (==) - -#if defined(HTYPE_GID_T) -instance GEq CGid where - geq = (==) -#endif - -instance GEq Char where - geq = (==) - -#if defined(HTYPE_INO_T) -instance GEq CIno where - geq = (==) -#endif - -instance GEq CInt where - geq = (==) - -instance GEq CIntMax where - geq = (==) - -instance GEq CIntPtr where - geq = (==) - -instance GEq CLLong where - geq = (==) - -instance GEq CLong where - geq = (==) - -#if defined(HTYPE_MODE_T) -instance GEq CMode where - geq = (==) -#endif - -#if defined(HTYPE_NLINK_T) -instance GEq CNlink where - geq = (==) -#endif - -#if defined(HTYPE_OFF_T) -instance GEq COff where - geq = (==) -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEq a => GEq (Complex a) where - geq = geqdefault -#endif - -instance GEq a => GEq (Const a b) where - geq = geqdefault - -#if defined(HTYPE_PID_T) -instance GEq CPid where - geq = (==) -#endif - -instance GEq CPtrdiff where - geq = (==) - -#if defined(HTYPE_RLIM_T) -instance GEq CRLim where - geq = (==) -#endif - -instance GEq CSChar where - geq = (==) - -#if defined(HTYPE_SPEED_T) -instance GEq CSpeed where - geq = (==) -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEq CSUSeconds where - geq = (==) -#endif - -instance GEq CShort where - geq = (==) - -instance GEq CSigAtomic where - geq = (==) - -instance GEq CSize where - geq = (==) - -#if defined(HTYPE_SSIZE_T) -instance GEq CSsize where - geq = (==) -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GEq CTcflag where - geq = (==) -#endif - -instance GEq CTime where - geq = (==) - -instance GEq CUChar where - geq = (==) - -#if defined(HTYPE_UID_T) -instance GEq CUid where - geq = (==) -#endif - -instance GEq CUInt where - geq = (==) - -instance GEq CUIntMax where - geq = (==) - -instance GEq CUIntPtr where - geq = (==) - -instance GEq CULLong where - geq = (==) - -instance GEq CULong where - geq = (==) - -#if MIN_VERSION_base(4,4,0) -instance GEq CUSeconds where - geq = (==) -#endif - -instance GEq CUShort where - geq = (==) - -instance GEq CWchar where - geq = (==) - -#if MIN_VERSION_base(4,9,0) -instance GEq DecidedStrictness where - geq = geqdefault -#endif - -instance GEq Double where - geq = (==) - -instance GEq a => GEq (Down a) where - geq = geqdefault - -instance GEq a => GEq (Dual a) where - geq = geqdefault - -instance (GEq a, GEq b) => GEq (Either a b) where - geq = geqdefault - -instance GEq Errno where - geq = (==) - -instance GEq ExitCode where - geq = geqdefault - -instance GEq Fd where - geq = (==) - -instance GEq a => GEq (Monoid.First a) where - geq = geqdefault - -#if MIN_VERSION_base(4,9,0) -instance GEq a => GEq (Semigroup.First a) where - geq = geqdefault -#endif - -instance GEq Fixity where - geq = geqdefault - -instance GEq Float where - geq = (==) - -instance GEq (ForeignPtr a) where - geq = (==) - -instance GEq (FunPtr a) where - geq = (==) - -instance GEq GeneralCategory where - geq = (==) - -instance GEq Handle where - geq = (==) - -instance GEq HandlePosn where - geq = (==) - -#if MIN_VERSION_base(4,8,0) -instance GEq a => GEq (Identity a) where - geq = geqdefault -#endif - -instance GEq Int where - geq = (==) - -instance GEq Int8 where - geq = (==) - -instance GEq Int16 where - geq = (==) - -instance GEq Int32 where - geq = (==) - -instance GEq Int64 where - geq = (==) - -instance GEq Integer where - geq = (==) - -instance GEq IntPtr where - geq = (==) - -instance GEq IOError where - geq = (==) - -instance GEq IOErrorType where - geq = (==) - -instance GEq IOMode where - geq = (==) - -instance GEq c => GEq (K1 i c p) where - geq = geqdefault - -instance GEq a => GEq (Monoid.Last a) where - geq = geqdefault - -#if MIN_VERSION_base(4,9,0) -instance GEq a => GEq (Semigroup.Last a) where - geq = geqdefault -#endif - -instance GEq (f p) => GEq (M1 i c f p) where - geq = geqdefault - -instance GEq a => GEq (Maybe a) where - geq = geqdefault - -#if MIN_VERSION_base(4,9,0) -instance GEq a => GEq (Max a) where - geq = geqdefault - -instance GEq a => GEq (Min a) where - geq = geqdefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GEq Natural where - geq = (==) -#endif - -#if MIN_VERSION_base(4,9,0) -instance GEq a => GEq (NonEmpty a) where - geq = geqdefault -#endif - -instance GEq Ordering where - geq = geqdefault - -instance GEq p => GEq (Par1 p) where - geq = geqdefault - -instance GEq a => GEq (Product a) where - geq = geqdefault - -#if MIN_VERSION_base(4,7,0) -instance GEq -# if MIN_VERSION_base(4,9,0) - (Proxy s) -# else - (Proxy (s :: *)) -# endif - where - geq = geqdefault -#endif - -instance GEq (Ptr a) where - geq = (==) - -instance GEq (f p) => GEq (Rec1 f p) where - geq = geqdefault - -instance GEq SeekMode where - geq = (==) - -instance GEq (StablePtr a) where - geq = (==) - -#if MIN_VERSION_base(4,9,0) -instance GEq SourceStrictness where - geq = geqdefault - -instance GEq SourceUnpackedness where - geq = geqdefault -#endif - -instance GEq a => GEq (Sum a) where - geq = geqdefault - -instance GEq (U1 p) where - geq = geqdefault - -instance GEq (UAddr p) where - geq = geqdefault - -instance GEq (UChar p) where - geq = geqdefault - -instance GEq (UDouble p) where - geq = geqdefault - -instance GEq (UFloat p) where - geq = geqdefault - -instance GEq (UInt p) where - geq = geqdefault - -instance GEq (UWord p) where - geq = geqdefault - -instance GEq Version where - geq = (==) - -#if MIN_VERSION_base(4,8,0) -instance GEq Void where - geq = (==) -#endif - -instance GEq Word where - geq = (==) - -instance GEq Word8 where - geq = (==) - -instance GEq Word16 where - geq = (==) - -instance GEq Word32 where - geq = (==) - -instance GEq Word64 where - geq = (==) - -instance GEq WordPtr where - geq = (==) - -#if MIN_VERSION_base(4,9,0) -instance GEq m => GEq (WrappedMonoid m) where - geq = geqdefault -#endif - -instance GEq a => GEq (ZipList a) where - geq = geqdefault - -#if MIN_VERSION_base(4,10,0) -instance GEq CBool where - geq = (==) - -# if defined(HTYPE_BLKSIZE_T) -instance GEq CBlkSize where - geq = (==) -# endif - -# if defined(HTYPE_BLKCNT_T) -instance GEq CBlkCnt where - geq = (==) -# endif - -# if defined(HTYPE_CLOCKID_T) -instance GEq CClockId where - geq = (==) -# endif - -# if defined(HTYPE_FSBLKCNT_T) -instance GEq CFsBlkCnt where - geq = (==) -# endif - -# if defined(HTYPE_FSFILCNT_T) -instance GEq CFsFilCnt where - geq = (==) -# endif - -# if defined(HTYPE_ID_T) -instance GEq CId where - geq = (==) -# endif - -# if defined(HTYPE_KEY_T) -instance GEq CKey where - geq = (==) -# endif - -# if defined(HTYPE_TIMER_T) -instance GEq CTimer where - geq = (==) -# endif -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MagicHash #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#include "HsBaseConfig.h"++module Generics.Deriving.Eq (+ -- * Generic Eq class+ GEq(..)++ -- * Default definition+ , geqdefault++ -- * Internal Eq class+ , GEq'(..)++ ) where++import Control.Applicative (Const, ZipList)++import Data.Char (GeneralCategory)+import Data.Int+import qualified Data.Monoid as Monoid (First, Last)+import Data.Monoid (All, Any, Dual, Product, Sum)+import Data.Version (Version)+import Data.Word++import Foreign.C.Error+import Foreign.C.Types+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr+import Foreign.StablePtr (StablePtr)++import Generics.Deriving.Base++import GHC.Exts hiding (Any)++import System.Exit (ExitCode)+import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)+import System.IO.Error (IOErrorType)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Data.Void (Void)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg(..), Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic show+--------------------------------------------------------------------------------++class GEq' f where+ geq' :: f a -> f a -> Bool++instance GEq' V1 where+ geq' _ _ = True++instance GEq' U1 where+ geq' _ _ = True++instance (GEq c) => GEq' (K1 i c) where+ geq' (K1 a) (K1 b) = geq a b++-- No instances for P or Rec because geq is only applicable to types of kind *++instance (GEq' a) => GEq' (M1 i c a) where+ geq' (M1 a) (M1 b) = geq' a b++instance (GEq' a, GEq' b) => GEq' (a :+: b) where+ geq' (L1 a) (L1 b) = geq' a b+ geq' (R1 a) (R1 b) = geq' a b+ geq' _ _ = False++instance (GEq' a, GEq' b) => GEq' (a :*: b) where+ geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2++-- Unboxed types+instance GEq' UAddr where+ geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)+instance GEq' UChar where+ geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)+instance GEq' UDouble where+ geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)+instance GEq' UFloat where+ geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)+instance GEq' UInt where+ geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)+instance GEq' UWord where+ geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2)++#if !(MIN_VERSION_base(4,7,0))+isTrue# :: Bool -> Bool+isTrue# = id+#endif+++class GEq a where+ geq :: a -> a -> Bool+++#if __GLASGOW_HASKELL__ >= 701+ default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool+ geq = geqdefault+#endif++geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool+geqdefault x y = geq' (from x) (from y)++-- Base types instances+instance GEq () where+ geq = geqdefault++instance (GEq a, GEq b) => GEq (a, b) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f)+ => GEq (a, b, c, d, e, f) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g)+ => GEq (a, b, c, d, e, f, g) where+ geq = geqdefault++instance GEq a => GEq [a] where+ geq = geqdefault++instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where+ geq = geqdefault++instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where+ geq = geqdefault++instance GEq (f (g p)) => GEq ((f :.: g) p) where+ geq = geqdefault++instance GEq All where+ geq = geqdefault++#if MIN_VERSION_base(4,8,0)+instance GEq (f a) => GEq (Alt f a) where+ geq = geqdefault+#endif++instance GEq Any where+ geq = geqdefault++#if !(MIN_VERSION_base(4,9,0))+instance GEq Arity where+ geq = geqdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Arg a b) where+ geq (Arg a _) (Arg b _) = geq a b+#endif++instance GEq Associativity where+ geq = geqdefault++instance GEq Bool where+ geq = geqdefault++instance GEq BufferMode where+ geq = (==)++#if defined(HTYPE_CC_T)+instance GEq CCc where+ geq = (==)+#endif++instance GEq CChar where+ geq = (==)++instance GEq CClock where+ geq = (==)++#if defined(HTYPE_DEV_T)+instance GEq CDev where+ geq = (==)+#endif++instance GEq CDouble where+ geq = (==)++instance GEq CFloat where+ geq = (==)++#if defined(HTYPE_GID_T)+instance GEq CGid where+ geq = (==)+#endif++instance GEq Char where+ geq = (==)++#if defined(HTYPE_INO_T)+instance GEq CIno where+ geq = (==)+#endif++instance GEq CInt where+ geq = (==)++instance GEq CIntMax where+ geq = (==)++instance GEq CIntPtr where+ geq = (==)++instance GEq CLLong where+ geq = (==)++instance GEq CLong where+ geq = (==)++#if defined(HTYPE_MODE_T)+instance GEq CMode where+ geq = (==)+#endif++#if defined(HTYPE_NLINK_T)+instance GEq CNlink where+ geq = (==)+#endif++#if defined(HTYPE_OFF_T)+instance GEq COff where+ geq = (==)+#endif++#if MIN_VERSION_base(4,4,0)+instance GEq a => GEq (Complex a) where+ geq = geqdefault+#endif++instance GEq a => GEq (Const a b) where+ geq = geqdefault++#if defined(HTYPE_PID_T)+instance GEq CPid where+ geq = (==)+#endif++instance GEq CPtrdiff where+ geq = (==)++#if defined(HTYPE_RLIM_T)+instance GEq CRLim where+ geq = (==)+#endif++instance GEq CSChar where+ geq = (==)++#if defined(HTYPE_SPEED_T)+instance GEq CSpeed where+ geq = (==)+#endif++#if MIN_VERSION_base(4,4,0)+instance GEq CSUSeconds where+ geq = (==)+#endif++instance GEq CShort where+ geq = (==)++instance GEq CSigAtomic where+ geq = (==)++instance GEq CSize where+ geq = (==)++#if defined(HTYPE_SSIZE_T)+instance GEq CSsize where+ geq = (==)+#endif++#if defined(HTYPE_TCFLAG_T)+instance GEq CTcflag where+ geq = (==)+#endif++instance GEq CTime where+ geq = (==)++instance GEq CUChar where+ geq = (==)++#if defined(HTYPE_UID_T)+instance GEq CUid where+ geq = (==)+#endif++instance GEq CUInt where+ geq = (==)++instance GEq CUIntMax where+ geq = (==)++instance GEq CUIntPtr where+ geq = (==)++instance GEq CULLong where+ geq = (==)++instance GEq CULong where+ geq = (==)++#if MIN_VERSION_base(4,4,0)+instance GEq CUSeconds where+ geq = (==)+#endif++instance GEq CUShort where+ geq = (==)++instance GEq CWchar where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq DecidedStrictness where+ geq = geqdefault+#endif++instance GEq Double where+ geq = (==)++instance GEq a => GEq (Down a) where+ geq = geqdefault++instance GEq a => GEq (Dual a) where+ geq = geqdefault++instance (GEq a, GEq b) => GEq (Either a b) where+ geq = geqdefault++instance GEq Errno where+ geq = (==)++instance GEq ExitCode where+ geq = geqdefault++instance GEq Fd where+ geq = (==)++instance GEq a => GEq (Monoid.First a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Semigroup.First a) where+ geq = geqdefault+#endif++instance GEq Fixity where+ geq = geqdefault++instance GEq Float where+ geq = (==)++instance GEq (ForeignPtr a) where+ geq = (==)++instance GEq (FunPtr a) where+ geq = (==)++instance GEq GeneralCategory where+ geq = (==)++instance GEq Handle where+ geq = (==)++instance GEq HandlePosn where+ geq = (==)++#if MIN_VERSION_base(4,8,0)+instance GEq a => GEq (Identity a) where+ geq = geqdefault+#endif++instance GEq Int where+ geq = (==)++instance GEq Int8 where+ geq = (==)++instance GEq Int16 where+ geq = (==)++instance GEq Int32 where+ geq = (==)++instance GEq Int64 where+ geq = (==)++instance GEq Integer where+ geq = (==)++instance GEq IntPtr where+ geq = (==)++instance GEq IOError where+ geq = (==)++instance GEq IOErrorType where+ geq = (==)++instance GEq IOMode where+ geq = (==)++instance GEq c => GEq (K1 i c p) where+ geq = geqdefault++instance GEq a => GEq (Monoid.Last a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Semigroup.Last a) where+ geq = geqdefault+#endif++instance GEq (f p) => GEq (M1 i c f p) where+ geq = geqdefault++instance GEq a => GEq (Maybe a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Max a) where+ geq = geqdefault++instance GEq a => GEq (Min a) where+ geq = geqdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GEq Natural where+ geq = (==)+#endif++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (NonEmpty a) where+ geq = geqdefault+#endif++instance GEq Ordering where+ geq = geqdefault++instance GEq p => GEq (Par1 p) where+ geq = geqdefault++instance GEq a => GEq (Product a) where+ geq = geqdefault++#if MIN_VERSION_base(4,7,0)+instance GEq+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ geq = geqdefault+#endif++instance GEq (Ptr a) where+ geq = (==)++instance GEq (f p) => GEq (Rec1 f p) where+ geq = geqdefault++instance GEq SeekMode where+ geq = (==)++instance GEq (StablePtr a) where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq SourceStrictness where+ geq = geqdefault++instance GEq SourceUnpackedness where+ geq = geqdefault+#endif++instance GEq a => GEq (Sum a) where+ geq = geqdefault++instance GEq (U1 p) where+ geq = geqdefault++instance GEq (UAddr p) where+ geq = geqdefault++instance GEq (UChar p) where+ geq = geqdefault++instance GEq (UDouble p) where+ geq = geqdefault++instance GEq (UFloat p) where+ geq = geqdefault++instance GEq (UInt p) where+ geq = geqdefault++instance GEq (UWord p) where+ geq = geqdefault++instance GEq Version where+ geq = (==)++#if MIN_VERSION_base(4,8,0)+instance GEq Void where+ geq = (==)+#endif++instance GEq Word where+ geq = (==)++instance GEq Word8 where+ geq = (==)++instance GEq Word16 where+ geq = (==)++instance GEq Word32 where+ geq = (==)++instance GEq Word64 where+ geq = (==)++instance GEq WordPtr where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq m => GEq (WrappedMonoid m) where+ geq = geqdefault+#endif++instance GEq a => GEq (ZipList a) where+ geq = geqdefault++#if MIN_VERSION_base(4,10,0)+instance GEq CBool where+ geq = (==)++# if defined(HTYPE_BLKSIZE_T)+instance GEq CBlkSize where+ geq = (==)+# endif++# if defined(HTYPE_BLKCNT_T)+instance GEq CBlkCnt where+ geq = (==)+# endif++# if defined(HTYPE_CLOCKID_T)+instance GEq CClockId where+ geq = (==)+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GEq CFsBlkCnt where+ geq = (==)+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GEq CFsFilCnt where+ geq = (==)+# endif++# if defined(HTYPE_ID_T)+instance GEq CId where+ geq = (==)+# endif++# if defined(HTYPE_KEY_T)+instance GEq CKey where+ geq = (==)+# endif++# if defined(HTYPE_TIMER_T)+instance GEq CTimer where+ geq = (==)+# endif+#endif
src/Generics/Deriving/Foldable.hs view
@@ -1,326 +1,326 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Foldable ( - -- * Generic Foldable class - GFoldable(..) - - -- * Default method - , gfoldMapdefault - - -- * Derived functions - , gtoList - , gconcat - , gconcatMap - , gand - , gor - , gany - , gall - , gsum - , gproduct - , gmaximum - , gmaximumBy - , gminimum - , gminimumBy - , gelem - , gnotElem - , gfind - - -- * Internal Foldable class - , GFoldable'(..) - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Maybe -import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..)) -import Data.Monoid (All(..), Any(..), Dual(..), Endo(..)) -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (Monoid(..)) -#endif - -import Generics.Deriving.Base - -#if MIN_VERSION_base(4,4,0) -import Data.Complex (Complex) -#endif - -#if MIN_VERSION_base(4,6,0) -import Data.Ord (Down) -#else -import GHC.Exts (Down) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Functor.Product as Functor (Product) -import qualified Data.Functor.Sum as Functor (Sum) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Semigroup as Semigroup (First, Last) -import Data.Semigroup (Arg, Max, Min, WrappedMonoid) -#endif - --------------------------------------------------------------------------------- --- Generic fold --------------------------------------------------------------------------------- - -class GFoldable' t where - gfoldMap' :: Monoid m => (a -> m) -> t a -> m - -instance GFoldable' V1 where - gfoldMap' _ _ = mempty - -instance GFoldable' U1 where - gfoldMap' _ U1 = mempty - -instance GFoldable' Par1 where - gfoldMap' f (Par1 a) = f a - -instance GFoldable' (K1 i c) where - gfoldMap' _ (K1 _) = mempty - -instance (GFoldable f) => GFoldable' (Rec1 f) where - gfoldMap' f (Rec1 a) = gfoldMap f a - -instance (GFoldable' f) => GFoldable' (M1 i c f) where - gfoldMap' f (M1 a) = gfoldMap' f a - -instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where - gfoldMap' f (L1 a) = gfoldMap' f a - gfoldMap' f (R1 a) = gfoldMap' f a - -instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where - gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b) - -instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where - gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x - -instance GFoldable' UAddr where - gfoldMap' _ (UAddr _) = mempty - -instance GFoldable' UChar where - gfoldMap' _ (UChar _) = mempty - -instance GFoldable' UDouble where - gfoldMap' _ (UDouble _) = mempty - -instance GFoldable' UFloat where - gfoldMap' _ (UFloat _) = mempty - -instance GFoldable' UInt where - gfoldMap' _ (UInt _) = mempty - -instance GFoldable' UWord where - gfoldMap' _ (UWord _) = mempty - -class GFoldable t where - gfoldMap :: Monoid m => (a -> m) -> t a -> m -#if __GLASGOW_HASKELL__ >= 701 - default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) - => (a -> m) -> t a -> m - gfoldMap = gfoldMapdefault -#endif - - gfold :: Monoid m => t m -> m - gfold = gfoldMap id - - gfoldr :: (a -> b -> b) -> b -> t a -> b - gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z - - gfoldr' :: (a -> b -> b) -> b -> t a -> b - gfoldr' f z0 xs = gfoldl f' id xs z0 - where f' k x z = k $! f x z - - gfoldl :: (a -> b -> a) -> a -> t b -> a - gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z - - gfoldl' :: (a -> b -> a) -> a -> t b -> a - gfoldl' f z0 xs = gfoldr f' id xs z0 - where f' x k z = k $! f z x - - gfoldr1 :: (a -> a -> a) -> t a -> a - gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure") - (gfoldr mf Nothing xs) - where - mf x Nothing = Just x - mf x (Just y) = Just (f x y) - - gfoldl1 :: (a -> a -> a) -> t a -> a - gfoldl1 f xs = fromMaybe (error "foldl1: empty structure") - (gfoldl mf Nothing xs) - where - mf Nothing y = Just y - mf (Just x) y = Just (f x y) - -gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) - => (a -> m) -> t a -> m -gfoldMapdefault f x = gfoldMap' f (from1 x) - --- Base types instances -instance GFoldable ((,) a) where - gfoldMap = gfoldMapdefault - -instance GFoldable [] where - gfoldMap = gfoldMapdefault - -#if MIN_VERSION_base(4,9,0) -instance GFoldable (Arg a) where - gfoldMap = gfoldMapdefault -#endif - -#if MIN_VERSION_base(4,4,0) -instance GFoldable Complex where - gfoldMap = gfoldMapdefault -#endif - -instance GFoldable (Const m) where - gfoldMap = gfoldMapdefault - -instance GFoldable Down where - gfoldMap = gfoldMapdefault - -instance GFoldable Dual where - gfoldMap = gfoldMapdefault - -instance GFoldable (Either a) where - gfoldMap = gfoldMapdefault - -instance GFoldable Monoid.First where - gfoldMap = gfoldMapdefault - -#if MIN_VERSION_base(4,9,0) -instance GFoldable (Semigroup.First) where - gfoldMap = gfoldMapdefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GFoldable Identity where - gfoldMap = gfoldMapdefault -#endif - -instance GFoldable Monoid.Last where - gfoldMap = gfoldMapdefault - -#if MIN_VERSION_base(4,9,0) -instance GFoldable Semigroup.Last where - gfoldMap = gfoldMapdefault - -instance GFoldable Max where - gfoldMap = gfoldMapdefault -#endif - -instance GFoldable Maybe where - gfoldMap = gfoldMapdefault - -#if MIN_VERSION_base(4,9,0) -instance GFoldable Min where - gfoldMap = gfoldMapdefault - -instance GFoldable NonEmpty where - gfoldMap = gfoldMapdefault -#endif - -instance GFoldable Monoid.Product where - gfoldMap = gfoldMapdefault - -#if MIN_VERSION_base(4,9,0) -instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where - gfoldMap = gfoldMapdefault -#endif - -#if MIN_VERSION_base(4,7,0) -instance GFoldable Proxy where - gfoldMap = gfoldMapdefault -#endif - -instance GFoldable Monoid.Sum where - gfoldMap = gfoldMapdefault - -#if MIN_VERSION_base(4,9,0) -instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where - gfoldMap = gfoldMapdefault - -instance GFoldable WrappedMonoid where - gfoldMap = gfoldMapdefault -#endif - -instance GFoldable ZipList where - gfoldMap = gfoldMapdefault - -gtoList :: GFoldable t => t a -> [a] -gtoList = gfoldr (:) [] - -gconcat :: GFoldable t => t [a] -> [a] -gconcat = gfold - -gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b] -gconcatMap = gfoldMap - -gand :: GFoldable t => t Bool -> Bool -gand = getAll . gfoldMap All - -gor :: GFoldable t => t Bool -> Bool -gor = getAny . gfoldMap Any - -gany :: GFoldable t => (a -> Bool) -> t a -> Bool -gany p = getAny . gfoldMap (Any . p) - -gall :: GFoldable t => (a -> Bool) -> t a -> Bool -gall p = getAll . gfoldMap (All . p) - -gsum :: (GFoldable t, Num a) => t a -> a -gsum = Monoid.getSum . gfoldMap Monoid.Sum - -gproduct :: (GFoldable t, Num a) => t a -> a -gproduct = Monoid.getProduct . gfoldMap Monoid.Product - -gmaximum :: (GFoldable t, Ord a) => t a -> a -gmaximum = gfoldr1 max - -gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a -gmaximumBy cmp = gfoldr1 max' - where max' x y = case cmp x y of - GT -> x - _ -> y - -gminimum :: (GFoldable t, Ord a) => t a -> a -gminimum = gfoldr1 min - -gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a -gminimumBy cmp = gfoldr1 min' - where min' x y = case cmp x y of - GT -> y - _ -> x - -gelem :: (GFoldable t, Eq a) => a -> t a -> Bool -gelem = gany . (==) - -gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool -gnotElem x = not . gelem x - -gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a -gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else []) +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Foldable (+ -- * Generic Foldable class+ GFoldable(..)++ -- * Default method+ , gfoldMapdefault++ -- * Derived functions+ , gtoList+ , gconcat+ , gconcatMap+ , gand+ , gor+ , gany+ , gall+ , gsum+ , gproduct+ , gmaximum+ , gmaximumBy+ , gminimum+ , gminimumBy+ , gelem+ , gnotElem+ , gfind++ -- * Internal Foldable class+ , GFoldable'(..)+ ) where++import Control.Applicative (Const, ZipList)++import Data.Maybe+import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..))+import Data.Monoid (All(..), Any(..), Dual(..), Endo(..))+#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid(..))+#endif++import Generics.Deriving.Base++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic fold+--------------------------------------------------------------------------------++class GFoldable' t where+ gfoldMap' :: Monoid m => (a -> m) -> t a -> m++instance GFoldable' V1 where+ gfoldMap' _ _ = mempty++instance GFoldable' U1 where+ gfoldMap' _ U1 = mempty++instance GFoldable' Par1 where+ gfoldMap' f (Par1 a) = f a++instance GFoldable' (K1 i c) where+ gfoldMap' _ (K1 _) = mempty++instance (GFoldable f) => GFoldable' (Rec1 f) where+ gfoldMap' f (Rec1 a) = gfoldMap f a++instance (GFoldable' f) => GFoldable' (M1 i c f) where+ gfoldMap' f (M1 a) = gfoldMap' f a++instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where+ gfoldMap' f (L1 a) = gfoldMap' f a+ gfoldMap' f (R1 a) = gfoldMap' f a++instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where+ gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b)++instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where+ gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x++instance GFoldable' UAddr where+ gfoldMap' _ (UAddr _) = mempty++instance GFoldable' UChar where+ gfoldMap' _ (UChar _) = mempty++instance GFoldable' UDouble where+ gfoldMap' _ (UDouble _) = mempty++instance GFoldable' UFloat where+ gfoldMap' _ (UFloat _) = mempty++instance GFoldable' UInt where+ gfoldMap' _ (UInt _) = mempty++instance GFoldable' UWord where+ gfoldMap' _ (UWord _) = mempty++class GFoldable t where+ gfoldMap :: Monoid m => (a -> m) -> t a -> m+#if __GLASGOW_HASKELL__ >= 701+ default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)+ => (a -> m) -> t a -> m+ gfoldMap = gfoldMapdefault+#endif++ gfold :: Monoid m => t m -> m+ gfold = gfoldMap id++ gfoldr :: (a -> b -> b) -> b -> t a -> b+ gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z++ gfoldr' :: (a -> b -> b) -> b -> t a -> b+ gfoldr' f z0 xs = gfoldl f' id xs z0+ where f' k x z = k $! f x z++ gfoldl :: (a -> b -> a) -> a -> t b -> a+ gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z++ gfoldl' :: (a -> b -> a) -> a -> t b -> a+ gfoldl' f z0 xs = gfoldr f' id xs z0+ where f' x k z = k $! f z x++ gfoldr1 :: (a -> a -> a) -> t a -> a+ gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure")+ (gfoldr mf Nothing xs)+ where+ mf x Nothing = Just x+ mf x (Just y) = Just (f x y)++ gfoldl1 :: (a -> a -> a) -> t a -> a+ gfoldl1 f xs = fromMaybe (error "foldl1: empty structure")+ (gfoldl mf Nothing xs)+ where+ mf Nothing y = Just y+ mf (Just x) y = Just (f x y)++gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)+ => (a -> m) -> t a -> m+gfoldMapdefault f x = gfoldMap' f (from1 x)++-- Base types instances+instance GFoldable ((,) a) where+ gfoldMap = gfoldMapdefault++instance GFoldable [] where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable (Arg a) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GFoldable Complex where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable (Const m) where+ gfoldMap = gfoldMapdefault++instance GFoldable Down where+ gfoldMap = gfoldMapdefault++instance GFoldable Dual where+ gfoldMap = gfoldMapdefault++instance GFoldable (Either a) where+ gfoldMap = gfoldMapdefault++instance GFoldable Monoid.First where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable (Semigroup.First) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GFoldable Identity where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Last where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable Semigroup.Last where+ gfoldMap = gfoldMapdefault++instance GFoldable Max where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Maybe where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable Min where+ gfoldMap = gfoldMapdefault++instance GFoldable NonEmpty where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Product where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,7,0)+instance GFoldable Proxy where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Sum where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where+ gfoldMap = gfoldMapdefault++instance GFoldable WrappedMonoid where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable ZipList where+ gfoldMap = gfoldMapdefault++gtoList :: GFoldable t => t a -> [a]+gtoList = gfoldr (:) []++gconcat :: GFoldable t => t [a] -> [a]+gconcat = gfold++gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b]+gconcatMap = gfoldMap++gand :: GFoldable t => t Bool -> Bool+gand = getAll . gfoldMap All++gor :: GFoldable t => t Bool -> Bool+gor = getAny . gfoldMap Any++gany :: GFoldable t => (a -> Bool) -> t a -> Bool+gany p = getAny . gfoldMap (Any . p)++gall :: GFoldable t => (a -> Bool) -> t a -> Bool+gall p = getAll . gfoldMap (All . p)++gsum :: (GFoldable t, Num a) => t a -> a+gsum = Monoid.getSum . gfoldMap Monoid.Sum++gproduct :: (GFoldable t, Num a) => t a -> a+gproduct = Monoid.getProduct . gfoldMap Monoid.Product++gmaximum :: (GFoldable t, Ord a) => t a -> a+gmaximum = gfoldr1 max++gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a+gmaximumBy cmp = gfoldr1 max'+ where max' x y = case cmp x y of+ GT -> x+ _ -> y++gminimum :: (GFoldable t, Ord a) => t a -> a+gminimum = gfoldr1 min++gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a+gminimumBy cmp = gfoldr1 min'+ where min' x y = case cmp x y of+ GT -> y+ _ -> x++gelem :: (GFoldable t, Eq a) => a -> t a -> Bool+gelem = gany . (==)++gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool+gnotElem x = not . gelem x++gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a+gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else [])
src/Generics/Deriving/Functor.hs view
@@ -1,242 +1,242 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -#endif - -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Functor ( - -- * Generic Functor class - GFunctor(..) - - -- * Default method - , gmapdefault - - -- * Internal Functor class - , GFunctor'(..) - - ) where - -import Control.Applicative (Const, ZipList) - -import qualified Data.Monoid as Monoid (First, Last, Product, Sum) -import Data.Monoid (Dual) - -import Generics.Deriving.Base - -#if MIN_VERSION_base(4,4,0) -import Data.Complex (Complex) -#endif - -#if MIN_VERSION_base(4,6,0) -import Data.Ord (Down) -#else -import GHC.Exts (Down) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Functor.Product as Functor (Product) -import qualified Data.Functor.Sum as Functor (Sum) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Semigroup as Semigroup (First, Last) -import Data.Semigroup (Arg, Max, Min, WrappedMonoid) -#endif - --------------------------------------------------------------------------------- --- Generic fmap --------------------------------------------------------------------------------- - -class GFunctor' f where - gmap' :: (a -> b) -> f a -> f b - -instance GFunctor' V1 where - gmap' _ x = case x of -#if __GLASGOW_HASKELL__ >= 708 - {} -#else - !_ -> error "Void gmap" -#endif - -instance GFunctor' U1 where - gmap' _ U1 = U1 - -instance GFunctor' Par1 where - gmap' f (Par1 a) = Par1 (f a) - -instance GFunctor' (K1 i c) where - gmap' _ (K1 a) = K1 a - -instance (GFunctor f) => GFunctor' (Rec1 f) where - gmap' f (Rec1 a) = Rec1 (gmap f a) - -instance (GFunctor' f) => GFunctor' (M1 i c f) where - gmap' f (M1 a) = M1 (gmap' f a) - -instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where - gmap' f (L1 a) = L1 (gmap' f a) - gmap' f (R1 a) = R1 (gmap' f a) - -instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where - gmap' f (a :*: b) = gmap' f a :*: gmap' f b - -instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where - gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x) - -instance GFunctor' UAddr where - gmap' _ (UAddr a) = UAddr a - -instance GFunctor' UChar where - gmap' _ (UChar c) = UChar c - -instance GFunctor' UDouble where - gmap' _ (UDouble d) = UDouble d - -instance GFunctor' UFloat where - gmap' _ (UFloat f) = UFloat f - -instance GFunctor' UInt where - gmap' _ (UInt i) = UInt i - -instance GFunctor' UWord where - gmap' _ (UWord w) = UWord w - -class GFunctor f where - gmap :: (a -> b) -> f a -> f b -#if __GLASGOW_HASKELL__ >= 701 - default gmap :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b - gmap = gmapdefault -#endif - -gmapdefault :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b -gmapdefault f = to1 . gmap' f . from1 - --- Base types instances -instance GFunctor ((->) r) where - gmap = fmap - -instance GFunctor ((,) a) where - gmap = gmapdefault - -instance GFunctor [] where - gmap = gmapdefault - -#if MIN_VERSION_base(4,8,0) -instance GFunctor f => GFunctor (Alt f) where - gmap = gmapdefault -#endif - -#if MIN_VERSION_base(4,9,0) -instance GFunctor (Arg a) where - gmap = gmapdefault -#endif - -#if MIN_VERSION_base(4,4,0) -instance GFunctor Complex where - gmap = gmapdefault -#endif - -instance GFunctor (Const m) where - gmap = gmapdefault - -instance GFunctor Down where - gmap = gmapdefault - -instance GFunctor Dual where - gmap = gmapdefault - -instance GFunctor (Either a) where - gmap = gmapdefault - -instance GFunctor Monoid.First where - gmap = gmapdefault - -#if MIN_VERSION_base(4,9,0) -instance GFunctor (Semigroup.First) where - gmap = gmapdefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GFunctor Identity where - gmap = gmapdefault -#endif - -instance GFunctor IO where - gmap = fmap - -instance GFunctor Monoid.Last where - gmap = gmapdefault - -#if MIN_VERSION_base(4,9,0) -instance GFunctor Semigroup.Last where - gmap = gmapdefault - -instance GFunctor Max where - gmap = gmapdefault -#endif - -instance GFunctor Maybe where - gmap = gmapdefault - -#if MIN_VERSION_base(4,9,0) -instance GFunctor Min where - gmap = gmapdefault - -instance GFunctor NonEmpty where - gmap = gmapdefault -#endif - -instance GFunctor Monoid.Product where - gmap = gmapdefault - -#if MIN_VERSION_base(4,9,0) -instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where - gmap = gmapdefault -#endif - -#if MIN_VERSION_base(4,7,0) -instance GFunctor Proxy where - gmap = gmapdefault -#endif - -instance GFunctor Monoid.Sum where - gmap = gmapdefault - -#if MIN_VERSION_base(4,9,0) -instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where - gmap = gmapdefault - -instance GFunctor WrappedMonoid where - gmap = gmapdefault -#endif - -instance GFunctor ZipList where - gmap = gmapdefault +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Functor (+ -- * Generic Functor class+ GFunctor(..)++ -- * Default method+ , gmapdefault++ -- * Internal Functor class+ , GFunctor'(..)++ ) where++import Control.Applicative (Const, ZipList)++import qualified Data.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)++import Generics.Deriving.Base++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic fmap+--------------------------------------------------------------------------------++class GFunctor' f where+ gmap' :: (a -> b) -> f a -> f b++instance GFunctor' V1 where+ gmap' _ x = case x of+#if __GLASGOW_HASKELL__ >= 708+ {}+#else+ !_ -> error "Void gmap"+#endif++instance GFunctor' U1 where+ gmap' _ U1 = U1++instance GFunctor' Par1 where+ gmap' f (Par1 a) = Par1 (f a)++instance GFunctor' (K1 i c) where+ gmap' _ (K1 a) = K1 a++instance (GFunctor f) => GFunctor' (Rec1 f) where+ gmap' f (Rec1 a) = Rec1 (gmap f a)++instance (GFunctor' f) => GFunctor' (M1 i c f) where+ gmap' f (M1 a) = M1 (gmap' f a)++instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where+ gmap' f (L1 a) = L1 (gmap' f a)+ gmap' f (R1 a) = R1 (gmap' f a)++instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where+ gmap' f (a :*: b) = gmap' f a :*: gmap' f b++instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where+ gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x)++instance GFunctor' UAddr where+ gmap' _ (UAddr a) = UAddr a++instance GFunctor' UChar where+ gmap' _ (UChar c) = UChar c++instance GFunctor' UDouble where+ gmap' _ (UDouble d) = UDouble d++instance GFunctor' UFloat where+ gmap' _ (UFloat f) = UFloat f++instance GFunctor' UInt where+ gmap' _ (UInt i) = UInt i++instance GFunctor' UWord where+ gmap' _ (UWord w) = UWord w++class GFunctor f where+ gmap :: (a -> b) -> f a -> f b+#if __GLASGOW_HASKELL__ >= 701+ default gmap :: (Generic1 f, GFunctor' (Rep1 f))+ => (a -> b) -> f a -> f b+ gmap = gmapdefault+#endif++gmapdefault :: (Generic1 f, GFunctor' (Rep1 f))+ => (a -> b) -> f a -> f b+gmapdefault f = to1 . gmap' f . from1++-- Base types instances+instance GFunctor ((->) r) where+ gmap = fmap++instance GFunctor ((,) a) where+ gmap = gmapdefault++instance GFunctor [] where+ gmap = gmapdefault++#if MIN_VERSION_base(4,8,0)+instance GFunctor f => GFunctor (Alt f) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GFunctor (Arg a) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GFunctor Complex where+ gmap = gmapdefault+#endif++instance GFunctor (Const m) where+ gmap = gmapdefault++instance GFunctor Down where+ gmap = gmapdefault++instance GFunctor Dual where+ gmap = gmapdefault++instance GFunctor (Either a) where+ gmap = gmapdefault++instance GFunctor Monoid.First where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor (Semigroup.First) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GFunctor Identity where+ gmap = gmapdefault+#endif++instance GFunctor IO where+ gmap = fmap++instance GFunctor Monoid.Last where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor Semigroup.Last where+ gmap = gmapdefault++instance GFunctor Max where+ gmap = gmapdefault+#endif++instance GFunctor Maybe where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor Min where+ gmap = gmapdefault++instance GFunctor NonEmpty where+ gmap = gmapdefault+#endif++instance GFunctor Monoid.Product where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,7,0)+instance GFunctor Proxy where+ gmap = gmapdefault+#endif++instance GFunctor Monoid.Sum where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where+ gmap = gmapdefault++instance GFunctor WrappedMonoid where+ gmap = gmapdefault+#endif++instance GFunctor ZipList where+ gmap = gmapdefault
src/Generics/Deriving/Instances.hs view
@@ -1,3585 +1,3585 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Generics.Deriving.Instances ( --- Only instances from Generics.Deriving.Base --- and the Generic1 instances -#if !(MIN_VERSION_base(4,16,0)) - Rep0Tuple8 - , Rep0Tuple9 - , Rep0Tuple10 - , Rep0Tuple11 - , Rep0Tuple12 - , Rep0Tuple13 - , Rep0Tuple14 - , Rep0Tuple15 - , Rep1Tuple8 - , Rep1Tuple9 - , Rep1Tuple10 - , Rep1Tuple11 - , Rep1Tuple12 - , Rep1Tuple13 - , Rep1Tuple14 - , Rep1Tuple15 -#endif -#if !(MIN_VERSION_base(4,14,0)) - , Rep0Kleisli - , Rep1Kleisli -#endif -#if !(MIN_VERSION_base(4,12,0)) - , Rep0Down - , Rep1Down -#endif -#if !(MIN_VERSION_base(4,9,0)) - , Rep0ExitCode - , Rep0Version - , Rep1ConSum - , Rep1ConProduct - , Rep1ConCompose - , Rep1K1 - , Rep1M1 - , Rep1Par1 - , Rep1Rec1 - , Rep1U1 - , Rep0V1 - , Rep1V1 - , Rep0UAddr - , Rep1UAddr - , Rep0UChar - , Rep1UChar - , Rep0UDouble - , Rep1UDouble - , Rep0UFloat - , Rep1UFloat - , Rep0UInt - , Rep1UInt - , Rep0UWord - , Rep1UWord -# if MIN_VERSION_base(4,4,0) - , Rep0Complex - , Rep1Complex -# endif -# if MIN_VERSION_base(4,7,0) - , Rep1Proxy -# endif -#endif -#if !(MIN_VERSION_base(4,7,0)) - , Rep0All - , Rep0Any - , Rep0Arity - , Rep0Associativity - , Rep0Const - , Rep1Const - , Rep0Dual - , Rep1Dual - , Rep0Endo - , Rep0First - , Rep1First - , Rep0Fixity - , Rep0Last - , Rep1Last - , Rep0Product - , Rep1Product - , Rep0Sum - , Rep1Sum - , Rep0WrappedArrow - , Rep1WrappedArrow - , Rep0WrappedMonad - , Rep1WrappedMonad - , Rep0ZipList - , Rep1ZipList - , Rep0U1 - , Rep0Par1 - , Rep0Rec1 - , Rep0K1 - , Rep0M1 - , Rep0ConSum - , Rep0ConProduct - , Rep0ConCompose -#endif -#if !(MIN_VERSION_base(4,6,0)) - , Rep1Either - , Rep1List - , Rep1Maybe - , Rep1Tuple2 - , Rep1Tuple3 - , Rep1Tuple4 - , Rep1Tuple5 - , Rep1Tuple6 - , Rep1Tuple7 -#endif -#if !(MIN_VERSION_base(4,4,0)) - , Rep0Bool - , Rep0Char - , Rep0Double - , Rep0Either - , Rep0Int - , Rep0Float - , Rep0List - , Rep0Maybe - , Rep0Ordering - , Rep0Tuple2 - , Rep0Tuple3 - , Rep0Tuple4 - , Rep0Tuple5 - , Rep0Tuple6 - , Rep0Tuple7 - , Rep0Unit -#endif - ) where - -#if !(MIN_VERSION_base(4,7,0)) -import Control.Applicative -import Data.Monoid -#endif - -#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,9,0)) -import Data.Complex (Complex(..)) -#endif - -#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,9,0)) -import Data.Proxy (Proxy(..)) -#endif - -#if !(MIN_VERSION_base(4,9,0)) -import Data.Version (Version(..)) -import System.Exit (ExitCode(..)) -#endif - -#if !(MIN_VERSION_base(4,12,0)) -# if MIN_VERSION_base(4,6,0) -import Data.Ord (Down(..)) -# else -import GHC.Exts (Down(..)) -# endif -#endif - -#if !(MIN_VERSION_base(4,14,0)) -import Control.Arrow (Kleisli(..)) -#endif - -#if !(MIN_VERSION_base(4,16,0)) -import Generics.Deriving.Base.Internal -#endif - -#if !(MIN_VERSION_base(4,16,0)) -# if MIN_VERSION_base(4,6,0) -type Rep0Tuple8 a b c d e f g h = Rep (a, b, c, d, e, f, g, h) -type Rep0Tuple9 a b c d e f g h i = Rep (a, b, c, d, e, f, g, h, i) -type Rep0Tuple10 a b c d e f g h i j = Rep (a, b, c, d, e, f, g, h, i, j) -type Rep0Tuple11 a b c d e f g h i j k = Rep (a, b, c, d, e, f, g, h, i, j, k) -type Rep0Tuple12 a b c d e f g h i j k l = Rep (a, b, c, d, e, f, g, h, i, j, k, l) -type Rep0Tuple13 a b c d e f g h i j k l m = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m) -type Rep0Tuple14 a b c d e f g h i j k l m n = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -type Rep0Tuple15 a b c d e f g h i j k l m n o = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -type Rep1Tuple8 a b c d e f g = Rep1 ((,,,,,,,) a b c d e f g) -type Rep1Tuple9 a b c d e f g h = Rep1 ((,,,,,,,,) a b c d e f g h) -type Rep1Tuple10 a b c d e f g h i = Rep1 ((,,,,,,,,,) a b c d e f g h i) -type Rep1Tuple11 a b c d e f g h i j = Rep1 ((,,,,,,,,,,) a b c d e f g h i j) -type Rep1Tuple12 a b c d e f g h i j k = Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k) -type Rep1Tuple13 a b c d e f g h i j k l = Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) -type Rep1Tuple14 a b c d e f g h i j k l m = Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) -type Rep1Tuple15 a b c d e f g h i j k l m n = Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) -deriving instance Generic (a, b, c, d, e, f, g, h) -deriving instance Generic (a, b, c, d, e, f, g, h, i) -deriving instance Generic (a, b, c, d, e, f, g, h, i, j) -deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k) -deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l) -deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m) -deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -deriving instance Generic1 ((,,,,,,,) a b c d e f g) -deriving instance Generic1 ((,,,,,,,,) a b c d e f g h) -deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i) -deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j) -deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k) -deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) -deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) -deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) -# else -type Rep0Tuple8 a b c d e f g h = D1 - D1Tuple8 - (C1 - C1_0Tuple8 - (((S1 - NoSelector - (Rec0 a) - :*: S1 - NoSelector - (Rec0 - b)) - :*: (S1 - NoSelector - (Rec0 - c) - :*: S1 - NoSelector - (Rec0 - d))) - :*: ((S1 - NoSelector - (Rec0 - e) - :*: S1 - NoSelector - (Rec0 - f)) - :*: (S1 - NoSelector - (Rec0 - g) - :*: S1 - NoSelector - (Rec0 - h))))) -type Rep1Tuple8 a b c d e f g = D1 - D1Tuple8 - (C1 - C1_0Tuple8 - (((S1 - NoSelector - (Rec0 a) - :*: S1 - NoSelector - (Rec0 - b)) - :*: (S1 - NoSelector - (Rec0 - c) - :*: S1 - NoSelector - (Rec0 - d))) - :*: ((S1 - NoSelector - (Rec0 - e) - :*: S1 - NoSelector - (Rec0 - f)) - :*: (S1 - NoSelector - (Rec0 - g) - :*: S1 - NoSelector - Par1)))) - -instance Generic (a, b, c, d, e, f, g, h) where - type Rep (a, b, c, d, e, f, g, h) = Rep0Tuple8 a b c d e f g h - - from x - = M1 - (case x of { - (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - (M1 (K1 g4)))) - ((:*:) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))) - ((:*:) - (M1 (K1 g7)) - (M1 (K1 g8))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) (M1 (K1 g3)) - (M1 (K1 g4)))) - ((:*:) ((:*:) (M1 (K1 g5)) - (M1 (K1 g6))) - ((:*:) (M1 (K1 g7)) - (M1 (K1 g8)))))) - -> (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 } - -instance Generic1 ((,,,,,,,) a b c d e f g) where - type Rep1 ((,,,,,,,) a b c d e f g) = Rep1Tuple8 a b c d e f g - - from1 x - = M1 - (case x of { - (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - (M1 (K1 g4)))) - ((:*:) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))) - ((:*:) - (M1 (K1 g7)) - (M1 (Par1 g8))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - (M1 g2)) - ((:*:) (M1 g3) - (M1 g4))) - ((:*:) ((:*:) (M1 g5) - (M1 g6)) - ((:*:) (M1 g7) - (M1 g8))))) - -> (,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unPar1 g8) } - -data D1Tuple8 -data C1_0Tuple8 - -instance Datatype D1Tuple8 where - datatypeName _ = "(,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple8 where - conName _ = "(,,,,,,,)" - ------ - -type Rep0Tuple9 a b c d e f g h i = D1 - D1Tuple9 - (C1 - C1_0Tuple9 - (((S1 - NoSelector - (Rec0 a) - :*: S1 - NoSelector - (Rec0 - b)) - :*: (S1 - NoSelector - (Rec0 - c) - :*: S1 - NoSelector - (Rec0 - d))) - :*: ((S1 - NoSelector - (Rec0 - e) - :*: S1 - NoSelector - (Rec0 - f)) - :*: (S1 - NoSelector - (Rec0 - g) - :*: (S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - (Rec0 - i)))))) -type Rep1Tuple9 a b c d e f g h = D1 - D1Tuple9 - (C1 - C1_0Tuple9 - (((S1 - NoSelector (Rec0 a) - :*: S1 - NoSelector - (Rec0 b)) - :*: (S1 - NoSelector - (Rec0 c) - :*: S1 - NoSelector - (Rec0 - d))) - :*: ((S1 - NoSelector - (Rec0 e) - :*: S1 - NoSelector - (Rec0 - f)) - :*: (S1 - NoSelector - (Rec0 - g) - :*: (S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - Par1))))) - -instance Generic (a, b, c, d, e, f, g, h, i) where - type Rep (a, b, c, d, e, f, g, h, i) = Rep0Tuple9 a b c d e f g h i - - from x - = M1 - (case x of { - (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - (M1 (K1 g4)))) - ((:*:) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))) - ((:*:) - (M1 (K1 g7)) - ((:*:) - (M1 (K1 g8)) - (M1 (K1 g9)))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) (M1 (K1 g3)) - (M1 (K1 g4)))) - ((:*:) ((:*:) (M1 (K1 g5)) - (M1 (K1 g6))) - ((:*:) (M1 (K1 g7)) - ((:*:) (M1 (K1 g8)) - (M1 (K1 g9))))))) - -> (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 } - -instance Generic1 ((,,,,,,,,) a b c d e f g h) where - type Rep1 ((,,,,,,,,) a b c d e f g h) = Rep1Tuple9 a b c d e f g h - - from1 x - = M1 - (case x of { - (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - (M1 (K1 g4)))) - ((:*:) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))) - ((:*:) - (M1 (K1 g7)) - ((:*:) - (M1 (K1 g8)) - (M1 (Par1 g9)))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - (M1 g2)) - ((:*:) (M1 g3) - (M1 g4))) - ((:*:) ((:*:) (M1 g5) - (M1 g6)) - ((:*:) (M1 g7) - ((:*:) (M1 g8) - (M1 g9)))))) - -> (,,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unK1 g8) - (unPar1 g9) } - -data D1Tuple9 -data C1_0Tuple9 - -instance Datatype D1Tuple9 where - datatypeName _ = "(,,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple9 where - conName _ = "(,,,,,,,,)" - ------ - -type Rep0Tuple10 a b c d e f g h i j = D1 - D1Tuple10 - (C1 - C1_0Tuple10 - (((S1 - NoSelector (Rec0 a) - :*: S1 - NoSelector - (Rec0 b)) - :*: (S1 - NoSelector - (Rec0 c) - :*: (S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)))) - :*: ((S1 - NoSelector - (Rec0 f) - :*: S1 - NoSelector - (Rec0 - g)) - :*: (S1 - NoSelector - (Rec0 - h) - :*: (S1 - NoSelector - (Rec0 - i) - :*: S1 - NoSelector - (Rec0 - j)))))) -type Rep1Tuple10 a b c d e f g h i = D1 - D1Tuple10 - (C1 - C1_0Tuple10 - (((S1 - NoSelector (Rec0 a) - :*: S1 - NoSelector - (Rec0 b)) - :*: (S1 - NoSelector - (Rec0 c) - :*: (S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)))) - :*: ((S1 - NoSelector - (Rec0 f) - :*: S1 - NoSelector - (Rec0 - g)) - :*: (S1 - NoSelector - (Rec0 - h) - :*: (S1 - NoSelector - (Rec0 - i) - :*: S1 - NoSelector - Par1))))) - -instance Generic (a, b, c, d, e, f, g, h, i, j) where - type Rep (a, b, c, d, e, f, g, h, i, j) = Rep0Tuple10 a b c d e f g h i j - - from x - = M1 - (case x of { - (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))))) - ((:*:) - ((:*:) - (M1 (K1 g6)) - (M1 (K1 g7))) - ((:*:) - (M1 (K1 g8)) - ((:*:) - (M1 (K1 g9)) - (M1 (K1 g10)))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) (M1 (K1 g3)) - ((:*:) (M1 (K1 g4)) - (M1 (K1 g5))))) - ((:*:) ((:*:) (M1 (K1 g6)) - (M1 (K1 g7))) - ((:*:) (M1 (K1 g8)) - ((:*:) (M1 (K1 g9)) - (M1 (K1 g10))))))) - -> (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 } - -instance Generic1 - ((,,,,,,,,,) a b c d e f g h i) where - type Rep1 ((,,,,,,,,,) a b c d e f g h i) = Rep1Tuple10 a b c d e f g h i - - from1 x - = M1 - (case x of { - (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))))) - ((:*:) - ((:*:) - (M1 (K1 g6)) - (M1 (K1 g7))) - ((:*:) - (M1 (K1 g8)) - ((:*:) - (M1 (K1 g9)) - (M1 (Par1 g10)))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - (M1 g2)) - ((:*:) (M1 g3) - ((:*:) (M1 g4) - (M1 g5)))) - ((:*:) ((:*:) (M1 g6) - (M1 g7)) - ((:*:) (M1 g8) - ((:*:) (M1 g9) - (M1 g10)))))) - -> (,,,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unK1 g8) - (unK1 g9) (unPar1 g10) } - -data D1Tuple10 -data C1_0Tuple10 - -instance Datatype D1Tuple10 where - datatypeName _ = "(,,,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple10 where - conName _ = "(,,,,,,,,,)" - ------ - -type Rep0Tuple11 a b c d e f g h i j k = D1 - D1Tuple11 - (C1 - C1_0Tuple11 - (((S1 - NoSelector - (Rec0 a) - :*: S1 - NoSelector - (Rec0 b)) - :*: (S1 - NoSelector - (Rec0 c) - :*: (S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)))) - :*: ((S1 - NoSelector - (Rec0 f) - :*: (S1 - NoSelector - (Rec0 - g) - :*: S1 - NoSelector - (Rec0 - h))) - :*: (S1 - NoSelector - (Rec0 - i) - :*: (S1 - NoSelector - (Rec0 - j) - :*: S1 - NoSelector - (Rec0 - k)))))) -type Rep1Tuple11 a b c d e f g h i j = D1 - D1Tuple11 - (C1 - C1_0Tuple11 - (((S1 - NoSelector - (Rec0 a) - :*: S1 - NoSelector - (Rec0 b)) - :*: (S1 - NoSelector - (Rec0 c) - :*: (S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)))) - :*: ((S1 - NoSelector - (Rec0 f) - :*: (S1 - NoSelector - (Rec0 - g) - :*: S1 - NoSelector - (Rec0 - h))) - :*: (S1 - NoSelector - (Rec0 - i) - :*: (S1 - NoSelector - (Rec0 - j) - :*: S1 - NoSelector - Par1))))) - -instance Generic - (a, b, c, d, e, f, g, h, i, j, k) where - type Rep (a, b, c, d, e, f, g, h, i, j, k) = Rep0Tuple11 a b c d e f g h i j k - - from x - = M1 - (case x of { - (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))))) - ((:*:) - ((:*:) - (M1 (K1 g6)) - ((:*:) - (M1 (K1 g7)) - (M1 (K1 g8)))) - ((:*:) - (M1 (K1 g9)) - ((:*:) - (M1 (K1 g10)) - (M1 (K1 g11)))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) (M1 (K1 g3)) - ((:*:) (M1 (K1 g4)) - (M1 (K1 g5))))) - ((:*:) ((:*:) (M1 (K1 g6)) - ((:*:) (M1 (K1 g7)) - (M1 (K1 g8)))) - ((:*:) (M1 (K1 g9)) - ((:*:) (M1 (K1 g10)) - (M1 (K1 g11))))))) - -> (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 } - -instance Generic1 - ((,,,,,,,,,,) a b c d e f g h i j) where - type Rep1 ((,,,,,,,,,,) a b c d e f g h i j) = Rep1Tuple11 a b c d e f g h i j - - from1 x - = M1 - (case x of { - (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - (M1 (K1 g2))) - ((:*:) - (M1 (K1 g3)) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))))) - ((:*:) - ((:*:) - (M1 (K1 g6)) - ((:*:) - (M1 (K1 g7)) - (M1 (K1 g8)))) - ((:*:) - (M1 (K1 g9)) - ((:*:) - (M1 (K1 g10)) - (M1 (Par1 g11)))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - (M1 g2)) - ((:*:) (M1 g3) - ((:*:) (M1 g4) - (M1 g5)))) - ((:*:) ((:*:) (M1 g6) - ((:*:) (M1 g7) - (M1 g8))) - ((:*:) (M1 g9) - ((:*:) (M1 g10) - (M1 g11)))))) - -> (,,,,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unK1 g8) - (unK1 g9) (unK1 g10) - (unPar1 g11) } - -data D1Tuple11 -data C1_0Tuple11 - -instance Datatype D1Tuple11 where - datatypeName _ = "(,,,,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple11 where - conName _ = "(,,,,,,,,,,)" - ------ - -type Rep0Tuple12 a b c d e f g h i j k l = D1 - D1Tuple12 - (C1 - C1_0Tuple12 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: (S1 - NoSelector - (Rec0 d) - :*: (S1 - NoSelector - (Rec0 - e) - :*: S1 - NoSelector - (Rec0 - f)))) - :*: ((S1 - NoSelector - (Rec0 g) - :*: (S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - (Rec0 - i))) - :*: (S1 - NoSelector - (Rec0 - j) - :*: (S1 - NoSelector - (Rec0 - k) - :*: S1 - NoSelector - (Rec0 - l)))))) -type Rep1Tuple12 a b c d e f g h i j k = D1 - D1Tuple12 - (C1 - C1_0Tuple12 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: (S1 - NoSelector - (Rec0 d) - :*: (S1 - NoSelector - (Rec0 - e) - :*: S1 - NoSelector - (Rec0 - f)))) - :*: ((S1 - NoSelector - (Rec0 g) - :*: (S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - (Rec0 - i))) - :*: (S1 - NoSelector - (Rec0 - j) - :*: (S1 - NoSelector - (Rec0 - k) - :*: S1 - NoSelector - Par1))))) - -instance Generic - (a, b, c, d, e, f, g, h, i, j, k, l) where - type Rep (a, b, c, d, e, f, g, h, i, j, k, l) = Rep0Tuple12 a b c d e f g h i j k l - - from x - = M1 - (case x of { - (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - (M1 (K1 g4)) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))))) - ((:*:) - ((:*:) - (M1 (K1 g7)) - ((:*:) - (M1 (K1 g8)) - (M1 (K1 g9)))) - ((:*:) - (M1 (K1 g10)) - ((:*:) - (M1 (K1 g11)) - (M1 (K1 g12)))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - ((:*:) (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) (M1 (K1 g4)) - ((:*:) (M1 (K1 g5)) - (M1 (K1 g6))))) - ((:*:) ((:*:) (M1 (K1 g7)) - ((:*:) (M1 (K1 g8)) - (M1 (K1 g9)))) - ((:*:) (M1 (K1 g10)) - ((:*:) (M1 (K1 g11)) - (M1 (K1 g12))))))) - -> (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 } - -instance Generic1 - ((,,,,,,,,,,,) a b c d e f g h i j k) where - type Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k) = Rep1Tuple12 a b c d e f g h i j k - - from1 x - = M1 - (case x of { - (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - (M1 (K1 g4)) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))))) - ((:*:) - ((:*:) - (M1 (K1 g7)) - ((:*:) - (M1 (K1 g8)) - (M1 (K1 g9)))) - ((:*:) - (M1 (K1 g10)) - ((:*:) - (M1 (K1 g11)) - (M1 (Par1 g12)))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - ((:*:) (M1 g2) - (M1 g3))) - ((:*:) (M1 g4) - ((:*:) (M1 g5) - (M1 g6)))) - ((:*:) ((:*:) (M1 g7) - ((:*:) (M1 g8) - (M1 g9))) - ((:*:) (M1 g10) - ((:*:) (M1 g11) - (M1 g12)))))) - -> (,,,,,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unK1 g8) - (unK1 g9) (unK1 g10) - (unK1 g11) (unPar1 g12) } - -data D1Tuple12 -data C1_0Tuple12 - -instance Datatype D1Tuple12 where - datatypeName _ = "(,,,,,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple12 where - conName _ = "(,,,,,,,,,,,)" - ------ - -type Rep0Tuple13 a b c d e f g h i j k l m = D1 - D1Tuple13 - (C1 - C1_0Tuple13 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 - b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: (S1 - NoSelector - (Rec0 - d) - :*: (S1 - NoSelector - (Rec0 - e) - :*: S1 - NoSelector - (Rec0 - f)))) - :*: ((S1 - NoSelector - (Rec0 - g) - :*: (S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - (Rec0 - i))) - :*: ((S1 - NoSelector - (Rec0 - j) - :*: S1 - NoSelector - (Rec0 - k)) - :*: (S1 - NoSelector - (Rec0 - l) - :*: S1 - NoSelector - (Rec0 - m)))))) -type Rep1Tuple13 a b c d e f g h i j k l = D1 - D1Tuple13 - (C1 - C1_0Tuple13 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 - b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: (S1 - NoSelector - (Rec0 - d) - :*: (S1 - NoSelector - (Rec0 - e) - :*: S1 - NoSelector - (Rec0 - f)))) - :*: ((S1 - NoSelector - (Rec0 - g) - :*: (S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - (Rec0 - i))) - :*: ((S1 - NoSelector - (Rec0 - j) - :*: S1 - NoSelector - (Rec0 - k)) - :*: (S1 - NoSelector - (Rec0 - l) - :*: S1 - NoSelector - Par1))))) - -data D1Tuple13 -data C1_0Tuple13 - -instance Generic - (a, b, c, d, e, f, g, h, i, j, k, l, m) where - type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m) = Rep0Tuple13 a b c d e f g h i j k l m - - from x - = M1 - (case x of { - (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - (M1 (K1 g4)) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))))) - ((:*:) - ((:*:) - (M1 (K1 g7)) - ((:*:) - (M1 (K1 g8)) - (M1 (K1 g9)))) - ((:*:) - ((:*:) - (M1 (K1 g10)) - (M1 (K1 g11))) - ((:*:) - (M1 (K1 g12)) - (M1 (K1 g13)))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - ((:*:) (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) (M1 (K1 g4)) - ((:*:) (M1 (K1 g5)) - (M1 (K1 g6))))) - ((:*:) ((:*:) (M1 (K1 g7)) - ((:*:) (M1 (K1 g8)) - (M1 (K1 g9)))) - ((:*:) ((:*:) (M1 (K1 g10)) - (M1 (K1 g11))) - ((:*:) (M1 (K1 g12)) - (M1 (K1 g13))))))) - -> (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 } - -instance Generic1 - ((,,,,,,,,,,,,) a b c d e f g h i j k l) where - type Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) = Rep1Tuple13 a b c d e f g h i j k l - - from1 x - = M1 - (case x of { - (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - (M1 (K1 g4)) - ((:*:) - (M1 (K1 g5)) - (M1 (K1 g6))))) - ((:*:) - ((:*:) - (M1 (K1 g7)) - ((:*:) - (M1 (K1 g8)) - (M1 (K1 g9)))) - ((:*:) - ((:*:) - (M1 (K1 g10)) - (M1 (K1 g11))) - ((:*:) - (M1 (K1 g12)) - (M1 (Par1 g13)))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - ((:*:) (M1 g2) - (M1 g3))) - ((:*:) (M1 g4) - ((:*:) (M1 g5) - (M1 g6)))) - ((:*:) ((:*:) (M1 g7) - ((:*:) (M1 g8) - (M1 g9))) - ((:*:) ((:*:) (M1 g10) - (M1 g11)) - ((:*:) (M1 g12) - (M1 g13)))))) - -> (,,,,,,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unK1 g8) - (unK1 g9) (unK1 g10) - (unK1 g11) (unK1 g12) - (unPar1 g13) } - -instance Datatype D1Tuple13 where - datatypeName _ = "(,,,,,,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple13 where - conName _ = "(,,,,,,,,,,,,)" - ------ - -type Rep0Tuple14 a b c d e f g h i j k l m n = D1 - D1Tuple14 - (C1 - C1_0Tuple14 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 - b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: ((S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)) - :*: (S1 - NoSelector - (Rec0 - f) - :*: S1 - NoSelector - (Rec0 - g)))) - :*: ((S1 - NoSelector - (Rec0 - h) - :*: (S1 - NoSelector - (Rec0 - i) - :*: S1 - NoSelector - (Rec0 - j))) - :*: ((S1 - NoSelector - (Rec0 - k) - :*: S1 - NoSelector - (Rec0 - l)) - :*: (S1 - NoSelector - (Rec0 - m) - :*: S1 - NoSelector - (Rec0 - n)))))) -type Rep1Tuple14 a b c d e f g h i j k l m = D1 - D1Tuple14 - (C1 - C1_0Tuple14 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 - b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: ((S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)) - :*: (S1 - NoSelector - (Rec0 - f) - :*: S1 - NoSelector - (Rec0 - g)))) - :*: ((S1 - NoSelector - (Rec0 - h) - :*: (S1 - NoSelector - (Rec0 - i) - :*: S1 - NoSelector - (Rec0 - j))) - :*: ((S1 - NoSelector - (Rec0 - k) - :*: S1 - NoSelector - (Rec0 - l)) - :*: (S1 - NoSelector - (Rec0 - m) - :*: S1 - NoSelector - Par1))))) - -instance Generic - (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where - type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = Rep0Tuple14 a b c d e f g h i j k l m n - - from x - = M1 - (case x of { - (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))) - ((:*:) - (M1 (K1 g6)) - (M1 (K1 g7))))) - ((:*:) - ((:*:) - (M1 (K1 g8)) - ((:*:) - (M1 (K1 g9)) - (M1 (K1 g10)))) - ((:*:) - ((:*:) - (M1 (K1 g11)) - (M1 (K1 g12))) - ((:*:) - (M1 (K1 g13)) - (M1 (K1 g14)))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - ((:*:) (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) ((:*:) (M1 (K1 g4)) - (M1 (K1 g5))) - ((:*:) (M1 (K1 g6)) - (M1 (K1 g7))))) - ((:*:) ((:*:) (M1 (K1 g8)) - ((:*:) (M1 (K1 g9)) - (M1 (K1 g10)))) - ((:*:) ((:*:) (M1 (K1 g11)) - (M1 (K1 g12))) - ((:*:) (M1 (K1 g13)) - (M1 (K1 g14))))))) - -> (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 } - -instance Generic1 - ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where - type Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) = Rep1Tuple14 a b c d e f g h i j k l m - - from1 x - = M1 - (case x of { - (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))) - ((:*:) - (M1 (K1 g6)) - (M1 (K1 g7))))) - ((:*:) - ((:*:) - (M1 (K1 g8)) - ((:*:) - (M1 (K1 g9)) - (M1 (K1 g10)))) - ((:*:) - ((:*:) - (M1 (K1 g11)) - (M1 (K1 g12))) - ((:*:) - (M1 (K1 g13)) - (M1 (Par1 g14)))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - ((:*:) (M1 g2) - (M1 g3))) - ((:*:) ((:*:) (M1 g4) - (M1 g5)) - ((:*:) (M1 g6) - (M1 g7)))) - ((:*:) ((:*:) (M1 g8) - ((:*:) (M1 g9) - (M1 g10))) - ((:*:) ((:*:) (M1 g11) - (M1 g12)) - ((:*:) (M1 g13) - (M1 g14)))))) - -> (,,,,,,,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unK1 g8) - (unK1 g9) (unK1 g10) - (unK1 g11) (unK1 g12) - (unK1 g13) (unPar1 g14) } - -data D1Tuple14 -data C1_0Tuple14 - -instance Datatype D1Tuple14 where - datatypeName _ = "(,,,,,,,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple14 where - conName _ = "(,,,,,,,,,,,,,)" - ------ - -type Rep0Tuple15 a b c d e f g h i j k l m n o = D1 - D1Tuple15 - (C1 - C1_0Tuple15 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 - b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: ((S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)) - :*: (S1 - NoSelector - (Rec0 - f) - :*: S1 - NoSelector - (Rec0 - g)))) - :*: (((S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - (Rec0 - i)) - :*: (S1 - NoSelector - (Rec0 - j) - :*: S1 - NoSelector - (Rec0 - k))) - :*: ((S1 - NoSelector - (Rec0 - l) - :*: S1 - NoSelector - (Rec0 - m)) - :*: (S1 - NoSelector - (Rec0 - n) - :*: S1 - NoSelector - (Rec0 - o)))))) -type Rep1Tuple15 a b c d e f g h i j k l m n = D1 - D1Tuple15 - (C1 - C1_0Tuple15 - (((S1 - NoSelector - (Rec0 a) - :*: (S1 - NoSelector - (Rec0 - b) - :*: S1 - NoSelector - (Rec0 - c))) - :*: ((S1 - NoSelector - (Rec0 - d) - :*: S1 - NoSelector - (Rec0 - e)) - :*: (S1 - NoSelector - (Rec0 - f) - :*: S1 - NoSelector - (Rec0 - g)))) - :*: (((S1 - NoSelector - (Rec0 - h) - :*: S1 - NoSelector - (Rec0 - i)) - :*: (S1 - NoSelector - (Rec0 - j) - :*: S1 - NoSelector - (Rec0 - k))) - :*: ((S1 - NoSelector - (Rec0 - l) - :*: S1 - NoSelector - (Rec0 - m)) - :*: (S1 - NoSelector - (Rec0 - n) - :*: S1 - NoSelector - Par1))))) - -instance Generic - (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where - type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = Rep0Tuple15 a b c d e f g h i j k l m n o - - from x - = M1 - (case x of { - (,,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))) - ((:*:) - (M1 (K1 g6)) - (M1 (K1 g7))))) - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g8)) - (M1 (K1 g9))) - ((:*:) - (M1 (K1 g10)) - (M1 (K1 g11)))) - ((:*:) - ((:*:) - (M1 (K1 g12)) - (M1 (K1 g13))) - ((:*:) - (M1 (K1 g14)) - (M1 (K1 g15)))))) }) - to (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) - ((:*:) (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) ((:*:) (M1 (K1 g4)) - (M1 (K1 g5))) - ((:*:) (M1 (K1 g6)) - (M1 (K1 g7))))) - ((:*:) ((:*:) ((:*:) (M1 (K1 g8)) - (M1 (K1 g9))) - ((:*:) (M1 (K1 g10)) - (M1 (K1 g11)))) - ((:*:) ((:*:) (M1 (K1 g12)) - (M1 (K1 g13))) - ((:*:) (M1 (K1 g14)) - (M1 (K1 g15))))))) - -> (,,,,,,,,,,,,,,) - g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 } - -instance Generic1 - ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where - type Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) = Rep1Tuple15 a b c d e f g h i j k l m n - - from1 x - = M1 - (case x of { - (,,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 - -> M1 - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g1)) - ((:*:) - (M1 (K1 g2)) - (M1 (K1 g3)))) - ((:*:) - ((:*:) - (M1 (K1 g4)) - (M1 (K1 g5))) - ((:*:) - (M1 (K1 g6)) - (M1 (K1 g7))))) - ((:*:) - ((:*:) - ((:*:) - (M1 (K1 g8)) - (M1 (K1 g9))) - ((:*:) - (M1 (K1 g10)) - (M1 (K1 g11)))) - ((:*:) - ((:*:) - (M1 (K1 g12)) - (M1 (K1 g13))) - ((:*:) - (M1 (K1 g14)) - (M1 (Par1 g15)))))) }) - to1 (M1 x) - = case x of { - (M1 ((:*:) ((:*:) ((:*:) (M1 g1) - ((:*:) (M1 g2) - (M1 g3))) - ((:*:) ((:*:) (M1 g4) - (M1 g5)) - ((:*:) (M1 g6) - (M1 g7)))) - ((:*:) ((:*:) ((:*:) (M1 g8) - (M1 g9)) - ((:*:) (M1 g10) - (M1 g11))) - ((:*:) ((:*:) (M1 g12) - (M1 g13)) - ((:*:) (M1 g14) - (M1 g15)))))) - -> (,,,,,,,,,,,,,,) - (unK1 g1) (unK1 g2) - (unK1 g3) (unK1 g4) - (unK1 g5) (unK1 g6) - (unK1 g7) (unK1 g8) - (unK1 g9) (unK1 g10) - (unK1 g11) (unK1 g12) - (unK1 g13) (unK1 g14) - (unPar1 g15) } - -data D1Tuple15 -data C1_0Tuple15 - -instance Datatype D1Tuple15 where - datatypeName _ = "(,,,,,,,,,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple15 where - conName _ = "(,,,,,,,,,,,,,,)" - -# endif -#endif - -#if !(MIN_VERSION_base(4,14,0)) -# if MIN_VERSION_base(4,6,0) -type Rep0Kleisli m a b = Rep (Kleisli m a b) -type Rep1Kleisli m a = Rep1 (Kleisli m a) -deriving instance Generic (Kleisli m a b) -deriving instance Generic1 (Kleisli m a) -# else -type Rep0Kleisli m a b = D1 D1Kleisli (C1 C1_0Kleisli (S1 S1_0_0Kleisli (Rec0 (a -> m b)))) -type Rep1Kleisli m a = D1 D1Kleisli (C1 C1_0Kleisli (S1 S1_0_0Kleisli ((->) a :.: Rec1 m))) - -instance Generic (Kleisli m a b) where - type Rep (Kleisli m a b) = Rep0Kleisli m a b - from x = M1 (case x of - Kleisli g -> M1 (M1 (K1 g))) - to (M1 x) = case x of - M1 (M1 (K1 g)) -> Kleisli g - -instance Generic1 (Kleisli m a) where - type Rep1 (Kleisli m a) = Rep1Kleisli m a - from1 x = M1 (case x of - Kleisli g -> M1 (M1 (Comp1 (fmap Rec1 g)))) - to1 (M1 x) = case x of - M1 (M1 g) -> Kleisli (fmap unRec1 (unComp1 g)) - -data D1Kleisli -data C1_0Kleisli -data S1_0_0Kleisli - -instance Datatype D1Kleisli where - datatypeName _ = "Kleisli" - moduleName _ = "Control.Arrow" - -instance Constructor C1_0Kleisli where - conName _ = "Kleisli" - conIsRecord _ = True - -instance Selector S1_0_0Kleisli where - selName _ = "runKleisli" -# endif -#endif - -#if !(MIN_VERSION_base(4,12,0)) -# if MIN_VERSION_base(4,6,0) -type Rep0Down a = Rep (Down a) -type Rep1Down = Rep1 Down -deriving instance Generic (Down a) -deriving instance Generic1 Down -# else -type Rep0Down a = D1 D1Down (C1 C1_0Down (S1 NoSelector (Rec0 a))) -type Rep1Down = D1 D1Down (C1 C1_0Down (S1 NoSelector Par1)) - -instance Generic (Down a) where - type Rep (Down a) = Rep0Down a - from x = M1 (case x of - Down g -> M1 (M1 (K1 g))) - to (M1 x) = case x of - M1 (M1 (K1 g)) -> Down g - -instance Generic1 Down where - type Rep1 Down = Rep1Down - from1 x = M1 (case x of - Down g -> M1 (M1 (Par1 g))) - to1 (M1 x) = case x of - M1 (M1 g) -> Down (unPar1 g) - -data D1Down -data C1_0Down - -instance Datatype D1Down where - datatypeName _ = "Down" - moduleName _ = "GHC.Exts" - -instance Constructor C1_0Down where - conName _ = "Down" -# endif -#endif - ------ - -#if !(MIN_VERSION_base(4,9,0)) -type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1 - :+: C1 C1_1ExitCode (S1 NoSelector (Rec0 Int))) - -instance Generic ExitCode where - type Rep ExitCode = Rep0ExitCode - from x = M1 (case x of - ExitSuccess -> L1 (M1 U1) - ExitFailure g -> R1 (M1 (M1 (K1 g)))) - to (M1 x) = case x of - L1 (M1 U1) -> ExitSuccess - R1 (M1 (M1 (K1 g))) -> ExitFailure g - -data D1ExitCode -data C1_0ExitCode -data C1_1ExitCode - -instance Datatype D1ExitCode where - datatypeName _ = "ExitCode" - moduleName _ = "GHC.IO.Exception" - -instance Constructor C1_0ExitCode where - conName _ = "ExitSuccess" - -instance Constructor C1_1ExitCode where - conName _ = "ExitFailure" - ------ - -type Rep0Version = D1 D1Version (C1 C1_0Version (S1 S1_0_0Version (Rec0 [Int]) - :*: S1 S1_0_1Version (Rec0 [String]))) - -instance Generic Version where - type Rep Version = Rep0Version - from (Version b t) = M1 (M1 (M1 (K1 b) :*: M1 (K1 t))) - to (M1 (M1 (M1 (K1 b) :*: M1 (K1 t)))) = Version b t - -data D1Version -data C1_0Version -data S1_0_0Version -data S1_0_1Version - -instance Datatype D1Version where - datatypeName _ = "Version" - moduleName _ = "Data.Version" - -instance Constructor C1_0Version where - conName _ = "Version" - conIsRecord _ = True - -instance Selector S1_0_0Version where - selName _ = "versionBranch" - -instance Selector S1_0_1Version where - selName _ = "versionTags" - ------ - -type Rep1ConSum f g = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec1 f)) - :+: C1 C1_1ConSum (S1 NoSelector (Rec1 g))) - -instance Generic1 (f :+: g) where - type Rep1 (f :+: g) = Rep1ConSum f g - from1 x = M1 (case x of - L1 l -> L1 (M1 (M1 (Rec1 l))) - R1 r -> R1 (M1 (M1 (Rec1 r)))) - to1 (M1 x) = case x of - L1 (M1 (M1 l)) -> L1 (unRec1 l) - R1 (M1 (M1 r)) -> R1 (unRec1 r) - -data D1ConSum -data C1_0ConSum -data C1_1ConSum - -instance Datatype D1ConSum where - datatypeName _ = ":+:" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0ConSum where - conName _ = "L1" - -instance Constructor C1_1ConSum where - conName _ = "R1" - ------ - -type Rep1ConProduct f g = D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec1 f) - :*: S1 NoSelector (Rec1 g))) - -instance Generic1 (f :*: g) where - type Rep1 (f :*: g) = Rep1ConProduct f g - from1 (f :*: g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) - to1 (M1 (M1 (M1 f :*: M1 g))) = unRec1 f :*: unRec1 g - -data D1ConProduct -data C1_ConProduct - -instance Datatype D1ConProduct where - datatypeName _ = ":*:" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_ConProduct where - conName _ = ":*:" - conFixity _ = Infix RightAssociative 6 - ------ - -type Rep1ConCompose f g = - D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (f :.: Rec1 g))) - -instance Functor f => Generic1 (f :.: g) where - type Rep1 (f :.: g) = Rep1ConCompose f g - from1 (Comp1 c) = M1 (M1 (M1 (Comp1 (fmap Rec1 c)))) - to1 (M1 (M1 (M1 c))) = Comp1 (fmap unRec1 (unComp1 c)) - -data D1ConCompose -data C1_0ConCompose -data S1_0_0ConCompose - -instance Datatype D1ConCompose where - datatypeName _ = ":.:" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0ConCompose where - conName _ = "Comp1" - conIsRecord _ = True - -instance Selector S1_0_0ConCompose where - selName _ = "unComp1" - ------ - -type Rep1K1 i c = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) - -instance Generic1 (K1 i c) where - type Rep1 (K1 i c) = Rep1K1 i c - from1 (K1 c) = M1 (M1 (M1 (K1 c))) - to1 (M1 (M1 (M1 c))) = K1 (unK1 c) - -data D1K1 -data C1_0K1 -data S1_0_0K1 - -instance Datatype D1K1 where - datatypeName _ = "K1" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0K1 where - conName _ = "K1" - conIsRecord _ = True - -instance Selector S1_0_0K1 where - selName _ = "unK1" - ------ - -type Rep1M1 i c f = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec1 f))) - -instance Generic1 (M1 i c f) where - type Rep1 (M1 i c f) = Rep1M1 i c f - from1 (M1 m) = M1 (M1 (M1 (Rec1 m))) - to1 (M1 (M1 (M1 m))) = M1 (unRec1 m) - -data D1M1 -data C1_0M1 -data S1_0_0M1 - -instance Datatype D1M1 where - datatypeName _ = "M1" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0M1 where - conName _ = "M1" - conIsRecord _ = True - -instance Selector S1_0_0M1 where - selName _ = "unM1" - ------ - -type Rep1Par1 = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 Par1)) - -instance Generic1 Par1 where - type Rep1 Par1 = Rep1Par1 - from1 (Par1 p) = M1 (M1 (M1 (Par1 p))) - to1 (M1 (M1 (M1 p))) = Par1 (unPar1 p) - -data D1Par1 -data C1_0Par1 -data S1_0_0Par1 - -instance Datatype D1Par1 where - datatypeName _ = "Par1" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Par1 where - conName _ = "Par1" - conIsRecord _ = True - -instance Selector S1_0_0Par1 where - selName _ = "unPar1" - ------ - -type Rep1Rec1 f = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec1 f))) - -instance Generic1 (Rec1 f) where - type Rep1 (Rec1 f) = Rep1Rec1 f - from1 (Rec1 r) = M1 (M1 (M1 (Rec1 r))) - to1 (M1 (M1 (M1 r))) = Rec1 (unRec1 r) - -data D1Rec1 -data C1_0Rec1 -data S1_0_0Rec1 - -instance Datatype D1Rec1 where - datatypeName _ = "Rec1" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Rec1 where - conName _ = "Rec1" - conIsRecord _ = True - -instance Selector S1_0_0Rec1 where - selName _ = "unRec1" - ------ - -type Rep1U1 = D1 D1U1 (C1 C1_0U1 U1) - -instance Generic1 U1 where - type Rep1 U1 = Rep1U1 - from1 U1 = M1 (M1 U1) - to1 (M1 (M1 U1)) = U1 - -data D1U1 -data C1_0U1 - -instance Datatype D1U1 where - datatypeName _ = "U1" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0U1 where - conName _ = "U1" - ------ - -type Rep0V1 p = D1 D1V1 V1 -type Rep1V1 = D1 D1V1 V1 - -instance Generic (V1 p) where - type Rep (V1 p) = Rep0V1 p - from x = M1 (case x of !_ -> error "No generic representation for empty datatype V1") - to (M1 !_) = error "No values for empty datatype V1" - -instance Generic1 V1 where - type Rep1 V1 = Rep1V1 - from1 x = M1 (case x of !_ -> error "No generic representation for empty datatype V1") - to1 (M1 !_) = error "No values for empty datatype V1" - -data D1V1 - -instance Datatype D1V1 where - datatypeName _ = "V1" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - ------ - -type Rep0UAddr p = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr)) -type Rep1UAddr = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr)) - -instance Generic (UAddr p) where - type Rep (UAddr p) = Rep0UAddr p - from (UAddr a) = M1 (M1 (M1 (UAddr a))) - to (M1 (M1 (M1 (UAddr a)))) = UAddr a - -instance Generic1 UAddr where - type Rep1 UAddr = Rep1UAddr - from1 (UAddr a) = M1 (M1 (M1 (UAddr a))) - to1 (M1 (M1 (M1 (UAddr a)))) = UAddr a - -data D1UAddr -data C1_0UAddr -data S1_0_0UAddr - -instance Datatype D1UAddr where - datatypeName _ = "UAddr" - moduleName _ = "Generics.Deriving.Base.Internal" - -instance Constructor C1_0UAddr where - conName _ = "UAddr" - conIsRecord _ = True - -instance Selector S1_0_0UAddr where - selName _ = "uAddr#" - ------ - -type Rep0UChar p = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar)) -type Rep1UChar = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar)) - -instance Generic (UChar p) where - type Rep (UChar p) = Rep0UChar p - from (UChar c) = M1 (M1 (M1 (UChar c))) - to (M1 (M1 (M1 (UChar c)))) = UChar c - -instance Generic1 UChar where - type Rep1 UChar = Rep1UChar - from1 (UChar c) = M1 (M1 (M1 (UChar c))) - to1 (M1 (M1 (M1 (UChar c)))) = UChar c - -data D1UChar -data C1_0UChar -data S1_0_0UChar - -instance Datatype D1UChar where - datatypeName _ = "UChar" - moduleName _ = "Generics.Deriving.Base.Internal" - -instance Constructor C1_0UChar where - conName _ = "UChar" - conIsRecord _ = True - -instance Selector S1_0_0UChar where - selName _ = "uChar#" - ------ - -type Rep0UDouble p = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble)) -type Rep1UDouble = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble)) - -instance Generic (UDouble p) where - type Rep (UDouble p) = Rep0UDouble p - from (UDouble d) = M1 (M1 (M1 (UDouble d))) - to (M1 (M1 (M1 (UDouble d)))) = UDouble d - -instance Generic1 UDouble where - type Rep1 UDouble = Rep1UDouble - from1 (UDouble d) = M1 (M1 (M1 (UDouble d))) - to1 (M1 (M1 (M1 (UDouble d)))) = UDouble d - -data D1UDouble -data C1_0UDouble -data S1_0_0UDouble - -instance Datatype D1UDouble where - datatypeName _ = "UDouble" - moduleName _ = "Generics.Deriving.Base.Internal" - -instance Constructor C1_0UDouble where - conName _ = "UDouble" - conIsRecord _ = True - -instance Selector S1_0_0UDouble where - selName _ = "uDouble#" - ------ - -type Rep0UFloat p = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat)) -type Rep1UFloat = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat)) - -instance Generic (UFloat p) where - type Rep (UFloat p) = Rep0UFloat p - from (UFloat f) = M1 (M1 (M1 (UFloat f))) - to (M1 (M1 (M1 (UFloat f)))) = UFloat f - -instance Generic1 UFloat where - type Rep1 UFloat = Rep1UFloat - from1 (UFloat f) = M1 (M1 (M1 (UFloat f))) - to1 (M1 (M1 (M1 (UFloat f)))) = UFloat f - -data D1UFloat -data C1_0UFloat -data S1_0_0UFloat - -instance Datatype D1UFloat where - datatypeName _ = "UFloat" - moduleName _ = "Generics.Deriving.Base.Internal" - -instance Constructor C1_0UFloat where - conName _ = "UFloat" - conIsRecord _ = True - -instance Selector S1_0_0UFloat where - selName _ = "uFloat#" - ------ - -type Rep0UInt p = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt)) -type Rep1UInt = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt)) - -instance Generic (UInt p) where - type Rep (UInt p) = Rep0UInt p - from (UInt i) = M1 (M1 (M1 (UInt i))) - to (M1 (M1 (M1 (UInt i)))) = UInt i - -instance Generic1 UInt where - type Rep1 UInt = Rep1UInt - from1 (UInt i) = M1 (M1 (M1 (UInt i))) - to1 (M1 (M1 (M1 (UInt i)))) = UInt i - -data D1UInt -data C1_0UInt -data S1_0_0UInt - -instance Datatype D1UInt where - datatypeName _ = "UInt" - moduleName _ = "Generics.Deriving.Base.Internal" - -instance Constructor C1_0UInt where - conName _ = "UInt" - conIsRecord _ = True - -instance Selector S1_0_0UInt where - selName _ = "uInt#" - ------ - -type Rep0UWord p = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord)) -type Rep1UWord = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord)) - -instance Generic (UWord p) where - type Rep (UWord p) = Rep0UWord p - from (UWord w) = M1 (M1 (M1 (UWord w))) - to (M1 (M1 (M1 (UWord w)))) = UWord w - -instance Generic1 UWord where - type Rep1 UWord = Rep1UWord - from1 (UWord w) = M1 (M1 (M1 (UWord w))) - to1 (M1 (M1 (M1 (UWord w)))) = UWord w - -data D1UWord -data C1_0UWord -data S1_0_0UWord - -instance Datatype D1UWord where - datatypeName _ = "UWord" - moduleName _ = "Generics.Deriving.Base.Internal" - -instance Constructor C1_0UWord where - conName _ = "UWord" - conIsRecord _ = True - -instance Selector S1_0_0UWord where - selName _ = "uWord#" - ------ - -# if MIN_VERSION_base(4,4,0) -type Rep0Complex a = D1 D1Complex (C1 C1_0Complex (S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 a))) -type Rep1Complex = D1 D1Complex (C1 C1_0Complex (S1 NoSelector Par1 - :*: S1 NoSelector Par1)) - -instance Generic (Complex a) where - type Rep (Complex a) = Rep0Complex a - from (a :+ b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) - to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = a :+ b - -instance Generic1 Complex where - type Rep1 Complex = Rep1Complex - from1 (a :+ b) = M1 (M1 (M1 (Par1 a) :*: M1 (Par1 b))) - to1 (M1 (M1 (M1 a :*: M1 b))) = unPar1 a :+ unPar1 b - -data D1Complex -data C1_0Complex - -instance Datatype D1Complex where - datatypeName _ = "Complex" - moduleName _ = "Data.Complex" - -instance Constructor C1_0Complex where - conName _ = ":+" - conFixity _ = Infix LeftAssociative 9 -# endif - ------ - -# if MIN_VERSION_base(4,7,0) -type Rep1Proxy = D1 D1Proxy (C1 C1_0Proxy U1) - -instance Generic1 Proxy where - type Rep1 Proxy = Rep1Proxy - from1 Proxy = M1 (M1 U1) - to1 (M1 (M1 U1)) = Proxy - -data D1Proxy -data C1_0Proxy - -instance Datatype D1Proxy where - datatypeName _ = "Proxy" - moduleName _ = "Data.Proxy" - -instance Constructor C1_0Proxy where - conName _ = "Proxy" -# endif -#endif - ------ - -#if !(MIN_VERSION_base(4,7,0)) --------------------------------------------------------------------------------- --- Representations for base types --------------------------------------------------------------------------------- - -type Rep0All = D1 D1All (C1 C1_0All (S1 S1_0_0All (Rec0 Bool))) - -instance Generic All where - type Rep All = Rep0All - from (All a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = All a - -data D1All -data C1_0All -data S1_0_0All - -instance Datatype D1All where - datatypeName _ = "All" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0All where - conName _ = "All" - conIsRecord _ = True - -instance Selector S1_0_0All where - selName _ = "getAll" - ------ - -type Rep0Any = D1 D1Any (C1 C1_0Any (S1 S1_0_0Any (Rec0 Bool))) - -instance Generic Any where - type Rep Any = Rep0Any - from (Any a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = Any a - -data D1Any -data C1_0Any -data S1_0_0Any - -instance Datatype D1Any where - datatypeName _ = "Any" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Any where - conName _ = "Any" - conIsRecord _ = True - -instance Selector S1_0_0Any where - selName _ = "getAny" - ------ - -type Rep0Arity = D1 D1Arity (C1 C1_0Arity U1 - :+: C1 C1_1Arity (S1 NoSelector (Rec0 Int))) - -instance Generic Arity where - type Rep Arity = Rep0Arity - - from x = M1 (case x of - NoArity -> L1 (M1 U1) - Arity a -> R1 (M1 (M1 (K1 a)))) - - to (M1 x) = case x of - L1 (M1 U1) -> NoArity - R1 (M1 (M1 (K1 a))) -> Arity a - -data D1Arity -data C1_0Arity -data C1_1Arity - -instance Datatype D1Arity where - datatypeName _ = "Arity" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Arity where - conName _ = "NoArity" - -instance Constructor C1_1Arity where - conName _ = "Arity" - ------ - -type Rep0Associativity = D1 D1Associativity (C1 C1_0Associativity U1 - :+: (C1 C1_1Associativity U1 - :+: C1 C1_2Associativity U1)) - -instance Generic Associativity where - type Rep Associativity = Rep0Associativity - - from x = M1 (case x of - LeftAssociative -> L1 (M1 U1) - RightAssociative -> R1 (L1 (M1 U1)) - NotAssociative -> R1 (R1 (M1 U1))) - - to (M1 x) = case x of - L1 (M1 U1) -> LeftAssociative - R1 (L1 (M1 U1)) -> RightAssociative - R1 (R1 (M1 U1)) -> NotAssociative - -data D1Associativity -data C1_0Associativity -data C1_1Associativity -data C1_2Associativity - -instance Datatype D1Associativity where - datatypeName _ = "Associativity" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Associativity where - conName _ = "LeftAssociative" - -instance Constructor C1_1Associativity where - conName _ = "RightAssociative" - -instance Constructor C1_2Associativity where - conName _ = "NotAssociative" - ------ - -type Rep0Const a b = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) -type Rep1Const a = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) - -instance Generic (Const a b) where - type Rep (Const a b) = Rep0Const a b - from (Const a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = Const a - -instance Generic1 (Const a) where - type Rep1 (Const a) = Rep1Const a - from1 (Const a) = M1 (M1 (M1 (K1 a))) - to1 (M1 (M1 (M1 (K1 a)))) = Const a - -data D1Const -data C1_0Const -data S1_0_0Const - -instance Datatype D1Const where - datatypeName _ = "Const" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0Const where - conName _ = "Const" - conIsRecord _ = True - -instance Selector S1_0_0Const where - selName _ = "getConst" - ------ - -type Rep0Dual a = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual (Rec0 a))) -type Rep1Dual = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual Par1)) - -instance Generic (Dual a) where - type Rep (Dual a) = Rep0Dual a - from (Dual d) = M1 (M1 (M1 (K1 d))) - to (M1 (M1 (M1 (K1 d)))) = Dual d - -instance Generic1 Dual where - type Rep1 Dual = Rep1Dual - from1 (Dual d) = M1 (M1 (M1 (Par1 d))) - to1 (M1 (M1 (M1 (Par1 d)))) = Dual d - -data D1Dual -data C1_0Dual -data S1_0_0Dual - -instance Datatype D1Dual where - datatypeName _ = "Dual" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Dual where - conName _ = "Dual" - conIsRecord _ = True - -instance Selector S1_0_0Dual where - selName _ = "getDual" - ------ - -type Rep0Endo a = D1 D1Endo (C1 C1_0Endo (S1 S1_0_0Endo (Rec0 (a -> a)))) - -instance Generic (Endo a) where - type Rep (Endo a) = Rep0Endo a - from (Endo e) = M1 (M1 (M1 (K1 e))) - to (M1 (M1 (M1 (K1 e)))) = Endo e - -data D1Endo -data C1_0Endo -data S1_0_0Endo - -instance Datatype D1Endo where - datatypeName _ = "Endo" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Endo where - conName _ = "Endo" - conIsRecord _ = True - -instance Selector S1_0_0Endo where - selName _ = "appEndo" - ------ - -type Rep0First a = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec0 (Maybe a)))) -type Rep1First = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec1 Maybe))) - -instance Generic (First a) where - type Rep (First a) = Rep0First a - from (First f) = M1 (M1 (M1 (K1 f))) - to (M1 (M1 (M1 (K1 f)))) = First f - -instance Generic1 First where - type Rep1 First = Rep1First - from1 (First f) = M1 (M1 (M1 (Rec1 f))) - to1 (M1 (M1 (M1 (Rec1 f)))) = First f - -data D1First -data C1_0First -data S1_0_0First - -instance Datatype D1First where - datatypeName _ = "First" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0First where - conName _ = "First" - conIsRecord _ = True - -instance Selector S1_0_0First where - selName _ = "getFirst" - ------ - -type Rep0Fixity = D1 D1Fixity (C1 C1_0Fixity U1 - :+: C1 C1_1Fixity (S1 NoSelector (Rec0 Associativity) - :*: S1 NoSelector (Rec0 Int))) - -instance Generic Fixity where - type Rep Fixity = Rep0Fixity - - from x = M1 (case x of - Prefix -> L1 (M1 U1) - Infix a i -> R1 (M1 (M1 (K1 a) :*: M1 (K1 i)))) - - to (M1 x) = case x of - L1 (M1 U1) -> Prefix - R1 (M1 (M1 (K1 a) :*: M1 (K1 i))) -> Infix a i - -data D1Fixity -data C1_0Fixity -data C1_1Fixity - -instance Datatype D1Fixity where - datatypeName _ = "Fixity" -# if !(MIN_VERSION_base(4,4,0)) - moduleName _ = "Generics.Deriving.Base.Internal" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Fixity where - conName _ = "Prefix" - -instance Constructor C1_1Fixity where - conName _ = "Infix" - ------ - -type Rep0Last a = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec0 (Maybe a)))) -type Rep1Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec1 Maybe))) - -instance Generic (Last a) where - type Rep (Last a) = Rep0Last a - from (Last l) = M1 (M1 (M1 (K1 l))) - to (M1 (M1 (M1 (K1 l)))) = Last l - -instance Generic1 Last where - type Rep1 Last = Rep1Last - from1 (Last l) = M1 (M1 (M1 (Rec1 l))) - to1 (M1 (M1 (M1 (Rec1 l)))) = Last l - -data D1Last -data C1_0Last -data S1_0_0Last - -instance Datatype D1Last where - datatypeName _ = "Last" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Last where - conName _ = "Last" - conIsRecord _ = True - -instance Selector S1_0_0Last where - selName _ = "getLast" - ------ - -type Rep0Product a = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product (Rec0 a))) -type Rep1Product = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product Par1)) - -instance Generic (Product a) where - type Rep (Product a) = Rep0Product a - from (Product p) = M1 (M1 (M1 (K1 p))) - to (M1 (M1 (M1 (K1 p)))) = Product p - -instance Generic1 Product where - type Rep1 Product = Rep1Product - from1 (Product p) = M1 (M1 (M1 (Par1 p))) - to1 (M1 (M1 (M1 (Par1 p)))) = Product p - -data D1Product -data C1_0Product -data S1_0_0Product - -instance Datatype D1Product where - datatypeName _ = "Product" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Product where - conName _ = "Product" - conIsRecord _ = True - -instance Selector S1_0_0Product where - selName _ = "getProduct" - ------ - -type Rep0Sum a = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum (Rec0 a))) -type Rep1Sum = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum Par1)) - -instance Generic (Sum a) where - type Rep (Sum a) = Rep0Sum a - from (Sum s) = M1 (M1 (M1 (K1 s))) - to (M1 (M1 (M1 (K1 s)))) = Sum s - -instance Generic1 Sum where - type Rep1 Sum = Rep1Sum - from1 (Sum s) = M1 (M1 (M1 (Par1 s))) - to1 (M1 (M1 (M1 (Par1 s)))) = Sum s - -data D1Sum -data C1_0Sum -data S1_0_0Sum - -instance Datatype D1Sum where - datatypeName _ = "Sum" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Sum where - conName _ = "Sum" - conIsRecord _ = True - -instance Selector S1_0_0Sum where - selName _ = "getSum" - ------ - -type Rep0WrappedArrow a b c = - D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec0 (a b c)))) -type Rep1WrappedArrow a b = - D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec1 (a b)))) - -instance Generic (WrappedArrow a b c) where - type Rep (WrappedArrow a b c) = Rep0WrappedArrow a b c - from (WrapArrow a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = WrapArrow a - -instance Generic1 (WrappedArrow a b) where - type Rep1 (WrappedArrow a b) = Rep1WrappedArrow a b - from1 (WrapArrow a) = M1 (M1 (M1 (Rec1 a))) - to1 (M1 (M1 (M1 (Rec1 a)))) = WrapArrow a - -data D1WrappedArrow -data C1_0WrappedArrow -data S1_0_0WrappedArrow - -instance Datatype D1WrappedArrow where - datatypeName _ = "WrappedArrow" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0WrappedArrow where - conName _ = "WrapArrow" - conIsRecord _ = True - -instance Selector S1_0_0WrappedArrow where - selName _ = "unwrapArrow" - ------ - -type Rep0WrappedMonad m a = - D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec0 (m a)))) -type Rep1WrappedMonad m = - D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec1 m))) - -instance Generic (WrappedMonad m a) where - type Rep (WrappedMonad m a) = Rep0WrappedMonad m a - from (WrapMonad m) = M1 (M1 (M1 (K1 m))) - to (M1 (M1 (M1 (K1 m)))) = WrapMonad m - -instance Generic1 (WrappedMonad m) where - type Rep1 (WrappedMonad m) = Rep1WrappedMonad m - from1 (WrapMonad m) = M1 (M1 (M1 (Rec1 m))) - to1 (M1 (M1 (M1 (Rec1 m)))) = WrapMonad m - -data D1WrappedMonad -data C1_0WrappedMonad -data S1_0_0WrappedMonad - -instance Datatype D1WrappedMonad where - datatypeName _ = "WrappedMonad" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0WrappedMonad where - conName _ = "WrapMonad" - conIsRecord _ = True - -instance Selector S1_0_0WrappedMonad where - selName _ = "unwrapMonad" - ------ - -type Rep0ZipList a = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec0 [a]))) -type Rep1ZipList = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec1 []))) - -instance Generic (ZipList a) where - type Rep (ZipList a) = Rep0ZipList a - from (ZipList z) = M1 (M1 (M1 (K1 z))) - to (M1 (M1 (M1 (K1 z)))) = ZipList z - -instance Generic1 ZipList where - type Rep1 ZipList = Rep1ZipList - from1 (ZipList z) = M1 (M1 (M1 (Rec1 z))) - to1 (M1 (M1 (M1 (Rec1 z)))) = ZipList z - -data D1ZipList -data C1_0ZipList -data S1_0_0ZipList - -instance Datatype D1ZipList where - datatypeName _ = "ZipList" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0ZipList where - conName _ = "ZipList" - conIsRecord _ = True - -instance Selector S1_0_0ZipList where - selName _ = "getZipList" - ------ - -type Rep0U1 p = D1 D1U1 (C1 C1_0U1 U1) - -instance Generic (U1 p) where - type Rep (U1 p) = Rep0U1 p - from U1 = M1 (M1 U1) - to (M1 (M1 U1)) = U1 - ------ - -type Rep0Par1 p = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 (Rec0 p))) - -instance Generic (Par1 p) where - type Rep (Par1 p) = Rep0Par1 p - from (Par1 p) = M1 (M1 (M1 (K1 p))) - to (M1 (M1 (M1 (K1 p)))) = Par1 p - ------ - -type Rep0Rec1 f p = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec0 (f p)))) - -instance Generic (Rec1 f p) where - type Rep (Rec1 f p) = Rep0Rec1 f p - from (Rec1 r) = M1 (M1 (M1 (K1 r))) - to (M1 (M1 (M1 (K1 r)))) = Rec1 r - ------ - -type Rep0K1 i c p = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) - -instance Generic (K1 i c p) where - type Rep (K1 i c p) = Rep0K1 i c p - from (K1 c) = M1 (M1 (M1 (K1 c))) - to (M1 (M1 (M1 (K1 c)))) = K1 c - ------ - -type Rep0M1 i c f p = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec0 (f p)))) - -instance Generic (M1 i c f p) where - type Rep (M1 i c f p) = Rep0M1 i c f p - from (M1 m) = M1 (M1 (M1 (K1 m))) - to (M1 (M1 (M1 (K1 m)))) = M1 m - ------ - -type Rep0ConSum f g p = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec0 (f p))) - :+: C1 C1_1ConSum (S1 NoSelector (Rec0 (g p)))) - -instance Generic ((f :+: g) p) where - type Rep ((f :+: g) p) = Rep0ConSum f g p - - from x = M1 (case x of - L1 l -> L1 (M1 (M1 (K1 l))) - R1 r -> R1 (M1 (M1 (K1 r)))) - - to (M1 x) = case x of - L1 (M1 (M1 (K1 l))) -> L1 l - R1 (M1 (M1 (K1 r))) -> R1 r - ------ - -type Rep0ConProduct f g p = - D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec0 (f p)) - :*: S1 NoSelector (Rec0 (g p)))) - -instance Generic ((f :*: g) p) where - type Rep ((f :*: g) p) = Rep0ConProduct f g p - from (f :*: g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g))) - to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = f :*: g - ------ - -type Rep0ConCompose f g p = - D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (Rec0 (f (g p))))) - -instance Generic ((f :.: g) p) where - type Rep ((f :.: g) p) = Rep0ConCompose f g p - from (Comp1 c) = M1 (M1 (M1 (K1 c))) - to (M1 (M1 (M1 (K1 c)))) = Comp1 c -#endif - ------ - -#if !(MIN_VERSION_base(4,6,0)) -type Rep1List = D1 D1List (C1 C1_0List U1 :+: - C1 C1_1List (S1 NoSelector Par1 - :*: S1 NoSelector (Rec1 []))) - -instance Generic1 [] where - type Rep1 [] = Rep1List - - from1 x = M1 (case x of - [] -> L1 (M1 U1) - h:t -> R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t)))) - - to1 (M1 x) = case x of - L1 (M1 U1) -> [] - R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))) -> h : t - -data D1List -data C1_0List -data C1_1List - -instance Datatype D1List where - datatypeName _ = "[]" - moduleName _ = "GHC.Types" - -instance Constructor C1_0List where - conName _ = "[]" - -instance Constructor C1_1List where - conName _ = ":" - conFixity _ = Infix RightAssociative 5 - ------ - -type Rep1Either a = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) - :+: C1 C1_1Either (S1 NoSelector Par1)) - -instance Generic1 (Either a) where - type Rep1 (Either a) = Rep1Either a - - from1 x = M1 (case x of - Left l -> L1 (M1 (M1 (K1 l))) - Right r -> R1 (M1 (M1 (Par1 r)))) - - to1 (M1 x) = case x of - L1 (M1 (M1 (K1 l))) -> Left l - R1 (M1 (M1 (Par1 r))) -> Right r - -data D1Either -data C1_0Either -data C1_1Either - -instance Datatype D1Either where - datatypeName _ = "Either" - moduleName _ = "Data.Either" - -instance Constructor C1_0Either where - conName _ = "Left" - -instance Constructor C1_1Either where - conName _ = "Right" - ------ - -type Rep1Maybe = D1 D1Maybe (C1 C1_0Maybe U1 - :+: C1 C1_1Maybe (S1 NoSelector Par1)) - -instance Generic1 Maybe where - type Rep1 Maybe = Rep1Maybe - - from1 x = M1 (case x of - Nothing -> L1 (M1 U1) - Just j -> R1 (M1 (M1 (Par1 j)))) - - to1 (M1 x) = case x of - L1 (M1 U1) -> Nothing - R1 (M1 (M1 (Par1 j))) -> Just j - -data D1Maybe -data C1_0Maybe -data C1_1Maybe - -instance Datatype D1Maybe where - datatypeName _ = "Maybe" - -- As of base-4.7.0.0, Maybe is actually located in GHC.Base. - -- We don't need to worry about this for the versions of base - -- that this instance is defined for, however. - moduleName _ = "Data.Maybe" - -instance Constructor C1_0Maybe where - conName _ = "Nothing" - -instance Constructor C1_1Maybe where - conName _ = "Just" - ------ - -type Rep1Tuple2 a = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) - :*: S1 NoSelector Par1)) - -instance Generic1 ((,) a) where - type Rep1 ((,) a) = Rep1Tuple2 a - from1 (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b))) - to1 (M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))) = (a, b) - -data D1Tuple2 -data C1_0Tuple2 - -instance Datatype D1Tuple2 where - datatypeName _ = "(,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple2 where - conName _ = "(,)" - ------ - -type Rep1Tuple3 a b = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector Par1))) - -instance Generic1 ((,,) a b) where - type Rep1 ((,,) a b) = Rep1Tuple3 a b - from1 (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c)))) - to1 (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))) = (a, b, c) - -data D1Tuple3 -data C1_0Tuple3 - -instance Datatype D1Tuple3 where - datatypeName _ = "(,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple3 where - conName _ = "(,,)" - ------ - -type Rep1Tuple4 a b c = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: S1 NoSelector Par1))) - -instance Generic1 ((,,,) a b c) where - type Rep1 ((,,,) a b c) = Rep1Tuple4 a b c - - from1 (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (Par1 d)))) - - to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (Par1 d))))) - = (a, b, c, d) - -data D1Tuple4 -data C1_0Tuple4 - -instance Datatype D1Tuple4 where - datatypeName _ = "(,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple4 where - conName _ = "(,,,)" - ------ - -type Rep1Tuple5 a b c d = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: (S1 NoSelector (Rec0 d) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,) a b c d) where - type Rep1 ((,,,,) a b c d) = Rep1Tuple5 a b c d - - from1 (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e)))))) - = (a, b, c, d, e) - -data D1Tuple5 -data C1_0Tuple5 - -instance Datatype D1Tuple5 where - datatypeName _ = "(,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple5 where - conName _ = "(,,,,)" - ------ - -type Rep1Tuple6 a b c d e = - D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: (S1 NoSelector (Rec0 d) - :*: (S1 NoSelector (Rec0 e) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,,) a b c d e) where - type Rep1 ((,,,,,) a b c d e) = Rep1Tuple6 a b c d e - - from1 (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f)))))) - = (a, b, c, d, e, f) - -data D1Tuple6 -data C1_0Tuple6 - -instance Datatype D1Tuple6 where - datatypeName _ = "(,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple6 where - conName _ = "(,,,,,)" - ------ - -type Rep1Tuple7 a b c d e f = - D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: ((S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e)) - :*: (S1 NoSelector (Rec0 f) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,,,) a b c d e f) where - type Rep1 ((,,,,,,) a b c d e f) = Rep1Tuple7 a b c d e f - - from1 (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g)))))) - = (a, b, c, d, e, f, g) - -data D1Tuple7 -data C1_0Tuple7 - -instance Datatype D1Tuple7 where - datatypeName _ = "(,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple7 where - conName _ = "(,,,,,,)" -#endif - ------ - -#if !(MIN_VERSION_base(4,4,0)) -type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1) - -instance Generic Bool where - type Rep Bool = Rep0Bool - - from x = M1 (case x of - False -> L1 (M1 U1) - True -> R1 (M1 U1)) - - to (M1 x) = case x of - L1 (M1 U1) -> False - R1 (M1 U1) -> True - -data D1Bool -data C1_0Bool -data C1_1Bool - -instance Datatype D1Bool where - datatypeName _ = "Bool" - moduleName _ = "GHC.Bool" - -instance Constructor C1_0Bool where - conName _ = "False" - -instance Constructor C1_1Bool where - conName _ = "True" - ------ - -data D_Char -data C_Char - -instance Datatype D_Char where - datatypeName _ = "Char" - moduleName _ = "GHC.Base" - -instance Constructor C_Char where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char))) - -instance Generic Char where - type Rep Char = Rep0Char - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -data D_Double -data C_Double - -instance Datatype D_Double where - datatypeName _ = "Double" - moduleName _ = "GHC.Float" - -instance Constructor C_Double where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double))) - -instance Generic Double where - type Rep Double = Rep0Double - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -type Rep0Either a b = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) - :+: C1 C1_1Either (S1 NoSelector (Rec0 b))) - -instance Generic (Either a b) where - type Rep (Either a b) = Rep0Either a b - - from x = M1 (case x of - Left l -> L1 (M1 (M1 (K1 l))) - Right r -> R1 (M1 (M1 (K1 r)))) - - to (M1 x) = case x of - L1 (M1 (M1 (K1 l))) -> Left l - R1 (M1 (M1 (K1 r))) -> Right r - ------ - -data D_Int -data C_Int - -instance Datatype D_Int where - datatypeName _ = "Int" - moduleName _ = "GHC.Int" - -instance Constructor C_Int where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int))) - -instance Generic Int where - type Rep Int = Rep0Int - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -data D_Float -data C_Float - -instance Datatype D_Float where - datatypeName _ = "Float" - moduleName _ = "GHC.Float" - -instance Constructor C_Float where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float))) - -instance Generic Float where - type Rep Float = Rep0Float - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -type Rep0List a = - D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 [a]))) - -instance Generic [a] where - type Rep [a] = Rep0List a - - from x = M1 (case x of - [] -> L1 (M1 U1) - h:t -> R1 (M1 (M1 (K1 h) :*: M1 (K1 t)))) - - to (M1 x) = case x of - L1 (M1 U1) -> [] - R1 (M1 (M1 (K1 h) :*: M1 (K1 t))) -> h : t - ------ - -type Rep0Maybe a = D1 D1Maybe (C1 C1_0Maybe U1 - :+: C1 C1_1Maybe (S1 NoSelector (Rec0 a))) - -instance Generic (Maybe a) where - type Rep (Maybe a) = Rep0Maybe a - - from x = M1 (case x of - Nothing -> L1 (M1 U1) - Just j -> R1 (M1 (M1 (K1 j)))) - - to (M1 x) = case x of - L1 (M1 U1) -> Nothing - R1 (M1 (M1 (K1 j))) -> Just j - ------ - -type Rep0Ordering = D1 D1Ordering (C1 C1_0Ordering U1 - :+: (C1 C1_1Ordering U1 :+: C1 C1_2Ordering U1)) - -instance Generic Ordering where - type Rep Ordering = Rep0Ordering - - from x = M1 (case x of - LT -> L1 (M1 U1) - EQ -> R1 (L1 (M1 U1)) - GT -> R1 (R1 (M1 U1))) - - to (M1 x) = case x of - L1 (M1 U1) -> LT - R1 (L1 (M1 U1)) -> EQ - R1 (R1 (M1 U1)) -> GT - -data D1Ordering -data C1_0Ordering -data C1_1Ordering -data C1_2Ordering - -instance Datatype D1Ordering where - datatypeName _ = "Ordering" - moduleName _ = "GHC.Ordering" - -instance Constructor C1_0Ordering where - conName _ = "LT" - -instance Constructor C1_1Ordering where - conName _ = "EQ" - -instance Constructor C1_2Ordering where - conName _ = "GT" - ------ - -type Rep0Unit = D1 D1Unit (C1 C1_0Unit U1) - -instance Generic () where - type Rep () = Rep0Unit - from () = M1 (M1 U1) - to (M1 (M1 U1)) = () - -data D1Unit -data C1_0Unit - -instance Datatype D1Unit where - datatypeName _ = "()" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Unit where - conName _ = "()" - ------ - -type Rep0Tuple2 a b = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b))) - -instance Generic (a, b) where - type Rep (a, b) = Rep0Tuple2 a b - from (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) - to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = (a, b) - ------ - -type Rep0Tuple3 a b c = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c)))) - -instance Generic (a, b, c) where - type Rep (a, b, c) = Rep0Tuple3 a b c - from (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))) - to (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))) = (a, b, c) - ------ - -type Rep0Tuple4 a b c d = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: S1 NoSelector (Rec0 d)))) - -instance Generic (a, b, c, d) where - type Rep (a, b, c, d) = Rep0Tuple4 a b c d - - from (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (K1 d)))) - - to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (K1 d))))) - = (a, b, c, d) - ------ - -type Rep0Tuple5 a b c d e = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: (S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e))))) - -instance Generic (a, b, c, d, e) where - type Rep (a, b, c, d, e) = Rep0Tuple5 a b c d e - - from (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e))))) - - to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e)))))) - = (a, b, c, d, e) - ------ - -type Rep0Tuple6 a b c d e f = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: (S1 NoSelector (Rec0 d) - :*: (S1 NoSelector (Rec0 e) - :*: S1 NoSelector (Rec0 f))))) - -instance Generic (a, b, c, d, e, f) where - type Rep (a, b, c, d, e, f) = Rep0Tuple6 a b c d e f - - from (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f))))) - - to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f)))))) - = (a, b, c, d, e, f) - ------ - -type Rep0Tuple7 a b c d e f g - = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: ((S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e)) - :*: (S1 NoSelector (Rec0 f) - :*: S1 NoSelector (Rec0 g))))) - -instance Generic (a, b, c, d, e, f, g) where - type Rep (a, b, c, d, e, f, g) = Rep0Tuple7 a b c d e f g - - from (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g))))) - - to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g)))))) - = (a, b, c, d, e, f, g) - -#endif +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 711+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Generics.Deriving.Instances (+-- Only instances from Generics.Deriving.Base+-- and the Generic1 instances+#if !(MIN_VERSION_base(4,16,0))+ Rep0Tuple8+ , Rep0Tuple9+ , Rep0Tuple10+ , Rep0Tuple11+ , Rep0Tuple12+ , Rep0Tuple13+ , Rep0Tuple14+ , Rep0Tuple15+ , Rep1Tuple8+ , Rep1Tuple9+ , Rep1Tuple10+ , Rep1Tuple11+ , Rep1Tuple12+ , Rep1Tuple13+ , Rep1Tuple14+ , Rep1Tuple15+#endif+#if !(MIN_VERSION_base(4,14,0))+ , Rep0Kleisli+ , Rep1Kleisli+#endif+#if !(MIN_VERSION_base(4,12,0))+ , Rep0Down+ , Rep1Down+#endif+#if !(MIN_VERSION_base(4,9,0))+ , Rep0ExitCode+ , Rep0Version+ , Rep1ConSum+ , Rep1ConProduct+ , Rep1ConCompose+ , Rep1K1+ , Rep1M1+ , Rep1Par1+ , Rep1Rec1+ , Rep1U1+ , Rep0V1+ , Rep1V1+ , Rep0UAddr+ , Rep1UAddr+ , Rep0UChar+ , Rep1UChar+ , Rep0UDouble+ , Rep1UDouble+ , Rep0UFloat+ , Rep1UFloat+ , Rep0UInt+ , Rep1UInt+ , Rep0UWord+ , Rep1UWord+# if MIN_VERSION_base(4,4,0)+ , Rep0Complex+ , Rep1Complex+# endif+# if MIN_VERSION_base(4,7,0)+ , Rep1Proxy+# endif+#endif+#if !(MIN_VERSION_base(4,7,0))+ , Rep0All+ , Rep0Any+ , Rep0Arity+ , Rep0Associativity+ , Rep0Const+ , Rep1Const+ , Rep0Dual+ , Rep1Dual+ , Rep0Endo+ , Rep0First+ , Rep1First+ , Rep0Fixity+ , Rep0Last+ , Rep1Last+ , Rep0Product+ , Rep1Product+ , Rep0Sum+ , Rep1Sum+ , Rep0WrappedArrow+ , Rep1WrappedArrow+ , Rep0WrappedMonad+ , Rep1WrappedMonad+ , Rep0ZipList+ , Rep1ZipList+ , Rep0U1+ , Rep0Par1+ , Rep0Rec1+ , Rep0K1+ , Rep0M1+ , Rep0ConSum+ , Rep0ConProduct+ , Rep0ConCompose+#endif+#if !(MIN_VERSION_base(4,6,0))+ , Rep1Either+ , Rep1List+ , Rep1Maybe+ , Rep1Tuple2+ , Rep1Tuple3+ , Rep1Tuple4+ , Rep1Tuple5+ , Rep1Tuple6+ , Rep1Tuple7+#endif+#if !(MIN_VERSION_base(4,4,0))+ , Rep0Bool+ , Rep0Char+ , Rep0Double+ , Rep0Either+ , Rep0Int+ , Rep0Float+ , Rep0List+ , Rep0Maybe+ , Rep0Ordering+ , Rep0Tuple2+ , Rep0Tuple3+ , Rep0Tuple4+ , Rep0Tuple5+ , Rep0Tuple6+ , Rep0Tuple7+ , Rep0Unit+#endif+ ) where++#if !(MIN_VERSION_base(4,7,0))+import Control.Applicative+import Data.Monoid+#endif++#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,9,0))+import Data.Complex (Complex(..))+#endif++#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,9,0))+import Data.Proxy (Proxy(..))+#endif++#if !(MIN_VERSION_base(4,9,0))+import Data.Version (Version(..))+import System.Exit (ExitCode(..))+#endif++#if !(MIN_VERSION_base(4,12,0))+# if MIN_VERSION_base(4,6,0)+import Data.Ord (Down(..))+# else+import GHC.Exts (Down(..))+# endif+#endif++#if !(MIN_VERSION_base(4,14,0))+import Control.Arrow (Kleisli(..))+#endif++#if !(MIN_VERSION_base(4,16,0))+import Generics.Deriving.Base.Internal+#endif++#if !(MIN_VERSION_base(4,16,0))+# if MIN_VERSION_base(4,6,0)+type Rep0Tuple8 a b c d e f g h = Rep (a, b, c, d, e, f, g, h)+type Rep0Tuple9 a b c d e f g h i = Rep (a, b, c, d, e, f, g, h, i)+type Rep0Tuple10 a b c d e f g h i j = Rep (a, b, c, d, e, f, g, h, i, j)+type Rep0Tuple11 a b c d e f g h i j k = Rep (a, b, c, d, e, f, g, h, i, j, k)+type Rep0Tuple12 a b c d e f g h i j k l = Rep (a, b, c, d, e, f, g, h, i, j, k, l)+type Rep0Tuple13 a b c d e f g h i j k l m = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m)+type Rep0Tuple14 a b c d e f g h i j k l m n = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+type Rep0Tuple15 a b c d e f g h i j k l m n o = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+type Rep1Tuple8 a b c d e f g = Rep1 ((,,,,,,,) a b c d e f g)+type Rep1Tuple9 a b c d e f g h = Rep1 ((,,,,,,,,) a b c d e f g h)+type Rep1Tuple10 a b c d e f g h i = Rep1 ((,,,,,,,,,) a b c d e f g h i)+type Rep1Tuple11 a b c d e f g h i j = Rep1 ((,,,,,,,,,,) a b c d e f g h i j)+type Rep1Tuple12 a b c d e f g h i j k = Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k)+type Rep1Tuple13 a b c d e f g h i j k l = Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l)+type Rep1Tuple14 a b c d e f g h i j k l m = Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m)+type Rep1Tuple15 a b c d e f g h i j k l m n = Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n)+deriving instance Generic (a, b, c, d, e, f, g, h)+deriving instance Generic (a, b, c, d, e, f, g, h, i)+deriving instance Generic (a, b, c, d, e, f, g, h, i, j)+deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k)+deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l)+deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m)+deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+deriving instance Generic1 ((,,,,,,,) a b c d e f g)+deriving instance Generic1 ((,,,,,,,,) a b c d e f g h)+deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i)+deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j)+deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k)+deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l)+deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m)+deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n)+# else+type Rep0Tuple8 a b c d e f g h = D1+ D1Tuple8+ (C1+ C1_0Tuple8+ (((S1+ NoSelector+ (Rec0 a)+ :*: S1+ NoSelector+ (Rec0+ b))+ :*: (S1+ NoSelector+ (Rec0+ c)+ :*: S1+ NoSelector+ (Rec0+ d)))+ :*: ((S1+ NoSelector+ (Rec0+ e)+ :*: S1+ NoSelector+ (Rec0+ f))+ :*: (S1+ NoSelector+ (Rec0+ g)+ :*: S1+ NoSelector+ (Rec0+ h)))))+type Rep1Tuple8 a b c d e f g = D1+ D1Tuple8+ (C1+ C1_0Tuple8+ (((S1+ NoSelector+ (Rec0 a)+ :*: S1+ NoSelector+ (Rec0+ b))+ :*: (S1+ NoSelector+ (Rec0+ c)+ :*: S1+ NoSelector+ (Rec0+ d)))+ :*: ((S1+ NoSelector+ (Rec0+ e)+ :*: S1+ NoSelector+ (Rec0+ f))+ :*: (S1+ NoSelector+ (Rec0+ g)+ :*: S1+ NoSelector+ Par1))))++instance Generic (a, b, c, d, e, f, g, h) where+ type Rep (a, b, c, d, e, f, g, h) = Rep0Tuple8 a b c d e f g h++ from x+ = M1+ (case x of {+ (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ (M1 (K1 g4))))+ ((:*:)+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))+ ((:*:)+ (M1 (K1 g7))+ (M1 (K1 g8))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:) (M1 (K1 g3))+ (M1 (K1 g4))))+ ((:*:) ((:*:) (M1 (K1 g5))+ (M1 (K1 g6)))+ ((:*:) (M1 (K1 g7))+ (M1 (K1 g8))))))+ -> (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 }++instance Generic1 ((,,,,,,,) a b c d e f g) where+ type Rep1 ((,,,,,,,) a b c d e f g) = Rep1Tuple8 a b c d e f g++ from1 x+ = M1+ (case x of {+ (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ (M1 (K1 g4))))+ ((:*:)+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))+ ((:*:)+ (M1 (K1 g7))+ (M1 (Par1 g8))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ (M1 g2))+ ((:*:) (M1 g3)+ (M1 g4)))+ ((:*:) ((:*:) (M1 g5)+ (M1 g6))+ ((:*:) (M1 g7)+ (M1 g8)))))+ -> (,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unPar1 g8) }++data D1Tuple8+data C1_0Tuple8++instance Datatype D1Tuple8 where+ datatypeName _ = "(,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple8 where+ conName _ = "(,,,,,,,)"++-----++type Rep0Tuple9 a b c d e f g h i = D1+ D1Tuple9+ (C1+ C1_0Tuple9+ (((S1+ NoSelector+ (Rec0 a)+ :*: S1+ NoSelector+ (Rec0+ b))+ :*: (S1+ NoSelector+ (Rec0+ c)+ :*: S1+ NoSelector+ (Rec0+ d)))+ :*: ((S1+ NoSelector+ (Rec0+ e)+ :*: S1+ NoSelector+ (Rec0+ f))+ :*: (S1+ NoSelector+ (Rec0+ g)+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ (Rec0+ i))))))+type Rep1Tuple9 a b c d e f g h = D1+ D1Tuple9+ (C1+ C1_0Tuple9+ (((S1+ NoSelector (Rec0 a)+ :*: S1+ NoSelector+ (Rec0 b))+ :*: (S1+ NoSelector+ (Rec0 c)+ :*: S1+ NoSelector+ (Rec0+ d)))+ :*: ((S1+ NoSelector+ (Rec0 e)+ :*: S1+ NoSelector+ (Rec0+ f))+ :*: (S1+ NoSelector+ (Rec0+ g)+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ Par1)))))++instance Generic (a, b, c, d, e, f, g, h, i) where+ type Rep (a, b, c, d, e, f, g, h, i) = Rep0Tuple9 a b c d e f g h i++ from x+ = M1+ (case x of {+ (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ (M1 (K1 g4))))+ ((:*:)+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))+ ((:*:)+ (M1 (K1 g7))+ ((:*:)+ (M1 (K1 g8))+ (M1 (K1 g9)))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:) (M1 (K1 g3))+ (M1 (K1 g4))))+ ((:*:) ((:*:) (M1 (K1 g5))+ (M1 (K1 g6)))+ ((:*:) (M1 (K1 g7))+ ((:*:) (M1 (K1 g8))+ (M1 (K1 g9)))))))+ -> (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 }++instance Generic1 ((,,,,,,,,) a b c d e f g h) where+ type Rep1 ((,,,,,,,,) a b c d e f g h) = Rep1Tuple9 a b c d e f g h++ from1 x+ = M1+ (case x of {+ (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ (M1 (K1 g4))))+ ((:*:)+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))+ ((:*:)+ (M1 (K1 g7))+ ((:*:)+ (M1 (K1 g8))+ (M1 (Par1 g9)))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ (M1 g2))+ ((:*:) (M1 g3)+ (M1 g4)))+ ((:*:) ((:*:) (M1 g5)+ (M1 g6))+ ((:*:) (M1 g7)+ ((:*:) (M1 g8)+ (M1 g9))))))+ -> (,,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unK1 g8)+ (unPar1 g9) }++data D1Tuple9+data C1_0Tuple9++instance Datatype D1Tuple9 where+ datatypeName _ = "(,,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple9 where+ conName _ = "(,,,,,,,,)"++-----++type Rep0Tuple10 a b c d e f g h i j = D1+ D1Tuple10+ (C1+ C1_0Tuple10+ (((S1+ NoSelector (Rec0 a)+ :*: S1+ NoSelector+ (Rec0 b))+ :*: (S1+ NoSelector+ (Rec0 c)+ :*: (S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))))+ :*: ((S1+ NoSelector+ (Rec0 f)+ :*: S1+ NoSelector+ (Rec0+ g))+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: (S1+ NoSelector+ (Rec0+ i)+ :*: S1+ NoSelector+ (Rec0+ j))))))+type Rep1Tuple10 a b c d e f g h i = D1+ D1Tuple10+ (C1+ C1_0Tuple10+ (((S1+ NoSelector (Rec0 a)+ :*: S1+ NoSelector+ (Rec0 b))+ :*: (S1+ NoSelector+ (Rec0 c)+ :*: (S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))))+ :*: ((S1+ NoSelector+ (Rec0 f)+ :*: S1+ NoSelector+ (Rec0+ g))+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: (S1+ NoSelector+ (Rec0+ i)+ :*: S1+ NoSelector+ Par1)))))++instance Generic (a, b, c, d, e, f, g, h, i, j) where+ type Rep (a, b, c, d, e, f, g, h, i, j) = Rep0Tuple10 a b c d e f g h i j++ from x+ = M1+ (case x of {+ (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g6))+ (M1 (K1 g7)))+ ((:*:)+ (M1 (K1 g8))+ ((:*:)+ (M1 (K1 g9))+ (M1 (K1 g10)))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:) (M1 (K1 g3))+ ((:*:) (M1 (K1 g4))+ (M1 (K1 g5)))))+ ((:*:) ((:*:) (M1 (K1 g6))+ (M1 (K1 g7)))+ ((:*:) (M1 (K1 g8))+ ((:*:) (M1 (K1 g9))+ (M1 (K1 g10)))))))+ -> (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 }++instance Generic1+ ((,,,,,,,,,) a b c d e f g h i) where+ type Rep1 ((,,,,,,,,,) a b c d e f g h i) = Rep1Tuple10 a b c d e f g h i++ from1 x+ = M1+ (case x of {+ (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g6))+ (M1 (K1 g7)))+ ((:*:)+ (M1 (K1 g8))+ ((:*:)+ (M1 (K1 g9))+ (M1 (Par1 g10)))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ (M1 g2))+ ((:*:) (M1 g3)+ ((:*:) (M1 g4)+ (M1 g5))))+ ((:*:) ((:*:) (M1 g6)+ (M1 g7))+ ((:*:) (M1 g8)+ ((:*:) (M1 g9)+ (M1 g10))))))+ -> (,,,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unK1 g8)+ (unK1 g9) (unPar1 g10) }++data D1Tuple10+data C1_0Tuple10++instance Datatype D1Tuple10 where+ datatypeName _ = "(,,,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple10 where+ conName _ = "(,,,,,,,,,)"++-----++type Rep0Tuple11 a b c d e f g h i j k = D1+ D1Tuple11+ (C1+ C1_0Tuple11+ (((S1+ NoSelector+ (Rec0 a)+ :*: S1+ NoSelector+ (Rec0 b))+ :*: (S1+ NoSelector+ (Rec0 c)+ :*: (S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))))+ :*: ((S1+ NoSelector+ (Rec0 f)+ :*: (S1+ NoSelector+ (Rec0+ g)+ :*: S1+ NoSelector+ (Rec0+ h)))+ :*: (S1+ NoSelector+ (Rec0+ i)+ :*: (S1+ NoSelector+ (Rec0+ j)+ :*: S1+ NoSelector+ (Rec0+ k))))))+type Rep1Tuple11 a b c d e f g h i j = D1+ D1Tuple11+ (C1+ C1_0Tuple11+ (((S1+ NoSelector+ (Rec0 a)+ :*: S1+ NoSelector+ (Rec0 b))+ :*: (S1+ NoSelector+ (Rec0 c)+ :*: (S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))))+ :*: ((S1+ NoSelector+ (Rec0 f)+ :*: (S1+ NoSelector+ (Rec0+ g)+ :*: S1+ NoSelector+ (Rec0+ h)))+ :*: (S1+ NoSelector+ (Rec0+ i)+ :*: (S1+ NoSelector+ (Rec0+ j)+ :*: S1+ NoSelector+ Par1)))))++instance Generic+ (a, b, c, d, e, f, g, h, i, j, k) where+ type Rep (a, b, c, d, e, f, g, h, i, j, k) = Rep0Tuple11 a b c d e f g h i j k++ from x+ = M1+ (case x of {+ (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g6))+ ((:*:)+ (M1 (K1 g7))+ (M1 (K1 g8))))+ ((:*:)+ (M1 (K1 g9))+ ((:*:)+ (M1 (K1 g10))+ (M1 (K1 g11)))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:) (M1 (K1 g3))+ ((:*:) (M1 (K1 g4))+ (M1 (K1 g5)))))+ ((:*:) ((:*:) (M1 (K1 g6))+ ((:*:) (M1 (K1 g7))+ (M1 (K1 g8))))+ ((:*:) (M1 (K1 g9))+ ((:*:) (M1 (K1 g10))+ (M1 (K1 g11)))))))+ -> (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 }++instance Generic1+ ((,,,,,,,,,,) a b c d e f g h i j) where+ type Rep1 ((,,,,,,,,,,) a b c d e f g h i j) = Rep1Tuple11 a b c d e f g h i j++ from1 x+ = M1+ (case x of {+ (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ (M1 (K1 g2)))+ ((:*:)+ (M1 (K1 g3))+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g6))+ ((:*:)+ (M1 (K1 g7))+ (M1 (K1 g8))))+ ((:*:)+ (M1 (K1 g9))+ ((:*:)+ (M1 (K1 g10))+ (M1 (Par1 g11)))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ (M1 g2))+ ((:*:) (M1 g3)+ ((:*:) (M1 g4)+ (M1 g5))))+ ((:*:) ((:*:) (M1 g6)+ ((:*:) (M1 g7)+ (M1 g8)))+ ((:*:) (M1 g9)+ ((:*:) (M1 g10)+ (M1 g11))))))+ -> (,,,,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unK1 g8)+ (unK1 g9) (unK1 g10)+ (unPar1 g11) }++data D1Tuple11+data C1_0Tuple11++instance Datatype D1Tuple11 where+ datatypeName _ = "(,,,,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple11 where+ conName _ = "(,,,,,,,,,,)"++-----++type Rep0Tuple12 a b c d e f g h i j k l = D1+ D1Tuple12+ (C1+ C1_0Tuple12+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0 b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: (S1+ NoSelector+ (Rec0 d)+ :*: (S1+ NoSelector+ (Rec0+ e)+ :*: S1+ NoSelector+ (Rec0+ f))))+ :*: ((S1+ NoSelector+ (Rec0 g)+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ (Rec0+ i)))+ :*: (S1+ NoSelector+ (Rec0+ j)+ :*: (S1+ NoSelector+ (Rec0+ k)+ :*: S1+ NoSelector+ (Rec0+ l))))))+type Rep1Tuple12 a b c d e f g h i j k = D1+ D1Tuple12+ (C1+ C1_0Tuple12+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0 b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: (S1+ NoSelector+ (Rec0 d)+ :*: (S1+ NoSelector+ (Rec0+ e)+ :*: S1+ NoSelector+ (Rec0+ f))))+ :*: ((S1+ NoSelector+ (Rec0 g)+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ (Rec0+ i)))+ :*: (S1+ NoSelector+ (Rec0+ j)+ :*: (S1+ NoSelector+ (Rec0+ k)+ :*: S1+ NoSelector+ Par1)))))++instance Generic+ (a, b, c, d, e, f, g, h, i, j, k, l) where+ type Rep (a, b, c, d, e, f, g, h, i, j, k, l) = Rep0Tuple12 a b c d e f g h i j k l++ from x+ = M1+ (case x of {+ (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ (M1 (K1 g4))+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g7))+ ((:*:)+ (M1 (K1 g8))+ (M1 (K1 g9))))+ ((:*:)+ (M1 (K1 g10))+ ((:*:)+ (M1 (K1 g11))+ (M1 (K1 g12)))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ ((:*:) (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:) (M1 (K1 g4))+ ((:*:) (M1 (K1 g5))+ (M1 (K1 g6)))))+ ((:*:) ((:*:) (M1 (K1 g7))+ ((:*:) (M1 (K1 g8))+ (M1 (K1 g9))))+ ((:*:) (M1 (K1 g10))+ ((:*:) (M1 (K1 g11))+ (M1 (K1 g12)))))))+ -> (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 }++instance Generic1+ ((,,,,,,,,,,,) a b c d e f g h i j k) where+ type Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k) = Rep1Tuple12 a b c d e f g h i j k++ from1 x+ = M1+ (case x of {+ (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ (M1 (K1 g4))+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g7))+ ((:*:)+ (M1 (K1 g8))+ (M1 (K1 g9))))+ ((:*:)+ (M1 (K1 g10))+ ((:*:)+ (M1 (K1 g11))+ (M1 (Par1 g12)))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ ((:*:) (M1 g2)+ (M1 g3)))+ ((:*:) (M1 g4)+ ((:*:) (M1 g5)+ (M1 g6))))+ ((:*:) ((:*:) (M1 g7)+ ((:*:) (M1 g8)+ (M1 g9)))+ ((:*:) (M1 g10)+ ((:*:) (M1 g11)+ (M1 g12))))))+ -> (,,,,,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unK1 g8)+ (unK1 g9) (unK1 g10)+ (unK1 g11) (unPar1 g12) }++data D1Tuple12+data C1_0Tuple12++instance Datatype D1Tuple12 where+ datatypeName _ = "(,,,,,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple12 where+ conName _ = "(,,,,,,,,,,,)"++-----++type Rep0Tuple13 a b c d e f g h i j k l m = D1+ D1Tuple13+ (C1+ C1_0Tuple13+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0+ b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: (S1+ NoSelector+ (Rec0+ d)+ :*: (S1+ NoSelector+ (Rec0+ e)+ :*: S1+ NoSelector+ (Rec0+ f))))+ :*: ((S1+ NoSelector+ (Rec0+ g)+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ (Rec0+ i)))+ :*: ((S1+ NoSelector+ (Rec0+ j)+ :*: S1+ NoSelector+ (Rec0+ k))+ :*: (S1+ NoSelector+ (Rec0+ l)+ :*: S1+ NoSelector+ (Rec0+ m))))))+type Rep1Tuple13 a b c d e f g h i j k l = D1+ D1Tuple13+ (C1+ C1_0Tuple13+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0+ b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: (S1+ NoSelector+ (Rec0+ d)+ :*: (S1+ NoSelector+ (Rec0+ e)+ :*: S1+ NoSelector+ (Rec0+ f))))+ :*: ((S1+ NoSelector+ (Rec0+ g)+ :*: (S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ (Rec0+ i)))+ :*: ((S1+ NoSelector+ (Rec0+ j)+ :*: S1+ NoSelector+ (Rec0+ k))+ :*: (S1+ NoSelector+ (Rec0+ l)+ :*: S1+ NoSelector+ Par1)))))++data D1Tuple13+data C1_0Tuple13++instance Generic+ (a, b, c, d, e, f, g, h, i, j, k, l, m) where+ type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m) = Rep0Tuple13 a b c d e f g h i j k l m++ from x+ = M1+ (case x of {+ (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ (M1 (K1 g4))+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g7))+ ((:*:)+ (M1 (K1 g8))+ (M1 (K1 g9))))+ ((:*:)+ ((:*:)+ (M1 (K1 g10))+ (M1 (K1 g11)))+ ((:*:)+ (M1 (K1 g12))+ (M1 (K1 g13)))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ ((:*:) (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:) (M1 (K1 g4))+ ((:*:) (M1 (K1 g5))+ (M1 (K1 g6)))))+ ((:*:) ((:*:) (M1 (K1 g7))+ ((:*:) (M1 (K1 g8))+ (M1 (K1 g9))))+ ((:*:) ((:*:) (M1 (K1 g10))+ (M1 (K1 g11)))+ ((:*:) (M1 (K1 g12))+ (M1 (K1 g13)))))))+ -> (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 }++instance Generic1+ ((,,,,,,,,,,,,) a b c d e f g h i j k l) where+ type Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) = Rep1Tuple13 a b c d e f g h i j k l++ from1 x+ = M1+ (case x of {+ (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ (M1 (K1 g4))+ ((:*:)+ (M1 (K1 g5))+ (M1 (K1 g6)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g7))+ ((:*:)+ (M1 (K1 g8))+ (M1 (K1 g9))))+ ((:*:)+ ((:*:)+ (M1 (K1 g10))+ (M1 (K1 g11)))+ ((:*:)+ (M1 (K1 g12))+ (M1 (Par1 g13)))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ ((:*:) (M1 g2)+ (M1 g3)))+ ((:*:) (M1 g4)+ ((:*:) (M1 g5)+ (M1 g6))))+ ((:*:) ((:*:) (M1 g7)+ ((:*:) (M1 g8)+ (M1 g9)))+ ((:*:) ((:*:) (M1 g10)+ (M1 g11))+ ((:*:) (M1 g12)+ (M1 g13))))))+ -> (,,,,,,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unK1 g8)+ (unK1 g9) (unK1 g10)+ (unK1 g11) (unK1 g12)+ (unPar1 g13) }++instance Datatype D1Tuple13 where+ datatypeName _ = "(,,,,,,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple13 where+ conName _ = "(,,,,,,,,,,,,)"++-----++type Rep0Tuple14 a b c d e f g h i j k l m n = D1+ D1Tuple14+ (C1+ C1_0Tuple14+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0+ b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: ((S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))+ :*: (S1+ NoSelector+ (Rec0+ f)+ :*: S1+ NoSelector+ (Rec0+ g))))+ :*: ((S1+ NoSelector+ (Rec0+ h)+ :*: (S1+ NoSelector+ (Rec0+ i)+ :*: S1+ NoSelector+ (Rec0+ j)))+ :*: ((S1+ NoSelector+ (Rec0+ k)+ :*: S1+ NoSelector+ (Rec0+ l))+ :*: (S1+ NoSelector+ (Rec0+ m)+ :*: S1+ NoSelector+ (Rec0+ n))))))+type Rep1Tuple14 a b c d e f g h i j k l m = D1+ D1Tuple14+ (C1+ C1_0Tuple14+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0+ b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: ((S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))+ :*: (S1+ NoSelector+ (Rec0+ f)+ :*: S1+ NoSelector+ (Rec0+ g))))+ :*: ((S1+ NoSelector+ (Rec0+ h)+ :*: (S1+ NoSelector+ (Rec0+ i)+ :*: S1+ NoSelector+ (Rec0+ j)))+ :*: ((S1+ NoSelector+ (Rec0+ k)+ :*: S1+ NoSelector+ (Rec0+ l))+ :*: (S1+ NoSelector+ (Rec0+ m)+ :*: S1+ NoSelector+ Par1)))))++instance Generic+ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+ type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = Rep0Tuple14 a b c d e f g h i j k l m n++ from x+ = M1+ (case x of {+ (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))+ ((:*:)+ (M1 (K1 g6))+ (M1 (K1 g7)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g8))+ ((:*:)+ (M1 (K1 g9))+ (M1 (K1 g10))))+ ((:*:)+ ((:*:)+ (M1 (K1 g11))+ (M1 (K1 g12)))+ ((:*:)+ (M1 (K1 g13))+ (M1 (K1 g14)))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ ((:*:) (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:) ((:*:) (M1 (K1 g4))+ (M1 (K1 g5)))+ ((:*:) (M1 (K1 g6))+ (M1 (K1 g7)))))+ ((:*:) ((:*:) (M1 (K1 g8))+ ((:*:) (M1 (K1 g9))+ (M1 (K1 g10))))+ ((:*:) ((:*:) (M1 (K1 g11))+ (M1 (K1 g12)))+ ((:*:) (M1 (K1 g13))+ (M1 (K1 g14)))))))+ -> (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 }++instance Generic1+ ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where+ type Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) = Rep1Tuple14 a b c d e f g h i j k l m++ from1 x+ = M1+ (case x of {+ (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))+ ((:*:)+ (M1 (K1 g6))+ (M1 (K1 g7)))))+ ((:*:)+ ((:*:)+ (M1 (K1 g8))+ ((:*:)+ (M1 (K1 g9))+ (M1 (K1 g10))))+ ((:*:)+ ((:*:)+ (M1 (K1 g11))+ (M1 (K1 g12)))+ ((:*:)+ (M1 (K1 g13))+ (M1 (Par1 g14)))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ ((:*:) (M1 g2)+ (M1 g3)))+ ((:*:) ((:*:) (M1 g4)+ (M1 g5))+ ((:*:) (M1 g6)+ (M1 g7))))+ ((:*:) ((:*:) (M1 g8)+ ((:*:) (M1 g9)+ (M1 g10)))+ ((:*:) ((:*:) (M1 g11)+ (M1 g12))+ ((:*:) (M1 g13)+ (M1 g14))))))+ -> (,,,,,,,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unK1 g8)+ (unK1 g9) (unK1 g10)+ (unK1 g11) (unK1 g12)+ (unK1 g13) (unPar1 g14) }++data D1Tuple14+data C1_0Tuple14++instance Datatype D1Tuple14 where+ datatypeName _ = "(,,,,,,,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple14 where+ conName _ = "(,,,,,,,,,,,,,)"++-----++type Rep0Tuple15 a b c d e f g h i j k l m n o = D1+ D1Tuple15+ (C1+ C1_0Tuple15+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0+ b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: ((S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))+ :*: (S1+ NoSelector+ (Rec0+ f)+ :*: S1+ NoSelector+ (Rec0+ g))))+ :*: (((S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ (Rec0+ i))+ :*: (S1+ NoSelector+ (Rec0+ j)+ :*: S1+ NoSelector+ (Rec0+ k)))+ :*: ((S1+ NoSelector+ (Rec0+ l)+ :*: S1+ NoSelector+ (Rec0+ m))+ :*: (S1+ NoSelector+ (Rec0+ n)+ :*: S1+ NoSelector+ (Rec0+ o))))))+type Rep1Tuple15 a b c d e f g h i j k l m n = D1+ D1Tuple15+ (C1+ C1_0Tuple15+ (((S1+ NoSelector+ (Rec0 a)+ :*: (S1+ NoSelector+ (Rec0+ b)+ :*: S1+ NoSelector+ (Rec0+ c)))+ :*: ((S1+ NoSelector+ (Rec0+ d)+ :*: S1+ NoSelector+ (Rec0+ e))+ :*: (S1+ NoSelector+ (Rec0+ f)+ :*: S1+ NoSelector+ (Rec0+ g))))+ :*: (((S1+ NoSelector+ (Rec0+ h)+ :*: S1+ NoSelector+ (Rec0+ i))+ :*: (S1+ NoSelector+ (Rec0+ j)+ :*: S1+ NoSelector+ (Rec0+ k)))+ :*: ((S1+ NoSelector+ (Rec0+ l)+ :*: S1+ NoSelector+ (Rec0+ m))+ :*: (S1+ NoSelector+ (Rec0+ n)+ :*: S1+ NoSelector+ Par1)))))++instance Generic+ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+ type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = Rep0Tuple15 a b c d e f g h i j k l m n o++ from x+ = M1+ (case x of {+ (,,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))+ ((:*:)+ (M1 (K1 g6))+ (M1 (K1 g7)))))+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g8))+ (M1 (K1 g9)))+ ((:*:)+ (M1 (K1 g10))+ (M1 (K1 g11))))+ ((:*:)+ ((:*:)+ (M1 (K1 g12))+ (M1 (K1 g13)))+ ((:*:)+ (M1 (K1 g14))+ (M1 (K1 g15)))))) })+ to (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1))+ ((:*:) (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:) ((:*:) (M1 (K1 g4))+ (M1 (K1 g5)))+ ((:*:) (M1 (K1 g6))+ (M1 (K1 g7)))))+ ((:*:) ((:*:) ((:*:) (M1 (K1 g8))+ (M1 (K1 g9)))+ ((:*:) (M1 (K1 g10))+ (M1 (K1 g11))))+ ((:*:) ((:*:) (M1 (K1 g12))+ (M1 (K1 g13)))+ ((:*:) (M1 (K1 g14))+ (M1 (K1 g15)))))))+ -> (,,,,,,,,,,,,,,)+ g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 }++instance Generic1+ ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where+ type Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) = Rep1Tuple15 a b c d e f g h i j k l m n++ from1 x+ = M1+ (case x of {+ (,,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15+ -> M1+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g1))+ ((:*:)+ (M1 (K1 g2))+ (M1 (K1 g3))))+ ((:*:)+ ((:*:)+ (M1 (K1 g4))+ (M1 (K1 g5)))+ ((:*:)+ (M1 (K1 g6))+ (M1 (K1 g7)))))+ ((:*:)+ ((:*:)+ ((:*:)+ (M1 (K1 g8))+ (M1 (K1 g9)))+ ((:*:)+ (M1 (K1 g10))+ (M1 (K1 g11))))+ ((:*:)+ ((:*:)+ (M1 (K1 g12))+ (M1 (K1 g13)))+ ((:*:)+ (M1 (K1 g14))+ (M1 (Par1 g15)))))) })+ to1 (M1 x)+ = case x of {+ (M1 ((:*:) ((:*:) ((:*:) (M1 g1)+ ((:*:) (M1 g2)+ (M1 g3)))+ ((:*:) ((:*:) (M1 g4)+ (M1 g5))+ ((:*:) (M1 g6)+ (M1 g7))))+ ((:*:) ((:*:) ((:*:) (M1 g8)+ (M1 g9))+ ((:*:) (M1 g10)+ (M1 g11)))+ ((:*:) ((:*:) (M1 g12)+ (M1 g13))+ ((:*:) (M1 g14)+ (M1 g15))))))+ -> (,,,,,,,,,,,,,,)+ (unK1 g1) (unK1 g2)+ (unK1 g3) (unK1 g4)+ (unK1 g5) (unK1 g6)+ (unK1 g7) (unK1 g8)+ (unK1 g9) (unK1 g10)+ (unK1 g11) (unK1 g12)+ (unK1 g13) (unK1 g14)+ (unPar1 g15) }++data D1Tuple15+data C1_0Tuple15++instance Datatype D1Tuple15 where+ datatypeName _ = "(,,,,,,,,,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple15 where+ conName _ = "(,,,,,,,,,,,,,,)"++# endif+#endif++#if !(MIN_VERSION_base(4,14,0))+# if MIN_VERSION_base(4,6,0)+type Rep0Kleisli m a b = Rep (Kleisli m a b)+type Rep1Kleisli m a = Rep1 (Kleisli m a)+deriving instance Generic (Kleisli m a b)+deriving instance Generic1 (Kleisli m a)+# else+type Rep0Kleisli m a b = D1 D1Kleisli (C1 C1_0Kleisli (S1 S1_0_0Kleisli (Rec0 (a -> m b))))+type Rep1Kleisli m a = D1 D1Kleisli (C1 C1_0Kleisli (S1 S1_0_0Kleisli ((->) a :.: Rec1 m)))++instance Generic (Kleisli m a b) where+ type Rep (Kleisli m a b) = Rep0Kleisli m a b+ from x = M1 (case x of+ Kleisli g -> M1 (M1 (K1 g)))+ to (M1 x) = case x of+ M1 (M1 (K1 g)) -> Kleisli g++instance Generic1 (Kleisli m a) where+ type Rep1 (Kleisli m a) = Rep1Kleisli m a+ from1 x = M1 (case x of+ Kleisli g -> M1 (M1 (Comp1 (fmap Rec1 g))))+ to1 (M1 x) = case x of+ M1 (M1 g) -> Kleisli (fmap unRec1 (unComp1 g))++data D1Kleisli+data C1_0Kleisli+data S1_0_0Kleisli++instance Datatype D1Kleisli where+ datatypeName _ = "Kleisli"+ moduleName _ = "Control.Arrow"++instance Constructor C1_0Kleisli where+ conName _ = "Kleisli"+ conIsRecord _ = True++instance Selector S1_0_0Kleisli where+ selName _ = "runKleisli"+# endif+#endif++#if !(MIN_VERSION_base(4,12,0))+# if MIN_VERSION_base(4,6,0)+type Rep0Down a = Rep (Down a)+type Rep1Down = Rep1 Down+deriving instance Generic (Down a)+deriving instance Generic1 Down+# else+type Rep0Down a = D1 D1Down (C1 C1_0Down (S1 NoSelector (Rec0 a)))+type Rep1Down = D1 D1Down (C1 C1_0Down (S1 NoSelector Par1))++instance Generic (Down a) where+ type Rep (Down a) = Rep0Down a+ from x = M1 (case x of+ Down g -> M1 (M1 (K1 g)))+ to (M1 x) = case x of+ M1 (M1 (K1 g)) -> Down g++instance Generic1 Down where+ type Rep1 Down = Rep1Down+ from1 x = M1 (case x of+ Down g -> M1 (M1 (Par1 g)))+ to1 (M1 x) = case x of+ M1 (M1 g) -> Down (unPar1 g)++data D1Down+data C1_0Down++instance Datatype D1Down where+ datatypeName _ = "Down"+ moduleName _ = "GHC.Exts"++instance Constructor C1_0Down where+ conName _ = "Down"+# endif+#endif++-----++#if !(MIN_VERSION_base(4,9,0))+type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1+ :+: C1 C1_1ExitCode (S1 NoSelector (Rec0 Int)))++instance Generic ExitCode where+ type Rep ExitCode = Rep0ExitCode+ from x = M1 (case x of+ ExitSuccess -> L1 (M1 U1)+ ExitFailure g -> R1 (M1 (M1 (K1 g))))+ to (M1 x) = case x of+ L1 (M1 U1) -> ExitSuccess+ R1 (M1 (M1 (K1 g))) -> ExitFailure g++data D1ExitCode+data C1_0ExitCode+data C1_1ExitCode++instance Datatype D1ExitCode where+ datatypeName _ = "ExitCode"+ moduleName _ = "GHC.IO.Exception"++instance Constructor C1_0ExitCode where+ conName _ = "ExitSuccess"++instance Constructor C1_1ExitCode where+ conName _ = "ExitFailure"++-----++type Rep0Version = D1 D1Version (C1 C1_0Version (S1 S1_0_0Version (Rec0 [Int])+ :*: S1 S1_0_1Version (Rec0 [String])))++instance Generic Version where+ type Rep Version = Rep0Version+ from (Version b t) = M1 (M1 (M1 (K1 b) :*: M1 (K1 t)))+ to (M1 (M1 (M1 (K1 b) :*: M1 (K1 t)))) = Version b t++data D1Version+data C1_0Version+data S1_0_0Version+data S1_0_1Version++instance Datatype D1Version where+ datatypeName _ = "Version"+ moduleName _ = "Data.Version"++instance Constructor C1_0Version where+ conName _ = "Version"+ conIsRecord _ = True++instance Selector S1_0_0Version where+ selName _ = "versionBranch"++instance Selector S1_0_1Version where+ selName _ = "versionTags"++-----++type Rep1ConSum f g = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec1 f))+ :+: C1 C1_1ConSum (S1 NoSelector (Rec1 g)))++instance Generic1 (f :+: g) where+ type Rep1 (f :+: g) = Rep1ConSum f g+ from1 x = M1 (case x of+ L1 l -> L1 (M1 (M1 (Rec1 l)))+ R1 r -> R1 (M1 (M1 (Rec1 r))))+ to1 (M1 x) = case x of+ L1 (M1 (M1 l)) -> L1 (unRec1 l)+ R1 (M1 (M1 r)) -> R1 (unRec1 r)++data D1ConSum+data C1_0ConSum+data C1_1ConSum++instance Datatype D1ConSum where+ datatypeName _ = ":+:"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0ConSum where+ conName _ = "L1"++instance Constructor C1_1ConSum where+ conName _ = "R1"++-----++type Rep1ConProduct f g = D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec1 f)+ :*: S1 NoSelector (Rec1 g)))++instance Generic1 (f :*: g) where+ type Rep1 (f :*: g) = Rep1ConProduct f g+ from1 (f :*: g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))+ to1 (M1 (M1 (M1 f :*: M1 g))) = unRec1 f :*: unRec1 g++data D1ConProduct+data C1_ConProduct++instance Datatype D1ConProduct where+ datatypeName _ = ":*:"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_ConProduct where+ conName _ = ":*:"+ conFixity _ = Infix RightAssociative 6++-----++type Rep1ConCompose f g =+ D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (f :.: Rec1 g)))++instance Functor f => Generic1 (f :.: g) where+ type Rep1 (f :.: g) = Rep1ConCompose f g+ from1 (Comp1 c) = M1 (M1 (M1 (Comp1 (fmap Rec1 c))))+ to1 (M1 (M1 (M1 c))) = Comp1 (fmap unRec1 (unComp1 c))++data D1ConCompose+data C1_0ConCompose+data S1_0_0ConCompose++instance Datatype D1ConCompose where+ datatypeName _ = ":.:"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0ConCompose where+ conName _ = "Comp1"+ conIsRecord _ = True++instance Selector S1_0_0ConCompose where+ selName _ = "unComp1"++-----++type Rep1K1 i c = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c)))++instance Generic1 (K1 i c) where+ type Rep1 (K1 i c) = Rep1K1 i c+ from1 (K1 c) = M1 (M1 (M1 (K1 c)))+ to1 (M1 (M1 (M1 c))) = K1 (unK1 c)++data D1K1+data C1_0K1+data S1_0_0K1++instance Datatype D1K1 where+ datatypeName _ = "K1"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0K1 where+ conName _ = "K1"+ conIsRecord _ = True++instance Selector S1_0_0K1 where+ selName _ = "unK1"++-----++type Rep1M1 i c f = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec1 f)))++instance Generic1 (M1 i c f) where+ type Rep1 (M1 i c f) = Rep1M1 i c f+ from1 (M1 m) = M1 (M1 (M1 (Rec1 m)))+ to1 (M1 (M1 (M1 m))) = M1 (unRec1 m)++data D1M1+data C1_0M1+data S1_0_0M1++instance Datatype D1M1 where+ datatypeName _ = "M1"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0M1 where+ conName _ = "M1"+ conIsRecord _ = True++instance Selector S1_0_0M1 where+ selName _ = "unM1"++-----++type Rep1Par1 = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 Par1))++instance Generic1 Par1 where+ type Rep1 Par1 = Rep1Par1+ from1 (Par1 p) = M1 (M1 (M1 (Par1 p)))+ to1 (M1 (M1 (M1 p))) = Par1 (unPar1 p)++data D1Par1+data C1_0Par1+data S1_0_0Par1++instance Datatype D1Par1 where+ datatypeName _ = "Par1"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Par1 where+ conName _ = "Par1"+ conIsRecord _ = True++instance Selector S1_0_0Par1 where+ selName _ = "unPar1"++-----++type Rep1Rec1 f = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec1 f)))++instance Generic1 (Rec1 f) where+ type Rep1 (Rec1 f) = Rep1Rec1 f+ from1 (Rec1 r) = M1 (M1 (M1 (Rec1 r)))+ to1 (M1 (M1 (M1 r))) = Rec1 (unRec1 r)++data D1Rec1+data C1_0Rec1+data S1_0_0Rec1++instance Datatype D1Rec1 where+ datatypeName _ = "Rec1"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Rec1 where+ conName _ = "Rec1"+ conIsRecord _ = True++instance Selector S1_0_0Rec1 where+ selName _ = "unRec1"++-----++type Rep1U1 = D1 D1U1 (C1 C1_0U1 U1)++instance Generic1 U1 where+ type Rep1 U1 = Rep1U1+ from1 U1 = M1 (M1 U1)+ to1 (M1 (M1 U1)) = U1++data D1U1+data C1_0U1++instance Datatype D1U1 where+ datatypeName _ = "U1"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0U1 where+ conName _ = "U1"++-----++type Rep0V1 p = D1 D1V1 V1+type Rep1V1 = D1 D1V1 V1++instance Generic (V1 p) where+ type Rep (V1 p) = Rep0V1 p+ from x = M1 (case x of !_ -> error "No generic representation for empty datatype V1")+ to (M1 !_) = error "No values for empty datatype V1"++instance Generic1 V1 where+ type Rep1 V1 = Rep1V1+ from1 x = M1 (case x of !_ -> error "No generic representation for empty datatype V1")+ to1 (M1 !_) = error "No values for empty datatype V1"++data D1V1++instance Datatype D1V1 where+ datatypeName _ = "V1"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++-----++type Rep0UAddr p = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr))+type Rep1UAddr = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr))++instance Generic (UAddr p) where+ type Rep (UAddr p) = Rep0UAddr p+ from (UAddr a) = M1 (M1 (M1 (UAddr a)))+ to (M1 (M1 (M1 (UAddr a)))) = UAddr a++instance Generic1 UAddr where+ type Rep1 UAddr = Rep1UAddr+ from1 (UAddr a) = M1 (M1 (M1 (UAddr a)))+ to1 (M1 (M1 (M1 (UAddr a)))) = UAddr a++data D1UAddr+data C1_0UAddr+data S1_0_0UAddr++instance Datatype D1UAddr where+ datatypeName _ = "UAddr"+ moduleName _ = "Generics.Deriving.Base.Internal"++instance Constructor C1_0UAddr where+ conName _ = "UAddr"+ conIsRecord _ = True++instance Selector S1_0_0UAddr where+ selName _ = "uAddr#"++-----++type Rep0UChar p = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar))+type Rep1UChar = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar))++instance Generic (UChar p) where+ type Rep (UChar p) = Rep0UChar p+ from (UChar c) = M1 (M1 (M1 (UChar c)))+ to (M1 (M1 (M1 (UChar c)))) = UChar c++instance Generic1 UChar where+ type Rep1 UChar = Rep1UChar+ from1 (UChar c) = M1 (M1 (M1 (UChar c)))+ to1 (M1 (M1 (M1 (UChar c)))) = UChar c++data D1UChar+data C1_0UChar+data S1_0_0UChar++instance Datatype D1UChar where+ datatypeName _ = "UChar"+ moduleName _ = "Generics.Deriving.Base.Internal"++instance Constructor C1_0UChar where+ conName _ = "UChar"+ conIsRecord _ = True++instance Selector S1_0_0UChar where+ selName _ = "uChar#"++-----++type Rep0UDouble p = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble))+type Rep1UDouble = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble))++instance Generic (UDouble p) where+ type Rep (UDouble p) = Rep0UDouble p+ from (UDouble d) = M1 (M1 (M1 (UDouble d)))+ to (M1 (M1 (M1 (UDouble d)))) = UDouble d++instance Generic1 UDouble where+ type Rep1 UDouble = Rep1UDouble+ from1 (UDouble d) = M1 (M1 (M1 (UDouble d)))+ to1 (M1 (M1 (M1 (UDouble d)))) = UDouble d++data D1UDouble+data C1_0UDouble+data S1_0_0UDouble++instance Datatype D1UDouble where+ datatypeName _ = "UDouble"+ moduleName _ = "Generics.Deriving.Base.Internal"++instance Constructor C1_0UDouble where+ conName _ = "UDouble"+ conIsRecord _ = True++instance Selector S1_0_0UDouble where+ selName _ = "uDouble#"++-----++type Rep0UFloat p = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat))+type Rep1UFloat = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat))++instance Generic (UFloat p) where+ type Rep (UFloat p) = Rep0UFloat p+ from (UFloat f) = M1 (M1 (M1 (UFloat f)))+ to (M1 (M1 (M1 (UFloat f)))) = UFloat f++instance Generic1 UFloat where+ type Rep1 UFloat = Rep1UFloat+ from1 (UFloat f) = M1 (M1 (M1 (UFloat f)))+ to1 (M1 (M1 (M1 (UFloat f)))) = UFloat f++data D1UFloat+data C1_0UFloat+data S1_0_0UFloat++instance Datatype D1UFloat where+ datatypeName _ = "UFloat"+ moduleName _ = "Generics.Deriving.Base.Internal"++instance Constructor C1_0UFloat where+ conName _ = "UFloat"+ conIsRecord _ = True++instance Selector S1_0_0UFloat where+ selName _ = "uFloat#"++-----++type Rep0UInt p = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt))+type Rep1UInt = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt))++instance Generic (UInt p) where+ type Rep (UInt p) = Rep0UInt p+ from (UInt i) = M1 (M1 (M1 (UInt i)))+ to (M1 (M1 (M1 (UInt i)))) = UInt i++instance Generic1 UInt where+ type Rep1 UInt = Rep1UInt+ from1 (UInt i) = M1 (M1 (M1 (UInt i)))+ to1 (M1 (M1 (M1 (UInt i)))) = UInt i++data D1UInt+data C1_0UInt+data S1_0_0UInt++instance Datatype D1UInt where+ datatypeName _ = "UInt"+ moduleName _ = "Generics.Deriving.Base.Internal"++instance Constructor C1_0UInt where+ conName _ = "UInt"+ conIsRecord _ = True++instance Selector S1_0_0UInt where+ selName _ = "uInt#"++-----++type Rep0UWord p = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord))+type Rep1UWord = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord))++instance Generic (UWord p) where+ type Rep (UWord p) = Rep0UWord p+ from (UWord w) = M1 (M1 (M1 (UWord w)))+ to (M1 (M1 (M1 (UWord w)))) = UWord w++instance Generic1 UWord where+ type Rep1 UWord = Rep1UWord+ from1 (UWord w) = M1 (M1 (M1 (UWord w)))+ to1 (M1 (M1 (M1 (UWord w)))) = UWord w++data D1UWord+data C1_0UWord+data S1_0_0UWord++instance Datatype D1UWord where+ datatypeName _ = "UWord"+ moduleName _ = "Generics.Deriving.Base.Internal"++instance Constructor C1_0UWord where+ conName _ = "UWord"+ conIsRecord _ = True++instance Selector S1_0_0UWord where+ selName _ = "uWord#"++-----++# if MIN_VERSION_base(4,4,0)+type Rep0Complex a = D1 D1Complex (C1 C1_0Complex (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 a)))+type Rep1Complex = D1 D1Complex (C1 C1_0Complex (S1 NoSelector Par1+ :*: S1 NoSelector Par1))++instance Generic (Complex a) where+ type Rep (Complex a) = Rep0Complex a+ from (a :+ b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))+ to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = a :+ b++instance Generic1 Complex where+ type Rep1 Complex = Rep1Complex+ from1 (a :+ b) = M1 (M1 (M1 (Par1 a) :*: M1 (Par1 b)))+ to1 (M1 (M1 (M1 a :*: M1 b))) = unPar1 a :+ unPar1 b++data D1Complex+data C1_0Complex++instance Datatype D1Complex where+ datatypeName _ = "Complex"+ moduleName _ = "Data.Complex"++instance Constructor C1_0Complex where+ conName _ = ":+"+ conFixity _ = Infix LeftAssociative 9+# endif++-----++# if MIN_VERSION_base(4,7,0)+type Rep1Proxy = D1 D1Proxy (C1 C1_0Proxy U1)++instance Generic1 Proxy where+ type Rep1 Proxy = Rep1Proxy+ from1 Proxy = M1 (M1 U1)+ to1 (M1 (M1 U1)) = Proxy++data D1Proxy+data C1_0Proxy++instance Datatype D1Proxy where+ datatypeName _ = "Proxy"+ moduleName _ = "Data.Proxy"++instance Constructor C1_0Proxy where+ conName _ = "Proxy"+# endif+#endif++-----++#if !(MIN_VERSION_base(4,7,0))+--------------------------------------------------------------------------------+-- Representations for base types+--------------------------------------------------------------------------------++type Rep0All = D1 D1All (C1 C1_0All (S1 S1_0_0All (Rec0 Bool)))++instance Generic All where+ type Rep All = Rep0All+ from (All a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = All a++data D1All+data C1_0All+data S1_0_0All++instance Datatype D1All where+ datatypeName _ = "All"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0All where+ conName _ = "All"+ conIsRecord _ = True++instance Selector S1_0_0All where+ selName _ = "getAll"++-----++type Rep0Any = D1 D1Any (C1 C1_0Any (S1 S1_0_0Any (Rec0 Bool)))++instance Generic Any where+ type Rep Any = Rep0Any+ from (Any a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = Any a++data D1Any+data C1_0Any+data S1_0_0Any++instance Datatype D1Any where+ datatypeName _ = "Any"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Any where+ conName _ = "Any"+ conIsRecord _ = True++instance Selector S1_0_0Any where+ selName _ = "getAny"++-----++type Rep0Arity = D1 D1Arity (C1 C1_0Arity U1+ :+: C1 C1_1Arity (S1 NoSelector (Rec0 Int)))++instance Generic Arity where+ type Rep Arity = Rep0Arity++ from x = M1 (case x of+ NoArity -> L1 (M1 U1)+ Arity a -> R1 (M1 (M1 (K1 a))))++ to (M1 x) = case x of+ L1 (M1 U1) -> NoArity+ R1 (M1 (M1 (K1 a))) -> Arity a++data D1Arity+data C1_0Arity+data C1_1Arity++instance Datatype D1Arity where+ datatypeName _ = "Arity"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Arity where+ conName _ = "NoArity"++instance Constructor C1_1Arity where+ conName _ = "Arity"++-----++type Rep0Associativity = D1 D1Associativity (C1 C1_0Associativity U1+ :+: (C1 C1_1Associativity U1+ :+: C1 C1_2Associativity U1))++instance Generic Associativity where+ type Rep Associativity = Rep0Associativity++ from x = M1 (case x of+ LeftAssociative -> L1 (M1 U1)+ RightAssociative -> R1 (L1 (M1 U1))+ NotAssociative -> R1 (R1 (M1 U1)))++ to (M1 x) = case x of+ L1 (M1 U1) -> LeftAssociative+ R1 (L1 (M1 U1)) -> RightAssociative+ R1 (R1 (M1 U1)) -> NotAssociative++data D1Associativity+data C1_0Associativity+data C1_1Associativity+data C1_2Associativity++instance Datatype D1Associativity where+ datatypeName _ = "Associativity"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Associativity where+ conName _ = "LeftAssociative"++instance Constructor C1_1Associativity where+ conName _ = "RightAssociative"++instance Constructor C1_2Associativity where+ conName _ = "NotAssociative"++-----++type Rep0Const a b = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a)))+type Rep1Const a = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a)))++instance Generic (Const a b) where+ type Rep (Const a b) = Rep0Const a b+ from (Const a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = Const a++instance Generic1 (Const a) where+ type Rep1 (Const a) = Rep1Const a+ from1 (Const a) = M1 (M1 (M1 (K1 a)))+ to1 (M1 (M1 (M1 (K1 a)))) = Const a++data D1Const+data C1_0Const+data S1_0_0Const++instance Datatype D1Const where+ datatypeName _ = "Const"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0Const where+ conName _ = "Const"+ conIsRecord _ = True++instance Selector S1_0_0Const where+ selName _ = "getConst"++-----++type Rep0Dual a = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual (Rec0 a)))+type Rep1Dual = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual Par1))++instance Generic (Dual a) where+ type Rep (Dual a) = Rep0Dual a+ from (Dual d) = M1 (M1 (M1 (K1 d)))+ to (M1 (M1 (M1 (K1 d)))) = Dual d++instance Generic1 Dual where+ type Rep1 Dual = Rep1Dual+ from1 (Dual d) = M1 (M1 (M1 (Par1 d)))+ to1 (M1 (M1 (M1 (Par1 d)))) = Dual d++data D1Dual+data C1_0Dual+data S1_0_0Dual++instance Datatype D1Dual where+ datatypeName _ = "Dual"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Dual where+ conName _ = "Dual"+ conIsRecord _ = True++instance Selector S1_0_0Dual where+ selName _ = "getDual"++-----++type Rep0Endo a = D1 D1Endo (C1 C1_0Endo (S1 S1_0_0Endo (Rec0 (a -> a))))++instance Generic (Endo a) where+ type Rep (Endo a) = Rep0Endo a+ from (Endo e) = M1 (M1 (M1 (K1 e)))+ to (M1 (M1 (M1 (K1 e)))) = Endo e++data D1Endo+data C1_0Endo+data S1_0_0Endo++instance Datatype D1Endo where+ datatypeName _ = "Endo"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Endo where+ conName _ = "Endo"+ conIsRecord _ = True++instance Selector S1_0_0Endo where+ selName _ = "appEndo"++-----++type Rep0First a = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec0 (Maybe a))))+type Rep1First = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec1 Maybe)))++instance Generic (First a) where+ type Rep (First a) = Rep0First a+ from (First f) = M1 (M1 (M1 (K1 f)))+ to (M1 (M1 (M1 (K1 f)))) = First f++instance Generic1 First where+ type Rep1 First = Rep1First+ from1 (First f) = M1 (M1 (M1 (Rec1 f)))+ to1 (M1 (M1 (M1 (Rec1 f)))) = First f++data D1First+data C1_0First+data S1_0_0First++instance Datatype D1First where+ datatypeName _ = "First"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0First where+ conName _ = "First"+ conIsRecord _ = True++instance Selector S1_0_0First where+ selName _ = "getFirst"++-----++type Rep0Fixity = D1 D1Fixity (C1 C1_0Fixity U1+ :+: C1 C1_1Fixity (S1 NoSelector (Rec0 Associativity)+ :*: S1 NoSelector (Rec0 Int)))++instance Generic Fixity where+ type Rep Fixity = Rep0Fixity++ from x = M1 (case x of+ Prefix -> L1 (M1 U1)+ Infix a i -> R1 (M1 (M1 (K1 a) :*: M1 (K1 i))))++ to (M1 x) = case x of+ L1 (M1 U1) -> Prefix+ R1 (M1 (M1 (K1 a) :*: M1 (K1 i))) -> Infix a i++data D1Fixity+data C1_0Fixity+data C1_1Fixity++instance Datatype D1Fixity where+ datatypeName _ = "Fixity"+# if !(MIN_VERSION_base(4,4,0))+ moduleName _ = "Generics.Deriving.Base.Internal"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Fixity where+ conName _ = "Prefix"++instance Constructor C1_1Fixity where+ conName _ = "Infix"++-----++type Rep0Last a = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec0 (Maybe a))))+type Rep1Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec1 Maybe)))++instance Generic (Last a) where+ type Rep (Last a) = Rep0Last a+ from (Last l) = M1 (M1 (M1 (K1 l)))+ to (M1 (M1 (M1 (K1 l)))) = Last l++instance Generic1 Last where+ type Rep1 Last = Rep1Last+ from1 (Last l) = M1 (M1 (M1 (Rec1 l)))+ to1 (M1 (M1 (M1 (Rec1 l)))) = Last l++data D1Last+data C1_0Last+data S1_0_0Last++instance Datatype D1Last where+ datatypeName _ = "Last"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Last where+ conName _ = "Last"+ conIsRecord _ = True++instance Selector S1_0_0Last where+ selName _ = "getLast"++-----++type Rep0Product a = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product (Rec0 a)))+type Rep1Product = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product Par1))++instance Generic (Product a) where+ type Rep (Product a) = Rep0Product a+ from (Product p) = M1 (M1 (M1 (K1 p)))+ to (M1 (M1 (M1 (K1 p)))) = Product p++instance Generic1 Product where+ type Rep1 Product = Rep1Product+ from1 (Product p) = M1 (M1 (M1 (Par1 p)))+ to1 (M1 (M1 (M1 (Par1 p)))) = Product p++data D1Product+data C1_0Product+data S1_0_0Product++instance Datatype D1Product where+ datatypeName _ = "Product"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Product where+ conName _ = "Product"+ conIsRecord _ = True++instance Selector S1_0_0Product where+ selName _ = "getProduct"++-----++type Rep0Sum a = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum (Rec0 a)))+type Rep1Sum = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum Par1))++instance Generic (Sum a) where+ type Rep (Sum a) = Rep0Sum a+ from (Sum s) = M1 (M1 (M1 (K1 s)))+ to (M1 (M1 (M1 (K1 s)))) = Sum s++instance Generic1 Sum where+ type Rep1 Sum = Rep1Sum+ from1 (Sum s) = M1 (M1 (M1 (Par1 s)))+ to1 (M1 (M1 (M1 (Par1 s)))) = Sum s++data D1Sum+data C1_0Sum+data S1_0_0Sum++instance Datatype D1Sum where+ datatypeName _ = "Sum"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Sum where+ conName _ = "Sum"+ conIsRecord _ = True++instance Selector S1_0_0Sum where+ selName _ = "getSum"++-----++type Rep0WrappedArrow a b c =+ D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec0 (a b c))))+type Rep1WrappedArrow a b =+ D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec1 (a b))))++instance Generic (WrappedArrow a b c) where+ type Rep (WrappedArrow a b c) = Rep0WrappedArrow a b c+ from (WrapArrow a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = WrapArrow a++instance Generic1 (WrappedArrow a b) where+ type Rep1 (WrappedArrow a b) = Rep1WrappedArrow a b+ from1 (WrapArrow a) = M1 (M1 (M1 (Rec1 a)))+ to1 (M1 (M1 (M1 (Rec1 a)))) = WrapArrow a++data D1WrappedArrow+data C1_0WrappedArrow+data S1_0_0WrappedArrow++instance Datatype D1WrappedArrow where+ datatypeName _ = "WrappedArrow"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0WrappedArrow where+ conName _ = "WrapArrow"+ conIsRecord _ = True++instance Selector S1_0_0WrappedArrow where+ selName _ = "unwrapArrow"++-----++type Rep0WrappedMonad m a =+ D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec0 (m a))))+type Rep1WrappedMonad m =+ D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec1 m)))++instance Generic (WrappedMonad m a) where+ type Rep (WrappedMonad m a) = Rep0WrappedMonad m a+ from (WrapMonad m) = M1 (M1 (M1 (K1 m)))+ to (M1 (M1 (M1 (K1 m)))) = WrapMonad m++instance Generic1 (WrappedMonad m) where+ type Rep1 (WrappedMonad m) = Rep1WrappedMonad m+ from1 (WrapMonad m) = M1 (M1 (M1 (Rec1 m)))+ to1 (M1 (M1 (M1 (Rec1 m)))) = WrapMonad m++data D1WrappedMonad+data C1_0WrappedMonad+data S1_0_0WrappedMonad++instance Datatype D1WrappedMonad where+ datatypeName _ = "WrappedMonad"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0WrappedMonad where+ conName _ = "WrapMonad"+ conIsRecord _ = True++instance Selector S1_0_0WrappedMonad where+ selName _ = "unwrapMonad"++-----++type Rep0ZipList a = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec0 [a])))+type Rep1ZipList = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec1 [])))++instance Generic (ZipList a) where+ type Rep (ZipList a) = Rep0ZipList a+ from (ZipList z) = M1 (M1 (M1 (K1 z)))+ to (M1 (M1 (M1 (K1 z)))) = ZipList z++instance Generic1 ZipList where+ type Rep1 ZipList = Rep1ZipList+ from1 (ZipList z) = M1 (M1 (M1 (Rec1 z)))+ to1 (M1 (M1 (M1 (Rec1 z)))) = ZipList z++data D1ZipList+data C1_0ZipList+data S1_0_0ZipList++instance Datatype D1ZipList where+ datatypeName _ = "ZipList"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0ZipList where+ conName _ = "ZipList"+ conIsRecord _ = True++instance Selector S1_0_0ZipList where+ selName _ = "getZipList"++-----++type Rep0U1 p = D1 D1U1 (C1 C1_0U1 U1)++instance Generic (U1 p) where+ type Rep (U1 p) = Rep0U1 p+ from U1 = M1 (M1 U1)+ to (M1 (M1 U1)) = U1++-----++type Rep0Par1 p = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 (Rec0 p)))++instance Generic (Par1 p) where+ type Rep (Par1 p) = Rep0Par1 p+ from (Par1 p) = M1 (M1 (M1 (K1 p)))+ to (M1 (M1 (M1 (K1 p)))) = Par1 p++-----++type Rep0Rec1 f p = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec0 (f p))))++instance Generic (Rec1 f p) where+ type Rep (Rec1 f p) = Rep0Rec1 f p+ from (Rec1 r) = M1 (M1 (M1 (K1 r)))+ to (M1 (M1 (M1 (K1 r)))) = Rec1 r++-----++type Rep0K1 i c p = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c)))++instance Generic (K1 i c p) where+ type Rep (K1 i c p) = Rep0K1 i c p+ from (K1 c) = M1 (M1 (M1 (K1 c)))+ to (M1 (M1 (M1 (K1 c)))) = K1 c++-----++type Rep0M1 i c f p = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec0 (f p))))++instance Generic (M1 i c f p) where+ type Rep (M1 i c f p) = Rep0M1 i c f p+ from (M1 m) = M1 (M1 (M1 (K1 m)))+ to (M1 (M1 (M1 (K1 m)))) = M1 m++-----++type Rep0ConSum f g p = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec0 (f p)))+ :+: C1 C1_1ConSum (S1 NoSelector (Rec0 (g p))))++instance Generic ((f :+: g) p) where+ type Rep ((f :+: g) p) = Rep0ConSum f g p++ from x = M1 (case x of+ L1 l -> L1 (M1 (M1 (K1 l)))+ R1 r -> R1 (M1 (M1 (K1 r))))++ to (M1 x) = case x of+ L1 (M1 (M1 (K1 l))) -> L1 l+ R1 (M1 (M1 (K1 r))) -> R1 r++-----++type Rep0ConProduct f g p =+ D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec0 (f p))+ :*: S1 NoSelector (Rec0 (g p))))++instance Generic ((f :*: g) p) where+ type Rep ((f :*: g) p) = Rep0ConProduct f g p+ from (f :*: g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))+ to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = f :*: g++-----++type Rep0ConCompose f g p =+ D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (Rec0 (f (g p)))))++instance Generic ((f :.: g) p) where+ type Rep ((f :.: g) p) = Rep0ConCompose f g p+ from (Comp1 c) = M1 (M1 (M1 (K1 c)))+ to (M1 (M1 (M1 (K1 c)))) = Comp1 c+#endif++-----++#if !(MIN_VERSION_base(4,6,0))+type Rep1List = D1 D1List (C1 C1_0List U1 :+:+ C1 C1_1List (S1 NoSelector Par1+ :*: S1 NoSelector (Rec1 [])))++instance Generic1 [] where+ type Rep1 [] = Rep1List++ from1 x = M1 (case x of+ [] -> L1 (M1 U1)+ h:t -> R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))))++ to1 (M1 x) = case x of+ L1 (M1 U1) -> []+ R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))) -> h : t++data D1List+data C1_0List+data C1_1List++instance Datatype D1List where+ datatypeName _ = "[]"+ moduleName _ = "GHC.Types"++instance Constructor C1_0List where+ conName _ = "[]"++instance Constructor C1_1List where+ conName _ = ":"+ conFixity _ = Infix RightAssociative 5++-----++type Rep1Either a = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a))+ :+: C1 C1_1Either (S1 NoSelector Par1))++instance Generic1 (Either a) where+ type Rep1 (Either a) = Rep1Either a++ from1 x = M1 (case x of+ Left l -> L1 (M1 (M1 (K1 l)))+ Right r -> R1 (M1 (M1 (Par1 r))))++ to1 (M1 x) = case x of+ L1 (M1 (M1 (K1 l))) -> Left l+ R1 (M1 (M1 (Par1 r))) -> Right r++data D1Either+data C1_0Either+data C1_1Either++instance Datatype D1Either where+ datatypeName _ = "Either"+ moduleName _ = "Data.Either"++instance Constructor C1_0Either where+ conName _ = "Left"++instance Constructor C1_1Either where+ conName _ = "Right"++-----++type Rep1Maybe = D1 D1Maybe (C1 C1_0Maybe U1+ :+: C1 C1_1Maybe (S1 NoSelector Par1))++instance Generic1 Maybe where+ type Rep1 Maybe = Rep1Maybe++ from1 x = M1 (case x of+ Nothing -> L1 (M1 U1)+ Just j -> R1 (M1 (M1 (Par1 j))))++ to1 (M1 x) = case x of+ L1 (M1 U1) -> Nothing+ R1 (M1 (M1 (Par1 j))) -> Just j++data D1Maybe+data C1_0Maybe+data C1_1Maybe++instance Datatype D1Maybe where+ datatypeName _ = "Maybe"+ -- As of base-4.7.0.0, Maybe is actually located in GHC.Base.+ -- We don't need to worry about this for the versions of base+ -- that this instance is defined for, however.+ moduleName _ = "Data.Maybe"++instance Constructor C1_0Maybe where+ conName _ = "Nothing"++instance Constructor C1_1Maybe where+ conName _ = "Just"++-----++type Rep1Tuple2 a = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector Par1))++instance Generic1 ((,) a) where+ type Rep1 ((,) a) = Rep1Tuple2 a+ from1 (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))+ to1 (M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))) = (a, b)++data D1Tuple2+data C1_0Tuple2++instance Datatype D1Tuple2 where+ datatypeName _ = "(,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple2 where+ conName _ = "(,)"++-----++type Rep1Tuple3 a b = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector Par1)))++instance Generic1 ((,,) a b) where+ type Rep1 ((,,) a b) = Rep1Tuple3 a b+ from1 (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))+ to1 (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))) = (a, b, c)++data D1Tuple3+data C1_0Tuple3++instance Datatype D1Tuple3 where+ datatypeName _ = "(,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple3 where+ conName _ = "(,,)"++-----++type Rep1Tuple4 a b c = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: S1 NoSelector Par1)))++instance Generic1 ((,,,) a b c) where+ type Rep1 ((,,,) a b c) = Rep1Tuple4 a b c++ from1 (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (Par1 d))))++ to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (Par1 d)))))+ = (a, b, c, d)++data D1Tuple4+data C1_0Tuple4++instance Datatype D1Tuple4 where+ datatypeName _ = "(,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple4 where+ conName _ = "(,,,)"++-----++type Rep1Tuple5 a b c d = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: (S1 NoSelector (Rec0 d)+ :*: S1 NoSelector Par1))))++instance Generic1 ((,,,,) a b c d) where+ type Rep1 ((,,,,) a b c d) = Rep1Tuple5 a b c d++ from1 (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e)))))++ to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e))))))+ = (a, b, c, d, e)++data D1Tuple5+data C1_0Tuple5++instance Datatype D1Tuple5 where+ datatypeName _ = "(,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple5 where+ conName _ = "(,,,,)"++-----++type Rep1Tuple6 a b c d e =+ D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: (S1 NoSelector (Rec0 d)+ :*: (S1 NoSelector (Rec0 e)+ :*: S1 NoSelector Par1))))++instance Generic1 ((,,,,,) a b c d e) where+ type Rep1 ((,,,,,) a b c d e) = Rep1Tuple6 a b c d e++ from1 (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f)))))++ to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f))))))+ = (a, b, c, d, e, f)++data D1Tuple6+data C1_0Tuple6++instance Datatype D1Tuple6 where+ datatypeName _ = "(,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple6 where+ conName _ = "(,,,,,)"++-----++type Rep1Tuple7 a b c d e f =+ D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: ((S1 NoSelector (Rec0 d)+ :*: S1 NoSelector (Rec0 e))+ :*: (S1 NoSelector (Rec0 f)+ :*: S1 NoSelector Par1))))++instance Generic1 ((,,,,,,) a b c d e f) where+ type Rep1 ((,,,,,,) a b c d e f) = Rep1Tuple7 a b c d e f++ from1 (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g)))))++ to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g))))))+ = (a, b, c, d, e, f, g)++data D1Tuple7+data C1_0Tuple7++instance Datatype D1Tuple7 where+ datatypeName _ = "(,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple7 where+ conName _ = "(,,,,,,)"+#endif++-----++#if !(MIN_VERSION_base(4,4,0))+type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1)++instance Generic Bool where+ type Rep Bool = Rep0Bool++ from x = M1 (case x of+ False -> L1 (M1 U1)+ True -> R1 (M1 U1))++ to (M1 x) = case x of+ L1 (M1 U1) -> False+ R1 (M1 U1) -> True++data D1Bool+data C1_0Bool+data C1_1Bool++instance Datatype D1Bool where+ datatypeName _ = "Bool"+ moduleName _ = "GHC.Bool"++instance Constructor C1_0Bool where+ conName _ = "False"++instance Constructor C1_1Bool where+ conName _ = "True"++-----++data D_Char+data C_Char++instance Datatype D_Char where+ datatypeName _ = "Char"+ moduleName _ = "GHC.Base"++instance Constructor C_Char where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char)))++instance Generic Char where+ type Rep Char = Rep0Char+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++data D_Double+data C_Double++instance Datatype D_Double where+ datatypeName _ = "Double"+ moduleName _ = "GHC.Float"++instance Constructor C_Double where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double)))++instance Generic Double where+ type Rep Double = Rep0Double+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++type Rep0Either a b = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a))+ :+: C1 C1_1Either (S1 NoSelector (Rec0 b)))++instance Generic (Either a b) where+ type Rep (Either a b) = Rep0Either a b++ from x = M1 (case x of+ Left l -> L1 (M1 (M1 (K1 l)))+ Right r -> R1 (M1 (M1 (K1 r))))++ to (M1 x) = case x of+ L1 (M1 (M1 (K1 l))) -> Left l+ R1 (M1 (M1 (K1 r))) -> Right r++-----++data D_Int+data C_Int++instance Datatype D_Int where+ datatypeName _ = "Int"+ moduleName _ = "GHC.Int"++instance Constructor C_Int where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int)))++instance Generic Int where+ type Rep Int = Rep0Int+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++data D_Float+data C_Float++instance Datatype D_Float where+ datatypeName _ = "Float"+ moduleName _ = "GHC.Float"++instance Constructor C_Float where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float)))++instance Generic Float where+ type Rep Float = Rep0Float+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++type Rep0List a =+ D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 [a])))++instance Generic [a] where+ type Rep [a] = Rep0List a++ from x = M1 (case x of+ [] -> L1 (M1 U1)+ h:t -> R1 (M1 (M1 (K1 h) :*: M1 (K1 t))))++ to (M1 x) = case x of+ L1 (M1 U1) -> []+ R1 (M1 (M1 (K1 h) :*: M1 (K1 t))) -> h : t++-----++type Rep0Maybe a = D1 D1Maybe (C1 C1_0Maybe U1+ :+: C1 C1_1Maybe (S1 NoSelector (Rec0 a)))++instance Generic (Maybe a) where+ type Rep (Maybe a) = Rep0Maybe a++ from x = M1 (case x of+ Nothing -> L1 (M1 U1)+ Just j -> R1 (M1 (M1 (K1 j))))++ to (M1 x) = case x of+ L1 (M1 U1) -> Nothing+ R1 (M1 (M1 (K1 j))) -> Just j++-----++type Rep0Ordering = D1 D1Ordering (C1 C1_0Ordering U1+ :+: (C1 C1_1Ordering U1 :+: C1 C1_2Ordering U1))++instance Generic Ordering where+ type Rep Ordering = Rep0Ordering++ from x = M1 (case x of+ LT -> L1 (M1 U1)+ EQ -> R1 (L1 (M1 U1))+ GT -> R1 (R1 (M1 U1)))++ to (M1 x) = case x of+ L1 (M1 U1) -> LT+ R1 (L1 (M1 U1)) -> EQ+ R1 (R1 (M1 U1)) -> GT++data D1Ordering+data C1_0Ordering+data C1_1Ordering+data C1_2Ordering++instance Datatype D1Ordering where+ datatypeName _ = "Ordering"+ moduleName _ = "GHC.Ordering"++instance Constructor C1_0Ordering where+ conName _ = "LT"++instance Constructor C1_1Ordering where+ conName _ = "EQ"++instance Constructor C1_2Ordering where+ conName _ = "GT"++-----++type Rep0Unit = D1 D1Unit (C1 C1_0Unit U1)++instance Generic () where+ type Rep () = Rep0Unit+ from () = M1 (M1 U1)+ to (M1 (M1 U1)) = ()++data D1Unit+data C1_0Unit++instance Datatype D1Unit where+ datatypeName _ = "()"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Unit where+ conName _ = "()"++-----++type Rep0Tuple2 a b = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b)))++instance Generic (a, b) where+ type Rep (a, b) = Rep0Tuple2 a b+ from (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))+ to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = (a, b)++-----++type Rep0Tuple3 a b c = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c))))++instance Generic (a, b, c) where+ type Rep (a, b, c) = Rep0Tuple3 a b c+ from (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))+ to (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))) = (a, b, c)++-----++type Rep0Tuple4 a b c d = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: S1 NoSelector (Rec0 d))))++instance Generic (a, b, c, d) where+ type Rep (a, b, c, d) = Rep0Tuple4 a b c d++ from (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (K1 d))))++ to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (K1 d)))))+ = (a, b, c, d)++-----++type Rep0Tuple5 a b c d e = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: (S1 NoSelector (Rec0 d)+ :*: S1 NoSelector (Rec0 e)))))++instance Generic (a, b, c, d, e) where+ type Rep (a, b, c, d, e) = Rep0Tuple5 a b c d e++ from (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e)))))++ to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e))))))+ = (a, b, c, d, e)++-----++type Rep0Tuple6 a b c d e f = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: (S1 NoSelector (Rec0 d)+ :*: (S1 NoSelector (Rec0 e)+ :*: S1 NoSelector (Rec0 f)))))++instance Generic (a, b, c, d, e, f) where+ type Rep (a, b, c, d, e, f) = Rep0Tuple6 a b c d e f++ from (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f)))))++ to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f))))))+ = (a, b, c, d, e, f)++-----++type Rep0Tuple7 a b c d e f g+ = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: ((S1 NoSelector (Rec0 d)+ :*: S1 NoSelector (Rec0 e))+ :*: (S1 NoSelector (Rec0 f)+ :*: S1 NoSelector (Rec0 g)))))++instance Generic (a, b, c, d, e, f, g) where+ type Rep (a, b, c, d, e, f, g) = Rep0Tuple7 a b c d e f g++ from (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g)))))++ to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g))))))+ = (a, b, c, d, e, f, g)++#endif
src/Generics/Deriving/Monoid.hs view
@@ -1,27 +1,27 @@-{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Monoid (module Generics.Deriving.Monoid.Internal) where - -import Generics.Deriving.Monoid.Internal -import Generics.Deriving.Semigroup (GSemigroup(..)) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (WrappedMonoid) -#endif - -instance GSemigroup a => GMonoid (Maybe a) where - gmempty = Nothing - gmappend = gsappend - -#if MIN_VERSION_base(4,9,0) -instance GMonoid m => GMonoid (WrappedMonoid m) where - gmempty = gmemptydefault - gmappend = gmappenddefault -#endif +{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Monoid (module Generics.Deriving.Monoid.Internal) where++import Generics.Deriving.Monoid.Internal+import Generics.Deriving.Semigroup (GSemigroup(..))++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (WrappedMonoid)+#endif++instance GSemigroup a => GMonoid (Maybe a) where+ gmempty = Nothing+ gmappend = gsappend++#if MIN_VERSION_base(4,9,0)+instance GMonoid m => GMonoid (WrappedMonoid m) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+#endif
src/Generics/Deriving/Monoid/Internal.hs view
@@ -1,276 +1,276 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Monoid.Internal ( - - -- * Introduction - {- | This module provides two main features: - - 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances - of the types from "Data.Monoid" - - 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend' - - The generic defaults only work for types without alternatives (i.e. they have - only one constructor). We cannot in general know how to deal with different - constructors. - -} - - -- * GMonoid type class - GMonoid(..), - - -- * Default definitions - -- ** GMonoid - gmemptydefault, - gmappenddefault, - - -- * Internal auxiliary class for GMonoid - GMonoid'(..), - - -- ** Monoid - {- | These functions can be used in a 'Monoid' instance. For example: - - @ - -- LANGUAGE DeriveGeneric - - import Generics.Deriving.Base (Generic) - import Generics.Deriving.Monoid - - data T a = C a (Maybe a) deriving Generic - - instance Monoid a => Monoid (T a) where - mempty = memptydefault - mappend = mappenddefault - @ - -} - memptydefault, - mappenddefault, - - -- * Internal auxiliary class for Monoid - Monoid'(..), - - -- * The Monoid module - -- | This is exported for convenient access to the various wrapper types. - module Data.Monoid, - - ) where - --------------------------------------------------------------------------------- - -import Control.Applicative -import Data.Monoid -import Generics.Deriving.Base -import Generics.Deriving.Semigroup.Internal - -#if MIN_VERSION_base(4,6,0) -import Data.Ord (Down) -#else -import GHC.Exts (Down) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - --------------------------------------------------------------------------------- - -class GSemigroup' f => GMonoid' f where - gmempty' :: f x - gmappend' :: f x -> f x -> f x - -instance GMonoid' U1 where - gmempty' = U1 - gmappend' U1 U1 = U1 - -instance GMonoid a => GMonoid' (K1 i a) where - gmempty' = K1 gmempty - gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y) - -instance GMonoid' f => GMonoid' (M1 i c f) where - gmempty' = M1 gmempty' - gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y) - -instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where - gmempty' = gmempty' :*: gmempty' - gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2 - --------------------------------------------------------------------------------- - -gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a -gmemptydefault = to gmempty' - -gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a -gmappenddefault x y = to (gmappend' (from x) (from y)) - --------------------------------------------------------------------------------- - -class Monoid' f where - mempty' :: f x - mappend' :: f x -> f x -> f x - -instance Monoid' U1 where - mempty' = U1 - mappend' U1 U1 = U1 - -instance Monoid a => Monoid' (K1 i a) where - mempty' = K1 mempty - mappend' (K1 x) (K1 y) = K1 (x `mappend` y) - -instance Monoid' f => Monoid' (M1 i c f) where - mempty' = M1 mempty' - mappend' (M1 x) (M1 y) = M1 (x `mappend'` y) - -instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where - mempty' = mempty' :*: mempty' - mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2 - --------------------------------------------------------------------------------- - -memptydefault :: (Generic a, Monoid' (Rep a)) => a -memptydefault = to mempty' - -mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a -mappenddefault x y = to (mappend' (from x) (from y)) - --------------------------------------------------------------------------------- - -class GSemigroup a => GMonoid a where - - -- | Generic 'mempty' - gmempty :: a - - -- | Generic 'mappend' - gmappend :: a -> a -> a - - -- | Generic 'mconcat' - gmconcat :: [a] -> a - gmconcat = foldr gmappend gmempty - -#if __GLASGOW_HASKELL__ >= 701 - default gmempty :: (Generic a, GMonoid' (Rep a)) => a - gmempty = to gmempty' - - default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a - gmappend x y = to (gmappend' (from x) (from y)) -#endif - --------------------------------------------------------------------------------- - --- Instances that reuse Monoid -instance GMonoid Ordering where - gmempty = mempty - gmappend = mappend -instance GMonoid () where - gmempty = mempty - gmappend = mappend -instance GMonoid Any where - gmempty = mempty - gmappend = mappend -instance GMonoid All where - gmempty = mempty - gmappend = mappend -instance GMonoid (First a) where - gmempty = mempty - gmappend = mappend -instance GMonoid (Last a) where - gmempty = mempty - gmappend = mappend -instance Num a => GMonoid (Sum a) where - gmempty = mempty - gmappend = mappend -instance Num a => GMonoid (Product a) where - gmempty = mempty - gmappend = mappend -instance GMonoid [a] where - gmempty = mempty - gmappend = mappend -instance GMonoid (Endo a) where - gmempty = mempty - gmappend = mappend -#if MIN_VERSION_base(4,8,0) -instance Alternative f => GMonoid (Alt f a) where - gmempty = mempty - gmappend = mappend -#endif - --- Handwritten instances -instance GMonoid a => GMonoid (Dual a) where - gmempty = Dual gmempty - gmappend (Dual x) (Dual y) = Dual (gmappend y x) -instance GMonoid b => GMonoid (a -> b) where - gmempty _ = gmempty - gmappend f g x = gmappend (f x) (g x) -instance GMonoid a => GMonoid (Const a b) where - gmempty = gmemptydefault - gmappend = gmappenddefault -instance GMonoid a => GMonoid (Down a) where - gmempty = gmemptydefault - gmappend = gmappenddefault - -#if MIN_VERSION_base(4,7,0) -instance GMonoid -# if MIN_VERSION_base(4,9,0) - (Proxy s) -# else - (Proxy (s :: *)) -# endif - where - gmempty = memptydefault - gmappend = mappenddefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GMonoid a => GMonoid (Identity a) where - gmempty = gmemptydefault - gmappend = gmappenddefault -#endif - --- Tuple instances -instance (GMonoid a,GMonoid b) => GMonoid (a,b) where - gmempty = (gmempty,gmempty) - gmappend (a1,b1) (a2,b2) = - (gmappend a1 a2,gmappend b1 b2) -instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where - gmempty = (gmempty,gmempty,gmempty) - gmappend (a1,b1,c1) (a2,b2,c2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where - gmempty = (gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2) +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Monoid.Internal (++ -- * Introduction+ {- | This module provides two main features:++ 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances+ of the types from "Data.Monoid"++ 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend'++ The generic defaults only work for types without alternatives (i.e. they have+ only one constructor). We cannot in general know how to deal with different+ constructors.+ -}++ -- * GMonoid type class+ GMonoid(..),++ -- * Default definitions+ -- ** GMonoid+ gmemptydefault,+ gmappenddefault,++ -- * Internal auxiliary class for GMonoid+ GMonoid'(..),++ -- ** Monoid+ {- | These functions can be used in a 'Monoid' instance. For example:++ @+ -- LANGUAGE DeriveGeneric++ import Generics.Deriving.Base (Generic)+ import Generics.Deriving.Monoid++ data T a = C a (Maybe a) deriving Generic++ instance Monoid a => Monoid (T a) where+ mempty = memptydefault+ mappend = mappenddefault+ @+ -}+ memptydefault,+ mappenddefault,++ -- * Internal auxiliary class for Monoid+ Monoid'(..),++ -- * The Monoid module+ -- | This is exported for convenient access to the various wrapper types.+ module Data.Monoid,++ ) where++--------------------------------------------------------------------------------++import Control.Applicative+import Data.Monoid+import Generics.Deriving.Base+import Generics.Deriving.Semigroup.Internal++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++--------------------------------------------------------------------------------++class GSemigroup' f => GMonoid' f where+ gmempty' :: f x+ gmappend' :: f x -> f x -> f x++instance GMonoid' U1 where+ gmempty' = U1+ gmappend' U1 U1 = U1++instance GMonoid a => GMonoid' (K1 i a) where+ gmempty' = K1 gmempty+ gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y)++instance GMonoid' f => GMonoid' (M1 i c f) where+ gmempty' = M1 gmempty'+ gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y)++instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where+ gmempty' = gmempty' :*: gmempty'+ gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2++--------------------------------------------------------------------------------++gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a+gmemptydefault = to gmempty'++gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a+gmappenddefault x y = to (gmappend' (from x) (from y))++--------------------------------------------------------------------------------++class Monoid' f where+ mempty' :: f x+ mappend' :: f x -> f x -> f x++instance Monoid' U1 where+ mempty' = U1+ mappend' U1 U1 = U1++instance Monoid a => Monoid' (K1 i a) where+ mempty' = K1 mempty+ mappend' (K1 x) (K1 y) = K1 (x `mappend` y)++instance Monoid' f => Monoid' (M1 i c f) where+ mempty' = M1 mempty'+ mappend' (M1 x) (M1 y) = M1 (x `mappend'` y)++instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where+ mempty' = mempty' :*: mempty'+ mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2++--------------------------------------------------------------------------------++memptydefault :: (Generic a, Monoid' (Rep a)) => a+memptydefault = to mempty'++mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a+mappenddefault x y = to (mappend' (from x) (from y))++--------------------------------------------------------------------------------++class GSemigroup a => GMonoid a where++ -- | Generic 'mempty'+ gmempty :: a++ -- | Generic 'mappend'+ gmappend :: a -> a -> a++ -- | Generic 'mconcat'+ gmconcat :: [a] -> a+ gmconcat = foldr gmappend gmempty++#if __GLASGOW_HASKELL__ >= 701+ default gmempty :: (Generic a, GMonoid' (Rep a)) => a+ gmempty = to gmempty'++ default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a+ gmappend x y = to (gmappend' (from x) (from y))+#endif++--------------------------------------------------------------------------------++-- Instances that reuse Monoid+instance GMonoid Ordering where+ gmempty = mempty+ gmappend = mappend+instance GMonoid () where+ gmempty = mempty+ gmappend = mappend+instance GMonoid Any where+ gmempty = mempty+ gmappend = mappend+instance GMonoid All where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (First a) where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (Last a) where+ gmempty = mempty+ gmappend = mappend+instance Num a => GMonoid (Sum a) where+ gmempty = mempty+ gmappend = mappend+instance Num a => GMonoid (Product a) where+ gmempty = mempty+ gmappend = mappend+instance GMonoid [a] where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (Endo a) where+ gmempty = mempty+ gmappend = mappend+#if MIN_VERSION_base(4,8,0)+instance Alternative f => GMonoid (Alt f a) where+ gmempty = mempty+ gmappend = mappend+#endif++-- Handwritten instances+instance GMonoid a => GMonoid (Dual a) where+ gmempty = Dual gmempty+ gmappend (Dual x) (Dual y) = Dual (gmappend y x)+instance GMonoid b => GMonoid (a -> b) where+ gmempty _ = gmempty+ gmappend f g x = gmappend (f x) (g x)+instance GMonoid a => GMonoid (Const a b) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+instance GMonoid a => GMonoid (Down a) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault++#if MIN_VERSION_base(4,7,0)+instance GMonoid+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ gmempty = memptydefault+ gmappend = mappenddefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GMonoid a => GMonoid (Identity a) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+#endif++-- Tuple instances+instance (GMonoid a,GMonoid b) => GMonoid (a,b) where+ gmempty = (gmempty,gmempty)+ gmappend (a1,b1) (a2,b2) =+ (gmappend a1 a2,gmappend b1 b2)+instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where+ gmempty = (gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1) (a2,b2,c2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where+ gmempty = (gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2)
src/Generics/Deriving/Semigroup.hs view
@@ -1,20 +1,20 @@-{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -#if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Semigroup (module Generics.Deriving.Semigroup.Internal) where - -import Generics.Deriving.Semigroup.Internal - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (WrappedMonoid(..)) -import Generics.Deriving.Monoid.Internal (GMonoid(..)) - -instance GMonoid m => GSemigroup (WrappedMonoid m) where - gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b) -#endif +{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Semigroup (module Generics.Deriving.Semigroup.Internal) where++import Generics.Deriving.Semigroup.Internal++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (WrappedMonoid(..))+import Generics.Deriving.Monoid.Internal (GMonoid(..))++instance GMonoid m => GSemigroup (WrappedMonoid m) where+ gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b)+#endif
src/Generics/Deriving/Semigroup/Internal.hs view
@@ -1,215 +1,215 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Semigroup.Internal ( - -- * Generic semigroup class - GSemigroup(..) - - -- * Default definition - , gsappenddefault - - -- * Internal semigroup class - , GSemigroup'(..) - - ) where - -import Control.Applicative -import Data.Monoid as Monoid -#if MIN_VERSION_base(4,5,0) - hiding ((<>)) -#endif -import Generics.Deriving.Base - -#if MIN_VERSION_base(4,6,0) -import Data.Ord (Down) -#else -import GHC.Exts (Down) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Void (Void) -#endif - -#if MIN_VERSION_base(4,9,0) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Semigroup as Semigroup -#endif - -------------------------------------------------------------------------------- - -infixr 6 `gsappend'` -class GSemigroup' f where - gsappend' :: f x -> f x -> f x - -instance GSemigroup' U1 where - gsappend' U1 U1 = U1 - -instance GSemigroup a => GSemigroup' (K1 i a) where - gsappend' (K1 x) (K1 y) = K1 (gsappend x y) - -instance GSemigroup' f => GSemigroup' (M1 i c f) where - gsappend' (M1 x) (M1 y) = M1 (gsappend' x y) - -instance (GSemigroup' f, GSemigroup' g) => GSemigroup' (f :*: g) where - gsappend' (x1 :*: y1) (x2 :*: y2) = gsappend' x1 x2 :*: gsappend' y1 y2 - -------------------------------------------------------------------------------- - -infixr 6 `gsappend` -class GSemigroup a where - gsappend :: a -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a - gsappend = gsappenddefault -#endif - - gstimes :: Integral b => b -> a -> a - gstimes y0 x0 - | y0 <= 0 = error "gstimes: positive multiplier expected" - | otherwise = f x0 y0 - where - f x y - | even y = f (gsappend x x) (y `quot` 2) - | y == 1 = x - | otherwise = g (gsappend x x) (pred y `quot` 2) x - g x y z - | even y = g (gsappend x x) (y `quot` 2) z - | y == 1 = gsappend x z - | otherwise = g (gsappend x x) (pred y `quot` 2) (gsappend x z) - -#if MIN_VERSION_base(4,9,0) - -- | Only available with @base-4.9@ or later - gsconcat :: NonEmpty a -> a - gsconcat (a :| as) = go a as where - go b (c:cs) = gsappend b (go c cs) - go b [] = b -#endif - -infixr 6 `gsappenddefault` -gsappenddefault :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a -gsappenddefault x y = to (gsappend' (from x) (from y)) - -------------------------------------------------------------------------------- - --- Instances that reuse Monoid -instance GSemigroup Ordering where - gsappend = mappend -instance GSemigroup () where - gsappend = mappend -instance GSemigroup Any where - gsappend = mappend -instance GSemigroup All where - gsappend = mappend -instance GSemigroup (Monoid.First a) where - gsappend = mappend -instance GSemigroup (Monoid.Last a) where - gsappend = mappend -instance Num a => GSemigroup (Sum a) where - gsappend = mappend -instance Num a => GSemigroup (Product a) where - gsappend = mappend -instance GSemigroup [a] where - gsappend = mappend -instance GSemigroup (Endo a) where - gsappend = mappend -#if MIN_VERSION_base(4,8,0) -instance Alternative f => GSemigroup (Alt f a) where - gsappend = mappend -#endif - --- Handwritten instances -instance GSemigroup a => GSemigroup (Dual a) where - gsappend (Dual x) (Dual y) = Dual (gsappend y x) -instance GSemigroup a => GSemigroup (Maybe a) where - gsappend Nothing x = x - gsappend x Nothing = x - gsappend (Just x) (Just y) = Just (gsappend x y) -instance GSemigroup b => GSemigroup (a -> b) where - gsappend f g x = gsappend (f x) (g x) -instance GSemigroup a => GSemigroup (Const a b) where - gsappend = gsappenddefault -instance GSemigroup a => GSemigroup (Down a) where - gsappend = gsappenddefault -instance GSemigroup (Either a b) where - gsappend Left{} b = b - gsappend a _ = a - -#if MIN_VERSION_base(4,7,0) -instance GSemigroup -# if MIN_VERSION_base(4,9,0) - (Proxy s) -# else - (Proxy (s :: *)) -# endif - where - gsappend = gsappenddefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GSemigroup a => GSemigroup (Identity a) where - gsappend = gsappenddefault - -instance GSemigroup Void where - gsappend a _ = a -#endif - -#if MIN_VERSION_base(4,9,0) -instance GSemigroup (Semigroup.First a) where - gsappend = (<>) - -instance GSemigroup (Semigroup.Last a) where - gsappend = (<>) - -instance Ord a => GSemigroup (Max a) where - gsappend = (<>) - -instance Ord a => GSemigroup (Min a) where - gsappend = (<>) - -instance GSemigroup (NonEmpty a) where - gsappend = (<>) -#endif - --- Tuple instances -instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where - gsappend (a1,b1) (a2,b2) = - (gsappend a1 a2,gsappend b1 b2) -instance (GSemigroup a,GSemigroup b,GSemigroup c) => GSemigroup (a,b,c) where - gsappend (a1,b1,c1) (a2,b2,c2) = - (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2) -instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d) => GSemigroup (a,b,c,d) where - gsappend (a1,b1,c1,d1) (a2,b2,c2,d2) = - (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2) -instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e) => GSemigroup (a,b,c,d,e) where - gsappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = - (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2) -instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f) => GSemigroup (a,b,c,d,e,f) where - gsappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = - (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2) -instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g) => GSemigroup (a,b,c,d,e,f,g) where - gsappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = - (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2) -instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g,GSemigroup h) => GSemigroup (a,b,c,d,e,f,g,h) where - gsappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = - (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2,gsappend h1 h2) +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Semigroup.Internal (+ -- * Generic semigroup class+ GSemigroup(..)++ -- * Default definition+ , gsappenddefault++ -- * Internal semigroup class+ , GSemigroup'(..)++ ) where++import Control.Applicative+import Data.Monoid as Monoid+#if MIN_VERSION_base(4,5,0)+ hiding ((<>))+#endif+import Generics.Deriving.Base++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Void (Void)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup as Semigroup+#endif++-------------------------------------------------------------------------------++infixr 6 `gsappend'`+class GSemigroup' f where+ gsappend' :: f x -> f x -> f x++instance GSemigroup' U1 where+ gsappend' U1 U1 = U1++instance GSemigroup a => GSemigroup' (K1 i a) where+ gsappend' (K1 x) (K1 y) = K1 (gsappend x y)++instance GSemigroup' f => GSemigroup' (M1 i c f) where+ gsappend' (M1 x) (M1 y) = M1 (gsappend' x y)++instance (GSemigroup' f, GSemigroup' g) => GSemigroup' (f :*: g) where+ gsappend' (x1 :*: y1) (x2 :*: y2) = gsappend' x1 x2 :*: gsappend' y1 y2++-------------------------------------------------------------------------------++infixr 6 `gsappend`+class GSemigroup a where+ gsappend :: a -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a+ gsappend = gsappenddefault+#endif++ gstimes :: Integral b => b -> a -> a+ gstimes y0 x0+ | y0 <= 0 = error "gstimes: positive multiplier expected"+ | otherwise = f x0 y0+ where+ f x y+ | even y = f (gsappend x x) (y `quot` 2)+ | y == 1 = x+ | otherwise = g (gsappend x x) (pred y `quot` 2) x+ g x y z+ | even y = g (gsappend x x) (y `quot` 2) z+ | y == 1 = gsappend x z+ | otherwise = g (gsappend x x) (pred y `quot` 2) (gsappend x z)++#if MIN_VERSION_base(4,9,0)+ -- | Only available with @base-4.9@ or later+ gsconcat :: NonEmpty a -> a+ gsconcat (a :| as) = go a as where+ go b (c:cs) = gsappend b (go c cs)+ go b [] = b+#endif++infixr 6 `gsappenddefault`+gsappenddefault :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a+gsappenddefault x y = to (gsappend' (from x) (from y))++-------------------------------------------------------------------------------++-- Instances that reuse Monoid+instance GSemigroup Ordering where+ gsappend = mappend+instance GSemigroup () where+ gsappend = mappend+instance GSemigroup Any where+ gsappend = mappend+instance GSemigroup All where+ gsappend = mappend+instance GSemigroup (Monoid.First a) where+ gsappend = mappend+instance GSemigroup (Monoid.Last a) where+ gsappend = mappend+instance Num a => GSemigroup (Sum a) where+ gsappend = mappend+instance Num a => GSemigroup (Product a) where+ gsappend = mappend+instance GSemigroup [a] where+ gsappend = mappend+instance GSemigroup (Endo a) where+ gsappend = mappend+#if MIN_VERSION_base(4,8,0)+instance Alternative f => GSemigroup (Alt f a) where+ gsappend = mappend+#endif++-- Handwritten instances+instance GSemigroup a => GSemigroup (Dual a) where+ gsappend (Dual x) (Dual y) = Dual (gsappend y x)+instance GSemigroup a => GSemigroup (Maybe a) where+ gsappend Nothing x = x+ gsappend x Nothing = x+ gsappend (Just x) (Just y) = Just (gsappend x y)+instance GSemigroup b => GSemigroup (a -> b) where+ gsappend f g x = gsappend (f x) (g x)+instance GSemigroup a => GSemigroup (Const a b) where+ gsappend = gsappenddefault+instance GSemigroup a => GSemigroup (Down a) where+ gsappend = gsappenddefault+instance GSemigroup (Either a b) where+ gsappend Left{} b = b+ gsappend a _ = a++#if MIN_VERSION_base(4,7,0)+instance GSemigroup+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ gsappend = gsappenddefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GSemigroup a => GSemigroup (Identity a) where+ gsappend = gsappenddefault++instance GSemigroup Void where+ gsappend a _ = a+#endif++#if MIN_VERSION_base(4,9,0)+instance GSemigroup (Semigroup.First a) where+ gsappend = (<>)++instance GSemigroup (Semigroup.Last a) where+ gsappend = (<>)++instance Ord a => GSemigroup (Max a) where+ gsappend = (<>)++instance Ord a => GSemigroup (Min a) where+ gsappend = (<>)++instance GSemigroup (NonEmpty a) where+ gsappend = (<>)+#endif++-- Tuple instances+instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where+ gsappend (a1,b1) (a2,b2) =+ (gsappend a1 a2,gsappend b1 b2)+instance (GSemigroup a,GSemigroup b,GSemigroup c) => GSemigroup (a,b,c) where+ gsappend (a1,b1,c1) (a2,b2,c2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d) => GSemigroup (a,b,c,d) where+ gsappend (a1,b1,c1,d1) (a2,b2,c2,d2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e) => GSemigroup (a,b,c,d,e) where+ gsappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f) => GSemigroup (a,b,c,d,e,f) where+ gsappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g) => GSemigroup (a,b,c,d,e,f,g) where+ gsappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g,GSemigroup h) => GSemigroup (a,b,c,d,e,f,g,h) where+ gsappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2,gsappend h1 h2)
src/Generics/Deriving/Show.hs view
@@ -1,666 +1,666 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -#endif - -module Generics.Deriving.Show ( - -- * Generic show class - GShow(..) - - -- * Default definition - , gshowsPrecdefault - - -- * Internal show class - , GShow'(..) - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Char (GeneralCategory) -import Data.Int -import Data.Monoid (All, Any, Dual, Product, Sum) -import qualified Data.Monoid as Monoid (First, Last) -import Data.Version (Version) -import Data.Word - -import Foreign.C.Types -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.Ptr - -import Generics.Deriving.Base - -import GHC.Exts hiding (Any) - -import System.Exit (ExitCode) -import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) -import System.IO.Error (IOErrorType) -import System.Posix.Types - -#if MIN_VERSION_base(4,4,0) -import Data.Complex (Complex) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Data.Void (Void) -import Numeric.Natural (Natural) -#endif - -#if MIN_VERSION_base(4,9,0) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Semigroup as Semigroup (First, Last) -import Data.Semigroup (Arg, Max, Min, WrappedMonoid) -#endif - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -intersperse :: a -> [a] -> [a] -intersperse _ [] = [] -intersperse _ [h] = [h] -intersperse x (h:t) = h : x : (intersperse x t) - -appPrec :: Int -appPrec = 2 - -data Type = Rec | Tup | Pref | Inf String - -class GShow' f where - gshowsPrec' :: Type -> Int -> f a -> ShowS - isNullary :: f a -> Bool - isNullary = error "generic show (isNullary): unnecessary case" - -instance GShow' V1 where - gshowsPrec' _ _ x = case x of -#if __GLASGOW_HASKELL__ >= 708 - {} -#else - !_ -> error "Void gshowsPrec" -#endif - -instance GShow' U1 where - gshowsPrec' _ _ U1 = id - isNullary _ = True - -instance (GShow c) => GShow' (K1 i c) where - gshowsPrec' _ n (K1 a) = gshowsPrec n a - isNullary _ = False - --- No instances for P or Rec because gshow is only applicable to types of kind * - -instance (GShow' a, Constructor c) => GShow' (M1 C c a) where - gshowsPrec' _ n c@(M1 x) = - case fixity of - Prefix -> showParen (n > appPrec && not (isNullary x)) - ( showString (conName c) - . if (isNullary x) then id else showChar ' ' - . showBraces t (gshowsPrec' t appPrec x)) - Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x)) - where fixity = conFixity c - t = if (conIsRecord c) then Rec else - case (conIsTuple c) of - True -> Tup - False -> case fixity of - Prefix -> Pref - Infix _ _ -> Inf (show (conName c)) - showBraces :: Type -> ShowS -> ShowS - showBraces Rec p = showChar '{' . p . showChar '}' - showBraces Tup p = showChar '(' . p . showChar ')' - showBraces Pref p = p - showBraces (Inf _) p = p - - conIsTuple :: C1 c f p -> Bool - conIsTuple y = tupleName (conName y) where - tupleName ('(':',':_) = True - tupleName _ = False - -instance (Selector s, GShow' a) => GShow' (M1 S s a) where - gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec) - (gshowsPrec' t n x) - | otherwise = showString (selName s) - . showString " = " - . gshowsPrec' t 0 x - isNullary (M1 x) = isNullary x - -instance (GShow' a) => GShow' (M1 D d a) where - gshowsPrec' t n (M1 x) = gshowsPrec' t n x - -instance (GShow' a, GShow' b) => GShow' (a :+: b) where - gshowsPrec' t n (L1 x) = gshowsPrec' t n x - gshowsPrec' t n (R1 x) = gshowsPrec' t n x - -instance (GShow' a, GShow' b) => GShow' (a :*: b) where - gshowsPrec' t@Rec n (a :*: b) = - gshowsPrec' t n a . showString ", " . gshowsPrec' t n b - gshowsPrec' t@(Inf s) n (a :*: b) = - gshowsPrec' t n a . showString s . gshowsPrec' t n b - gshowsPrec' t@Tup n (a :*: b) = - gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b - gshowsPrec' t@Pref n (a :*: b) = - gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b - - -- If we have a product then it is not a nullary constructor - isNullary _ = False - --- Unboxed types -instance GShow' UChar where - gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' -instance GShow' UDouble where - gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" -instance GShow' UFloat where - gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' -instance GShow' UInt where - gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' -instance GShow' UWord where - gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##" - - -class GShow a where - gshowsPrec :: Int -> a -> ShowS -#if __GLASGOW_HASKELL__ >= 701 - default gshowsPrec :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS - gshowsPrec = gshowsPrecdefault -#endif - - gshows :: a -> ShowS - gshows = gshowsPrec 0 - - gshow :: a -> String - gshow x = gshows x "" - - gshowList :: [a] -> ShowS - gshowList l = showChar '[' - . foldr (.) id - (intersperse (showChar ',') (map (gshowsPrec 0) l)) - . showChar ']' - -gshowsPrecdefault :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS -gshowsPrecdefault n = gshowsPrec' Pref n . from - - --- Base types instances --- Base types instances -instance GShow () where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b) => GShow (a, b) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f) - => GShow (a, b, c, d, e, f) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g) - => GShow (a, b, c, d, e, f, g) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow [a] where - gshowsPrec _ = gshowList - -instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where - gshowsPrec = gshowsPrecdefault - -instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (f (g p)) => GShow ((f :.: g) p) where - gshowsPrec = gshowsPrecdefault - -instance GShow All where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow (f a) => GShow (Alt f a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Any where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,9,0) -instance (GShow a, GShow b) => GShow (Arg a b) where - gshowsPrec = gshowsPrecdefault -#endif - -#if !(MIN_VERSION_base(4,9,0)) -instance GShow Arity where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Associativity where - gshowsPrec = gshowsPrecdefault - -instance GShow Bool where - gshowsPrec = gshowsPrecdefault - -instance GShow BufferMode where - gshowsPrec = showsPrec - -#if defined(HTYPE_CC_T) -instance GShow CCc where - gshowsPrec = showsPrec -#endif - -instance GShow CChar where - gshowsPrec = showsPrec - -instance GShow CClock where - gshowsPrec = showsPrec - -#if defined(HTYPE_DEV_T) -instance GShow CDev where - gshowsPrec = showsPrec -#endif - -instance GShow CDouble where - gshowsPrec = showsPrec - -instance GShow CFloat where - gshowsPrec = showsPrec - -#if defined(HTYPE_GID_T) -instance GShow CGid where - gshowsPrec = showsPrec -#endif - -instance GShow Char where - gshowsPrec = showsPrec - gshowList = showList - -#if defined(HTYPE_INO_T) -instance GShow CIno where - gshowsPrec = showsPrec -#endif - -instance GShow CInt where - gshowsPrec = showsPrec - -instance GShow CIntMax where - gshowsPrec = showsPrec - -instance GShow CIntPtr where - gshowsPrec = showsPrec - -instance GShow CLLong where - gshowsPrec = showsPrec - -instance GShow CLong where - gshowsPrec = showsPrec - -#if defined(HTYPE_MODE_T) -instance GShow CMode where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_NLINK_T) -instance GShow CNlink where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_OFF_T) -instance GShow COff where - gshowsPrec = showsPrec -#endif - -#if MIN_VERSION_base(4,4,0) -instance GShow a => GShow (Complex a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow a => GShow (Const a b) where - gshowsPrec = gshowsPrecdefault - -#if defined(HTYPE_PID_T) -instance GShow CPid where - gshowsPrec = showsPrec -#endif - -instance GShow CPtrdiff where - gshowsPrec = showsPrec - -#if defined(HTYPE_RLIM_T) -instance GShow CRLim where - gshowsPrec = showsPrec -#endif - -instance GShow CSChar where - gshowsPrec = showsPrec - -#if defined(HTYPE_SPEED_T) -instance GShow CSpeed where - gshowsPrec = showsPrec -#endif - -#if MIN_VERSION_base(4,4,0) -instance GShow CSUSeconds where - gshowsPrec = showsPrec -#endif - -instance GShow CShort where - gshowsPrec = showsPrec - -instance GShow CSigAtomic where - gshowsPrec = showsPrec - -instance GShow CSize where - gshowsPrec = showsPrec - -#if defined(HTYPE_SSIZE_T) -instance GShow CSsize where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GShow CTcflag where - gshowsPrec = showsPrec -#endif - -instance GShow CTime where - gshowsPrec = showsPrec - -instance GShow CUChar where - gshowsPrec = showsPrec - -#if defined(HTYPE_UID_T) -instance GShow CUid where - gshowsPrec = showsPrec -#endif - -instance GShow CUInt where - gshowsPrec = showsPrec - -instance GShow CUIntMax where - gshowsPrec = showsPrec - -instance GShow CUIntPtr where - gshowsPrec = showsPrec - -instance GShow CULLong where - gshowsPrec = showsPrec - -instance GShow CULong where - gshowsPrec = showsPrec - -#if MIN_VERSION_base(4,4,0) -instance GShow CUSeconds where - gshowsPrec = showsPrec -#endif - -instance GShow CUShort where - gshowsPrec = showsPrec - -instance GShow CWchar where - gshowsPrec = showsPrec - -instance GShow Double where - gshowsPrec = showsPrec - -instance GShow a => GShow (Down a) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Dual a) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b) => GShow (Either a b) where - gshowsPrec = gshowsPrecdefault - -instance GShow ExitCode where - gshowsPrec = gshowsPrecdefault - -instance GShow Fd where - gshowsPrec = showsPrec - -instance GShow a => GShow (Monoid.First a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,9,0) -instance GShow a => GShow (Semigroup.First a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Fixity where - gshowsPrec = gshowsPrecdefault - -instance GShow Float where - gshowsPrec = showsPrec - -instance GShow (ForeignPtr a) where - gshowsPrec = showsPrec - -instance GShow (FunPtr a) where - gshowsPrec = showsPrec - -instance GShow GeneralCategory where - gshowsPrec = showsPrec - -instance GShow Handle where - gshowsPrec = showsPrec - -instance GShow HandlePosn where - gshowsPrec = showsPrec - -#if MIN_VERSION_base(4,8,0) -instance GShow a => GShow (Identity a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Int where - gshowsPrec = showsPrec - -instance GShow Int8 where - gshowsPrec = showsPrec - -instance GShow Int16 where - gshowsPrec = showsPrec - -instance GShow Int32 where - gshowsPrec = showsPrec - -instance GShow Int64 where - gshowsPrec = showsPrec - -instance GShow Integer where - gshowsPrec = showsPrec - -instance GShow IntPtr where - gshowsPrec = showsPrec - -instance GShow IOError where - gshowsPrec = showsPrec - -instance GShow IOErrorType where - gshowsPrec = showsPrec - -instance GShow IOMode where - gshowsPrec = showsPrec - -instance GShow c => GShow (K1 i c p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Monoid.Last a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,9,0) -instance GShow a => GShow (Semigroup.Last a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow (f p) => GShow (M1 i c f p) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,9,0) -instance GShow a => GShow (Max a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow a => GShow (Maybe a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,9,0) -instance GShow a => GShow (Min a) where - gshowsPrec = gshowsPrecdefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GShow Natural where - gshowsPrec = showsPrec -#endif - -#if MIN_VERSION_base(4,9,0) -instance GShow a => GShow (NonEmpty a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Ordering where - gshowsPrec = gshowsPrecdefault - -instance GShow p => GShow (Par1 p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Product a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,7,0) -instance GShow (Proxy s) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow (Ptr a) where - gshowsPrec = showsPrec - -instance GShow (f p) => GShow (Rec1 f p) where - gshowsPrec = gshowsPrecdefault - -instance GShow SeekMode where - gshowsPrec = showsPrec - -instance GShow a => GShow (Sum a) where - gshowsPrec = gshowsPrecdefault - -instance GShow (U1 p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (UChar p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (UDouble p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (UFloat p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (UInt p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (UWord p) where - gshowsPrec = gshowsPrecdefault - -instance GShow Version where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow Void where - gshowsPrec = showsPrec -#endif - -instance GShow Word where - gshowsPrec = showsPrec - -instance GShow Word8 where - gshowsPrec = showsPrec - -instance GShow Word16 where - gshowsPrec = showsPrec - -instance GShow Word32 where - gshowsPrec = showsPrec - -instance GShow Word64 where - gshowsPrec = showsPrec - -instance GShow WordPtr where - gshowsPrec = showsPrec - -#if MIN_VERSION_base(4,9,0) -instance GShow m => GShow (WrappedMonoid m) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow a => GShow (ZipList a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,10,0) -instance GShow CBool where - gshowsPrec = showsPrec - -# if defined(HTYPE_BLKSIZE_T) -instance GShow CBlkSize where - gshowsPrec = showsPrec -# endif - -# if defined(HTYPE_BLKCNT_T) -instance GShow CBlkCnt where - gshowsPrec = showsPrec -# endif - -# if defined(HTYPE_CLOCKID_T) -instance GShow CClockId where - gshowsPrec = showsPrec -# endif - -# if defined(HTYPE_FSBLKCNT_T) -instance GShow CFsBlkCnt where - gshowsPrec = showsPrec -# endif - -# if defined(HTYPE_FSFILCNT_T) -instance GShow CFsFilCnt where - gshowsPrec = showsPrec -# endif - -# if defined(HTYPE_ID_T) -instance GShow CId where - gshowsPrec = showsPrec -# endif - -# if defined(HTYPE_KEY_T) -instance GShow CKey where - gshowsPrec = showsPrec -# endif - -# if defined(HTYPE_TIMER_T) -instance GShow CTimer where - gshowsPrec = showsPrec -# endif -#endif +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++module Generics.Deriving.Show (+ -- * Generic show class+ GShow(..)++ -- * Default definition+ , gshowsPrecdefault++ -- * Internal show class+ , GShow'(..)++ ) where++import Control.Applicative (Const, ZipList)++import Data.Char (GeneralCategory)+import Data.Int+import Data.Monoid (All, Any, Dual, Product, Sum)+import qualified Data.Monoid as Monoid (First, Last)+import Data.Version (Version)+import Data.Word++import Foreign.C.Types+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr++import Generics.Deriving.Base++import GHC.Exts hiding (Any)++import System.Exit (ExitCode)+import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)+import System.IO.Error (IOErrorType)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Data.Void (Void)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic show+--------------------------------------------------------------------------------++intersperse :: a -> [a] -> [a]+intersperse _ [] = []+intersperse _ [h] = [h]+intersperse x (h:t) = h : x : (intersperse x t)++appPrec :: Int+appPrec = 2++data Type = Rec | Tup | Pref | Inf String++class GShow' f where+ gshowsPrec' :: Type -> Int -> f a -> ShowS+ isNullary :: f a -> Bool+ isNullary = error "generic show (isNullary): unnecessary case"++instance GShow' V1 where+ gshowsPrec' _ _ x = case x of+#if __GLASGOW_HASKELL__ >= 708+ {}+#else+ !_ -> error "Void gshowsPrec"+#endif++instance GShow' U1 where+ gshowsPrec' _ _ U1 = id+ isNullary _ = True++instance (GShow c) => GShow' (K1 i c) where+ gshowsPrec' _ n (K1 a) = gshowsPrec n a+ isNullary _ = False++-- No instances for P or Rec because gshow is only applicable to types of kind *++instance (GShow' a, Constructor c) => GShow' (M1 C c a) where+ gshowsPrec' _ n c@(M1 x) =+ case fixity of+ Prefix -> showParen (n > appPrec && not (isNullary x))+ ( showString (conName c)+ . if (isNullary x) then id else showChar ' '+ . showBraces t (gshowsPrec' t appPrec x))+ Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x))+ where fixity = conFixity c+ t = if (conIsRecord c) then Rec else+ case (conIsTuple c) of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf (show (conName c))+ showBraces :: Type -> ShowS -> ShowS+ showBraces Rec p = showChar '{' . p . showChar '}'+ showBraces Tup p = showChar '(' . p . showChar ')'+ showBraces Pref p = p+ showBraces (Inf _) p = p++ conIsTuple :: C1 c f p -> Bool+ conIsTuple y = tupleName (conName y) where+ tupleName ('(':',':_) = True+ tupleName _ = False++instance (Selector s, GShow' a) => GShow' (M1 S s a) where+ gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec)+ (gshowsPrec' t n x)+ | otherwise = showString (selName s)+ . showString " = "+ . gshowsPrec' t 0 x+ isNullary (M1 x) = isNullary x++instance (GShow' a) => GShow' (M1 D d a) where+ gshowsPrec' t n (M1 x) = gshowsPrec' t n x++instance (GShow' a, GShow' b) => GShow' (a :+: b) where+ gshowsPrec' t n (L1 x) = gshowsPrec' t n x+ gshowsPrec' t n (R1 x) = gshowsPrec' t n x++instance (GShow' a, GShow' b) => GShow' (a :*: b) where+ gshowsPrec' t@Rec n (a :*: b) =+ gshowsPrec' t n a . showString ", " . gshowsPrec' t n b+ gshowsPrec' t@(Inf s) n (a :*: b) =+ gshowsPrec' t n a . showString s . gshowsPrec' t n b+ gshowsPrec' t@Tup n (a :*: b) =+ gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b+ gshowsPrec' t@Pref n (a :*: b) =+ gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b++ -- If we have a product then it is not a nullary constructor+ isNullary _ = False++-- Unboxed types+instance GShow' UChar where+ gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#'+instance GShow' UDouble where+ gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"+instance GShow' UFloat where+ gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#'+instance GShow' UInt where+ gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#'+instance GShow' UWord where+ gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##"+++class GShow a where+ gshowsPrec :: Int -> a -> ShowS+#if __GLASGOW_HASKELL__ >= 701+ default gshowsPrec :: (Generic a, GShow' (Rep a))+ => Int -> a -> ShowS+ gshowsPrec = gshowsPrecdefault+#endif++ gshows :: a -> ShowS+ gshows = gshowsPrec 0++ gshow :: a -> String+ gshow x = gshows x ""++ gshowList :: [a] -> ShowS+ gshowList l = showChar '['+ . foldr (.) id+ (intersperse (showChar ',') (map (gshowsPrec 0) l))+ . showChar ']'++gshowsPrecdefault :: (Generic a, GShow' (Rep a))+ => Int -> a -> ShowS+gshowsPrecdefault n = gshowsPrec' Pref n . from+++-- Base types instances+-- Base types instances+instance GShow () where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b) => GShow (a, b) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f)+ => GShow (a, b, c, d, e, f) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g)+ => GShow (a, b, c, d, e, f, g) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow [a] where+ gshowsPrec _ = gshowList++instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where+ gshowsPrec = gshowsPrecdefault++instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (f (g p)) => GShow ((f :.: g) p) where+ gshowsPrec = gshowsPrecdefault++instance GShow All where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,8,0)+instance GShow (f a) => GShow (Alt f a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Any where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance (GShow a, GShow b) => GShow (Arg a b) where+ gshowsPrec = gshowsPrecdefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GShow Arity where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Associativity where+ gshowsPrec = gshowsPrecdefault++instance GShow Bool where+ gshowsPrec = gshowsPrecdefault++instance GShow BufferMode where+ gshowsPrec = showsPrec++#if defined(HTYPE_CC_T)+instance GShow CCc where+ gshowsPrec = showsPrec+#endif++instance GShow CChar where+ gshowsPrec = showsPrec++instance GShow CClock where+ gshowsPrec = showsPrec++#if defined(HTYPE_DEV_T)+instance GShow CDev where+ gshowsPrec = showsPrec+#endif++instance GShow CDouble where+ gshowsPrec = showsPrec++instance GShow CFloat where+ gshowsPrec = showsPrec++#if defined(HTYPE_GID_T)+instance GShow CGid where+ gshowsPrec = showsPrec+#endif++instance GShow Char where+ gshowsPrec = showsPrec+ gshowList = showList++#if defined(HTYPE_INO_T)+instance GShow CIno where+ gshowsPrec = showsPrec+#endif++instance GShow CInt where+ gshowsPrec = showsPrec++instance GShow CIntMax where+ gshowsPrec = showsPrec++instance GShow CIntPtr where+ gshowsPrec = showsPrec++instance GShow CLLong where+ gshowsPrec = showsPrec++instance GShow CLong where+ gshowsPrec = showsPrec++#if defined(HTYPE_MODE_T)+instance GShow CMode where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_NLINK_T)+instance GShow CNlink where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_OFF_T)+instance GShow COff where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,4,0)+instance GShow a => GShow (Complex a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (Const a b) where+ gshowsPrec = gshowsPrecdefault++#if defined(HTYPE_PID_T)+instance GShow CPid where+ gshowsPrec = showsPrec+#endif++instance GShow CPtrdiff where+ gshowsPrec = showsPrec++#if defined(HTYPE_RLIM_T)+instance GShow CRLim where+ gshowsPrec = showsPrec+#endif++instance GShow CSChar where+ gshowsPrec = showsPrec++#if defined(HTYPE_SPEED_T)+instance GShow CSpeed where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,4,0)+instance GShow CSUSeconds where+ gshowsPrec = showsPrec+#endif++instance GShow CShort where+ gshowsPrec = showsPrec++instance GShow CSigAtomic where+ gshowsPrec = showsPrec++instance GShow CSize where+ gshowsPrec = showsPrec++#if defined(HTYPE_SSIZE_T)+instance GShow CSsize where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_TCFLAG_T)+instance GShow CTcflag where+ gshowsPrec = showsPrec+#endif++instance GShow CTime where+ gshowsPrec = showsPrec++instance GShow CUChar where+ gshowsPrec = showsPrec++#if defined(HTYPE_UID_T)+instance GShow CUid where+ gshowsPrec = showsPrec+#endif++instance GShow CUInt where+ gshowsPrec = showsPrec++instance GShow CUIntMax where+ gshowsPrec = showsPrec++instance GShow CUIntPtr where+ gshowsPrec = showsPrec++instance GShow CULLong where+ gshowsPrec = showsPrec++instance GShow CULong where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,4,0)+instance GShow CUSeconds where+ gshowsPrec = showsPrec+#endif++instance GShow CUShort where+ gshowsPrec = showsPrec++instance GShow CWchar where+ gshowsPrec = showsPrec++instance GShow Double where+ gshowsPrec = showsPrec++instance GShow a => GShow (Down a) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Dual a) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b) => GShow (Either a b) where+ gshowsPrec = gshowsPrecdefault++instance GShow ExitCode where+ gshowsPrec = gshowsPrecdefault++instance GShow Fd where+ gshowsPrec = showsPrec++instance GShow a => GShow (Monoid.First a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Semigroup.First a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Fixity where+ gshowsPrec = gshowsPrecdefault++instance GShow Float where+ gshowsPrec = showsPrec++instance GShow (ForeignPtr a) where+ gshowsPrec = showsPrec++instance GShow (FunPtr a) where+ gshowsPrec = showsPrec++instance GShow GeneralCategory where+ gshowsPrec = showsPrec++instance GShow Handle where+ gshowsPrec = showsPrec++instance GShow HandlePosn where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,8,0)+instance GShow a => GShow (Identity a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Int where+ gshowsPrec = showsPrec++instance GShow Int8 where+ gshowsPrec = showsPrec++instance GShow Int16 where+ gshowsPrec = showsPrec++instance GShow Int32 where+ gshowsPrec = showsPrec++instance GShow Int64 where+ gshowsPrec = showsPrec++instance GShow Integer where+ gshowsPrec = showsPrec++instance GShow IntPtr where+ gshowsPrec = showsPrec++instance GShow IOError where+ gshowsPrec = showsPrec++instance GShow IOErrorType where+ gshowsPrec = showsPrec++instance GShow IOMode where+ gshowsPrec = showsPrec++instance GShow c => GShow (K1 i c p) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Monoid.Last a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Semigroup.Last a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow (f p) => GShow (M1 i c f p) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Max a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (Maybe a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Min a) where+ gshowsPrec = gshowsPrecdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GShow Natural where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (NonEmpty a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Ordering where+ gshowsPrec = gshowsPrecdefault++instance GShow p => GShow (Par1 p) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Product a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,7,0)+instance GShow (Proxy s) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow (Ptr a) where+ gshowsPrec = showsPrec++instance GShow (f p) => GShow (Rec1 f p) where+ gshowsPrec = gshowsPrecdefault++instance GShow SeekMode where+ gshowsPrec = showsPrec++instance GShow a => GShow (Sum a) where+ gshowsPrec = gshowsPrecdefault++instance GShow (U1 p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UChar p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UDouble p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UFloat p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UInt p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UWord p) where+ gshowsPrec = gshowsPrecdefault++instance GShow Version where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,8,0)+instance GShow Void where+ gshowsPrec = showsPrec+#endif++instance GShow Word where+ gshowsPrec = showsPrec++instance GShow Word8 where+ gshowsPrec = showsPrec++instance GShow Word16 where+ gshowsPrec = showsPrec++instance GShow Word32 where+ gshowsPrec = showsPrec++instance GShow Word64 where+ gshowsPrec = showsPrec++instance GShow WordPtr where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,9,0)+instance GShow m => GShow (WrappedMonoid m) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (ZipList a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,10,0)+instance GShow CBool where+ gshowsPrec = showsPrec++# if defined(HTYPE_BLKSIZE_T)+instance GShow CBlkSize where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_BLKCNT_T)+instance GShow CBlkCnt where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_CLOCKID_T)+instance GShow CClockId where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GShow CFsBlkCnt where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GShow CFsFilCnt where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_ID_T)+instance GShow CId where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_KEY_T)+instance GShow CKey where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_TIMER_T)+instance GShow CTimer where+ gshowsPrec = showsPrec+# endif+#endif
src/Generics/Deriving/TH.hs view
@@ -1,1227 +1,1228 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} - -{- | -Module : Generics.Deriving.TH -Copyright : (c) 2008--2009 Universiteit Utrecht -License : BSD3 - -Maintainer : generics@haskell.org -Stability : experimental -Portability : non-portable - -This module contains Template Haskell code that can be used to -automatically generate the boilerplate code for the generic deriving -library. - -To use these functions, pass the name of a data type as an argument: - -@ -{-# LANGUAGE TemplateHaskell #-} - -data Example a = Example Int Char a -$('deriveAll0' ''Example) -- Derives Generic instance -$('deriveAll1' ''Example) -- Derives Generic1 instance -$('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances -@ - -On GHC 7.4 or later, this code can also be used with data families. To derive -for a data family instance, pass the name of one of the instance's constructors: - -@ -{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} - -data family Family a b -newtype instance Family Char x = FamilyChar Char -data instance Family Bool x = FamilyTrue | FamilyFalse - -$('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ... -$('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ... --- Alternatively, one could type $(deriveAll1 'FamilyFalse) -@ --} - --- Adapted from Generics.Regular.TH -module Generics.Deriving.TH ( - -- * @derive@- functions - deriveMeta - , deriveData - , deriveConstructors - , deriveSelectors - - , deriveAll - , deriveAll0 - , deriveAll1 - , deriveAll0And1 - , deriveRepresentable0 - , deriveRepresentable1 - , deriveRep0 - , deriveRep1 - - -- * @make@- functions - -- $make - , makeRep0Inline - , makeRep0 - , makeRep0FromType - , makeFrom - , makeFrom0 - , makeTo - , makeTo0 - , makeRep1Inline - , makeRep1 - , makeRep1FromType - , makeFrom1 - , makeTo1 - - -- * Options - -- $options - -- ** Option types - , Options(..) - , defaultOptions - , RepOptions(..) - , defaultRepOptions - , KindSigOptions - , defaultKindSigOptions - , EmptyCaseOptions - , defaultEmptyCaseOptions - - -- ** Functions with optional arguments - , deriveAll0Options - , deriveAll1Options - , deriveAll0And1Options - , deriveRepresentable0Options - , deriveRepresentable1Options - , deriveRep0Options - , deriveRep1Options - - , makeFrom0Options - , makeTo0Options - , makeFrom1Options - , makeTo1Options - ) where - -import Control.Monad ((>=>), unless, when) - -import qualified Data.Map as Map (empty, fromList) - -import Generics.Deriving.TH.Internal -#if MIN_VERSION_base(4,9,0) -import Generics.Deriving.TH.Post4_9 -#else -import Generics.Deriving.TH.Pre4_9 -#endif - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH - -{- $options -'Options' gives you a way to further tweak derived 'Generic' and 'Generic1' instances: - -* 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit the code - directly (the 'InlineRep' option). One can also choose to emit a separate type - synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and - 'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the - 'TypeSynonymRep' option). - -* 'EmptyCaseOptions': By default, all derived instances for empty data types - (i.e., data types with no constructors) use 'error' in @from(1)@/@to(1)@. - For instance, @data Empty@ would have this derived 'Generic' instance: - - @ - instance Generic Empty where - type Rep Empty = D1 ('MetaData ...) V1 - from _ = M1 (error "No generic representation for empty datatype Empty") - to (M1 _) = error "No generic representation for empty datatype Empty" - @ - - This matches the behavior of GHC up until 8.4, when derived @Generic(1)@ - instances began to use the @EmptyCase@ extension. In GHC 8.4, the derived - 'Generic' instance for @Empty@ would instead be: - - @ - instance Generic Empty where - type Rep Empty = D1 ('MetaData ...) V1 - from x = M1 (case x of {}) - to (M1 x) = case x of {} - @ - - This is a slightly better encoding since, for example, any divergent - computations passed to 'from' will actually diverge (as opposed to before, - where the result would always be a call to 'error'). On the other hand, using - this encoding in @generic-deriving@ has one large drawback: it requires - enabling @EmptyCase@, an extension which was only introduced in GHC 7.8 - (and only received reliable pattern-match coverage checking in 8.2). - - The 'EmptyCaseOptions' field controls whether code should be emitted that - uses @EmptyCase@ (i.e., 'EmptyCaseOptions' set to 'True') or not ('False'). - The default value is 'False'. Note that even if set to 'True', this option - has no effect on GHCs before 7.8, as @EmptyCase@ did not exist then. - -* 'KindSigOptions': By default, all derived instances will use explicit kind - signatures (when the 'KindSigOptions' is 'True'). You might wish to set the - 'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at - a particular kind that GHC will infer correctly, but the functions in this - module won't guess correctly. You probably won't ever need this option - unless you are a power user. --} - --- | Additional options for configuring derived 'Generic'/'Generic1' instances --- using Template Haskell. -data Options = Options - { repOptions :: RepOptions - , kindSigOptions :: KindSigOptions - , emptyCaseOptions :: EmptyCaseOptions - } deriving (Eq, Ord, Read, Show) - --- | Sensible default 'Options'. -defaultOptions :: Options -defaultOptions = Options - { repOptions = defaultRepOptions - , kindSigOptions = defaultKindSigOptions - , emptyCaseOptions = defaultEmptyCaseOptions - } - --- | Configures whether 'Rep'/'Rep1' type instances should be defined inline in a --- derived 'Generic'/'Generic1' instance ('InlineRep') or defined in terms of a --- type synonym ('TypeSynonymRep'). -data RepOptions = InlineRep - | TypeSynonymRep - deriving (Eq, Ord, Read, Show) - --- | 'InlineRep', a sensible default 'RepOptions'. -defaultRepOptions :: RepOptions -defaultRepOptions = InlineRep - --- | 'True' if explicit kind signatures should be used in derived --- 'Generic'/'Generic1' instances, 'False' otherwise. -type KindSigOptions = Bool - --- | 'True', a sensible default 'KindSigOptions'. -defaultKindSigOptions :: KindSigOptions -defaultKindSigOptions = True - --- | 'True' if generated code for empty data types should use the @EmptyCase@ --- extension, 'False' otherwise. This has no effect on GHCs before 7.8, since --- @EmptyCase@ is only available in 7.8 or later. -type EmptyCaseOptions = Bool - --- | Sensible default 'EmptyCaseOptions'. -defaultEmptyCaseOptions :: EmptyCaseOptions -defaultEmptyCaseOptions = False - --- | A backwards-compatible synonym for 'deriveAll0'. -deriveAll :: Name -> Q [Dec] -deriveAll = deriveAll0 - --- | Given the type and the name (as string) for the type to derive, --- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' --- instances, and the 'Representable0' instance. -deriveAll0 :: Name -> Q [Dec] -deriveAll0 = deriveAll0Options defaultOptions - --- | Like 'deriveAll0', but takes an 'Options' argument. -deriveAll0Options :: Options -> Name -> Q [Dec] -deriveAll0Options = deriveAllCommon True False - --- | Given the type and the name (as string) for the type to derive, --- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' --- instances, and the 'Representable1' instance. -deriveAll1 :: Name -> Q [Dec] -deriveAll1 = deriveAll1Options defaultOptions - --- | Like 'deriveAll1', but takes an 'Options' argument. -deriveAll1Options :: Options -> Name -> Q [Dec] -deriveAll1Options = deriveAllCommon False True - --- | Given the type and the name (as string) for the type to derive, --- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' --- instances, the 'Representable0' instance, and the 'Representable1' instance. -deriveAll0And1 :: Name -> Q [Dec] -deriveAll0And1 = deriveAll0And1Options defaultOptions - --- | Like 'deriveAll0And1', but takes an 'Options' argument. -deriveAll0And1Options :: Options -> Name -> Q [Dec] -deriveAll0And1Options = deriveAllCommon True True - -deriveAllCommon :: Bool -> Bool -> Options -> Name -> Q [Dec] -deriveAllCommon generic generic1 opts n = do - a <- deriveMeta n - b <- if generic - then deriveRepresentableCommon Generic opts n - else return [] - c <- if generic1 - then deriveRepresentableCommon Generic1 opts n - else return [] - return (a ++ b ++ c) - --- | Given the type and the name (as string) for the Representable0 type --- synonym to derive, generate the 'Representable0' instance. -deriveRepresentable0 :: Name -> Q [Dec] -deriveRepresentable0 = deriveRepresentable0Options defaultOptions - --- | Like 'deriveRepresentable0', but takes an 'Options' argument. -deriveRepresentable0Options :: Options -> Name -> Q [Dec] -deriveRepresentable0Options = deriveRepresentableCommon Generic - --- | Given the type and the name (as string) for the Representable1 type --- synonym to derive, generate the 'Representable1' instance. -deriveRepresentable1 :: Name -> Q [Dec] -deriveRepresentable1 = deriveRepresentable1Options defaultOptions - --- | Like 'deriveRepresentable1', but takes an 'Options' argument. -deriveRepresentable1Options :: Options -> Name -> Q [Dec] -deriveRepresentable1Options = deriveRepresentableCommon Generic1 - -deriveRepresentableCommon :: GenericClass -> Options -> Name -> Q [Dec] -deriveRepresentableCommon gClass opts n = do - rep <- if repOptions opts == InlineRep - then return [] - else deriveRepCommon gClass (kindSigOptions opts) n - inst <- deriveInst gClass opts n - return (rep ++ inst) - --- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0' --- is used. -deriveRep0 :: Name -> Q [Dec] -deriveRep0 = deriveRep0Options defaultKindSigOptions - --- | Like 'deriveRep0', but takes an 'KindSigOptions' argument. -deriveRep0Options :: KindSigOptions -> Name -> Q [Dec] -deriveRep0Options = deriveRepCommon Generic - --- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1' --- is used. -deriveRep1 :: Name -> Q [Dec] -deriveRep1 = deriveRep1Options defaultKindSigOptions - --- | Like 'deriveRep1', but takes an 'KindSigOptions' argument. -deriveRep1Options :: KindSigOptions -> Name -> Q [Dec] -deriveRep1Options = deriveRepCommon Generic1 - -deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec] -deriveRepCommon gClass useKindSigs n = do - i <- reifyDataInfo n - let (name, instTys, cons, dv) = either error id i - gt = mkGenericTvbs gClass instTys - -- See Note [Forcing buildTypeInstance] - !_ <- buildTypeInstance gClass useKindSigs name instTys - - -- See Note [Kind signatures in derived instances] - let tySynVars = genericInitTvbs gt - tySynVars' = if useKindSigs - then tySynVars - else map unKindedTV tySynVars - fmap (:[]) $ tySynD (genRepName gClass dv name) - tySynVars' - (repType gt dv name Map.empty cons) - -deriveInst :: GenericClass -> Options -> Name -> Q [Dec] -deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName -deriveInst Generic1 = deriveInstCommon generic1TypeName rep1TypeName Generic1 from1ValName to1ValName - -deriveInstCommon :: Name - -> Name - -> GenericClass - -> Name - -> Name - -> Options - -> Name - -> Q [Dec] -deriveInstCommon genericName repName gClass fromName toName opts n = do - i <- reifyDataInfo n - let (name, instTys, cons, dv) = either error id i - gt = mkGenericTvbs gClass instTys - useKindSigs = kindSigOptions opts - -- See Note [Forcing buildTypeInstance] - !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name instTys - tyInsRHS <- if repOptions opts == InlineRep - then repType gt dv name Map.empty cons - else makeRepTySynApp gClass dv name origTy - - let origSigTy = if useKindSigs - then SigT origTy origKind - else origTy - tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return tyInsRHS) - let ecOptions = emptyCaseOptions opts - mkBody maker = [clause [] - (normalB $ - mkCaseExp $ - maker gt ecOptions name cons) - []] - fcs = mkBody mkFrom - tcs = mkBody mkTo - - inline_pragmas - | inlining_useful cons -#if MIN_VERSION_template_haskell(2,7,0) - = map (\fun_name -> - pragInlD fun_name -# if MIN_VERSION_template_haskell(2,8,0) - Inline FunLike (FromPhase 1) -# else - (inlineSpecPhase True False True 1) -# endif - ) [fromName, toName] -#else - = [] -- Sadly, GHC 7.0 and 7.2 appear to suffer from a bug that - -- prevents them from attaching INLINE pragmas to class methods - -- via Template Haskell, so don't bother generating any pragmas at - -- all for these GHC versions. -#endif - | otherwise - = [] - - fmap (:[]) $ - instanceD (cxt []) (conT genericName `appT` return origSigTy) - (inline_pragmas ++ [return tyIns, funD fromName fcs, funD toName tcs]) - where - -- Adapted from inlining_useful in GHC.Tc.Deriv.Generics.mkBindsRep in the - -- GHC source code: - -- - -- https://gitlab.haskell.org/ghc/ghc/-/blob/80729d96e47c99dc38e83612dfcfe01cf565eac0/compiler/GHC/Tc/Deriv/Generics.hs#L368-386 - inlining_useful cons - | ncons <= 1 = True - | ncons <= 4 = max_fields <= 5 - | ncons <= 8 = max_fields <= 2 - | ncons <= 16 = max_fields <= 1 - | ncons <= 24 = max_fields == 0 - | otherwise = False - where - ncons = length cons - max_fields = maximum $ map (length . constructorFields) cons - -{- $make - -There are some data types for which the Template Haskell deriver functions in -this module are not sophisticated enough to infer the correct 'Generic' or -'Generic1' instances. As an example, consider this data type: - -@ -newtype Fix f a = Fix (f (Fix f a)) -@ - -A proper 'Generic1' instance would look like this: - -@ -instance Functor f => Generic1 (Fix f) where ... -@ - -Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint. -One can still define a 'Generic1' instance for @Fix@, however, by using the -functions in this module that are prefixed with @make@-. For example: - -@ -$('deriveMeta' ''Fix) -$('deriveRep1' ''Fix) -instance Functor f => Generic1 (Fix f) where - type Rep1 (Fix f) = $('makeRep1Inline' ''Fix [t| Fix f |]) - from1 = $('makeFrom1' ''Fix) - to1 = $('makeTo1' ''Fix) -@ - -Note that due to the lack of type-level lambdas in Haskell, one must manually -apply @'makeRep1Inline' ''Fix@ to the type @Fix f@. - -Be aware that there is a bug on GHC 7.0, 7.2, and 7.4 which might prevent you from -using 'makeRep0Inline' and 'makeRep1Inline'. In the @Fix@ example above, you -would experience the following error: - -@ - Kinded thing `f' used as a type - In the Template Haskell quotation [t| Fix f |] -@ - -Then a workaround is to use 'makeRep1' instead, which requires you to: - -1. Invoke 'deriveRep1' beforehand - -2. Pass as arguments the type variables that occur in the instance, in order - from left to right, topologically sorted, excluding duplicates. (Normally, - 'makeRep1Inline' would figure this out for you.) - -Using the above example: - -@ -$('deriveMeta' ''Fix) -$('deriveRep1' ''Fix) -instance Functor f => Generic1 (Fix f) where - type Rep1 (Fix f) = $('makeRep1' ''Fix) f - from1 = $('makeFrom1' ''Fix) - to1 = $('makeTo1' ''Fix) -@ - -On GHC 7.4, you might encounter more complicated examples involving data -families. For instance: - -@ -data family Fix a b c d -newtype instance Fix b (f c) (g b) a = Fix (f (Fix b (f c) (g b) a)) - -$('deriveMeta' ''Fix) -$('deriveRep1' ''Fix) -instance Functor f => Generic1 (Fix b (f c) (g b)) where - type Rep1 (Fix b (f c) (g b)) = $('makeRep1' 'Fix) b f c g - from1 = $('makeFrom1' 'Fix) - to1 = $('makeTo1' 'Fix) -@ - -Note that you don't pass @b@ twice, only once. --} - --- | Generates the full 'Rep' type inline. Since this type can be quite --- large, it is recommended you only use this to define 'Rep', e.g., --- --- @ --- type Rep (Foo (a :: k) b) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) b |]) --- @ --- --- You can then simply refer to @Rep (Foo a b)@ elsewhere. --- --- Note that the type passed as an argument to 'makeRep0Inline' must match the --- type argument of 'Rep' exactly, even up to including the explicit kind --- signature on @a@. This is due to a limitation of Template Haskell—without --- the kind signature, 'makeRep0Inline' has no way of figuring out the kind of --- @a@, and the generated type might be completely wrong as a result! -makeRep0Inline :: Name -> Q Type -> Q Type -makeRep0Inline n = makeRepCommon Generic InlineRep n . Just - --- | Generates the full 'Rep1' type inline. Since this type can be quite --- large, it is recommended you only use this to define 'Rep1', e.g., --- --- @ --- type Rep1 (Foo (a :: k)) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) |]) --- @ --- --- You can then simply refer to @Rep1 (Foo a)@ elsewhere. --- --- Note that the type passed as an argument to 'makeRep1Inline' must match the --- type argument of 'Rep1' exactly, even up to including the explicit kind --- signature on @a@. This is due to a limitation of Template Haskell—without --- the kind signature, 'makeRep1Inline' has no way of figuring out the kind of --- @a@, and the generated type might be completely wrong as a result! -makeRep1Inline :: Name -> Q Type -> Q Type -makeRep1Inline n = makeRepCommon Generic1 InlineRep n . Just - --- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', --- which generates the type synonym declaration). After splicing it into --- Haskell source, it expects types as arguments. For example: --- --- @ --- type Rep (Foo a b) = $('makeRep0' ''Foo) a b --- @ --- --- The use of 'makeRep0' is generally discouraged, as it can sometimes be --- difficult to predict the order in which you are expected to pass type --- variables. As a result, 'makeRep0Inline' is recommended instead. However, --- 'makeRep0Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, --- so 'makeRep0' still exists for GHC 7.0, 7.2, and 7.4 users. -makeRep0 :: Name -> Q Type -makeRep0 n = makeRepCommon Generic TypeSynonymRep n Nothing - --- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', --- which generates the type synonym declaration). After splicing it into --- Haskell source, it expects types as arguments. For example: --- --- @ --- type Rep1 (Foo a) = $('makeRep1' ''Foo) a --- @ --- --- The use of 'makeRep1' is generally discouraged, as it can sometimes be --- difficult to predict the order in which you are expected to pass type --- variables. As a result, 'makeRep1Inline' is recommended instead. However, --- 'makeRep1Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, --- so 'makeRep1' still exists for GHC 7.0, 7.2, and 7.4 users. -makeRep1 :: Name -> Q Type -makeRep1 n = makeRepCommon Generic1 TypeSynonymRep n Nothing - --- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', --- which generates the type synonym declaration) applied to its type arguments. --- Unlike 'makeRep0', this also takes a quoted 'Type' as an argument, e.g., --- --- @ --- type Rep (Foo (a :: k) b) = $('makeRep0FromType' ''Foo [t| Foo (a :: k) b |]) --- @ --- --- Note that the type passed as an argument to 'makeRep0FromType' must match the --- type argument of 'Rep' exactly, even up to including the explicit kind --- signature on @a@. This is due to a limitation of Template Haskell—without --- the kind signature, 'makeRep0FromType' has no way of figuring out the kind of --- @a@, and the generated type might be completely wrong as a result! --- --- The use of 'makeRep0FromType' is generally discouraged, since 'makeRep0Inline' --- does exactly the same thing but without having to go through an intermediate --- type synonym, and as a result, 'makeRep0Inline' tends to be less buggy. -makeRep0FromType :: Name -> Q Type -> Q Type -makeRep0FromType n = makeRepCommon Generic TypeSynonymRep n . Just - --- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', --- which generates the type synonym declaration) applied to its type arguments. --- Unlike 'makeRep1', this also takes a quoted 'Type' as an argument, e.g., --- --- @ --- type Rep1 (Foo (a :: k)) = $('makeRep1FromType' ''Foo [t| Foo (a :: k) |]) --- @ --- --- Note that the type passed as an argument to 'makeRep1FromType' must match the --- type argument of 'Rep' exactly, even up to including the explicit kind --- signature on @a@. This is due to a limitation of Template Haskell—without --- the kind signature, 'makeRep1FromType' has no way of figuring out the kind of --- @a@, and the generated type might be completely wrong as a result! --- --- The use of 'makeRep1FromType' is generally discouraged, since 'makeRep1Inline' --- does exactly the same thing but without having to go through an intermediate --- type synonym, and as a result, 'makeRep1Inline' tends to be less buggy. -makeRep1FromType :: Name -> Q Type -> Q Type -makeRep1FromType n = makeRepCommon Generic1 TypeSynonymRep n . Just - -makeRepCommon :: GenericClass - -> RepOptions - -> Name - -> Maybe (Q Type) - -> Q Type -makeRepCommon gClass repOpts n mbQTy = do - i <- reifyDataInfo n - let (name, instTys, cons, dv) = either error id i - gt = mkGenericTvbs gClass instTys - -- See Note [Forcing buildTypeInstance] - !_ <- buildTypeInstance gClass False name instTys - - case (mbQTy, repOpts) of - (Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name - (Just qTy, InlineRep) -> qTy >>= makeRepInline gt dv name cons - (Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name - (Nothing, InlineRep) -> fail "makeRepCommon" - -makeRepInline :: GenericTvbs - -> DatatypeVariant_ - -> Name - -> [ConstructorInfo] - -> Type - -> Q Type -makeRepInline gt dv name cons ty = do - let instVars = freeVariablesWellScoped [ty] - tySynVars = genericInitTvbs gt - - typeSubst :: TypeSubst - typeSubst = Map.fromList $ - zip (map tvName tySynVars) - (map (VarT . tvName) instVars) - - repType gt dv name typeSubst cons - -makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name - -> Type -> Q Type -makeRepTySynApp gClass dv name ty = - -- Here, we figure out the distinct type variables (in order from left-to-right) - -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind - -- inferencer can figure out the kinds perfectly well, so we don't need to - -- give anything here explicit kind signatures. - let instTvbs = map unKindedTV $ freeVariablesWellScoped [ty] - in return $ applyTyToTvbs (genRepName gClass dv name) instTvbs - --- | A backwards-compatible synonym for 'makeFrom0'. -makeFrom :: Name -> Q Exp -makeFrom = makeFrom0 - --- | Generates a lambda expression which behaves like 'from'. -makeFrom0 :: Name -> Q Exp -makeFrom0 = makeFrom0Options defaultEmptyCaseOptions - --- | Like 'makeFrom0Options', but takes an 'EmptyCaseOptions' argument. -makeFrom0Options :: EmptyCaseOptions -> Name -> Q Exp -makeFrom0Options = makeFunCommon mkFrom Generic - --- | A backwards-compatible synonym for 'makeTo0'. -makeTo :: Name -> Q Exp -makeTo = makeTo0 - --- | Generates a lambda expression which behaves like 'to'. -makeTo0 :: Name -> Q Exp -makeTo0 = makeTo0Options defaultEmptyCaseOptions - --- | Like 'makeTo0Options', but takes an 'EmptyCaseOptions' argument. -makeTo0Options :: EmptyCaseOptions -> Name -> Q Exp -makeTo0Options = makeFunCommon mkTo Generic - --- | Generates a lambda expression which behaves like 'from1'. -makeFrom1 :: Name -> Q Exp -makeFrom1 = makeFrom1Options defaultEmptyCaseOptions - --- | Like 'makeFrom1Options', but takes an 'EmptyCaseOptions' argument. -makeFrom1Options :: EmptyCaseOptions -> Name -> Q Exp -makeFrom1Options = makeFunCommon mkFrom Generic1 - --- | Generates a lambda expression which behaves like 'to1'. -makeTo1 :: Name -> Q Exp -makeTo1 = makeTo1Options defaultEmptyCaseOptions - --- | Like 'makeTo1Options', but takes an 'EmptyCaseOptions' argument. -makeTo1Options :: EmptyCaseOptions -> Name -> Q Exp -makeTo1Options = makeFunCommon mkTo Generic1 - -makeFunCommon - :: (GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match) - -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp -makeFunCommon maker gClass ecOptions n = do - i <- reifyDataInfo n - let (name, instTys, cons, _) = either error id i - gt = mkGenericTvbs gClass instTys - -- See Note [Forcing buildTypeInstance] - buildTypeInstance gClass False name instTys - `seq` mkCaseExp (maker gt ecOptions name cons) - -genRepName :: GenericClass -> DatatypeVariant_ - -> Name -> Name -genRepName gClass dv n - = mkName - . showsDatatypeVariant dv - . (("Rep" ++ show (fromEnum gClass)) ++) - . ((showNameQual n ++ "_") ++) - . sanitizeName - $ nameBase n - -repType :: GenericTvbs - -> DatatypeVariant_ - -> Name - -> TypeSubst - -> [ConstructorInfo] - -> Q Type -repType gt dv dt typeSubst cs = - conT d1TypeName `appT` mkMetaDataType dv dt `appT` - foldBal sum' (conT v1TypeName) (map (repCon gt dv dt typeSubst) cs) - where - sum' :: Q Type -> Q Type -> Q Type - sum' a b = conT sumTypeName `appT` a `appT` b - -repCon :: GenericTvbs - -> DatatypeVariant_ - -> Name - -> TypeSubst - -> ConstructorInfo - -> Q Type -repCon gt dv dt typeSubst - (ConstructorInfo { constructorName = n - , constructorVars = vars - , constructorContext = ctxt - , constructorStrictness = bangs - , constructorFields = ts - , constructorVariant = cv - }) = do - checkExistentialContext n vars ctxt - let mbSelNames = case cv of - NormalConstructor -> Nothing - InfixConstructor -> Nothing - RecordConstructor selNames -> Just selNames - isRecord = case cv of - NormalConstructor -> False - InfixConstructor -> False - RecordConstructor _ -> True - isInfix = case cv of - NormalConstructor -> False - InfixConstructor -> True - RecordConstructor _ -> False - ssis <- reifySelStrictInfo n bangs - repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix - -repConWith :: GenericTvbs - -> DatatypeVariant_ - -> Name - -> Name - -> TypeSubst - -> Maybe [Name] - -> [SelStrictInfo] - -> [Type] - -> Bool - -> Bool - -> Q Type -repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do - let structureType :: Q Type - structureType = foldBal prodT (conT u1TypeName) f - - f :: [Q Type] - f = case mbSelNames of - Just selNames -> zipWith3 (repField gt dv dt n typeSubst . Just) - selNames ssis ts - Nothing -> zipWith (repField gt dv dt n typeSubst Nothing) - ssis ts - - conT c1TypeName - `appT` mkMetaConsType dv dt n isRecord isInfix - `appT` structureType - -prodT :: Q Type -> Q Type -> Q Type -prodT a b = conT productTypeName `appT` a `appT` b - -repField :: GenericTvbs - -> DatatypeVariant_ - -> Name - -> Name - -> TypeSubst - -> Maybe Name - -> SelStrictInfo - -> Type - -> Q Type -repField gt dv dt ns typeSubst mbF ssi t = - conT s1TypeName - `appT` mkMetaSelType dv dt ns mbF ssi - `appT` (repFieldArg gt =<< resolveTypeSynonyms t'') - where - -- See Note [Generic1 is polykinded in base-4.10] - t', t'' :: Type - t' = case gt of - Gen1{gen1LastTvbKindVar = Just _kvName} -> -#if MIN_VERSION_base(4,10,0) - t -#else - substNameWithKind _kvName starK t -#endif - _ -> t - t'' = applySubstitution typeSubst t' - -repFieldArg :: GenericTvbs -> Type -> Q Type -repFieldArg Gen0{} t = boxT t -repFieldArg (Gen1{gen1LastTvbName = name}) (dustOff -> t0) = - go t0 >>= \res -> case res of - NoPar -> boxT t0 - ArgRes _ r -> return r - where - -- | Returns NoPar if the parameter doesn't appear. - -- Expects its argument to have been dusted. - go :: Type -> Q (ArgRes Type) - go ForallT{} = rankNError -#if MIN_VERSION_template_haskell(2,16,0) - go ForallVisT{} = rankNError -#endif - go (VarT t) | t == name = ArgRes True `fmap` conT par1TypeName - go (AppT f x) = do - when (not (f `ground` name)) outOfPlaceTyVarError - mxr <- go (dustOff x) - case mxr of - NoPar -> return NoPar - ArgRes arg_is_param xr -> do - itf <- isUnsaturatedType f - when itf typeFamilyApplicationError - ArgRes False `fmap` - if arg_is_param - then - conT rec1TypeName `appT` return f - else - conT composeTypeName `appT` return f `appT` return xr - go _ = return NoPar - --- | The result of checking the argument. This NoPar --- means the parameter wasn't there. The Bool is True --- if the argument *is* the parameter, and False otherwise. -data ArgRes a = NoPar | ArgRes !Bool a - -boxT :: Type -> Q Type -boxT ty = case unboxedRepNames ty of - Just (boxTyName, _, _) -> conT boxTyName - Nothing -> conT rec0TypeName `appT` return ty - -mkCaseExp :: Q Match -> Q Exp -mkCaseExp qMatch = do - val <- newName "val" - lam1E (varP val) $ caseE (varE val) [qMatch] - -mkFrom :: GenericTvbs -> EmptyCaseOptions -> Name - -> [ConstructorInfo] -> Q Match -mkFrom gt ecOptions dt cs = do - y <- newName "y" - match (varP y) - (normalB $ conE m1DataName `appE` caseE (varE y) cases) - [] - where - cases = case cs of - [] -> errorFrom ecOptions dt - _ -> zipWith (fromCon gt id (length cs)) [1..] cs - -errorFrom :: EmptyCaseOptions -> Name -> [Q Match] -errorFrom useEmptyCase dt - | useEmptyCase && ghc7'8OrLater - = [] - | otherwise - = [do z <- newName "z" - match - (varP z) - (normalB $ - appE (varE seqValName) (varE z) `appE` - appE (varE errorValName) - (stringE $ "No generic representation for empty datatype " - ++ nameBase dt)) - []] - -mkTo :: GenericTvbs -> EmptyCaseOptions -> Name - -> [ConstructorInfo] -> Q Match -mkTo gt ecOptions dt cs = do - y <- newName "y" - match (conP m1DataName [varP y]) - (normalB $ caseE (varE y) cases) - [] - where - cases = case cs of - [] -> errorTo ecOptions dt - _ -> zipWith (toCon gt id (length cs)) [1..] cs - -errorTo :: EmptyCaseOptions -> Name -> [Q Match] -errorTo useEmptyCase dt - | useEmptyCase && ghc7'8OrLater - = [] - | otherwise - = [do z <- newName "z" - match - (varP z) - (normalB $ - appE (varE seqValName) (varE z) `appE` - appE (varE errorValName) - (stringE $ "No values for empty datatype " ++ nameBase dt)) - []] - -ghc7'8OrLater :: Bool -#if __GLASGOW_HASKELL__ >= 708 -ghc7'8OrLater = True -#else -ghc7'8OrLater = False -#endif - -fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int - -> ConstructorInfo -> Q Match -fromCon gt wrap m i - (ConstructorInfo { constructorName = cn - , constructorVars = vars - , constructorContext = ctxt - , constructorFields = ts - }) = do - checkExistentialContext cn vars ctxt - fNames <- newNameList "f" $ length ts - match (conP cn (map varP fNames)) - (normalB $ wrap $ lrE i m $ conE m1DataName `appE` - foldBal prodE (conE u1DataName) (zipWith (fromField gt) fNames ts)) [] - -prodE :: Q Exp -> Q Exp -> Q Exp -prodE x y = conE productDataName `appE` x `appE` y - -fromField :: GenericTvbs -> Name -> Type -> Q Exp -fromField gt nr t = conE m1DataName `appE` (fromFieldWrap gt nr =<< resolveTypeSynonyms t) - -fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp -fromFieldWrap _ _ ForallT{} = rankNError -fromFieldWrap gt nr (SigT t _) = fromFieldWrap gt nr t -fromFieldWrap Gen0{} nr t = conE (boxRepName t) `appE` varE nr -fromFieldWrap (Gen1{gen1LastTvbName = name}) nr t = wC t name `appE` varE nr - -wC :: Type -> Name -> Q Exp -wC (dustOff -> t0) name = - go t0 >>= \res -> case res of - NoPar -> conE $ boxRepName t0 - ArgRes _ r -> return r - where - -- | Returns NoPar if the parameter doesn't appear. - -- Expects its argument to have been dusted. - go :: Type -> Q (ArgRes Exp) - go ForallT{} = rankNError -#if MIN_VERSION_template_haskell(2,16,0) - go ForallVisT{} = rankNError -#endif - go (VarT t) | t == name = ArgRes True `fmap` conE par1DataName - go (AppT f x) = do - when (not (f `ground` name)) outOfPlaceTyVarError - mxr <- go (dustOff x) - case mxr of - NoPar -> return NoPar - ArgRes arg_is_param xr -> do - itf <- isUnsaturatedType f - when itf typeFamilyApplicationError - ArgRes False `fmap` - if arg_is_param - then - conE rec1DataName - else - infixApp (conE comp1DataName) (varE composeValName) (varE fmapValName `appE` return xr) - go _ = return NoPar - -boxRepName :: Type -> Name -boxRepName = maybe k1DataName snd3 . unboxedRepNames - -toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int - -> ConstructorInfo -> Q Match -toCon gt wrap m i - (ConstructorInfo { constructorName = cn - , constructorVars = vars - , constructorContext = ctxt - , constructorFields = ts - }) = do - checkExistentialContext cn vars ctxt - fNames <- newNameList "f" $ length ts - match (wrap $ lrP i m $ conP m1DataName - [foldBal prod (conP u1DataName []) (zipWith (toField gt) fNames ts)]) - (normalB $ foldl appE (conE cn) - (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gt nr) - fNames ts)) [] - where prod x y = conP productDataName [x,y] - -toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp -toConUnwC Gen0{} nr _ = varE nr -toConUnwC (Gen1{gen1LastTvbName = name}) nr t = unwC t name `appE` varE nr - -toField :: GenericTvbs -> Name -> Type -> Q Pat -toField gt nr t = conP m1DataName [toFieldWrap gt nr t] - -toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat -toFieldWrap Gen0{} nr t = conP (boxRepName t) [varP nr] -toFieldWrap Gen1{} nr _ = varP nr - -unwC :: Type -> Name -> Q Exp -unwC (dustOff -> t0) name = - go t0 >>= \res -> case res of - NoPar -> varE $ unboxRepName t0 - ArgRes _ r -> return r - where - -- | Returns NoPar if the parameter doesn't appear. - -- Expects its argument to have been dusted. - go :: Type -> Q (ArgRes Exp) - go ForallT{} = rankNError -#if MIN_VERSION_template_haskell(2,16,0) - go ForallVisT{} = rankNError -#endif - go (VarT t) | t == name = ArgRes True `fmap` varE unPar1ValName - go (AppT f x) = do - when (not (f `ground` name)) outOfPlaceTyVarError - mxr <- go (dustOff x) - case mxr of - NoPar -> return NoPar - ArgRes arg_is_param xr -> do - itf <- isUnsaturatedType f - when itf typeFamilyApplicationError - ArgRes False `fmap` - if arg_is_param - then - varE unRec1ValName - else - infixApp (varE fmapValName `appE` return xr) - (varE composeValName) - (varE unComp1ValName) - go _ = return NoPar - -unboxRepName :: Type -> Name -unboxRepName = maybe unK1ValName trd3 . unboxedRepNames - -lrP :: Int -> Int -> (Q Pat -> Q Pat) -lrP i n p - | n == 0 = fail "lrP: impossible" - | n == 1 = p - | i <= div n 2 = conP l1DataName [lrP i (div n 2) p] - | otherwise = conP r1DataName [lrP (i-m) (n-m) p] - where m = div n 2 - -lrE :: Int -> Int -> (Q Exp -> Q Exp) -lrE i n e - | n == 0 = fail "lrE: impossible" - | n == 1 = e - | i <= div n 2 = conE l1DataName `appE` lrE i (div n 2) e - | otherwise = conE r1DataName `appE` lrE (i-m) (n-m) e - where m = div n 2 - -unboxedRepNames :: Type -> Maybe (Name, Name, Name) -unboxedRepNames ty - | ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName) - | ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName) - | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName) - | ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName) - | ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName) - | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName) - | otherwise = Nothing - --- For the given Types, deduces the instance type (and kind) to use for a --- Generic(1) instance. Coming up with the instance type isn't as simple as --- dropping the last types, as you need to be wary of kinds being instantiated --- with *. --- See Note [Type inference in derived instances] -buildTypeInstance :: GenericClass - -- ^ Generic or Generic1 - -> KindSigOptions - -- ^ Whether or not to use explicit kind signatures in the instance type - -> Name - -- ^ The type constructor or data family name - -> [Type] - -- ^ The types to instantiate the instance with - -> Q (Type, Kind) -buildTypeInstance gClass useKindSigs tyConName varTysOrig = do - -- Make sure to expand through type/kind synonyms! Otherwise, the - -- eta-reduction check might get tripped up over type variables in a - -- synonym that are actually dropped. - -- (See GHC Trac #11416 for a scenario where this actually happened.) - varTysExp <- mapM resolveTypeSynonyms varTysOrig - - let remainingLength :: Int - remainingLength = length varTysOrig - fromEnum gClass - -#if !(MIN_VERSION_base(4,10,0)) - droppedTysExp :: [Type] - droppedTysExp = drop remainingLength varTysExp - - droppedStarKindStati :: [StarKindStatus] - droppedStarKindStati = map canRealizeKindStar droppedTysExp -#endif - - -- Check that: - -- - -- 1. There are enough types to drop - -- - -- 2. If using GHC 8.0 or earlier, all types are either of kind * or kind k - -- (for some kind variable k). See Note [Generic1 is polykinded in base-4.10]. - -- - -- If either of these checks fail, throw an error. - when (remainingLength < 0 -#if !(MIN_VERSION_base(4,10,0)) - || any (== OtherKind) droppedStarKindStati -#endif - ) $ - derivingKindError tyConName - - -- Substitute kind * for any dropped kind variables - let varTysExpSubst :: [Type] --- See Note [Generic1 is polykinded in base-4.10] -#if MIN_VERSION_base(4,10,0) - varTysExpSubst = varTysExp -#else - varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp - - droppedKindVarNames :: [Name] - droppedKindVarNames = catKindVarNames droppedStarKindStati -#endif - - let remainingTysExpSubst, droppedTysExpSubst :: [Type] - (remainingTysExpSubst, droppedTysExpSubst) = - splitAt remainingLength varTysExpSubst - --- See Note [Generic1 is polykinded in base-4.10] -#if !(MIN_VERSION_base(4,10,0)) - -- If any of the dropped types were polykinded, ensure that there are of - -- kind * after substituting * for the dropped kind variables. If not, - -- throw an error. - unless (all hasKindStar droppedTysExpSubst) $ - derivingKindError tyConName -#endif - - -- We now substitute all of the specialized-to-* kind variable names - -- with *, but in the original types, not the synonym-expanded types. The reason - -- we do this is a superficial one: we want the derived instance to resemble - -- the datatype written in source code as closely as possible. For example, - -- for the following data family instance: - -- - -- data family Fam a - -- newtype instance Fam String = Fam String - -- - -- We'd want to generate the instance: - -- - -- instance C (Fam String) - -- - -- Not: - -- - -- instance C (Fam [Char]) - let varTysOrigSubst :: [Type] - varTysOrigSubst = --- See Note [Generic1 is polykinded in base-4.10] -#if MIN_VERSION_base(4,10,0) - id -#else - map (substNamesWithKindStar droppedKindVarNames) -#endif - $ varTysOrig - - remainingTysOrigSubst, droppedTysOrigSubst :: [Type] - (remainingTysOrigSubst, droppedTysOrigSubst) = - splitAt remainingLength varTysOrigSubst - - remainingTysOrigSubst' :: [Type] - -- See Note [Kind signatures in derived instances] for an explanation - -- of the useKindSigs check. - remainingTysOrigSubst' = - if useKindSigs - then remainingTysOrigSubst - else map unSigT remainingTysOrigSubst - - instanceType :: Type - instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst' - - -- See Note [Kind signatures in derived instances] - instanceKind :: Kind - instanceKind = makeFunKind (map typeKind droppedTysOrigSubst) starK - - -- Ensure the dropped types can be safely eta-reduced. Otherwise, - -- throw an error. - unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $ - etaReductionError instanceType - return (instanceType, instanceKind) - -{- -Note [Forcing buildTypeInstance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Sometimes, we don't explicitly need to generate a Generic(1) type instance, but -we force buildTypeInstance nevertheless. This is because it performs some checks -for whether or not the provided datatype can actually have Generic(1) implemented for -it, and produces errors if it can't. Otherwise, laziness would cause these checks -to be skipped entirely, which could result in some indecipherable type errors -down the road. - -Note [Kind signatures in derived instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We generally include explicit type signatures in derived instances. One reason for -doing so is that in the case of certain data family instances, not including kind -signatures can result in ambiguity. For example, consider the following two data -family instances that are distinguished by their kinds: - - data family Fam (a :: k) - data instance Fam (a :: * -> *) - data instance Fam (a :: *) - -If we dropped the kind signature for a in a derived instance for Fam a, then GHC -would have no way of knowing which instance we are talking about. - -In addition to using explicit kind signatures in the instance head, we also put -explicit kinds in the associated Rep(1) instance. For example, this data type: - - data S (a :: k) = S k - -Will have the following Generic1 instance generated for it: - - instance Generic1 (S :: k -> *) where - type Rep1 (S :: k -> *) = ... (Rec0 k) - -Why do we do this? Imagine what the instance would be without the explicit kind -annotation in the Rep1 instance: - - instance Generic1 S where - type Rep1 S = ... (Rec0 k) - -This is an error, since the variable k is now out-of-scope! - -In the rare event that attaching explicit kind annotations does the wrong -thing, there are variants of the TH functions that allow configuring the -KindSigOptions. If KindSigOptions is set to False, then generated instances -will not include explicit kind signatures, leaving it up to GHC's kind -inference machinery to figure out the correct kinds. - -Note [Generic1 is polykinded in base-4.10] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Prior to base-4.10, Generic1 :: (* -> *) -> Constraint. This means that if a Generic1 -instance is defined for a polykinded data type like so: - - data Proxy k (a :: k) = Proxy - -Then k is unified with *, and this has an effect on the generated Generic1 instance: - - instance Generic1 (Proxy *) where ... - -We must take great care to ensure that all occurrences of k are substituted with *, -or else the generated instance will be ill kinded. - -In base-4.10 and later, Generic1 :: (k -> *) -> Constraint. This means we don't have -to do any of this kind unification trickery anymore! Hooray! --} +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}++{- |+Module : Generics.Deriving.TH+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++This module contains Template Haskell code that can be used to+automatically generate the boilerplate code for the generic deriving+library.++To use these functions, pass the name of a data type as an argument:++@+{-# LANGUAGE TemplateHaskell #-}++data Example a = Example Int Char a+$('deriveAll0' ''Example) -- Derives Generic instance+$('deriveAll1' ''Example) -- Derives Generic1 instance+$('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances+@++On GHC 7.4 or later, this code can also be used with data families. To derive+for a data family instance, pass the name of one of the instance's constructors:++@+{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}++data family Family a b+newtype instance Family Char x = FamilyChar Char+data instance Family Bool x = FamilyTrue | FamilyFalse++$('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ...+$('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ...+-- Alternatively, one could type $(deriveAll1 'FamilyFalse)+@+-}++-- Adapted from Generics.Regular.TH+module Generics.Deriving.TH (+ -- * @derive@- functions+ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors++ , deriveAll+ , deriveAll0+ , deriveAll1+ , deriveAll0And1+ , deriveRepresentable0+ , deriveRepresentable1+ , deriveRep0+ , deriveRep1++ -- * @make@- functions+ -- $make+ , makeRep0Inline+ , makeRep0+ , makeRep0FromType+ , makeFrom+ , makeFrom0+ , makeTo+ , makeTo0+ , makeRep1Inline+ , makeRep1+ , makeRep1FromType+ , makeFrom1+ , makeTo1++ -- * Options+ -- $options+ -- ** Option types+ , Options(..)+ , defaultOptions+ , RepOptions(..)+ , defaultRepOptions+ , KindSigOptions+ , defaultKindSigOptions+ , EmptyCaseOptions+ , defaultEmptyCaseOptions++ -- ** Functions with optional arguments+ , deriveAll0Options+ , deriveAll1Options+ , deriveAll0And1Options+ , deriveRepresentable0Options+ , deriveRepresentable1Options+ , deriveRep0Options+ , deriveRep1Options++ , makeFrom0Options+ , makeTo0Options+ , makeFrom1Options+ , makeTo1Options+ ) where++import Control.Monad ((>=>), unless, when)++import qualified Data.Map as Map (empty, fromList)++import Generics.Deriving.TH.Internal+#if MIN_VERSION_base(4,9,0)+import Generics.Deriving.TH.Post4_9+#else+import Generics.Deriving.TH.Pre4_9+#endif++import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Lib+import Language.Haskell.TH++{- $options+'Options' gives you a way to further tweak derived 'Generic' and 'Generic1' instances:++* 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit the code+ directly (the 'InlineRep' option). One can also choose to emit a separate type+ synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and+ 'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the+ 'TypeSynonymRep' option).++* 'EmptyCaseOptions': By default, all derived instances for empty data types+ (i.e., data types with no constructors) use 'error' in @from(1)@/@to(1)@.+ For instance, @data Empty@ would have this derived 'Generic' instance:++ @+ instance Generic Empty where+ type Rep Empty = D1 ('MetaData ...) V1+ from _ = M1 (error "No generic representation for empty datatype Empty")+ to (M1 _) = error "No generic representation for empty datatype Empty"+ @++ This matches the behavior of GHC up until 8.4, when derived @Generic(1)@+ instances began to use the @EmptyCase@ extension. In GHC 8.4, the derived+ 'Generic' instance for @Empty@ would instead be:++ @+ instance Generic Empty where+ type Rep Empty = D1 ('MetaData ...) V1+ from x = M1 (case x of {})+ to (M1 x) = case x of {}+ @++ This is a slightly better encoding since, for example, any divergent+ computations passed to 'from' will actually diverge (as opposed to before,+ where the result would always be a call to 'error'). On the other hand, using+ this encoding in @generic-deriving@ has one large drawback: it requires+ enabling @EmptyCase@, an extension which was only introduced in GHC 7.8+ (and only received reliable pattern-match coverage checking in 8.2).++ The 'EmptyCaseOptions' field controls whether code should be emitted that+ uses @EmptyCase@ (i.e., 'EmptyCaseOptions' set to 'True') or not ('False').+ The default value is 'False'. Note that even if set to 'True', this option+ has no effect on GHCs before 7.8, as @EmptyCase@ did not exist then.++* 'KindSigOptions': By default, all derived instances will use explicit kind+ signatures (when the 'KindSigOptions' is 'True'). You might wish to set the+ 'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at+ a particular kind that GHC will infer correctly, but the functions in this+ module won't guess correctly. You probably won't ever need this option+ unless you are a power user.+-}++-- | Additional options for configuring derived 'Generic'/'Generic1' instances+-- using Template Haskell.+data Options = Options+ { repOptions :: RepOptions+ , kindSigOptions :: KindSigOptions+ , emptyCaseOptions :: EmptyCaseOptions+ } deriving (Eq, Ord, Read, Show)++-- | Sensible default 'Options'.+defaultOptions :: Options+defaultOptions = Options+ { repOptions = defaultRepOptions+ , kindSigOptions = defaultKindSigOptions+ , emptyCaseOptions = defaultEmptyCaseOptions+ }++-- | Configures whether 'Rep'/'Rep1' type instances should be defined inline in a+-- derived 'Generic'/'Generic1' instance ('InlineRep') or defined in terms of a+-- type synonym ('TypeSynonymRep').+data RepOptions = InlineRep+ | TypeSynonymRep+ deriving (Eq, Ord, Read, Show)++-- | 'InlineRep', a sensible default 'RepOptions'.+defaultRepOptions :: RepOptions+defaultRepOptions = InlineRep++-- | 'True' if explicit kind signatures should be used in derived+-- 'Generic'/'Generic1' instances, 'False' otherwise.+type KindSigOptions = Bool++-- | 'True', a sensible default 'KindSigOptions'.+defaultKindSigOptions :: KindSigOptions+defaultKindSigOptions = True++-- | 'True' if generated code for empty data types should use the @EmptyCase@+-- extension, 'False' otherwise. This has no effect on GHCs before 7.8, since+-- @EmptyCase@ is only available in 7.8 or later.+type EmptyCaseOptions = Bool++-- | Sensible default 'EmptyCaseOptions'.+defaultEmptyCaseOptions :: EmptyCaseOptions+defaultEmptyCaseOptions = False++-- | A backwards-compatible synonym for 'deriveAll0'.+deriveAll :: Name -> Q [Dec]+deriveAll = deriveAll0++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'+-- instances, and the 'Representable0' instance.+deriveAll0 :: Name -> Q [Dec]+deriveAll0 = deriveAll0Options defaultOptions++-- | Like 'deriveAll0', but takes an 'Options' argument.+deriveAll0Options :: Options -> Name -> Q [Dec]+deriveAll0Options = deriveAllCommon True False++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'+-- instances, and the 'Representable1' instance.+deriveAll1 :: Name -> Q [Dec]+deriveAll1 = deriveAll1Options defaultOptions++-- | Like 'deriveAll1', but takes an 'Options' argument.+deriveAll1Options :: Options -> Name -> Q [Dec]+deriveAll1Options = deriveAllCommon False True++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'+-- instances, the 'Representable0' instance, and the 'Representable1' instance.+deriveAll0And1 :: Name -> Q [Dec]+deriveAll0And1 = deriveAll0And1Options defaultOptions++-- | Like 'deriveAll0And1', but takes an 'Options' argument.+deriveAll0And1Options :: Options -> Name -> Q [Dec]+deriveAll0And1Options = deriveAllCommon True True++deriveAllCommon :: Bool -> Bool -> Options -> Name -> Q [Dec]+deriveAllCommon generic generic1 opts n = do+ a <- deriveMeta n+ b <- if generic+ then deriveRepresentableCommon Generic opts n+ else return []+ c <- if generic1+ then deriveRepresentableCommon Generic1 opts n+ else return []+ return (a ++ b ++ c)++-- | Given the type and the name (as string) for the Representable0 type+-- synonym to derive, generate the 'Representable0' instance.+deriveRepresentable0 :: Name -> Q [Dec]+deriveRepresentable0 = deriveRepresentable0Options defaultOptions++-- | Like 'deriveRepresentable0', but takes an 'Options' argument.+deriveRepresentable0Options :: Options -> Name -> Q [Dec]+deriveRepresentable0Options = deriveRepresentableCommon Generic++-- | Given the type and the name (as string) for the Representable1 type+-- synonym to derive, generate the 'Representable1' instance.+deriveRepresentable1 :: Name -> Q [Dec]+deriveRepresentable1 = deriveRepresentable1Options defaultOptions++-- | Like 'deriveRepresentable1', but takes an 'Options' argument.+deriveRepresentable1Options :: Options -> Name -> Q [Dec]+deriveRepresentable1Options = deriveRepresentableCommon Generic1++deriveRepresentableCommon :: GenericClass -> Options -> Name -> Q [Dec]+deriveRepresentableCommon gClass opts n = do+ rep <- if repOptions opts == InlineRep+ then return []+ else deriveRepCommon gClass (kindSigOptions opts) n+ inst <- deriveInst gClass opts n+ return (rep ++ inst)++-- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'+-- is used.+deriveRep0 :: Name -> Q [Dec]+deriveRep0 = deriveRep0Options defaultKindSigOptions++-- | Like 'deriveRep0', but takes an 'KindSigOptions' argument.+deriveRep0Options :: KindSigOptions -> Name -> Q [Dec]+deriveRep0Options = deriveRepCommon Generic++-- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1'+-- is used.+deriveRep1 :: Name -> Q [Dec]+deriveRep1 = deriveRep1Options defaultKindSigOptions++-- | Like 'deriveRep1', but takes an 'KindSigOptions' argument.+deriveRep1Options :: KindSigOptions -> Name -> Q [Dec]+deriveRep1Options = deriveRepCommon Generic1++deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec]+deriveRepCommon gClass useKindSigs n = do+ i <- reifyDataInfo n+ let (name, instTys, cons, dv) = either error id i+ gt = mkGenericTvbs gClass instTys+ -- See Note [Forcing buildTypeInstance]+ !_ <- buildTypeInstance gClass useKindSigs name instTys++ -- See Note [Kind signatures in derived instances]+ let tySynVars = genericInitTvbs gt+ tySynVars' = if useKindSigs+ then tySynVars+ else map unKindedTV tySynVars+ fmap (:[]) $ tySynD (genRepName gClass dv name)+ (changeTVFlags bndrReq tySynVars')+ (repType gt dv name Map.empty cons)++deriveInst :: GenericClass -> Options -> Name -> Q [Dec]+deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName+deriveInst Generic1 = deriveInstCommon generic1TypeName rep1TypeName Generic1 from1ValName to1ValName++deriveInstCommon :: Name+ -> Name+ -> GenericClass+ -> Name+ -> Name+ -> Options+ -> Name+ -> Q [Dec]+deriveInstCommon genericName repName gClass fromName toName opts n = do+ i <- reifyDataInfo n+ let (name, instTys, cons, dv) = either error id i+ gt = mkGenericTvbs gClass instTys+ useKindSigs = kindSigOptions opts+ -- See Note [Forcing buildTypeInstance]+ !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name instTys+ tyInsRHS <- if repOptions opts == InlineRep+ then repType gt dv name Map.empty cons+ else makeRepTySynApp gClass dv name origTy++ let origSigTy = if useKindSigs+ then SigT origTy origKind+ else origTy+ tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return tyInsRHS)+ let ecOptions = emptyCaseOptions opts+ mkBody maker = [clause []+ (normalB $+ mkCaseExp $+ maker gt ecOptions name cons)+ []]+ fcs = mkBody mkFrom+ tcs = mkBody mkTo++ inline_pragmas+ | inlining_useful cons+#if MIN_VERSION_template_haskell(2,7,0)+ = map (\fun_name ->+ pragInlD fun_name+# if MIN_VERSION_template_haskell(2,8,0)+ Inline FunLike (FromPhase 1)+# else+ (inlineSpecPhase True False True 1)+# endif+ ) [fromName, toName]+#else+ = [] -- Sadly, GHC 7.0 and 7.2 appear to suffer from a bug that+ -- prevents them from attaching INLINE pragmas to class methods+ -- via Template Haskell, so don't bother generating any pragmas at+ -- all for these GHC versions.+#endif+ | otherwise+ = []++ fmap (:[]) $+ instanceD (cxt []) (conT genericName `appT` return origSigTy)+ (inline_pragmas ++ [return tyIns, funD fromName fcs, funD toName tcs])+ where+ -- Adapted from inlining_useful in GHC.Tc.Deriv.Generics.mkBindsRep in the+ -- GHC source code:+ --+ -- https://gitlab.haskell.org/ghc/ghc/-/blob/80729d96e47c99dc38e83612dfcfe01cf565eac0/compiler/GHC/Tc/Deriv/Generics.hs#L368-386+ inlining_useful cons+ | ncons <= 1 = True+ | ncons <= 4 = max_fields <= 5+ | ncons <= 8 = max_fields <= 2+ | ncons <= 16 = max_fields <= 1+ | ncons <= 24 = max_fields == 0+ | otherwise = False+ where+ ncons = length cons+ max_fields = maximum $ map (length . constructorFields) cons++{- $make++There are some data types for which the Template Haskell deriver functions in+this module are not sophisticated enough to infer the correct 'Generic' or+'Generic1' instances. As an example, consider this data type:++@+newtype Fix f a = Fix (f (Fix f a))+@++A proper 'Generic1' instance would look like this:++@+instance Functor f => Generic1 (Fix f) where ...+@++Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint.+One can still define a 'Generic1' instance for @Fix@, however, by using the+functions in this module that are prefixed with @make@-. For example:++@+$('deriveMeta' ''Fix)+$('deriveRep1' ''Fix)+instance Functor f => Generic1 (Fix f) where+ type Rep1 (Fix f) = $('makeRep1Inline' ''Fix [t| Fix f |])+ from1 = $('makeFrom1' ''Fix)+ to1 = $('makeTo1' ''Fix)+@++Note that due to the lack of type-level lambdas in Haskell, one must manually+apply @'makeRep1Inline' ''Fix@ to the type @Fix f@.++Be aware that there is a bug on GHC 7.0, 7.2, and 7.4 which might prevent you from+using 'makeRep0Inline' and 'makeRep1Inline'. In the @Fix@ example above, you+would experience the following error:++@+ Kinded thing `f' used as a type+ In the Template Haskell quotation [t| Fix f |]+@++Then a workaround is to use 'makeRep1' instead, which requires you to:++1. Invoke 'deriveRep1' beforehand++2. Pass as arguments the type variables that occur in the instance, in order+ from left to right, topologically sorted, excluding duplicates. (Normally,+ 'makeRep1Inline' would figure this out for you.)++Using the above example:++@+$('deriveMeta' ''Fix)+$('deriveRep1' ''Fix)+instance Functor f => Generic1 (Fix f) where+ type Rep1 (Fix f) = $('makeRep1' ''Fix) f+ from1 = $('makeFrom1' ''Fix)+ to1 = $('makeTo1' ''Fix)+@++On GHC 7.4, you might encounter more complicated examples involving data+families. For instance:++@+data family Fix a b c d+newtype instance Fix b (f c) (g b) a = Fix (f (Fix b (f c) (g b) a))++$('deriveMeta' ''Fix)+$('deriveRep1' ''Fix)+instance Functor f => Generic1 (Fix b (f c) (g b)) where+ type Rep1 (Fix b (f c) (g b)) = $('makeRep1' 'Fix) b f c g+ from1 = $('makeFrom1' 'Fix)+ to1 = $('makeTo1' 'Fix)+@++Note that you don't pass @b@ twice, only once.+-}++-- | Generates the full 'Rep' type inline. Since this type can be quite+-- large, it is recommended you only use this to define 'Rep', e.g.,+--+-- @+-- type Rep (Foo (a :: k) b) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) b |])+-- @+--+-- You can then simply refer to @Rep (Foo a b)@ elsewhere.+--+-- Note that the type passed as an argument to 'makeRep0Inline' must match the+-- type argument of 'Rep' exactly, even up to including the explicit kind+-- signature on @a@. This is due to a limitation of Template Haskell—without+-- the kind signature, 'makeRep0Inline' has no way of figuring out the kind of+-- @a@, and the generated type might be completely wrong as a result!+makeRep0Inline :: Name -> Q Type -> Q Type+makeRep0Inline n = makeRepCommon Generic InlineRep n . Just++-- | Generates the full 'Rep1' type inline. Since this type can be quite+-- large, it is recommended you only use this to define 'Rep1', e.g.,+--+-- @+-- type Rep1 (Foo (a :: k)) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) |])+-- @+--+-- You can then simply refer to @Rep1 (Foo a)@ elsewhere.+--+-- Note that the type passed as an argument to 'makeRep1Inline' must match the+-- type argument of 'Rep1' exactly, even up to including the explicit kind+-- signature on @a@. This is due to a limitation of Template Haskell—without+-- the kind signature, 'makeRep1Inline' has no way of figuring out the kind of+-- @a@, and the generated type might be completely wrong as a result!+makeRep1Inline :: Name -> Q Type -> Q Type+makeRep1Inline n = makeRepCommon Generic1 InlineRep n . Just++-- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0',+-- which generates the type synonym declaration). After splicing it into+-- Haskell source, it expects types as arguments. For example:+--+-- @+-- type Rep (Foo a b) = $('makeRep0' ''Foo) a b+-- @+--+-- The use of 'makeRep0' is generally discouraged, as it can sometimes be+-- difficult to predict the order in which you are expected to pass type+-- variables. As a result, 'makeRep0Inline' is recommended instead. However,+-- 'makeRep0Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug,+-- so 'makeRep0' still exists for GHC 7.0, 7.2, and 7.4 users.+makeRep0 :: Name -> Q Type+makeRep0 n = makeRepCommon Generic TypeSynonymRep n Nothing++-- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',+-- which generates the type synonym declaration). After splicing it into+-- Haskell source, it expects types as arguments. For example:+--+-- @+-- type Rep1 (Foo a) = $('makeRep1' ''Foo) a+-- @+--+-- The use of 'makeRep1' is generally discouraged, as it can sometimes be+-- difficult to predict the order in which you are expected to pass type+-- variables. As a result, 'makeRep1Inline' is recommended instead. However,+-- 'makeRep1Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug,+-- so 'makeRep1' still exists for GHC 7.0, 7.2, and 7.4 users.+makeRep1 :: Name -> Q Type+makeRep1 n = makeRepCommon Generic1 TypeSynonymRep n Nothing++-- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0',+-- which generates the type synonym declaration) applied to its type arguments.+-- Unlike 'makeRep0', this also takes a quoted 'Type' as an argument, e.g.,+--+-- @+-- type Rep (Foo (a :: k) b) = $('makeRep0FromType' ''Foo [t| Foo (a :: k) b |])+-- @+--+-- Note that the type passed as an argument to 'makeRep0FromType' must match the+-- type argument of 'Rep' exactly, even up to including the explicit kind+-- signature on @a@. This is due to a limitation of Template Haskell—without+-- the kind signature, 'makeRep0FromType' has no way of figuring out the kind of+-- @a@, and the generated type might be completely wrong as a result!+--+-- The use of 'makeRep0FromType' is generally discouraged, since 'makeRep0Inline'+-- does exactly the same thing but without having to go through an intermediate+-- type synonym, and as a result, 'makeRep0Inline' tends to be less buggy.+makeRep0FromType :: Name -> Q Type -> Q Type+makeRep0FromType n = makeRepCommon Generic TypeSynonymRep n . Just++-- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',+-- which generates the type synonym declaration) applied to its type arguments.+-- Unlike 'makeRep1', this also takes a quoted 'Type' as an argument, e.g.,+--+-- @+-- type Rep1 (Foo (a :: k)) = $('makeRep1FromType' ''Foo [t| Foo (a :: k) |])+-- @+--+-- Note that the type passed as an argument to 'makeRep1FromType' must match the+-- type argument of 'Rep' exactly, even up to including the explicit kind+-- signature on @a@. This is due to a limitation of Template Haskell—without+-- the kind signature, 'makeRep1FromType' has no way of figuring out the kind of+-- @a@, and the generated type might be completely wrong as a result!+--+-- The use of 'makeRep1FromType' is generally discouraged, since 'makeRep1Inline'+-- does exactly the same thing but without having to go through an intermediate+-- type synonym, and as a result, 'makeRep1Inline' tends to be less buggy.+makeRep1FromType :: Name -> Q Type -> Q Type+makeRep1FromType n = makeRepCommon Generic1 TypeSynonymRep n . Just++makeRepCommon :: GenericClass+ -> RepOptions+ -> Name+ -> Maybe (Q Type)+ -> Q Type+makeRepCommon gClass repOpts n mbQTy = do+ i <- reifyDataInfo n+ let (name, instTys, cons, dv) = either error id i+ gt = mkGenericTvbs gClass instTys+ -- See Note [Forcing buildTypeInstance]+ !_ <- buildTypeInstance gClass False name instTys++ case (mbQTy, repOpts) of+ (Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name+ (Just qTy, InlineRep) -> qTy >>= makeRepInline gt dv name cons+ (Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name+ (Nothing, InlineRep) -> fail "makeRepCommon"++makeRepInline :: GenericTvbs+ -> DatatypeVariant_+ -> Name+ -> [ConstructorInfo]+ -> Type+ -> Q Type+makeRepInline gt dv name cons ty = do+ let instVars = freeVariablesWellScoped [ty]+ tySynVars = genericInitTvbs gt++ typeSubst :: TypeSubst+ typeSubst = Map.fromList $+ zip (map tvName tySynVars)+ (map (VarT . tvName) instVars)++ repType gt dv name typeSubst cons++makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name+ -> Type -> Q Type+makeRepTySynApp gClass dv name ty =+ -- Here, we figure out the distinct type variables (in order from left-to-right)+ -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind+ -- inferencer can figure out the kinds perfectly well, so we don't need to+ -- give anything here explicit kind signatures.+ let instTvbs = map unKindedTV $ freeVariablesWellScoped [ty]+ in return $ applyTyToTvbs (genRepName gClass dv name) instTvbs++-- | A backwards-compatible synonym for 'makeFrom0'.+makeFrom :: Name -> Q Exp+makeFrom = makeFrom0++-- | Generates a lambda expression which behaves like 'from'.+makeFrom0 :: Name -> Q Exp+makeFrom0 = makeFrom0Options defaultEmptyCaseOptions++-- | Like 'makeFrom0Options', but takes an 'EmptyCaseOptions' argument.+makeFrom0Options :: EmptyCaseOptions -> Name -> Q Exp+makeFrom0Options = makeFunCommon mkFrom Generic++-- | A backwards-compatible synonym for 'makeTo0'.+makeTo :: Name -> Q Exp+makeTo = makeTo0++-- | Generates a lambda expression which behaves like 'to'.+makeTo0 :: Name -> Q Exp+makeTo0 = makeTo0Options defaultEmptyCaseOptions++-- | Like 'makeTo0Options', but takes an 'EmptyCaseOptions' argument.+makeTo0Options :: EmptyCaseOptions -> Name -> Q Exp+makeTo0Options = makeFunCommon mkTo Generic++-- | Generates a lambda expression which behaves like 'from1'.+makeFrom1 :: Name -> Q Exp+makeFrom1 = makeFrom1Options defaultEmptyCaseOptions++-- | Like 'makeFrom1Options', but takes an 'EmptyCaseOptions' argument.+makeFrom1Options :: EmptyCaseOptions -> Name -> Q Exp+makeFrom1Options = makeFunCommon mkFrom Generic1++-- | Generates a lambda expression which behaves like 'to1'.+makeTo1 :: Name -> Q Exp+makeTo1 = makeTo1Options defaultEmptyCaseOptions++-- | Like 'makeTo1Options', but takes an 'EmptyCaseOptions' argument.+makeTo1Options :: EmptyCaseOptions -> Name -> Q Exp+makeTo1Options = makeFunCommon mkTo Generic1++makeFunCommon+ :: (GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match)+ -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp+makeFunCommon maker gClass ecOptions n = do+ i <- reifyDataInfo n+ let (name, instTys, cons, _) = either error id i+ gt = mkGenericTvbs gClass instTys+ -- See Note [Forcing buildTypeInstance]+ buildTypeInstance gClass False name instTys+ `seq` mkCaseExp (maker gt ecOptions name cons)++genRepName :: GenericClass -> DatatypeVariant_+ -> Name -> Name+genRepName gClass dv n+ = mkName+ . showsDatatypeVariant dv+ . (("Rep" ++ show (fromEnum gClass)) ++)+ . ((showNameQual n ++ "_") ++)+ . sanitizeName+ $ nameBase n++repType :: GenericTvbs+ -> DatatypeVariant_+ -> Name+ -> TypeSubst+ -> [ConstructorInfo]+ -> Q Type+repType gt dv dt typeSubst cs =+ conT d1TypeName `appT` mkMetaDataType dv dt `appT`+ foldBal sum' (conT v1TypeName) (map (repCon gt dv dt typeSubst) cs)+ where+ sum' :: Q Type -> Q Type -> Q Type+ sum' a b = conT sumTypeName `appT` a `appT` b++repCon :: GenericTvbs+ -> DatatypeVariant_+ -> Name+ -> TypeSubst+ -> ConstructorInfo+ -> Q Type+repCon gt dv dt typeSubst+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorStrictness = bangs+ , constructorFields = ts+ , constructorVariant = cv+ }) = do+ checkExistentialContext n vars ctxt+ let mbSelNames = case cv of+ NormalConstructor -> Nothing+ InfixConstructor -> Nothing+ RecordConstructor selNames -> Just selNames+ isRecord = case cv of+ NormalConstructor -> False+ InfixConstructor -> False+ RecordConstructor _ -> True+ isInfix = case cv of+ NormalConstructor -> False+ InfixConstructor -> True+ RecordConstructor _ -> False+ ssis <- reifySelStrictInfo n bangs+ repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix++repConWith :: GenericTvbs+ -> DatatypeVariant_+ -> Name+ -> Name+ -> TypeSubst+ -> Maybe [Name]+ -> [SelStrictInfo]+ -> [Type]+ -> Bool+ -> Bool+ -> Q Type+repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do+ let structureType :: Q Type+ structureType = foldBal prodT (conT u1TypeName) f++ f :: [Q Type]+ f = case mbSelNames of+ Just selNames -> zipWith3 (repField gt dv dt n typeSubst . Just)+ selNames ssis ts+ Nothing -> zipWith (repField gt dv dt n typeSubst Nothing)+ ssis ts++ conT c1TypeName+ `appT` mkMetaConsType dv dt n isRecord isInfix+ `appT` structureType++prodT :: Q Type -> Q Type -> Q Type+prodT a b = conT productTypeName `appT` a `appT` b++repField :: GenericTvbs+ -> DatatypeVariant_+ -> Name+ -> Name+ -> TypeSubst+ -> Maybe Name+ -> SelStrictInfo+ -> Type+ -> Q Type+repField gt dv dt ns typeSubst mbF ssi t =+ conT s1TypeName+ `appT` mkMetaSelType dv dt ns mbF ssi+ `appT` (repFieldArg gt =<< resolveTypeSynonyms t'')+ where+ -- See Note [Generic1 is polykinded in base-4.10]+ t', t'' :: Type+ t' = case gt of+ Gen1{gen1LastTvbKindVar = Just _kvName} ->+#if MIN_VERSION_base(4,10,0)+ t+#else+ substNameWithKind _kvName starK t+#endif+ _ -> t+ t'' = applySubstitution typeSubst t'++repFieldArg :: GenericTvbs -> Type -> Q Type+repFieldArg Gen0{} t = boxT t+repFieldArg (Gen1{gen1LastTvbName = name}) (dustOff -> t0) =+ go t0 >>= \res -> case res of+ NoPar -> boxT t0+ ArgRes _ r -> return r+ where+ -- | Returns NoPar if the parameter doesn't appear.+ -- Expects its argument to have been dusted.+ go :: Type -> Q (ArgRes Type)+ go ForallT{} = rankNError+#if MIN_VERSION_template_haskell(2,16,0)+ go ForallVisT{} = rankNError+#endif+ go (VarT t) | t == name = ArgRes True `fmap` conT par1TypeName+ go (AppT f x) = do+ when (not (f `ground` name)) outOfPlaceTyVarError+ mxr <- go (dustOff x)+ case mxr of+ NoPar -> return NoPar+ ArgRes arg_is_param xr -> do+ itf <- isUnsaturatedType f+ when itf typeFamilyApplicationError+ ArgRes False `fmap`+ if arg_is_param+ then+ conT rec1TypeName `appT` return f+ else+ conT composeTypeName `appT` return f `appT` return xr+ go _ = return NoPar++-- | The result of checking the argument. This NoPar+-- means the parameter wasn't there. The Bool is True+-- if the argument *is* the parameter, and False otherwise.+data ArgRes a = NoPar | ArgRes !Bool a++boxT :: Type -> Q Type+boxT ty = case unboxedRepNames ty of+ Just (boxTyName, _, _) -> conT boxTyName+ Nothing -> conT rec0TypeName `appT` return ty++mkCaseExp :: Q Match -> Q Exp+mkCaseExp qMatch = do+ val <- newName "val"+ lam1E (varP val) $ caseE (varE val) [qMatch]++mkFrom :: GenericTvbs -> EmptyCaseOptions -> Name+ -> [ConstructorInfo] -> Q Match+mkFrom gt ecOptions dt cs = do+ y <- newName "y"+ match (varP y)+ (normalB $ conE m1DataName `appE` caseE (varE y) cases)+ []+ where+ cases = case cs of+ [] -> errorFrom ecOptions dt+ _ -> zipWith (fromCon gt id (length cs)) [1..] cs++errorFrom :: EmptyCaseOptions -> Name -> [Q Match]+errorFrom useEmptyCase dt+ | useEmptyCase && ghc7'8OrLater+ = []+ | otherwise+ = [do z <- newName "z"+ match+ (varP z)+ (normalB $+ appE (varE seqValName) (varE z) `appE`+ appE (varE errorValName)+ (stringE $ "No generic representation for empty datatype "+ ++ nameBase dt))+ []]++mkTo :: GenericTvbs -> EmptyCaseOptions -> Name+ -> [ConstructorInfo] -> Q Match+mkTo gt ecOptions dt cs = do+ y <- newName "y"+ match (conP m1DataName [varP y])+ (normalB $ caseE (varE y) cases)+ []+ where+ cases = case cs of+ [] -> errorTo ecOptions dt+ _ -> zipWith (toCon gt id (length cs)) [1..] cs++errorTo :: EmptyCaseOptions -> Name -> [Q Match]+errorTo useEmptyCase dt+ | useEmptyCase && ghc7'8OrLater+ = []+ | otherwise+ = [do z <- newName "z"+ match+ (varP z)+ (normalB $+ appE (varE seqValName) (varE z) `appE`+ appE (varE errorValName)+ (stringE $ "No values for empty datatype " ++ nameBase dt))+ []]++ghc7'8OrLater :: Bool+#if __GLASGOW_HASKELL__ >= 708+ghc7'8OrLater = True+#else+ghc7'8OrLater = False+#endif++fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int+ -> ConstructorInfo -> Q Match+fromCon gt wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ fNames <- newNameList "f" $ length ts+ match (conP cn (map varP fNames))+ (normalB $ wrap $ lrE i m $ conE m1DataName `appE`+ foldBal prodE (conE u1DataName) (zipWith (fromField gt) fNames ts)) []++prodE :: Q Exp -> Q Exp -> Q Exp+prodE x y = conE productDataName `appE` x `appE` y++fromField :: GenericTvbs -> Name -> Type -> Q Exp+fromField gt nr t = conE m1DataName `appE` (fromFieldWrap gt nr =<< resolveTypeSynonyms t)++fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp+fromFieldWrap _ _ ForallT{} = rankNError+fromFieldWrap gt nr (SigT t _) = fromFieldWrap gt nr t+fromFieldWrap Gen0{} nr t = conE (boxRepName t) `appE` varE nr+fromFieldWrap (Gen1{gen1LastTvbName = name}) nr t = wC t name `appE` varE nr++wC :: Type -> Name -> Q Exp+wC (dustOff -> t0) name =+ go t0 >>= \res -> case res of+ NoPar -> conE $ boxRepName t0+ ArgRes _ r -> return r+ where+ -- | Returns NoPar if the parameter doesn't appear.+ -- Expects its argument to have been dusted.+ go :: Type -> Q (ArgRes Exp)+ go ForallT{} = rankNError+#if MIN_VERSION_template_haskell(2,16,0)+ go ForallVisT{} = rankNError+#endif+ go (VarT t) | t == name = ArgRes True `fmap` conE par1DataName+ go (AppT f x) = do+ when (not (f `ground` name)) outOfPlaceTyVarError+ mxr <- go (dustOff x)+ case mxr of+ NoPar -> return NoPar+ ArgRes arg_is_param xr -> do+ itf <- isUnsaturatedType f+ when itf typeFamilyApplicationError+ ArgRes False `fmap`+ if arg_is_param+ then+ conE rec1DataName+ else+ infixApp (conE comp1DataName) (varE composeValName) (varE fmapValName `appE` return xr)+ go _ = return NoPar++boxRepName :: Type -> Name+boxRepName = maybe k1DataName snd3 . unboxedRepNames++toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int+ -> ConstructorInfo -> Q Match+toCon gt wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ fNames <- newNameList "f" $ length ts+ match (wrap $ lrP i m $ conP m1DataName+ [foldBal prod (conP u1DataName []) (zipWith (toField gt) fNames ts)])+ (normalB $ foldl appE (conE cn)+ (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gt nr)+ fNames ts)) []+ where prod x y = conP productDataName [x,y]++toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp+toConUnwC Gen0{} nr _ = varE nr+toConUnwC (Gen1{gen1LastTvbName = name}) nr t = unwC t name `appE` varE nr++toField :: GenericTvbs -> Name -> Type -> Q Pat+toField gt nr t = conP m1DataName [toFieldWrap gt nr t]++toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat+toFieldWrap Gen0{} nr t = conP (boxRepName t) [varP nr]+toFieldWrap Gen1{} nr _ = varP nr++unwC :: Type -> Name -> Q Exp+unwC (dustOff -> t0) name =+ go t0 >>= \res -> case res of+ NoPar -> varE $ unboxRepName t0+ ArgRes _ r -> return r+ where+ -- | Returns NoPar if the parameter doesn't appear.+ -- Expects its argument to have been dusted.+ go :: Type -> Q (ArgRes Exp)+ go ForallT{} = rankNError+#if MIN_VERSION_template_haskell(2,16,0)+ go ForallVisT{} = rankNError+#endif+ go (VarT t) | t == name = ArgRes True `fmap` varE unPar1ValName+ go (AppT f x) = do+ when (not (f `ground` name)) outOfPlaceTyVarError+ mxr <- go (dustOff x)+ case mxr of+ NoPar -> return NoPar+ ArgRes arg_is_param xr -> do+ itf <- isUnsaturatedType f+ when itf typeFamilyApplicationError+ ArgRes False `fmap`+ if arg_is_param+ then+ varE unRec1ValName+ else+ infixApp (varE fmapValName `appE` return xr)+ (varE composeValName)+ (varE unComp1ValName)+ go _ = return NoPar++unboxRepName :: Type -> Name+unboxRepName = maybe unK1ValName trd3 . unboxedRepNames++lrP :: Int -> Int -> (Q Pat -> Q Pat)+lrP i n p+ | n == 0 = fail "lrP: impossible"+ | n == 1 = p+ | i <= div n 2 = conP l1DataName [lrP i (div n 2) p]+ | otherwise = conP r1DataName [lrP (i-m) (n-m) p]+ where m = div n 2++lrE :: Int -> Int -> (Q Exp -> Q Exp)+lrE i n e+ | n == 0 = fail "lrE: impossible"+ | n == 1 = e+ | i <= div n 2 = conE l1DataName `appE` lrE i (div n 2) e+ | otherwise = conE r1DataName `appE` lrE (i-m) (n-m) e+ where m = div n 2++unboxedRepNames :: Type -> Maybe (Name, Name, Name)+unboxedRepNames ty+ | ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName)+ | ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName)+ | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName)+ | ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName)+ | ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName)+ | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName)+ | otherwise = Nothing++-- For the given Types, deduces the instance type (and kind) to use for a+-- Generic(1) instance. Coming up with the instance type isn't as simple as+-- dropping the last types, as you need to be wary of kinds being instantiated+-- with *.+-- See Note [Type inference in derived instances]+buildTypeInstance :: GenericClass+ -- ^ Generic or Generic1+ -> KindSigOptions+ -- ^ Whether or not to use explicit kind signatures in the instance type+ -> Name+ -- ^ The type constructor or data family name+ -> [Type]+ -- ^ The types to instantiate the instance with+ -> Q (Type, Kind)+buildTypeInstance gClass useKindSigs tyConName varTysOrig = do+ -- Make sure to expand through type/kind synonyms! Otherwise, the+ -- eta-reduction check might get tripped up over type variables in a+ -- synonym that are actually dropped.+ -- (See GHC Trac #11416 for a scenario where this actually happened.)+ varTysExp <- mapM resolveTypeSynonyms varTysOrig++ let remainingLength :: Int+ remainingLength = length varTysOrig - fromEnum gClass++#if !(MIN_VERSION_base(4,10,0))+ droppedTysExp :: [Type]+ droppedTysExp = drop remainingLength varTysExp++ droppedStarKindStati :: [StarKindStatus]+ droppedStarKindStati = map canRealizeKindStar droppedTysExp+#endif++ -- Check that:+ --+ -- 1. There are enough types to drop+ --+ -- 2. If using GHC 8.0 or earlier, all types are either of kind * or kind k+ -- (for some kind variable k). See Note [Generic1 is polykinded in base-4.10].+ --+ -- If either of these checks fail, throw an error.+ when (remainingLength < 0+#if !(MIN_VERSION_base(4,10,0))+ || any (== OtherKind) droppedStarKindStati+#endif+ ) $+ derivingKindError tyConName++ -- Substitute kind * for any dropped kind variables+ let varTysExpSubst :: [Type]+-- See Note [Generic1 is polykinded in base-4.10]+#if MIN_VERSION_base(4,10,0)+ varTysExpSubst = varTysExp+#else+ varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp++ droppedKindVarNames :: [Name]+ droppedKindVarNames = catKindVarNames droppedStarKindStati+#endif++ let remainingTysExpSubst, droppedTysExpSubst :: [Type]+ (remainingTysExpSubst, droppedTysExpSubst) =+ splitAt remainingLength varTysExpSubst++-- See Note [Generic1 is polykinded in base-4.10]+#if !(MIN_VERSION_base(4,10,0))+ -- If any of the dropped types were polykinded, ensure that there are of+ -- kind * after substituting * for the dropped kind variables. If not,+ -- throw an error.+ unless (all hasKindStar droppedTysExpSubst) $+ derivingKindError tyConName+#endif++ -- We now substitute all of the specialized-to-* kind variable names+ -- with *, but in the original types, not the synonym-expanded types. The reason+ -- we do this is a superficial one: we want the derived instance to resemble+ -- the datatype written in source code as closely as possible. For example,+ -- for the following data family instance:+ --+ -- data family Fam a+ -- newtype instance Fam String = Fam String+ --+ -- We'd want to generate the instance:+ --+ -- instance C (Fam String)+ --+ -- Not:+ --+ -- instance C (Fam [Char])+ let varTysOrigSubst :: [Type]+ varTysOrigSubst =+-- See Note [Generic1 is polykinded in base-4.10]+#if MIN_VERSION_base(4,10,0)+ id+#else+ map (substNamesWithKindStar droppedKindVarNames)+#endif+ $ varTysOrig++ remainingTysOrigSubst, droppedTysOrigSubst :: [Type]+ (remainingTysOrigSubst, droppedTysOrigSubst) =+ splitAt remainingLength varTysOrigSubst++ remainingTysOrigSubst' :: [Type]+ -- See Note [Kind signatures in derived instances] for an explanation+ -- of the useKindSigs check.+ remainingTysOrigSubst' =+ if useKindSigs+ then remainingTysOrigSubst+ else map unSigT remainingTysOrigSubst++ instanceType :: Type+ instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst'++ -- See Note [Kind signatures in derived instances]+ instanceKind :: Kind+ instanceKind = makeFunKind (map typeKind droppedTysOrigSubst) starK++ -- Ensure the dropped types can be safely eta-reduced. Otherwise,+ -- throw an error.+ unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $+ etaReductionError instanceType+ return (instanceType, instanceKind)++{-+Note [Forcing buildTypeInstance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Sometimes, we don't explicitly need to generate a Generic(1) type instance, but+we force buildTypeInstance nevertheless. This is because it performs some checks+for whether or not the provided datatype can actually have Generic(1) implemented for+it, and produces errors if it can't. Otherwise, laziness would cause these checks+to be skipped entirely, which could result in some indecipherable type errors+down the road.++Note [Kind signatures in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We generally include explicit type signatures in derived instances. One reason for+doing so is that in the case of certain data family instances, not including kind+signatures can result in ambiguity. For example, consider the following two data+family instances that are distinguished by their kinds:++ data family Fam (a :: k)+ data instance Fam (a :: * -> *)+ data instance Fam (a :: *)++If we dropped the kind signature for a in a derived instance for Fam a, then GHC+would have no way of knowing which instance we are talking about.++In addition to using explicit kind signatures in the instance head, we also put+explicit kinds in the associated Rep(1) instance. For example, this data type:++ data S (a :: k) = S k++Will have the following Generic1 instance generated for it:++ instance Generic1 (S :: k -> *) where+ type Rep1 (S :: k -> *) = ... (Rec0 k)++Why do we do this? Imagine what the instance would be without the explicit kind+annotation in the Rep1 instance:++ instance Generic1 S where+ type Rep1 S = ... (Rec0 k)++This is an error, since the variable k is now out-of-scope!++In the rare event that attaching explicit kind annotations does the wrong+thing, there are variants of the TH functions that allow configuring the+KindSigOptions. If KindSigOptions is set to False, then generated instances+will not include explicit kind signatures, leaving it up to GHC's kind+inference machinery to figure out the correct kinds.++Note [Generic1 is polykinded in base-4.10]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Prior to base-4.10, Generic1 :: (* -> *) -> Constraint. This means that if a Generic1+instance is defined for a polykinded data type like so:++ data Proxy k (a :: k) = Proxy++Then k is unified with *, and this has an effect on the generated Generic1 instance:++ instance Generic1 (Proxy *) where ...++We must take great care to ensure that all occurrences of k are substituted with *,+or else the generated instance will be ill kinded.++In base-4.10 and later, Generic1 :: (k -> *) -> Constraint. This means we don't have+to do any of this kind unification trickery anymore! Hooray!+-}
src/Generics/Deriving/TH/Internal.hs view
@@ -1,951 +1,1251 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} - -{- | -Module : Generics.Deriving.TH.Internal -Copyright : (c) 2008--2009 Universiteit Utrecht -License : BSD3 - -Maintainer : generics@haskell.org -Stability : experimental -Portability : non-portable - -Template Haskell-related utilities. --} - -module Generics.Deriving.TH.Internal where - -import Control.Monad (unless) - -import Data.Char (isAlphaNum, ord) -import Data.Foldable (foldr') -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Map as Map (Map) -import Data.Maybe (mapMaybe) -import qualified Data.Set as Set -import Data.Set (Set) - -import Language.Haskell.TH.Datatype as Datatype -import Language.Haskell.TH.Datatype.TyVarBndr -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr (pprint) -import Language.Haskell.TH.Syntax - -#ifndef CURRENT_PACKAGE_KEY -import Data.Version (showVersion) -import Paths_generic_deriving (version) -#endif - -------------------------------------------------------------------------------- --- Expanding type synonyms -------------------------------------------------------------------------------- - -type TypeSubst = Map Name Type - -applySubstitutionKind :: Map Name Kind -> Type -> Type -#if MIN_VERSION_template_haskell(2,8,0) -applySubstitutionKind = applySubstitution -#else -applySubstitutionKind _ t = t -#endif - -substNameWithKind :: Name -> Kind -> Type -> Type -substNameWithKind n k = applySubstitutionKind (Map.singleton n k) - -substNamesWithKindStar :: [Name] -> Type -> Type -substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns - -------------------------------------------------------------------------------- --- StarKindStatus -------------------------------------------------------------------------------- - --- | Whether a type is of kind @*@, a kind variable, or some other kind. The --- kind variable case is given special treatment solely to support GHC 8.0 and --- earlier, in which Generic1 was not poly-kinded. In order to support deriving --- Generic1 instances on these versions of GHC, we must substitute such kinds --- with @*@ to ensure that the resulting instance is well kinded. --- See @Note [Generic1 is polykinded in base-4.10]@ in "Generics.Deriving.TH". -data StarKindStatus = KindStar - | IsKindVar Name - | OtherKind - deriving Eq - --- | Does a Type have kind * or k (for some kind variable k)? -canRealizeKindStar :: Type -> StarKindStatus -canRealizeKindStar t - | hasKindStar t = KindStar - | otherwise = case t of -#if MIN_VERSION_template_haskell(2,8,0) - SigT _ (VarT k) -> IsKindVar k -#endif - _ -> OtherKind - --- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. --- Otherwise, returns 'Nothing'. -starKindStatusToName :: StarKindStatus -> Maybe Name -starKindStatusToName (IsKindVar n) = Just n -starKindStatusToName _ = Nothing - --- | Concat together all of the StarKindStatuses that are IsKindVar and extract --- the kind variables' Names out. -catKindVarNames :: [StarKindStatus] -> [Name] -catKindVarNames = mapMaybe starKindStatusToName - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - --- | Returns True if a Type has kind *. -hasKindStar :: Type -> Bool -hasKindStar VarT{} = True -#if MIN_VERSION_template_haskell(2,8,0) -hasKindStar (SigT _ StarT) = True -#else -hasKindStar (SigT _ StarK) = True -#endif -hasKindStar _ = False - --- | Converts a VarT or a SigT into Just the corresponding TyVarBndr. --- Converts other Types to Nothing. -typeToTyVarBndr :: Type -> Maybe TyVarBndrUnit -typeToTyVarBndr (VarT n) = Just (plainTV n) -typeToTyVarBndr (SigT (VarT n) k) = Just (kindedTV n k) -typeToTyVarBndr _ = Nothing - --- | If a Type is a SigT, returns its kind signature. Otherwise, return *. -typeKind :: Type -> Kind -typeKind (SigT _ k) = k -typeKind _ = starK - --- | Turns --- --- @ --- [a, b] c --- @ --- --- into --- --- @ --- a -> b -> c --- @ -makeFunType :: [Type] -> Type -> Type -makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys - --- | Turns --- --- @ --- [k1, k2] k3 --- @ --- --- into --- --- @ --- k1 -> k2 -> k3 --- @ -makeFunKind :: [Kind] -> Kind -> Kind -#if MIN_VERSION_template_haskell(2,8,0) -makeFunKind = makeFunType -#else -makeFunKind argKinds resKind = foldr' ArrowK resKind argKinds -#endif - --- | Remove any outer `SigT` and `ParensT` constructors, and turn --- an outermost `InfixT` constructor into plain applications. -dustOff :: Type -> Type -dustOff (SigT ty _) = dustOff ty -#if MIN_VERSION_template_haskell(2,11,0) -dustOff (ParensT ty) = dustOff ty -dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2 -#endif -dustOff ty = ty - --- | Checks whether a type is an unsaturated type family --- application. -isUnsaturatedType :: Type -> Q Bool -isUnsaturatedType = go 0 . dustOff - where - -- Expects its argument to be dusted - go :: Int -> Type -> Q Bool - go d t = case t of - ConT tcName -> check d tcName - AppT f _ -> go (d + 1) (dustOff f) - _ -> return False - - check :: Int -> Name -> Q Bool - check d tcName = do - mbinders <- getTypeFamilyBinders tcName - return $ case mbinders of - Just bndrs -> length bndrs > d - Nothing -> False - --- | Given a name, check if that name is a type family. If --- so, return a list of its binders. -getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndr_ ()]) -getTypeFamilyBinders tcName = do - info <- reify tcName - return $ case info of -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ - -> Just bndrs -#elif MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD TypeFam _ bndrs _) _ - -> Just bndrs -#else - TyConI (FamilyD TypeFam _ bndrs _) - -> Just bndrs -#endif - -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ - -> Just bndrs -#elif MIN_VERSION_template_haskell(2,9,0) - FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ - -> Just bndrs -#endif - - _ -> Nothing - --- | True if the type does not mention the Name -ground :: Type -> Name -> Bool -ground ty name = name `notElem` freeVariables ty - --- | Construct a type via curried application. -applyTyToTys :: Type -> [Type] -> Type -applyTyToTys = List.foldl' AppT - --- | Apply a type constructor name to type variable binders. -applyTyToTvbs :: Name -> [TyVarBndr_ flag] -> Type -applyTyToTvbs = List.foldl' (\a -> AppT a . tyVarBndrToType) . ConT - --- | Split a type signature by the arrows on its spine. For example, this: --- --- @ --- forall a b. (a -> b) -> Char -> () --- @ --- --- would split to this: --- --- @ --- ([a, b], [a -> b, Char, ()]) --- @ -uncurryTy :: Type -> ([TyVarBndrSpec], [Type]) -uncurryTy (AppT (AppT ArrowT t1) t2) = - let (tvbs, tys) = uncurryTy t2 - in (tvbs, t1:tys) -uncurryTy (SigT t _) = uncurryTy t -uncurryTy (ForallT tvbs _ t) = - let (tvbs', tys) = uncurryTy t - in (tvbs ++ tvbs', tys) -uncurryTy t = ([], [t]) - --- | Like uncurryType, except on a kind level. -uncurryKind :: Kind -> ([TyVarBndrSpec], [Kind]) -#if MIN_VERSION_template_haskell(2,8,0) -uncurryKind = uncurryTy -#else -uncurryKind (ArrowK k1 k2) = - let (kvbs, ks) = uncurryKind k2 - in (kvbs, k1:ks) -uncurryKind k = ([], [k]) -#endif - -tyVarBndrToType :: TyVarBndr_ flag -> Type -tyVarBndrToType = elimTV VarT (\n k -> SigT (VarT n) k) - --- | Generate a list of fresh names with a common prefix, and numbered suffixes. -newNameList :: String -> Int -> Q [Name] -newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] - --- | Checks to see if the last types in a data family instance can be safely eta- --- reduced (i.e., dropped), given the other types. This checks for three conditions: --- --- (1) All of the dropped types are type variables --- (2) All of the dropped types are distinct --- (3) None of the remaining types mention any of the dropped types -canEtaReduce :: [Type] -> [Type] -> Bool -canEtaReduce remaining dropped = - all isTyVar dropped - -- Make sure not to pass something of type [Type], since Type - -- didn't have an Ord instance until template-haskell-2.10.0.0 - && allDistinct droppedNames - && not (any (`mentionsName` droppedNames) remaining) - where - droppedNames :: [Name] - droppedNames = map varTToName dropped - --- | Extract the Name from a type variable. If the argument Type is not a --- type variable, throw an error. -varTToName :: Type -> Name -varTToName (VarT n) = n -varTToName (SigT t _) = varTToName t -varTToName _ = error "Not a type variable!" - --- | Is the given type a variable? -isTyVar :: Type -> Bool -isTyVar VarT{} = True -isTyVar (SigT t _) = isTyVar t -isTyVar _ = False - --- | Is the given kind a variable? -isKindVar :: Kind -> Bool -#if MIN_VERSION_template_haskell(2,8,0) -isKindVar = isTyVar -#else -isKindVar _ = False -- There are no kind variables -#endif - --- | Returns 'True' is a 'Type' contains no type variables. -isTypeMonomorphic :: Type -> Bool -isTypeMonomorphic = go - where - go :: Type -> Bool - go (AppT t1 t2) = go t1 && go t2 - go (SigT t _k) = go t -#if MIN_VERSION_template_haskell(2,8,0) - && go _k -#endif - go VarT{} = False - go _ = True - --- | Peel off a kind signature from a Type (if it has one). -unSigT :: Type -> Type -unSigT (SigT t _) = t -unSigT t = t - --- | Peel off a kind signature from a TyVarBndr (if it has one). -unKindedTV :: TyVarBndrUnit -> TyVarBndrUnit -unKindedTV tvb = elimTV (\_ -> tvb) (\n _ -> plainTV n) tvb - --- | Does the given type mention any of the Names in the list? -mentionsName :: Type -> [Name] -> Bool -mentionsName = go - where - go :: Type -> [Name] -> Bool - go (AppT t1 t2) names = go t1 names || go t2 names - go (SigT t _k) names = go t names -#if MIN_VERSION_template_haskell(2,8,0) - || go _k names -#endif - go (VarT n) names = n `elem` names - go _ _ = False - --- | Are all of the items in a list (which have an ordering) distinct? --- --- This uses Set (as opposed to nub) for better asymptotic time complexity. -allDistinct :: Ord a => [a] -> Bool -allDistinct = allDistinct' Set.empty - where - allDistinct' :: Ord a => Set a -> [a] -> Bool - allDistinct' uniqs (x:xs) - | x `Set.member` uniqs = False - | otherwise = allDistinct' (Set.insert x uniqs) xs - allDistinct' _ _ = True - -fst3 :: (a, b, c) -> a -fst3 (a, _, _) = a - -snd3 :: (a, b, c) -> b -snd3 (_, b, _) = b - -trd3 :: (a, b, c) -> c -trd3 (_, _, c) = c - -shrink :: (a, b, c) -> (b, c) -shrink (_, b, c) = (b, c) - -foldBal :: (a -> a -> a) -> a -> [a] -> a -{-# INLINE foldBal #-} -- inlined to produce specialised code for each op -foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0 - where - fold_bal op x !n xs = case xs of - [] -> x - [a] -> a - _ -> let !nl = n `div` 2 - !nr = n - nl - (l,r) = splitAt nl xs - in fold_bal op x nl l - `op` fold_bal op x nr r - -isNewtypeVariant :: DatatypeVariant_ -> Bool -isNewtypeVariant Datatype_ = False -isNewtypeVariant Newtype_ = True -isNewtypeVariant (DataInstance_ {}) = False -isNewtypeVariant (NewtypeInstance_ {}) = True - --- | Indicates whether Generic or Generic1 is being derived. -data GenericClass = Generic | Generic1 deriving Enum - --- | Records information about the type variables of a data type with a --- 'Generic' or 'Generic1' instance. -data GenericTvbs - -- | Information about a data type with a 'Generic' instance. - = Gen0 - { gen0Tvbs :: [TyVarBndrUnit] - -- ^ All of the type variable arguments to the data type. - } - -- | Information about a data type with a 'Generic1' instance. - | Gen1 - { gen1InitTvbs :: [TyVarBndrUnit] - -- ^ All of the type variable arguments to the data type except the - -- last one. In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the - -- 'gen1InitTvbs' would be @[a_1, ..., a_(n-1)]@. - , gen1LastTvbName :: Name - -- ^ The name of the last type variable argument to the data type. - -- In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the - -- 'gen1LastTvbName' name would be @a_n@. - , gen1LastTvbKindVar :: Maybe Name - -- ^ If the 'gen1LastTvbName' has kind @k@, where @k@ is some kind - -- variable, then the 'gen1LastTvbKindVar' is @'Just' k@. Otherwise, - -- the 'gen1LastTvbKindVar' is 'Nothing'. - } - --- | Compute 'GenericTvbs' from a 'GenericClass' and the type variable --- arguments to a data type. -mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs -mkGenericTvbs gClass tySynVars = - case gClass of - Generic -> Gen0{gen0Tvbs = freeVariablesWellScoped tySynVars} - Generic1 -> Gen1{ gen1InitTvbs = freeVariablesWellScoped initArgs - , gen1LastTvbName = varTToName lastArg - , gen1LastTvbKindVar = mbLastArgKindName - } - where - -- Everything below is only used for Generic1. - initArgs :: [Type] - initArgs = init tySynVars - - lastArg :: Type - lastArg = last tySynVars - - mbLastArgKindName :: Maybe Name - mbLastArgKindName = starKindStatusToName - $ canRealizeKindStar lastArg - --- | Return the type variable arguments to a data type that appear in a --- 'Generic' or 'Generic1' instance. For a 'Generic' instance, this consists of --- all the type variable arguments. For a 'Generic1' instance, this consists of --- all the type variable arguments except for the last one. -genericInitTvbs :: GenericTvbs -> [TyVarBndrUnit] -genericInitTvbs (Gen0{gen0Tvbs = tvbs}) = tvbs -genericInitTvbs (Gen1{gen1InitTvbs = tvbs}) = tvbs - --- | A version of 'DatatypeVariant' in which the data family instance --- constructors come equipped with the 'ConstructorInfo' of the first --- constructor in the family instance (for 'Name' generation purposes). -data DatatypeVariant_ - = Datatype_ - | Newtype_ - | DataInstance_ ConstructorInfo - | NewtypeInstance_ ConstructorInfo - -showsDatatypeVariant :: DatatypeVariant_ -> ShowS -showsDatatypeVariant variant = (++ '_':label) - where - dataPlain :: String - dataPlain = "Plain" - - dataFamily :: ConstructorInfo -> String - dataFamily con = "Family_" ++ sanitizeName (nameBase $ constructorName con) - - label :: String - label = case variant of - Datatype_ -> dataPlain - Newtype_ -> dataPlain - DataInstance_ con -> dataFamily con - NewtypeInstance_ con -> dataFamily con - -showNameQual :: Name -> String -showNameQual = sanitizeName . showQual - where - showQual (Name _ (NameQ m)) = modString m - showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m - showQual _ = "" - --- | Credit to Víctor López Juan for this trick -sanitizeName :: String -> String -sanitizeName nb = 'N':( - nb >>= \x -> case x of - c | isAlphaNum c || c == '\''-> [c] - '_' -> "__" - c -> "_" ++ show (ord c)) - --- | One of the last type variables cannot be eta-reduced (see the canEtaReduce --- function for the criteria it would have to meet). -etaReductionError :: Type -> Q a -etaReductionError instanceType = fail $ - "Cannot eta-reduce to an instance of form \n\tinstance (...) => " - ++ pprint instanceType - --- | Either the given data type doesn't have enough type variables, or one of --- the type variables to be eta-reduced cannot realize kind *. -derivingKindError :: Name -> Q a -derivingKindError tyConName = fail - . showString "Cannot derive well-kinded instance of form ‘Generic1 " - . showParen True - ( showString (nameBase tyConName) - . showString " ..." - ) - . showString "‘\n\tClass Generic1 expects an argument of kind " -#if MIN_VERSION_base(4,10,0) - . showString "k -> *" -#else - . showString "* -> *" -#endif - $ "" - --- | The data type mentions the last type variable in a place other --- than the last position of a data type in a constructor's field. -outOfPlaceTyVarError :: Q a -outOfPlaceTyVarError = fail - . showString "Constructor must only use its last type variable as" - . showString " the last argument of a data type" - $ "" - --- | The data type mentions the last type variable in a type family --- application. -typeFamilyApplicationError :: Q a -typeFamilyApplicationError = fail - . showString "Constructor must not apply its last type variable" - . showString " to an unsaturated type family" - $ "" - --- | We cannot define implementations for @from(1)@ or @to(1)@ at the term level --- for @type data@ declarations, which only exist at the type level. -typeDataError :: Name -> Q a -typeDataError dataName = fail - . showString "Cannot derive instance for ‘" - . showString (nameBase dataName) - . showString "‘, which is a ‘type data‘ declaration" - $ "" - --- | Cannot have a constructor argument of form (forall a1 ... an. <type>) --- when deriving Generic(1) -rankNError :: Q a -rankNError = fail "Cannot have polymorphic arguments" - --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -reifyDataInfo :: Name - -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)) -reifyDataInfo name = do - return $ Left $ ns ++ " Could not reify " ++ nameBase name - `recover` - do DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = tys - , datatypeVariant = variant - , datatypeCons = cons - } <- reifyDatatype name - variant_ <- case variant of - Datatype -> return Datatype_ - Newtype -> return Newtype_ - -- This isn't total, but the API requires that the data - -- family instance have at least one constructor anyways, - -- so this will always succeed. - DataInstance -> return $ DataInstance_ $ head cons - NewtypeInstance -> return $ NewtypeInstance_ $ head cons -#if MIN_VERSION_th_abstraction(0,5,0) - Datatype.TypeData -> typeDataError parentName -#endif - checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_) - where - ns :: String - ns = "Generics.Deriving.TH.reifyDataInfo: " - --- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts, --- so check to make sure the Cxt field of a datatype is null. -checkDataContext :: Name -> Cxt -> a -> Q a -checkDataContext _ [] x = return x -checkDataContext dataName _ _ = fail $ - nameBase dataName ++ " must not have a datatype context" - --- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs. -checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q () -checkExistentialContext conName vars ctxt = - unless (null vars && null ctxt) $ fail $ - nameBase conName ++ " must be a vanilla data constructor" - -------------------------------------------------------------------------------- --- Manually quoted names -------------------------------------------------------------------------------- - --- By manually generating these names we avoid needing to use the --- TemplateHaskell language extension when compiling the generic-deriving library. --- This allows the library to be used in stage1 cross-compilers. - -gdPackageKey :: String -#ifdef CURRENT_PACKAGE_KEY -gdPackageKey = CURRENT_PACKAGE_KEY -#else -gdPackageKey = "generic-deriving-" ++ showVersion version -#endif - -mkGD4'4_d :: String -> Name -#if MIN_VERSION_base(4,6,0) -mkGD4'4_d = mkNameG_d "base" "GHC.Generics" -#elif MIN_VERSION_base(4,4,0) -mkGD4'4_d = mkNameG_d "ghc-prim" "GHC.Generics" -#else -mkGD4'4_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" -#endif - -mkGD4'9_d :: String -> Name -#if MIN_VERSION_base(4,9,0) -mkGD4'9_d = mkNameG_d "base" "GHC.Generics" -#else -mkGD4'9_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" -#endif - -mkGD4'4_tc :: String -> Name -#if MIN_VERSION_base(4,6,0) -mkGD4'4_tc = mkNameG_tc "base" "GHC.Generics" -#elif MIN_VERSION_base(4,4,0) -mkGD4'4_tc = mkNameG_tc "ghc-prim" "GHC.Generics" -#else -mkGD4'4_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" -#endif - -mkGD4'9_tc :: String -> Name -#if MIN_VERSION_base(4,9,0) -mkGD4'9_tc = mkNameG_tc "base" "GHC.Generics" -#else -mkGD4'9_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" -#endif - -mkGD4'4_v :: String -> Name -#if MIN_VERSION_base(4,6,0) -mkGD4'4_v = mkNameG_v "base" "GHC.Generics" -#elif MIN_VERSION_base(4,4,0) -mkGD4'4_v = mkNameG_v "ghc-prim" "GHC.Generics" -#else -mkGD4'4_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" -#endif - -mkGD4'9_v :: String -> Name -#if MIN_VERSION_base(4,9,0) -mkGD4'9_v = mkNameG_v "base" "GHC.Generics" -#else -mkGD4'9_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" -#endif - -mkBaseName_d :: String -> String -> Name -mkBaseName_d = mkNameG_d "base" - -mkGHCPrimName_d :: String -> String -> Name -mkGHCPrimName_d = mkNameG_d "ghc-prim" - -mkGHCPrimName_tc :: String -> String -> Name -mkGHCPrimName_tc = mkNameG_tc "ghc-prim" - -mkGHCPrimName_v :: String -> String -> Name -mkGHCPrimName_v = mkNameG_v "ghc-prim" - -comp1DataName :: Name -comp1DataName = mkGD4'4_d "Comp1" - -infixDataName :: Name -infixDataName = mkGD4'4_d "Infix" - -k1DataName :: Name -k1DataName = mkGD4'4_d "K1" - -l1DataName :: Name -l1DataName = mkGD4'4_d "L1" - -leftAssociativeDataName :: Name -leftAssociativeDataName = mkGD4'4_d "LeftAssociative" - -m1DataName :: Name -m1DataName = mkGD4'4_d "M1" - -notAssociativeDataName :: Name -notAssociativeDataName = mkGD4'4_d "NotAssociative" - -par1DataName :: Name -par1DataName = mkGD4'4_d "Par1" - -prefixDataName :: Name -prefixDataName = mkGD4'4_d "Prefix" - -productDataName :: Name -productDataName = mkGD4'4_d ":*:" - -r1DataName :: Name -r1DataName = mkGD4'4_d "R1" - -rec1DataName :: Name -rec1DataName = mkGD4'4_d "Rec1" - -rightAssociativeDataName :: Name -rightAssociativeDataName = mkGD4'4_d "RightAssociative" - -u1DataName :: Name -u1DataName = mkGD4'4_d "U1" - -uAddrDataName :: Name -uAddrDataName = mkGD4'9_d "UAddr" - -uCharDataName :: Name -uCharDataName = mkGD4'9_d "UChar" - -uDoubleDataName :: Name -uDoubleDataName = mkGD4'9_d "UDouble" - -uFloatDataName :: Name -uFloatDataName = mkGD4'9_d "UFloat" - -uIntDataName :: Name -uIntDataName = mkGD4'9_d "UInt" - -uWordDataName :: Name -uWordDataName = mkGD4'9_d "UWord" - -c1TypeName :: Name -c1TypeName = mkGD4'4_tc "C1" - -composeTypeName :: Name -composeTypeName = mkGD4'4_tc ":.:" - -constructorTypeName :: Name -constructorTypeName = mkGD4'4_tc "Constructor" - -d1TypeName :: Name -d1TypeName = mkGD4'4_tc "D1" - -genericTypeName :: Name -genericTypeName = mkGD4'4_tc "Generic" - -generic1TypeName :: Name -generic1TypeName = mkGD4'4_tc "Generic1" - -datatypeTypeName :: Name -datatypeTypeName = mkGD4'4_tc "Datatype" - -noSelectorTypeName :: Name -noSelectorTypeName = mkGD4'4_tc "NoSelector" - -par1TypeName :: Name -par1TypeName = mkGD4'4_tc "Par1" - -productTypeName :: Name -productTypeName = mkGD4'4_tc ":*:" - -rec0TypeName :: Name -rec0TypeName = mkGD4'4_tc "Rec0" - -rec1TypeName :: Name -rec1TypeName = mkGD4'4_tc "Rec1" - -repTypeName :: Name -repTypeName = mkGD4'4_tc "Rep" - -rep1TypeName :: Name -rep1TypeName = mkGD4'4_tc "Rep1" - -s1TypeName :: Name -s1TypeName = mkGD4'4_tc "S1" - -selectorTypeName :: Name -selectorTypeName = mkGD4'4_tc "Selector" - -sumTypeName :: Name -sumTypeName = mkGD4'4_tc ":+:" - -u1TypeName :: Name -u1TypeName = mkGD4'4_tc "U1" - -uAddrTypeName :: Name -uAddrTypeName = mkGD4'9_tc "UAddr" - -uCharTypeName :: Name -uCharTypeName = mkGD4'9_tc "UChar" - -uDoubleTypeName :: Name -uDoubleTypeName = mkGD4'9_tc "UDouble" - -uFloatTypeName :: Name -uFloatTypeName = mkGD4'9_tc "UFloat" - -uIntTypeName :: Name -uIntTypeName = mkGD4'9_tc "UInt" - -uWordTypeName :: Name -uWordTypeName = mkGD4'9_tc "UWord" - -v1TypeName :: Name -v1TypeName = mkGD4'4_tc "V1" - -conFixityValName :: Name -conFixityValName = mkGD4'4_v "conFixity" - -conIsRecordValName :: Name -conIsRecordValName = mkGD4'4_v "conIsRecord" - -conNameValName :: Name -conNameValName = mkGD4'4_v "conName" - -datatypeNameValName :: Name -datatypeNameValName = mkGD4'4_v "datatypeName" - -isNewtypeValName :: Name -isNewtypeValName = mkGD4'4_v "isNewtype" - -fromValName :: Name -fromValName = mkGD4'4_v "from" - -from1ValName :: Name -from1ValName = mkGD4'4_v "from1" - -moduleNameValName :: Name -moduleNameValName = mkGD4'4_v "moduleName" - -selNameValName :: Name -selNameValName = mkGD4'4_v "selName" - -seqValName :: Name -seqValName = mkGHCPrimName_v "GHC.Prim" "seq" - -toValName :: Name -toValName = mkGD4'4_v "to" - -to1ValName :: Name -to1ValName = mkGD4'4_v "to1" - -uAddrHashValName :: Name -uAddrHashValName = mkGD4'9_v "uAddr#" - -uCharHashValName :: Name -uCharHashValName = mkGD4'9_v "uChar#" - -uDoubleHashValName :: Name -uDoubleHashValName = mkGD4'9_v "uDouble#" - -uFloatHashValName :: Name -uFloatHashValName = mkGD4'9_v "uFloat#" - -uIntHashValName :: Name -uIntHashValName = mkGD4'9_v "uInt#" - -uWordHashValName :: Name -uWordHashValName = mkGD4'9_v "uWord#" - -unComp1ValName :: Name -unComp1ValName = mkGD4'4_v "unComp1" - -unK1ValName :: Name -unK1ValName = mkGD4'4_v "unK1" - -unPar1ValName :: Name -unPar1ValName = mkGD4'4_v "unPar1" - -unRec1ValName :: Name -unRec1ValName = mkGD4'4_v "unRec1" - -trueDataName, falseDataName :: Name -#if MIN_VERSION_base(4,4,0) -trueDataName = mkGHCPrimName_d "GHC.Types" "True" -falseDataName = mkGHCPrimName_d "GHC.Types" "False" -#else -trueDataName = mkGHCPrimName_d "GHC.Bool" "True" -falseDataName = mkGHCPrimName_d "GHC.Bool" "False" -#endif - -nothingDataName, justDataName :: Name -#if MIN_VERSION_base(4,12,0) -nothingDataName = mkBaseName_d "GHC.Maybe" "Nothing" -justDataName = mkBaseName_d "GHC.Maybe" "Just" -#elif MIN_VERSION_base(4,8,0) -nothingDataName = mkBaseName_d "GHC.Base" "Nothing" -justDataName = mkBaseName_d "GHC.Base" "Just" -#else -nothingDataName = mkBaseName_d "Data.Maybe" "Nothing" -justDataName = mkBaseName_d "Data.Maybe" "Just" -#endif - -mkGHCPrim_tc :: String -> Name -mkGHCPrim_tc = mkNameG_tc "ghc-prim" "GHC.Prim" - -addrHashTypeName :: Name -addrHashTypeName = mkGHCPrim_tc "Addr#" - -charHashTypeName :: Name -charHashTypeName = mkGHCPrim_tc "Char#" - -doubleHashTypeName :: Name -doubleHashTypeName = mkGHCPrim_tc "Double#" - -floatHashTypeName :: Name -floatHashTypeName = mkGHCPrim_tc "Float#" - -intHashTypeName :: Name -intHashTypeName = mkGHCPrim_tc "Int#" - -wordHashTypeName :: Name -wordHashTypeName = mkGHCPrim_tc "Word#" - -composeValName :: Name -composeValName = mkNameG_v "base" "GHC.Base" "." - -errorValName :: Name -errorValName = mkNameG_v "base" "GHC.Err" "error" - -fmapValName :: Name -fmapValName = mkNameG_v "base" "GHC.Base" "fmap" - -undefinedValName :: Name -undefinedValName = mkNameG_v "base" "GHC.Err" "undefined" - -decidedLazyDataName :: Name -decidedLazyDataName = mkGD4'9_d "DecidedLazy" - -decidedStrictDataName :: Name -decidedStrictDataName = mkGD4'9_d "DecidedStrict" - -decidedUnpackDataName :: Name -decidedUnpackDataName = mkGD4'9_d "DecidedUnpack" - -infixIDataName :: Name -infixIDataName = mkGD4'9_d "InfixI" - -metaConsDataName :: Name -metaConsDataName = mkGD4'9_d "MetaCons" - -metaDataDataName :: Name -metaDataDataName = mkGD4'9_d "MetaData" - -metaNoSelDataName :: Name -metaNoSelDataName = mkGD4'9_d "MetaNoSel" - -metaSelDataName :: Name -metaSelDataName = mkGD4'9_d "MetaSel" - -noSourceStrictnessDataName :: Name -noSourceStrictnessDataName = mkGD4'9_d "NoSourceStrictness" - -noSourceUnpackednessDataName :: Name -noSourceUnpackednessDataName = mkGD4'9_d "NoSourceUnpackedness" - -prefixIDataName :: Name -prefixIDataName = mkGD4'9_d "PrefixI" - -sourceLazyDataName :: Name -sourceLazyDataName = mkGD4'9_d "SourceLazy" - -sourceNoUnpackDataName :: Name -sourceNoUnpackDataName = mkGD4'9_d "SourceNoUnpack" - -sourceStrictDataName :: Name -sourceStrictDataName = mkGD4'9_d "SourceStrict" - -sourceUnpackDataName :: Name -sourceUnpackDataName = mkGD4'9_d "SourceUnpack" - -packageNameValName :: Name -packageNameValName = mkGD4'4_v "packageName" +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#endif++{- |+Module : Generics.Deriving.TH.Internal+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell-related utilities.+-}++module Generics.Deriving.TH.Internal where++import Control.Monad (unless)++import Data.Char (isAlphaNum, ord)+import Data.Foldable (foldr')+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Map as Map (Map)+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Data.Set (Set)++import Language.Haskell.TH.Datatype as Datatype+import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr (pprint)+import Language.Haskell.TH.Syntax++#if __GLASGOW_HASKELL__ >= 800+import qualified Generics.Deriving as GD+import Generics.Deriving hiding+ ( DecidedStrictness(..), Fixity(Infix)+ , SourceStrictness(..), SourceUnpackedness(..)+ , datatypeName+ )+import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#)+#else+# ifndef CURRENT_PACKAGE_KEY+import Data.Version (showVersion)+import Paths_generic_deriving (version)+# endif+#endif++-------------------------------------------------------------------------------+-- Expanding type synonyms+-------------------------------------------------------------------------------++type TypeSubst = Map Name Type++applySubstitutionKind :: Map Name Kind -> Type -> Type+#if MIN_VERSION_template_haskell(2,8,0)+applySubstitutionKind = applySubstitution+#else+applySubstitutionKind _ t = t+#endif++substNameWithKind :: Name -> Kind -> Type -> Type+substNameWithKind n k = applySubstitutionKind (Map.singleton n k)++substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns++-------------------------------------------------------------------------------+-- StarKindStatus+-------------------------------------------------------------------------------++-- | Whether a type is of kind @*@, a kind variable, or some other kind. The+-- kind variable case is given special treatment solely to support GHC 8.0 and+-- earlier, in which Generic1 was not poly-kinded. In order to support deriving+-- Generic1 instances on these versions of GHC, we must substitute such kinds+-- with @*@ to ensure that the resulting instance is well kinded.+-- See @Note [Generic1 is polykinded in base-4.10]@ in "Generics.Deriving.TH".+data StarKindStatus = KindStar+ | IsKindVar Name+ | OtherKind+ deriving Eq++-- | Does a Type have kind * or k (for some kind variable k)?+canRealizeKindStar :: Type -> StarKindStatus+canRealizeKindStar t+ | hasKindStar t = KindStar+ | otherwise = case t of+#if MIN_VERSION_template_haskell(2,8,0)+ SigT _ (VarT k) -> IsKindVar k+#endif+ _ -> OtherKind++-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.+-- Otherwise, returns 'Nothing'.+starKindStatusToName :: StarKindStatus -> Maybe Name+starKindStatusToName (IsKindVar n) = Just n+starKindStatusToName _ = Nothing++-- | Concat together all of the StarKindStatuses that are IsKindVar and extract+-- the kind variables' Names out.+catKindVarNames :: [StarKindStatus] -> [Name]+catKindVarNames = mapMaybe starKindStatusToName++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++-- | Returns True if a Type has kind *.+hasKindStar :: Type -> Bool+hasKindStar VarT{} = True+#if MIN_VERSION_template_haskell(2,8,0)+hasKindStar (SigT _ StarT) = True+#else+hasKindStar (SigT _ StarK) = True+#endif+hasKindStar _ = False++-- | Converts a VarT or a SigT into Just the corresponding TyVarBndr.+-- Converts other Types to Nothing.+typeToTyVarBndr :: Type -> Maybe TyVarBndrUnit+typeToTyVarBndr (VarT n) = Just (plainTV n)+typeToTyVarBndr (SigT (VarT n) k) = Just (kindedTV n k)+typeToTyVarBndr _ = Nothing++-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.+typeKind :: Type -> Kind+typeKind (SigT _ k) = k+typeKind _ = starK++-- | Turns+--+-- @+-- [a, b] c+-- @+--+-- into+--+-- @+-- a -> b -> c+-- @+makeFunType :: [Type] -> Type -> Type+makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys++-- | Turns+--+-- @+-- [k1, k2] k3+-- @+--+-- into+--+-- @+-- k1 -> k2 -> k3+-- @+makeFunKind :: [Kind] -> Kind -> Kind+#if MIN_VERSION_template_haskell(2,8,0)+makeFunKind = makeFunType+#else+makeFunKind argKinds resKind = foldr' ArrowK resKind argKinds+#endif++-- | Remove any outer `SigT` and `ParensT` constructors, and turn+-- an outermost `InfixT` constructor into plain applications.+dustOff :: Type -> Type+dustOff (SigT ty _) = dustOff ty+#if MIN_VERSION_template_haskell(2,11,0)+dustOff (ParensT ty) = dustOff ty+dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2+#endif+dustOff ty = ty++-- | Checks whether a type is an unsaturated type family+-- application.+isUnsaturatedType :: Type -> Q Bool+isUnsaturatedType = go 0 . dustOff+ where+ -- Expects its argument to be dusted+ go :: Int -> Type -> Q Bool+ go d t = case t of+ ConT tcName -> check d tcName+ AppT f _ -> go (d + 1) (dustOff f)+ _ -> return False++ check :: Int -> Name -> Q Bool+ check d tcName = do+ mbinders <- getTypeFamilyBinders tcName+ return $ case mbinders of+ Just bndrs -> length bndrs > d+ Nothing -> False++-- | Given a name, check if that name is a type family. If+-- so, return a list of its binders.+getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndrVis])+getTypeFamilyBinders tcName = do+ info <- reify tcName+ return $ case info of+#if MIN_VERSION_template_haskell(2,11,0)+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> Just bndrs+#elif MIN_VERSION_template_haskell(2,7,0)+ FamilyI (FamilyD TypeFam _ bndrs _) _+ -> Just bndrs+#else+ TyConI (FamilyD TypeFam _ bndrs _)+ -> Just bndrs+#endif++#if MIN_VERSION_template_haskell(2,11,0)+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> Just bndrs+#elif MIN_VERSION_template_haskell(2,9,0)+ FamilyI (ClosedTypeFamilyD _ bndrs _ _) _+ -> Just bndrs+#endif++ _ -> Nothing++-- | True if the type does not mention the Name+ground :: Type -> Name -> Bool+ground ty name = name `notElem` freeVariables ty++-- | Construct a type via curried application.+applyTyToTys :: Type -> [Type] -> Type+applyTyToTys = List.foldl' AppT++-- | Apply a type constructor name to type variable binders.+applyTyToTvbs :: Name -> [TyVarBndr_ flag] -> Type+applyTyToTvbs = List.foldl' (\a -> AppT a . tyVarBndrToType) . ConT++-- | Split a type signature by the arrows on its spine. For example, this:+--+-- @+-- forall a b. (a -> b) -> Char -> ()+-- @+--+-- would split to this:+--+-- @+-- ([a, b], [a -> b, Char, ()])+-- @+uncurryTy :: Type -> ([TyVarBndrSpec], [Type])+uncurryTy (AppT (AppT ArrowT t1) t2) =+ let (tvbs, tys) = uncurryTy t2+ in (tvbs, t1:tys)+uncurryTy (SigT t _) = uncurryTy t+uncurryTy (ForallT tvbs _ t) =+ let (tvbs', tys) = uncurryTy t+ in (tvbs ++ tvbs', tys)+uncurryTy t = ([], [t])++-- | Like uncurryType, except on a kind level.+uncurryKind :: Kind -> ([TyVarBndrSpec], [Kind])+#if MIN_VERSION_template_haskell(2,8,0)+uncurryKind = uncurryTy+#else+uncurryKind (ArrowK k1 k2) =+ let (kvbs, ks) = uncurryKind k2+ in (kvbs, k1:ks)+uncurryKind k = ([], [k])+#endif++tyVarBndrToType :: TyVarBndr_ flag -> Type+tyVarBndrToType = elimTV VarT (\n k -> SigT (VarT n) k)++-- | Generate a list of fresh names with a common prefix, and numbered suffixes.+newNameList :: String -> Int -> Q [Name]+newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]++-- | Checks to see if the last types in a data family instance can be safely eta-+-- reduced (i.e., dropped), given the other types. This checks for three conditions:+--+-- (1) All of the dropped types are type variables+-- (2) All of the dropped types are distinct+-- (3) None of the remaining types mention any of the dropped types+canEtaReduce :: [Type] -> [Type] -> Bool+canEtaReduce remaining dropped =+ all isTyVar dropped+ -- Make sure not to pass something of type [Type], since Type+ -- didn't have an Ord instance until template-haskell-2.10.0.0+ && allDistinct droppedNames+ && not (any (`mentionsName` droppedNames) remaining)+ where+ droppedNames :: [Name]+ droppedNames = map varTToName dropped++-- | Extract the Name from a type variable. If the argument Type is not a+-- type variable, throw an error.+varTToName :: Type -> Name+varTToName (VarT n) = n+varTToName (SigT t _) = varTToName t+varTToName _ = error "Not a type variable!"++-- | Is the given type a variable?+isTyVar :: Type -> Bool+isTyVar VarT{} = True+isTyVar (SigT t _) = isTyVar t+isTyVar _ = False++-- | Is the given kind a variable?+isKindVar :: Kind -> Bool+#if MIN_VERSION_template_haskell(2,8,0)+isKindVar = isTyVar+#else+isKindVar _ = False -- There are no kind variables+#endif++-- | Returns 'True' is a 'Type' contains no type variables.+isTypeMonomorphic :: Type -> Bool+isTypeMonomorphic = go+ where+ go :: Type -> Bool+ go (AppT t1 t2) = go t1 && go t2+ go (SigT t _k) = go t+#if MIN_VERSION_template_haskell(2,8,0)+ && go _k+#endif+ go VarT{} = False+ go _ = True++-- | Peel off a kind signature from a Type (if it has one).+unSigT :: Type -> Type+unSigT (SigT t _) = t+unSigT t = t++-- | Peel off a kind signature from a TyVarBndr (if it has one).+unKindedTV :: TyVarBndrUnit -> TyVarBndrUnit+unKindedTV tvb = elimTV (\_ -> tvb) (\n _ -> plainTV n) tvb++-- | Does the given type mention any of the Names in the list?+mentionsName :: Type -> [Name] -> Bool+mentionsName = go+ where+ go :: Type -> [Name] -> Bool+ go (AppT t1 t2) names = go t1 names || go t2 names+ go (SigT t _k) names = go t names+#if MIN_VERSION_template_haskell(2,8,0)+ || go _k names+#endif+ go (VarT n) names = n `elem` names+ go _ _ = False++-- | Are all of the items in a list (which have an ordering) distinct?+--+-- This uses Set (as opposed to nub) for better asymptotic time complexity.+allDistinct :: Ord a => [a] -> Bool+allDistinct = allDistinct' Set.empty+ where+ allDistinct' :: Ord a => Set a -> [a] -> Bool+ allDistinct' uniqs (x:xs)+ | x `Set.member` uniqs = False+ | otherwise = allDistinct' (Set.insert x uniqs) xs+ allDistinct' _ _ = True++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++snd3 :: (a, b, c) -> b+snd3 (_, b, _) = b++trd3 :: (a, b, c) -> c+trd3 (_, _, c) = c++shrink :: (a, b, c) -> (b, c)+shrink (_, b, c) = (b, c)++foldBal :: (a -> a -> a) -> a -> [a] -> a+{-# INLINE foldBal #-} -- inlined to produce specialised code for each op+foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0+ where+ fold_bal op x !n xs = case xs of+ [] -> x+ [a] -> a+ _ -> let !nl = n `div` 2+ !nr = n - nl+ (l,r) = splitAt nl xs+ in fold_bal op x nl l+ `op` fold_bal op x nr r++isNewtypeVariant :: DatatypeVariant_ -> Bool+isNewtypeVariant Datatype_ = False+isNewtypeVariant Newtype_ = True+isNewtypeVariant (DataInstance_ {}) = False+isNewtypeVariant (NewtypeInstance_ {}) = True++-- | Indicates whether Generic or Generic1 is being derived.+data GenericClass = Generic | Generic1 deriving Enum++-- | Records information about the type variables of a data type with a+-- 'Generic' or 'Generic1' instance.+data GenericTvbs+ -- | Information about a data type with a 'Generic' instance.+ = Gen0+ { gen0Tvbs :: [TyVarBndrUnit]+ -- ^ All of the type variable arguments to the data type.+ }+ -- | Information about a data type with a 'Generic1' instance.+ | Gen1+ { gen1InitTvbs :: [TyVarBndrUnit]+ -- ^ All of the type variable arguments to the data type except the+ -- last one. In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the+ -- 'gen1InitTvbs' would be @[a_1, ..., a_(n-1)]@.+ , gen1LastTvbName :: Name+ -- ^ The name of the last type variable argument to the data type.+ -- In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the+ -- 'gen1LastTvbName' name would be @a_n@.+ , gen1LastTvbKindVar :: Maybe Name+ -- ^ If the 'gen1LastTvbName' has kind @k@, where @k@ is some kind+ -- variable, then the 'gen1LastTvbKindVar' is @'Just' k@. Otherwise,+ -- the 'gen1LastTvbKindVar' is 'Nothing'.+ }++-- | Compute 'GenericTvbs' from a 'GenericClass' and the type variable+-- arguments to a data type.+mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs+mkGenericTvbs gClass tySynVars =+ case gClass of+ Generic -> Gen0{gen0Tvbs = freeVariablesWellScoped tySynVars}+ Generic1 -> Gen1{ gen1InitTvbs = freeVariablesWellScoped initArgs+ , gen1LastTvbName = varTToName lastArg+ , gen1LastTvbKindVar = mbLastArgKindName+ }+ where+ -- Everything below is only used for Generic1.+ initArgs :: [Type]+ initArgs = init tySynVars++ lastArg :: Type+ lastArg = last tySynVars++ mbLastArgKindName :: Maybe Name+ mbLastArgKindName = starKindStatusToName+ $ canRealizeKindStar lastArg++-- | Return the type variable arguments to a data type that appear in a+-- 'Generic' or 'Generic1' instance. For a 'Generic' instance, this consists of+-- all the type variable arguments. For a 'Generic1' instance, this consists of+-- all the type variable arguments except for the last one.+genericInitTvbs :: GenericTvbs -> [TyVarBndrUnit]+genericInitTvbs (Gen0{gen0Tvbs = tvbs}) = tvbs+genericInitTvbs (Gen1{gen1InitTvbs = tvbs}) = tvbs++-- | A version of 'DatatypeVariant' in which the data family instance+-- constructors come equipped with the 'ConstructorInfo' of the first+-- constructor in the family instance (for 'Name' generation purposes).+data DatatypeVariant_+ = Datatype_+ | Newtype_+ | DataInstance_ ConstructorInfo+ | NewtypeInstance_ ConstructorInfo++showsDatatypeVariant :: DatatypeVariant_ -> ShowS+showsDatatypeVariant variant = (++ '_':label)+ where+ dataPlain :: String+ dataPlain = "Plain"++ dataFamily :: ConstructorInfo -> String+ dataFamily con = "Family_" ++ sanitizeName (nameBase $ constructorName con)++ label :: String+ label = case variant of+ Datatype_ -> dataPlain+ Newtype_ -> dataPlain+ DataInstance_ con -> dataFamily con+ NewtypeInstance_ con -> dataFamily con++showNameQual :: Name -> String+showNameQual = sanitizeName . showQual+ where+ showQual (Name _ (NameQ m)) = modString m+ showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m+ showQual _ = ""++-- | Credit to Víctor López Juan for this trick+sanitizeName :: String -> String+sanitizeName nb = 'N':(+ nb >>= \x -> case x of+ c | isAlphaNum c || c == '\''-> [c]+ '_' -> "__"+ c -> "_" ++ show (ord c))++-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce+-- function for the criteria it would have to meet).+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $+ "Cannot eta-reduce to an instance of form \n\tinstance (...) => "+ ++ pprint instanceType++-- | Either the given data type doesn't have enough type variables, or one of+-- the type variables to be eta-reduced cannot realize kind *.+derivingKindError :: Name -> Q a+derivingKindError tyConName = fail+ . showString "Cannot derive well-kinded instance of form ‘Generic1 "+ . showParen True+ ( showString (nameBase tyConName)+ . showString " ..."+ )+ . showString "‘\n\tClass Generic1 expects an argument of kind "+#if MIN_VERSION_base(4,10,0)+ . showString "k -> *"+#else+ . showString "* -> *"+#endif+ $ ""++-- | The data type mentions the last type variable in a place other+-- than the last position of a data type in a constructor's field.+outOfPlaceTyVarError :: Q a+outOfPlaceTyVarError = fail+ . showString "Constructor must only use its last type variable as"+ . showString " the last argument of a data type"+ $ ""++-- | The data type mentions the last type variable in a type family+-- application.+typeFamilyApplicationError :: Q a+typeFamilyApplicationError = fail+ . showString "Constructor must not apply its last type variable"+ . showString " to an unsaturated type family"+ $ ""++-- | We cannot define implementations for @from(1)@ or @to(1)@ at the term level+-- for @type data@ declarations, which only exist at the type level.+typeDataError :: Name -> Q a+typeDataError dataName = fail+ . showString "Cannot derive instance for ‘"+ . showString (nameBase dataName)+ . showString "‘, which is a ‘type data‘ declaration"+ $ ""++-- | Cannot have a constructor argument of form (forall a1 ... an. <type>)+-- when deriving Generic(1)+rankNError :: Q a+rankNError = fail "Cannot have polymorphic arguments"++-- | Boilerplate for top level splices.+--+-- The given Name must meet one of two criteria:+--+-- 1. It must be the name of a type constructor of a plain data type or newtype.+-- 2. It must be the name of a data family instance or newtype instance constructor.+--+-- Any other value will result in an exception.+reifyDataInfo :: Name+ -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_))+reifyDataInfo name = do+ return $ Left $ ns ++ " Could not reify " ++ nameBase name+ `recover`+ do DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeInstTypes = tys+ , datatypeVariant = variant+ , datatypeCons = cons+ } <- reifyDatatype name+ variant_ <-+ case variant of+ Datatype -> return Datatype_+ Newtype -> return Newtype_+ DataInstance -> return $ DataInstance_ $ headDataFamInstCon parentName cons+ NewtypeInstance -> return $ NewtypeInstance_ $ headDataFamInstCon parentName cons+#if MIN_VERSION_th_abstraction(0,5,0)+ Datatype.TypeData -> typeDataError parentName+#endif+ checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_)+ where+ ns :: String+ ns = "Generics.Deriving.TH.reifyDataInfo: "++ -- This isn't total, but the API requires that the data family instance have+ -- at least one constructor anyways, so this will always succeed.+ headDataFamInstCon :: Name -> [ConstructorInfo] -> ConstructorInfo+ headDataFamInstCon dataFamName cons =+ case cons of+ con:_ -> con+ [] -> error $ "reified data family instance without a data constructor: "+ ++ nameBase dataFamName++-- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts,+-- so check to make sure the Cxt field of a datatype is null.+checkDataContext :: Name -> Cxt -> a -> Q a+checkDataContext _ [] x = return x+checkDataContext dataName _ _ = fail $+ nameBase dataName ++ " must not have a datatype context"++-- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs.+checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q ()+checkExistentialContext constrName vars ctxt =+ unless (null vars && null ctxt) $ fail $+ nameBase constrName ++ " must be a vanilla data constructor"++#if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0))+type TyVarBndrVis = TyVarBndrUnit++bndrReq :: ()+bndrReq = ()+#endif++-------------------------------------------------------------------------------+-- Quoted names+-------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 800+-- With GHC 8.0 or later, we can simply use TemplateHaskellQuotes to quote each+-- name. Life is good.++comp1DataName :: Name+comp1DataName = 'Comp1++infixDataName :: Name+infixDataName = 'GD.Infix++k1DataName :: Name+k1DataName = 'K1++l1DataName :: Name+l1DataName = 'L1++leftAssociativeDataName :: Name+leftAssociativeDataName = 'LeftAssociative++m1DataName :: Name+m1DataName = 'M1++notAssociativeDataName :: Name+notAssociativeDataName = 'NotAssociative++par1DataName :: Name+par1DataName = 'Par1++prefixDataName :: Name+prefixDataName = 'Prefix++productDataName :: Name+productDataName = '(:*:)++r1DataName :: Name+r1DataName = 'R1++rec1DataName :: Name+rec1DataName = 'Rec1++rightAssociativeDataName :: Name+rightAssociativeDataName = 'RightAssociative++u1DataName :: Name+u1DataName = 'U1++uAddrDataName :: Name+uAddrDataName = 'UAddr++uCharDataName :: Name+uCharDataName = 'UChar++uDoubleDataName :: Name+uDoubleDataName = 'UDouble++uFloatDataName :: Name+uFloatDataName = 'UFloat++uIntDataName :: Name+uIntDataName = 'UInt++uWordDataName :: Name+uWordDataName = 'UWord++c1TypeName :: Name+c1TypeName = ''C1++composeTypeName :: Name+composeTypeName = ''(:.:)++constructorTypeName :: Name+constructorTypeName = ''Constructor++d1TypeName :: Name+d1TypeName = ''D1++genericTypeName :: Name+genericTypeName = ''Generic++generic1TypeName :: Name+generic1TypeName = ''Generic1++datatypeTypeName :: Name+datatypeTypeName = ''Datatype++par1TypeName :: Name+par1TypeName = ''Par1++productTypeName :: Name+productTypeName = ''(:*:)++rec0TypeName :: Name+rec0TypeName = ''Rec0++rec1TypeName :: Name+rec1TypeName = ''Rec1++repTypeName :: Name+repTypeName = ''Rep++rep1TypeName :: Name+rep1TypeName = ''Rep1++s1TypeName :: Name+s1TypeName = ''S1++selectorTypeName :: Name+selectorTypeName = ''Selector++sumTypeName :: Name+sumTypeName = ''(:+:)++u1TypeName :: Name+u1TypeName = ''U1++uAddrTypeName :: Name+uAddrTypeName = ''UAddr++uCharTypeName :: Name+uCharTypeName = ''UChar++uDoubleTypeName :: Name+uDoubleTypeName = ''UDouble++uFloatTypeName :: Name+uFloatTypeName = ''UFloat++uIntTypeName :: Name+uIntTypeName = ''UInt++uWordTypeName :: Name+uWordTypeName = ''UWord++v1TypeName :: Name+v1TypeName = ''V1++conFixityValName :: Name+conFixityValName = 'conFixity++conIsRecordValName :: Name+conIsRecordValName = 'conIsRecord++conNameValName :: Name+conNameValName = 'GD.conName++datatypeNameValName :: Name+datatypeNameValName = 'GD.datatypeName++isNewtypeValName :: Name+isNewtypeValName = 'isNewtype++fromValName :: Name+fromValName = 'from++from1ValName :: Name+from1ValName = 'from1++moduleNameValName :: Name+moduleNameValName = 'moduleName++selNameValName :: Name+selNameValName = 'selName++seqValName :: Name+seqValName = 'seq++toValName :: Name+toValName = 'to++to1ValName :: Name+to1ValName = 'to1++uAddrHashValName :: Name+uAddrHashValName = 'uAddr#++uCharHashValName :: Name+uCharHashValName = 'uChar#++uDoubleHashValName :: Name+uDoubleHashValName = 'uDouble#++uFloatHashValName :: Name+uFloatHashValName = 'uFloat#++uIntHashValName :: Name+uIntHashValName = 'uInt#++uWordHashValName :: Name+uWordHashValName = 'uWord#++unComp1ValName :: Name+unComp1ValName = 'unComp1++unK1ValName :: Name+unK1ValName = 'unK1++unPar1ValName :: Name+unPar1ValName = 'unPar1++unRec1ValName :: Name+unRec1ValName = 'unRec1++trueDataName, falseDataName :: Name+trueDataName = 'True+falseDataName = 'False++nothingDataName, justDataName :: Name+nothingDataName = 'Nothing+justDataName = 'Just++addrHashTypeName :: Name+addrHashTypeName = ''Addr#++charHashTypeName :: Name+charHashTypeName = ''Char#++doubleHashTypeName :: Name+doubleHashTypeName = ''Double#++floatHashTypeName :: Name+floatHashTypeName = ''Float#++intHashTypeName :: Name+intHashTypeName = ''Int#++wordHashTypeName :: Name+wordHashTypeName = ''Word#++composeValName :: Name+composeValName = '(.)++errorValName :: Name+errorValName = 'error++fmapValName :: Name+fmapValName = 'fmap++undefinedValName :: Name+undefinedValName = 'undefined++decidedLazyDataName :: Name+decidedLazyDataName = 'GD.DecidedLazy++decidedStrictDataName :: Name+decidedStrictDataName = 'GD.DecidedStrict++decidedUnpackDataName :: Name+decidedUnpackDataName = 'GD.DecidedUnpack++infixIDataName :: Name+infixIDataName = 'InfixI++metaConsDataName :: Name+metaConsDataName = 'MetaCons++metaDataDataName :: Name+metaDataDataName = 'MetaData++metaSelDataName :: Name+metaSelDataName = 'MetaSel++noSourceStrictnessDataName :: Name+noSourceStrictnessDataName = 'GD.NoSourceStrictness++noSourceUnpackednessDataName :: Name+noSourceUnpackednessDataName = 'GD.NoSourceUnpackedness++prefixIDataName :: Name+prefixIDataName = 'PrefixI++sourceLazyDataName :: Name+sourceLazyDataName = 'GD.SourceLazy++sourceNoUnpackDataName :: Name+sourceNoUnpackDataName = 'GD.SourceNoUnpack++sourceStrictDataName :: Name+sourceStrictDataName = 'GD.SourceStrict++sourceUnpackDataName :: Name+sourceUnpackDataName = 'GD.SourceUnpack++packageNameValName :: Name+packageNameValName = 'packageName+#else+-- On pre-8.0 GHCs, we do not have access to the TemplateHaskellQuotes+-- extension, so we construct the Template Haskell names by hand.+-- By manually generating these names we avoid needing to use the+-- TemplateHaskell language extension when compiling the generic-deriving library.+-- This allows the library to be used in stage1 cross-compilers.++gdPackageKey :: String+# ifdef CURRENT_PACKAGE_KEY+gdPackageKey = CURRENT_PACKAGE_KEY+# else+gdPackageKey = "generic-deriving-" ++ showVersion version+# endif++mkGD4'4_d :: String -> Name+# if MIN_VERSION_base(4,6,0)+mkGD4'4_d = mkNameG_d "base" "GHC.Generics"+# elif MIN_VERSION_base(4,4,0)+mkGD4'4_d = mkNameG_d "ghc-prim" "GHC.Generics"+# else+mkGD4'4_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal"+# endif++mkGD4'9_d :: String -> Name+mkGD4'9_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal"++mkGD4'4_tc :: String -> Name+# if MIN_VERSION_base(4,6,0)+mkGD4'4_tc = mkNameG_tc "base" "GHC.Generics"+# elif MIN_VERSION_base(4,4,0)+mkGD4'4_tc = mkNameG_tc "ghc-prim" "GHC.Generics"+# else+mkGD4'4_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal"+# endif++mkGD4'9_tc :: String -> Name+mkGD4'9_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal"++mkGD4'4_v :: String -> Name+# if MIN_VERSION_base(4,6,0)+mkGD4'4_v = mkNameG_v "base" "GHC.Generics"+# elif MIN_VERSION_base(4,4,0)+mkGD4'4_v = mkNameG_v "ghc-prim" "GHC.Generics"+# else+mkGD4'4_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal"+# endif++mkGD4'9_v :: String -> Name+mkGD4'9_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal"++mkBaseName_d :: String -> String -> Name+mkBaseName_d = mkNameG_d "base"++mkGHCPrimName_d :: String -> String -> Name+mkGHCPrimName_d = mkNameG_d "ghc-prim"++mkGHCPrimName_tc :: String -> String -> Name+mkGHCPrimName_tc = mkNameG_tc "ghc-prim"++mkGHCPrimName_v :: String -> String -> Name+mkGHCPrimName_v = mkNameG_v "ghc-prim"++comp1DataName :: Name+comp1DataName = mkGD4'4_d "Comp1"++infixDataName :: Name+infixDataName = mkGD4'4_d "Infix"++k1DataName :: Name+k1DataName = mkGD4'4_d "K1"++l1DataName :: Name+l1DataName = mkGD4'4_d "L1"++leftAssociativeDataName :: Name+leftAssociativeDataName = mkGD4'4_d "LeftAssociative"++m1DataName :: Name+m1DataName = mkGD4'4_d "M1"++notAssociativeDataName :: Name+notAssociativeDataName = mkGD4'4_d "NotAssociative"++par1DataName :: Name+par1DataName = mkGD4'4_d "Par1"++prefixDataName :: Name+prefixDataName = mkGD4'4_d "Prefix"++productDataName :: Name+productDataName = mkGD4'4_d ":*:"++r1DataName :: Name+r1DataName = mkGD4'4_d "R1"++rec1DataName :: Name+rec1DataName = mkGD4'4_d "Rec1"++rightAssociativeDataName :: Name+rightAssociativeDataName = mkGD4'4_d "RightAssociative"++u1DataName :: Name+u1DataName = mkGD4'4_d "U1"++uAddrDataName :: Name+uAddrDataName = mkGD4'9_d "UAddr"++uCharDataName :: Name+uCharDataName = mkGD4'9_d "UChar"++uDoubleDataName :: Name+uDoubleDataName = mkGD4'9_d "UDouble"++uFloatDataName :: Name+uFloatDataName = mkGD4'9_d "UFloat"++uIntDataName :: Name+uIntDataName = mkGD4'9_d "UInt"++uWordDataName :: Name+uWordDataName = mkGD4'9_d "UWord"++c1TypeName :: Name+c1TypeName = mkGD4'4_tc "C1"++composeTypeName :: Name+composeTypeName = mkGD4'4_tc ":.:"++constructorTypeName :: Name+constructorTypeName = mkGD4'4_tc "Constructor"++d1TypeName :: Name+d1TypeName = mkGD4'4_tc "D1"++genericTypeName :: Name+genericTypeName = mkGD4'4_tc "Generic"++generic1TypeName :: Name+generic1TypeName = mkGD4'4_tc "Generic1"++datatypeTypeName :: Name+datatypeTypeName = mkGD4'4_tc "Datatype"++-- This is only used prior to GHC 8.0.+noSelectorTypeName :: Name+noSelectorTypeName = mkGD4'4_tc "NoSelector"++par1TypeName :: Name+par1TypeName = mkGD4'4_tc "Par1"++productTypeName :: Name+productTypeName = mkGD4'4_tc ":*:"++rec0TypeName :: Name+rec0TypeName = mkGD4'4_tc "Rec0"++rec1TypeName :: Name+rec1TypeName = mkGD4'4_tc "Rec1"++repTypeName :: Name+repTypeName = mkGD4'4_tc "Rep"++rep1TypeName :: Name+rep1TypeName = mkGD4'4_tc "Rep1"++s1TypeName :: Name+s1TypeName = mkGD4'4_tc "S1"++selectorTypeName :: Name+selectorTypeName = mkGD4'4_tc "Selector"++sumTypeName :: Name+sumTypeName = mkGD4'4_tc ":+:"++u1TypeName :: Name+u1TypeName = mkGD4'4_tc "U1"++uAddrTypeName :: Name+uAddrTypeName = mkGD4'9_tc "UAddr"++uCharTypeName :: Name+uCharTypeName = mkGD4'9_tc "UChar"++uDoubleTypeName :: Name+uDoubleTypeName = mkGD4'9_tc "UDouble"++uFloatTypeName :: Name+uFloatTypeName = mkGD4'9_tc "UFloat"++uIntTypeName :: Name+uIntTypeName = mkGD4'9_tc "UInt"++uWordTypeName :: Name+uWordTypeName = mkGD4'9_tc "UWord"++v1TypeName :: Name+v1TypeName = mkGD4'4_tc "V1"++conFixityValName :: Name+conFixityValName = mkGD4'4_v "conFixity"++conIsRecordValName :: Name+conIsRecordValName = mkGD4'4_v "conIsRecord"++conNameValName :: Name+conNameValName = mkGD4'4_v "conName"++datatypeNameValName :: Name+datatypeNameValName = mkGD4'4_v "datatypeName"++isNewtypeValName :: Name+isNewtypeValName = mkGD4'4_v "isNewtype"++fromValName :: Name+fromValName = mkGD4'4_v "from"++from1ValName :: Name+from1ValName = mkGD4'4_v "from1"++moduleNameValName :: Name+moduleNameValName = mkGD4'4_v "moduleName"++selNameValName :: Name+selNameValName = mkGD4'4_v "selName"++seqValName :: Name+seqValName = mkGHCPrimName_v "GHC.Prim" "seq"++toValName :: Name+toValName = mkGD4'4_v "to"++to1ValName :: Name+to1ValName = mkGD4'4_v "to1"++uAddrHashValName :: Name+uAddrHashValName = mkGD4'9_v "uAddr#"++uCharHashValName :: Name+uCharHashValName = mkGD4'9_v "uChar#"++uDoubleHashValName :: Name+uDoubleHashValName = mkGD4'9_v "uDouble#"++uFloatHashValName :: Name+uFloatHashValName = mkGD4'9_v "uFloat#"++uIntHashValName :: Name+uIntHashValName = mkGD4'9_v "uInt#"++uWordHashValName :: Name+uWordHashValName = mkGD4'9_v "uWord#"++unComp1ValName :: Name+unComp1ValName = mkGD4'4_v "unComp1"++unK1ValName :: Name+unK1ValName = mkGD4'4_v "unK1"++unPar1ValName :: Name+unPar1ValName = mkGD4'4_v "unPar1"++unRec1ValName :: Name+unRec1ValName = mkGD4'4_v "unRec1"++trueDataName, falseDataName :: Name+# if MIN_VERSION_base(4,4,0)+trueDataName = mkGHCPrimName_d "GHC.Types" "True"+falseDataName = mkGHCPrimName_d "GHC.Types" "False"+# else+trueDataName = mkGHCPrimName_d "GHC.Bool" "True"+falseDataName = mkGHCPrimName_d "GHC.Bool" "False"+# endif++nothingDataName, justDataName :: Name+# if MIN_VERSION_base(4,8,0)+nothingDataName = mkBaseName_d "GHC.Base" "Nothing"+justDataName = mkBaseName_d "GHC.Base" "Just"+# else+nothingDataName = mkBaseName_d "Data.Maybe" "Nothing"+justDataName = mkBaseName_d "Data.Maybe" "Just"+# endif++mkGHCPrim_tc :: String -> Name+mkGHCPrim_tc = mkNameG_tc "ghc-prim" "GHC.Prim"++addrHashTypeName :: Name+addrHashTypeName = mkGHCPrim_tc "Addr#"++charHashTypeName :: Name+charHashTypeName = mkGHCPrim_tc "Char#"++doubleHashTypeName :: Name+doubleHashTypeName = mkGHCPrim_tc "Double#"++floatHashTypeName :: Name+floatHashTypeName = mkGHCPrim_tc "Float#"++intHashTypeName :: Name+intHashTypeName = mkGHCPrim_tc "Int#"++wordHashTypeName :: Name+wordHashTypeName = mkGHCPrim_tc "Word#"++composeValName :: Name+composeValName = mkNameG_v "base" "GHC.Base" "."++errorValName :: Name+errorValName = mkNameG_v "base" "GHC.Err" "error"++fmapValName :: Name+fmapValName = mkNameG_v "base" "GHC.Base" "fmap"++undefinedValName :: Name+undefinedValName = mkNameG_v "base" "GHC.Err" "undefined"++decidedLazyDataName :: Name+decidedLazyDataName = mkGD4'9_d "DecidedLazy"++decidedStrictDataName :: Name+decidedStrictDataName = mkGD4'9_d "DecidedStrict"++decidedUnpackDataName :: Name+decidedUnpackDataName = mkGD4'9_d "DecidedUnpack"++infixIDataName :: Name+infixIDataName = mkGD4'9_d "InfixI"++metaConsDataName :: Name+metaConsDataName = mkGD4'9_d "MetaCons"++metaDataDataName :: Name+metaDataDataName = mkGD4'9_d "MetaData"++metaSelDataName :: Name+metaSelDataName = mkGD4'9_d "MetaSel"++noSourceStrictnessDataName :: Name+noSourceStrictnessDataName = mkGD4'9_d "NoSourceStrictness"++noSourceUnpackednessDataName :: Name+noSourceUnpackednessDataName = mkGD4'9_d "NoSourceUnpackedness"++prefixIDataName :: Name+prefixIDataName = mkGD4'9_d "PrefixI"++sourceLazyDataName :: Name+sourceLazyDataName = mkGD4'9_d "SourceLazy"++sourceNoUnpackDataName :: Name+sourceNoUnpackDataName = mkGD4'9_d "SourceNoUnpack"++sourceStrictDataName :: Name+sourceStrictDataName = mkGD4'9_d "SourceStrict"++sourceUnpackDataName :: Name+sourceUnpackDataName = mkGD4'9_d "SourceUnpack"++packageNameValName :: Name+packageNameValName = mkGD4'4_v "packageName"+#endif
src/Generics/Deriving/TH/Post4_9.hs view
@@ -1,137 +1,137 @@-{- | -Module : Generics.Deriving.TH.Post4_9 -Copyright : (c) 2008--2009 Universiteit Utrecht -License : BSD3 - -Maintainer : generics@haskell.org -Stability : experimental -Portability : non-portable - -Template Haskell machinery for the type-literal-based variant of GHC -generics introduced in @base-4.9@. --} - -module Generics.Deriving.TH.Post4_9 ( - deriveMeta - , deriveData - , deriveConstructors - , deriveSelectors - , mkMetaDataType - , mkMetaConsType - , mkMetaSelType - , SelStrictInfo(..) - , reifySelStrictInfo - ) where - -import Data.Maybe (fromMaybe) - -import Generics.Deriving.TH.Internal - -import Language.Haskell.TH.Datatype as THAbs -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - -mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type -mkMetaDataType dv n = - promotedT metaDataDataName - `appT` litT (strTyLit (nameBase n)) - `appT` litT (strTyLit m) - `appT` litT (strTyLit pkg) - `appT` promoteBool (isNewtypeVariant dv) - where - m, pkg :: String - m = fromMaybe (error "Cannot fetch module name!") (nameModule n) - pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) - -mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type -mkMetaConsType _ _ n conIsRecord conIsInfix = do - mbFi <- reifyFixity n - promotedT metaConsDataName - `appT` litT (strTyLit (nameBase n)) - `appT` fixityIPromotedType mbFi conIsInfix - `appT` promoteBool conIsRecord - -promoteBool :: Bool -> Q Type -promoteBool True = promotedT trueDataName -promoteBool False = promotedT falseDataName - -fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type -fixityIPromotedType mbFi True = - promotedT infixIDataName - `appT` promoteAssociativity a - `appT` litT (numTyLit (toInteger n)) - where - Fixity n a = fromMaybe defaultFixity mbFi -fixityIPromotedType _ False = promotedT prefixIDataName - -promoteAssociativity :: FixityDirection -> Q Type -promoteAssociativity InfixL = promotedT leftAssociativeDataName -promoteAssociativity InfixR = promotedT rightAssociativeDataName -promoteAssociativity InfixN = promotedT notAssociativeDataName - -mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name - -> SelStrictInfo -> Q Type -mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) = - let mbSelNameT = case mbF of - Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f)) - Nothing -> promotedT nothingDataName - in promotedT metaSelDataName - `appT` mbSelNameT - `appT` promoteUnpackedness su - `appT` promoteStrictness ss - `appT` promoteDecidedStrictness ds - -data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness - -promoteUnpackedness :: Unpackedness -> Q Type -promoteUnpackedness UnspecifiedUnpackedness = promotedT noSourceUnpackednessDataName -promoteUnpackedness NoUnpack = promotedT sourceNoUnpackDataName -promoteUnpackedness Unpack = promotedT sourceUnpackDataName - -promoteStrictness :: Strictness -> Q Type -promoteStrictness UnspecifiedStrictness = promotedT noSourceStrictnessDataName -promoteStrictness Lazy = promotedT sourceLazyDataName -promoteStrictness THAbs.Strict = promotedT sourceStrictDataName - -promoteDecidedStrictness :: DecidedStrictness -> Q Type -promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName -promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName -promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName - -reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo] -reifySelStrictInfo conName fs = do - dcdStrs <- reifyConStrictness conName - let srcUnpks = map fieldUnpackedness fs - srcStrs = map fieldStrictness fs - return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs - --- | Given the type and the name (as string) for the type to derive, --- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' --- instances. --- --- On GHC 7.11 and up, this functionality is no longer used in GHC generics, --- so this function generates no declarations. -deriveMeta :: Name -> Q [Dec] -deriveMeta _ = return [] - --- | Given a datatype name, derive a datatype and instance of class 'Datatype'. --- --- On GHC 7.11 and up, this functionality is no longer used in GHC generics, --- so this function generates no declarations. -deriveData :: Name -> Q [Dec] -deriveData _ = return [] - --- | Given a datatype name, derive datatypes and --- instances of class 'Constructor'. --- --- On GHC 7.11 and up, this functionality is no longer used in GHC generics, --- so this function generates no declarations. -deriveConstructors :: Name -> Q [Dec] -deriveConstructors _ = return [] - --- | Given a datatype name, derive datatypes and instances of class 'Selector'. --- --- On GHC 7.11 and up, this functionality is no longer used in GHC generics, --- so this function generates no declarations. -deriveSelectors :: Name -> Q [Dec] -deriveSelectors _ = return [] +{- |+Module : Generics.Deriving.TH.Post4_9+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell machinery for the type-literal-based variant of GHC+generics introduced in @base-4.9@.+-}++module Generics.Deriving.TH.Post4_9 (+ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors+ , mkMetaDataType+ , mkMetaConsType+ , mkMetaSelType+ , SelStrictInfo(..)+ , reifySelStrictInfo+ ) where++import Data.Maybe (fromMaybe)++import Generics.Deriving.TH.Internal++import Language.Haskell.TH.Datatype as THAbs+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type+mkMetaDataType dv n =+ promotedT metaDataDataName+ `appT` litT (strTyLit (nameBase n))+ `appT` litT (strTyLit m)+ `appT` litT (strTyLit pkg)+ `appT` promoteBool (isNewtypeVariant dv)+ where+ m, pkg :: String+ m = fromMaybe (error "Cannot fetch module name!") (nameModule n)+ pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n)++mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType _ _ n conIsRecord conIsInfix = do+ mbFi <- reifyFixity n+ promotedT metaConsDataName+ `appT` litT (strTyLit (nameBase n))+ `appT` fixityIPromotedType mbFi conIsInfix+ `appT` promoteBool conIsRecord++promoteBool :: Bool -> Q Type+promoteBool True = promotedT trueDataName+promoteBool False = promotedT falseDataName++fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type+fixityIPromotedType mbFi True =+ promotedT infixIDataName+ `appT` promoteAssociativity a+ `appT` litT (numTyLit (toInteger n))+ where+ Fixity n a = fromMaybe defaultFixity mbFi+fixityIPromotedType _ False = promotedT prefixIDataName++promoteAssociativity :: FixityDirection -> Q Type+promoteAssociativity InfixL = promotedT leftAssociativeDataName+promoteAssociativity InfixR = promotedT rightAssociativeDataName+promoteAssociativity InfixN = promotedT notAssociativeDataName++mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name+ -> SelStrictInfo -> Q Type+mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) =+ let mbSelNameT = case mbF of+ Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f))+ Nothing -> promotedT nothingDataName+ in promotedT metaSelDataName+ `appT` mbSelNameT+ `appT` promoteUnpackedness su+ `appT` promoteStrictness ss+ `appT` promoteDecidedStrictness ds++data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness++promoteUnpackedness :: Unpackedness -> Q Type+promoteUnpackedness UnspecifiedUnpackedness = promotedT noSourceUnpackednessDataName+promoteUnpackedness NoUnpack = promotedT sourceNoUnpackDataName+promoteUnpackedness Unpack = promotedT sourceUnpackDataName++promoteStrictness :: Strictness -> Q Type+promoteStrictness UnspecifiedStrictness = promotedT noSourceStrictnessDataName+promoteStrictness Lazy = promotedT sourceLazyDataName+promoteStrictness THAbs.Strict = promotedT sourceStrictDataName++promoteDecidedStrictness :: DecidedStrictness -> Q Type+promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName+promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName+promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName++reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo]+reifySelStrictInfo conName fs = do+ dcdStrs <- reifyConStrictness conName+ let srcUnpks = map fieldUnpackedness fs+ srcStrs = map fieldStrictness fs+ return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'+-- instances.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveMeta :: Name -> Q [Dec]+deriveMeta _ = return []++-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveData :: Name -> Q [Dec]+deriveData _ = return []++-- | Given a datatype name, derive datatypes and+-- instances of class 'Constructor'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveConstructors :: Name -> Q [Dec]+deriveConstructors _ = return []++-- | Given a datatype name, derive datatypes and instances of class 'Selector'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveSelectors :: Name -> Q [Dec]+deriveSelectors _ = return []
src/Generics/Deriving/TH/Pre4_9.hs view
@@ -1,241 +1,241 @@-{-# LANGUAGE CPP #-} - -{- | -Module : Generics.Deriving.TH.Pre4_9 -Copyright : (c) 2008--2009 Universiteit Utrecht -License : BSD3 - -Maintainer : generics@haskell.org -Stability : experimental -Portability : non-portable - -Template Haskell machinery for the proxy datatype variant of GHC generics -used up until @base-4.9@. --} - -module Generics.Deriving.TH.Pre4_9 ( - deriveMeta - , deriveData - , deriveConstructors - , deriveSelectors - , mkMetaDataType - , mkMetaConsType - , mkMetaSelType - , SelStrictInfo - , reifySelStrictInfo - ) where - -import Data.List (intercalate) -import Data.Maybe (fromMaybe) - -import Generics.Deriving.TH.Internal - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- | Given the type and the name (as string) for the type to derive, --- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' --- instances. -deriveMeta :: Name -> Q [Dec] -deriveMeta n = - do a <- deriveData n - b <- deriveConstructors n - c <- deriveSelectors n - return (a ++ b ++ c) - --- | Given a datatype name, derive a datatype and instance of class 'Datatype'. -deriveData :: Name -> Q [Dec] -deriveData = dataInstance - --- | Given a datatype name, derive datatypes and --- instances of class 'Constructor'. -deriveConstructors :: Name -> Q [Dec] -deriveConstructors = constrInstance - --- | Given a datatype name, derive datatypes and instances of class 'Selector'. -deriveSelectors :: Name -> Q [Dec] -deriveSelectors = selectInstance - -dataInstance :: Name -> Q [Dec] -dataInstance n = do - i <- reifyDataInfo n - case i of - Left _ -> return [] - Right (n', _, _, dv) -> mkInstance n' dv - where - mkInstance n' dv = do - ds <- mkDataData dv n' - is <- mkDataInstance dv n' - return $ [ds,is] - -constrInstance :: Name -> Q [Dec] -constrInstance n = do - i <- reifyDataInfo n - case i of - Left _ -> return [] - Right (n', _, cons, dv) -> mkInstance n' cons dv - where - mkInstance n' cons dv = do - ds <- mapM (mkConstrData dv n') cons - is <- mapM (mkConstrInstance dv n') cons - return $ ds ++ is - -selectInstance :: Name -> Q [Dec] -selectInstance n = do - i <- reifyDataInfo n - case i of - Left _ -> return [] - Right (n', _, cons, dv) -> mkInstance n' cons dv - where - mkInstance n' cons dv = do - ds <- mapM (mkSelectData dv n') cons - is <- mapM (mkSelectInstance dv n') cons - return $ concat (ds ++ is) - -mkDataData :: DatatypeVariant_ -> Name -> Q Dec -mkDataData dv n = - dataD (cxt []) (genName dv [n]) [] -#if MIN_VERSION_template_haskell(2,11,0) - Nothing [] (cxt []) -#else - [] [] -#endif - -mkConstrData :: DatatypeVariant_ -> Name -> ConstructorInfo -> Q Dec -mkConstrData dv dt - (ConstructorInfo { constructorName = n - , constructorVars = vars - , constructorContext = ctxt - }) = do - checkExistentialContext n vars ctxt - dataD (cxt []) (genName dv [dt, n]) [] -#if MIN_VERSION_template_haskell(2,11,0) - Nothing [] (cxt []) -#else - [] [] -#endif - -mkSelectData :: DatatypeVariant_ -> Name -> ConstructorInfo -> Q [Dec] -mkSelectData dv dt - (ConstructorInfo { constructorName = n - , constructorVariant = cv - }) = - case cv of - NormalConstructor -> return [] - InfixConstructor -> return [] - RecordConstructor fs -> return (map one fs) - where one f = DataD [] (genName dv [dt, n, f]) [] -#if MIN_VERSION_template_haskell(2,11,0) - Nothing -#endif - [] [] -mkDataInstance :: DatatypeVariant_ -> Name -> Q Dec -mkDataInstance dv n = - instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n)) $ - [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] - , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []] - ] -#if MIN_VERSION_base(4,7,0) - ++ if isNewtypeVariant dv - then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]] - else [] -#endif - where - name = fromMaybe (error "Cannot fetch module name!") (nameModule n) - -liftFixity :: Fixity -> Q Exp -liftFixity (Fixity n a) = conE infixDataName - `appE` liftAssociativity a - `appE` lift n - -liftAssociativity :: FixityDirection -> Q Exp -liftAssociativity InfixL = conE leftAssociativeDataName -liftAssociativity InfixR = conE rightAssociativeDataName -liftAssociativity InfixN = conE notAssociativeDataName - -mkConstrInstance :: DatatypeVariant_ -> Name - -> ConstructorInfo -> Q Dec -mkConstrInstance dv dt - (ConstructorInfo { constructorName = n - , constructorVars = vars - , constructorContext = ctxt - , constructorVariant = cv - }) = do - checkExistentialContext n vars ctxt - case cv of - NormalConstructor -> mkConstrInstanceWith dv dt n False False [] - InfixConstructor -> do - i <- reify n -#if MIN_VERSION_template_haskell(2,11,0) - fi <- case i of - DataConI{} -> fromMaybe defaultFixity `fmap` reifyFixity n -#else - let fi = case i of - DataConI _ _ _ f -> f -#endif - _ -> error $ "Not a data constructor name: " ++ show n - mkConstrInstanceWith dv dt n False True - [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]] - RecordConstructor _ -> - mkConstrInstanceWith dv dt n True False - [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]] - -mkConstrInstanceWith :: DatatypeVariant_ - -> Name - -> Name - -> Bool - -> Bool - -> [Q Dec] - -> Q Dec -mkConstrInstanceWith dv dt n isRecord isInfix extra = - instanceD - (cxt []) - (appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix)) - (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra) - -mkSelectInstance :: DatatypeVariant_ -> Name - -> ConstructorInfo -> Q [Dec] -mkSelectInstance dv dt - (ConstructorInfo { constructorName = n - , constructorVariant = cv - }) = - case cv of - NormalConstructor -> return [] - InfixConstructor -> return [] - RecordConstructor fs -> mapM one fs - where - one :: Name -> Q Dec - one f = - instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ())) - [funD selNameValName [clause [wildP] - (normalB (litE (stringL (nameBase f)))) []]] - -genName :: DatatypeVariant_ -> [Name] -> Name -genName dv ns - = mkName - . showsDatatypeVariant dv - . intercalate "_" - . consQualName - $ map (sanitizeName . nameBase) ns - where - consQualName :: [String] -> [String] - consQualName = case ns of - [] -> id - n:_ -> (showNameQual n :) - -mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type -mkMetaDataType dv n = conT $ genName dv [n] - -mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type -mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n] - -mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name - -> SelStrictInfo -> Q Type -mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f] -mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName - -type SelStrictInfo = () - -reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo] -reifySelStrictInfo _ bangs = return (map (const ()) bangs) +{-# LANGUAGE CPP #-}++{- |+Module : Generics.Deriving.TH.Pre4_9+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell machinery for the proxy datatype variant of GHC generics+used up until @base-4.9@.+-}++module Generics.Deriving.TH.Pre4_9 (+ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors+ , mkMetaDataType+ , mkMetaConsType+ , mkMetaSelType+ , SelStrictInfo+ , reifySelStrictInfo+ ) where++import Data.List (intercalate)+import Data.Maybe (fromMaybe)++import Generics.Deriving.TH.Internal++import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'+-- instances.+deriveMeta :: Name -> Q [Dec]+deriveMeta n =+ do a <- deriveData n+ b <- deriveConstructors n+ c <- deriveSelectors n+ return (a ++ b ++ c)++-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.+deriveData :: Name -> Q [Dec]+deriveData = dataInstance++-- | Given a datatype name, derive datatypes and+-- instances of class 'Constructor'.+deriveConstructors :: Name -> Q [Dec]+deriveConstructors = constrInstance++-- | Given a datatype name, derive datatypes and instances of class 'Selector'.+deriveSelectors :: Name -> Q [Dec]+deriveSelectors = selectInstance++dataInstance :: Name -> Q [Dec]+dataInstance n = do+ i <- reifyDataInfo n+ case i of+ Left _ -> return []+ Right (n', _, _, dv) -> mkInstance n' dv+ where+ mkInstance n' dv = do+ ds <- mkDataData dv n'+ is <- mkDataInstance dv n'+ return $ [ds,is]++constrInstance :: Name -> Q [Dec]+constrInstance n = do+ i <- reifyDataInfo n+ case i of+ Left _ -> return []+ Right (n', _, cons, dv) -> mkInstance n' cons dv+ where+ mkInstance n' cons dv = do+ ds <- mapM (mkConstrData dv n') cons+ is <- mapM (mkConstrInstance dv n') cons+ return $ ds ++ is++selectInstance :: Name -> Q [Dec]+selectInstance n = do+ i <- reifyDataInfo n+ case i of+ Left _ -> return []+ Right (n', _, cons, dv) -> mkInstance n' cons dv+ where+ mkInstance n' cons dv = do+ ds <- mapM (mkSelectData dv n') cons+ is <- mapM (mkSelectInstance dv n') cons+ return $ concat (ds ++ is)++mkDataData :: DatatypeVariant_ -> Name -> Q Dec+mkDataData dv n =+ dataD (cxt []) (genName dv [n]) []+#if MIN_VERSION_template_haskell(2,11,0)+ Nothing [] (cxt [])+#else+ [] []+#endif++mkConstrData :: DatatypeVariant_ -> Name -> ConstructorInfo -> Q Dec+mkConstrData dv dt+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ }) = do+ checkExistentialContext n vars ctxt+ dataD (cxt []) (genName dv [dt, n]) []+#if MIN_VERSION_template_haskell(2,11,0)+ Nothing [] (cxt [])+#else+ [] []+#endif++mkSelectData :: DatatypeVariant_ -> Name -> ConstructorInfo -> Q [Dec]+mkSelectData dv dt+ (ConstructorInfo { constructorName = n+ , constructorVariant = cv+ }) =+ case cv of+ NormalConstructor -> return []+ InfixConstructor -> return []+ RecordConstructor fs -> return (map one fs)+ where one f = DataD [] (genName dv [dt, n, f]) []+#if MIN_VERSION_template_haskell(2,11,0)+ Nothing+#endif+ [] []+mkDataInstance :: DatatypeVariant_ -> Name -> Q Dec+mkDataInstance dv n =+ instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n)) $+ [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []]+ , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []]+ ]+#if MIN_VERSION_base(4,7,0)+ ++ if isNewtypeVariant dv+ then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]]+ else []+#endif+ where+ name = fromMaybe (error "Cannot fetch module name!") (nameModule n)++liftFixity :: Fixity -> Q Exp+liftFixity (Fixity n a) = conE infixDataName+ `appE` liftAssociativity a+ `appE` lift n++liftAssociativity :: FixityDirection -> Q Exp+liftAssociativity InfixL = conE leftAssociativeDataName+liftAssociativity InfixR = conE rightAssociativeDataName+liftAssociativity InfixN = conE notAssociativeDataName++mkConstrInstance :: DatatypeVariant_ -> Name+ -> ConstructorInfo -> Q Dec+mkConstrInstance dv dt+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorVariant = cv+ }) = do+ checkExistentialContext n vars ctxt+ case cv of+ NormalConstructor -> mkConstrInstanceWith dv dt n False False []+ InfixConstructor -> do+ i <- reify n+#if MIN_VERSION_template_haskell(2,11,0)+ fi <- case i of+ DataConI{} -> fromMaybe defaultFixity `fmap` reifyFixity n+#else+ let fi = case i of+ DataConI _ _ _ f -> f+#endif+ _ -> error $ "Not a data constructor name: " ++ show n+ mkConstrInstanceWith dv dt n False True+ [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]+ RecordConstructor _ ->+ mkConstrInstanceWith dv dt n True False+ [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]]++mkConstrInstanceWith :: DatatypeVariant_+ -> Name+ -> Name+ -> Bool+ -> Bool+ -> [Q Dec]+ -> Q Dec+mkConstrInstanceWith dv dt n isRecord isInfix extra =+ instanceD+ (cxt [])+ (appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix))+ (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)++mkSelectInstance :: DatatypeVariant_ -> Name+ -> ConstructorInfo -> Q [Dec]+mkSelectInstance dv dt+ (ConstructorInfo { constructorName = n+ , constructorVariant = cv+ }) =+ case cv of+ NormalConstructor -> return []+ InfixConstructor -> return []+ RecordConstructor fs -> mapM one fs+ where+ one :: Name -> Q Dec+ one f =+ instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ()))+ [funD selNameValName [clause [wildP]+ (normalB (litE (stringL (nameBase f)))) []]]++genName :: DatatypeVariant_ -> [Name] -> Name+genName dv ns+ = mkName+ . showsDatatypeVariant dv+ . intercalate "_"+ . consQualName+ $ map (sanitizeName . nameBase) ns+ where+ consQualName :: [String] -> [String]+ consQualName = case ns of+ [] -> id+ n:_ -> (showNameQual n :)++mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type+mkMetaDataType dv n = conT $ genName dv [n]++mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n]++mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name+ -> SelStrictInfo -> Q Type+mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f]+mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName++type SelStrictInfo = ()++reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo]+reifySelStrictInfo _ bangs = return (map (const ()) bangs)
src/Generics/Deriving/Traversable.hs view
@@ -1,244 +1,244 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -#endif - -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - -module Generics.Deriving.Traversable ( - -- * Generic Traversable class - GTraversable(..) - - -- * Default method - , gtraversedefault - - -- * Internal Traversable class - , GTraversable'(..) - - ) where - -import Control.Applicative (Const, WrappedMonad(..), ZipList) -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative (Applicative(..), (<$>)) -#endif - -import qualified Data.Monoid as Monoid (First, Last, Product, Sum) -import Data.Monoid (Dual) - -import Generics.Deriving.Base -import Generics.Deriving.Foldable -import Generics.Deriving.Functor - -#if MIN_VERSION_base(4,4,0) -import Data.Complex (Complex) -#endif - -#if MIN_VERSION_base(4,6,0) -import Data.Ord (Down) -#else -import GHC.Exts (Down) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Functor.Product as Functor (Product) -import qualified Data.Functor.Sum as Functor (Sum) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Semigroup as Semigroup (First, Last) -import Data.Semigroup (Arg, Max, Min, WrappedMonoid) -#endif - --------------------------------------------------------------------------------- --- Generic traverse --------------------------------------------------------------------------------- - -class GTraversable' t where - gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b) - -instance GTraversable' V1 where - gtraverse' _ x = pure $ case x of -#if __GLASGOW_HASKELL__ >= 708 - {} -#else - !_ -> error "Void gtraverse" -#endif - -instance GTraversable' U1 where - gtraverse' _ U1 = pure U1 - -instance GTraversable' Par1 where - gtraverse' f (Par1 a) = Par1 <$> f a - -instance GTraversable' (K1 i c) where - gtraverse' _ (K1 a) = pure (K1 a) - -instance (GTraversable f) => GTraversable' (Rec1 f) where - gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a - -instance (GTraversable' f) => GTraversable' (M1 i c f) where - gtraverse' f (M1 a) = M1 <$> gtraverse' f a - -instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where - gtraverse' f (L1 a) = L1 <$> gtraverse' f a - gtraverse' f (R1 a) = R1 <$> gtraverse' f a - -instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where - gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b - -instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where - gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x - -instance GTraversable' UAddr where - gtraverse' _ (UAddr a) = pure (UAddr a) - -instance GTraversable' UChar where - gtraverse' _ (UChar c) = pure (UChar c) - -instance GTraversable' UDouble where - gtraverse' _ (UDouble d) = pure (UDouble d) - -instance GTraversable' UFloat where - gtraverse' _ (UFloat f) = pure (UFloat f) - -instance GTraversable' UInt where - gtraverse' _ (UInt i) = pure (UInt i) - -instance GTraversable' UWord where - gtraverse' _ (UWord w) = pure (UWord w) - -class (GFunctor t, GFoldable t) => GTraversable t where - gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b) -#if __GLASGOW_HASKELL__ >= 701 - default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) - gtraverse = gtraversedefault -#endif - - gsequenceA :: Applicative f => t (f a) -> f (t a) - gsequenceA = gtraverse id - - gmapM :: Monad m => (a -> m b) -> t a -> m (t b) - gmapM f = unwrapMonad . gtraverse (WrapMonad . f) - - gsequence :: Monad m => t (m a) -> m (t a) - gsequence = gmapM id - -gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) -gtraversedefault f x = to1 <$> gtraverse' f (from1 x) - --- Base types instances -instance GTraversable ((,) a) where - gtraverse = gtraversedefault - -instance GTraversable [] where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,9,0) -instance GTraversable (Arg a) where - gtraverse = gtraversedefault -#endif - -#if MIN_VERSION_base(4,4,0) -instance GTraversable Complex where - gtraverse = gtraversedefault -#endif - -instance GTraversable (Const m) where - gtraverse = gtraversedefault - -instance GTraversable Down where - gtraverse = gtraversedefault - -instance GTraversable Dual where - gtraverse = gtraversedefault - -instance GTraversable (Either a) where - gtraverse = gtraversedefault - -instance GTraversable Monoid.First where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,9,0) -instance GTraversable (Semigroup.First) where - gtraverse = gtraversedefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GTraversable Identity where - gtraverse = gtraversedefault -#endif - -instance GTraversable Monoid.Last where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,9,0) -instance GTraversable Semigroup.Last where - gtraverse = gtraversedefault - -instance GTraversable Max where - gtraverse = gtraversedefault -#endif - -instance GTraversable Maybe where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,9,0) -instance GTraversable Min where - gtraverse = gtraversedefault - -instance GTraversable NonEmpty where - gtraverse = gtraversedefault -#endif - -instance GTraversable Monoid.Product where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,9,0) -instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where - gtraverse = gtraversedefault -#endif - -#if MIN_VERSION_base(4,7,0) -instance GTraversable Proxy where - gtraverse = gtraversedefault -#endif - -instance GTraversable Monoid.Sum where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,9,0) -instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where - gtraverse = gtraversedefault - -instance GTraversable WrappedMonoid where - gtraverse = gtraversedefault -#endif - -instance GTraversable ZipList where - gtraverse = gtraversedefault +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Traversable (+ -- * Generic Traversable class+ GTraversable(..)++ -- * Default method+ , gtraversedefault++ -- * Internal Traversable class+ , GTraversable'(..)++ ) where++import Control.Applicative (Const, WrappedMonad(..), ZipList)+#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative (Applicative(..), (<$>))+#endif++import qualified Data.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)++import Generics.Deriving.Base+import Generics.Deriving.Foldable+import Generics.Deriving.Functor++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic traverse+--------------------------------------------------------------------------------++class GTraversable' t where+ gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b)++instance GTraversable' V1 where+ gtraverse' _ x = pure $ case x of+#if __GLASGOW_HASKELL__ >= 708+ {}+#else+ !_ -> error "Void gtraverse"+#endif++instance GTraversable' U1 where+ gtraverse' _ U1 = pure U1++instance GTraversable' Par1 where+ gtraverse' f (Par1 a) = Par1 <$> f a++instance GTraversable' (K1 i c) where+ gtraverse' _ (K1 a) = pure (K1 a)++instance (GTraversable f) => GTraversable' (Rec1 f) where+ gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a++instance (GTraversable' f) => GTraversable' (M1 i c f) where+ gtraverse' f (M1 a) = M1 <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where+ gtraverse' f (L1 a) = L1 <$> gtraverse' f a+ gtraverse' f (R1 a) = R1 <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where+ gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b++instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where+ gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x++instance GTraversable' UAddr where+ gtraverse' _ (UAddr a) = pure (UAddr a)++instance GTraversable' UChar where+ gtraverse' _ (UChar c) = pure (UChar c)++instance GTraversable' UDouble where+ gtraverse' _ (UDouble d) = pure (UDouble d)++instance GTraversable' UFloat where+ gtraverse' _ (UFloat f) = pure (UFloat f)++instance GTraversable' UInt where+ gtraverse' _ (UInt i) = pure (UInt i)++instance GTraversable' UWord where+ gtraverse' _ (UWord w) = pure (UWord w)++class (GFunctor t, GFoldable t) => GTraversable t where+ gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b)+#if __GLASGOW_HASKELL__ >= 701+ default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+ gtraverse = gtraversedefault+#endif++ gsequenceA :: Applicative f => t (f a) -> f (t a)+ gsequenceA = gtraverse id++ gmapM :: Monad m => (a -> m b) -> t a -> m (t b)+ gmapM f = unwrapMonad . gtraverse (WrapMonad . f)++ gsequence :: Monad m => t (m a) -> m (t a)+ gsequence = gmapM id++gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+gtraversedefault f x = to1 <$> gtraverse' f (from1 x)++-- Base types instances+instance GTraversable ((,) a) where+ gtraverse = gtraversedefault++instance GTraversable [] where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable (Arg a) where+ gtraverse = gtraversedefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GTraversable Complex where+ gtraverse = gtraversedefault+#endif++instance GTraversable (Const m) where+ gtraverse = gtraversedefault++instance GTraversable Down where+ gtraverse = gtraversedefault++instance GTraversable Dual where+ gtraverse = gtraversedefault++instance GTraversable (Either a) where+ gtraverse = gtraversedefault++instance GTraversable Monoid.First where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable (Semigroup.First) where+ gtraverse = gtraversedefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GTraversable Identity where+ gtraverse = gtraversedefault+#endif++instance GTraversable Monoid.Last where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable Semigroup.Last where+ gtraverse = gtraversedefault++instance GTraversable Max where+ gtraverse = gtraversedefault+#endif++instance GTraversable Maybe where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable Min where+ gtraverse = gtraversedefault++instance GTraversable NonEmpty where+ gtraverse = gtraversedefault+#endif++instance GTraversable Monoid.Product where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where+ gtraverse = gtraversedefault+#endif++#if MIN_VERSION_base(4,7,0)+instance GTraversable Proxy where+ gtraverse = gtraversedefault+#endif++instance GTraversable Monoid.Sum where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where+ gtraverse = gtraversedefault++instance GTraversable WrappedMonoid where+ gtraverse = gtraversedefault+#endif++instance GTraversable ZipList where+ gtraverse = gtraversedefault
src/Generics/Deriving/Uniplate.hs view
@@ -1,392 +1,392 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ < 709 -{-# LANGUAGE OverlappingInstances #-} -#endif - -{- | -Module : Generics.Deriving.Uniplate -Copyright : 2011-2012 Universiteit Utrecht, University of Oxford -License : BSD3 - -Maintainer : generics@haskell.org -Stability : experimental -Portability : non-portable - -Summary: Functions inspired by the Uniplate generic programming library, -mostly implemented by Sean Leather. --} - -module Generics.Deriving.Uniplate ( - -- * Generic Uniplate class - Uniplate(..) - - -- * Derived functions - , uniplate - , universe - , rewrite - , rewriteM - , contexts - , holes - , para - - -- * Default definitions - , childrendefault - , contextdefault - , descenddefault - , descendMdefault - , transformdefault - , transformMdefault - - -- * Internal Uniplate class - , Uniplate'(..) - - -- * Internal Context class - , Context'(..) - ) where - - -import Generics.Deriving.Base - -import Control.Monad (liftM, liftM2) -import GHC.Exts (build) - --------------------------------------------------------------------------------- --- Generic Uniplate --------------------------------------------------------------------------------- - -class Uniplate' f b where - children' :: f a -> [b] - descend' :: (b -> b) -> f a -> f a - descendM' :: Monad m => (b -> m b) -> f a -> m (f a) - transform' :: (b -> b) -> f a -> f a - transformM' :: Monad m => (b -> m b) -> f a -> m (f a) - -instance Uniplate' U1 a where - children' U1 = [] - descend' _ U1 = U1 - descendM' _ U1 = return U1 - transform' _ U1 = U1 - transformM' _ U1 = return U1 - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - (Uniplate a) => Uniplate' (K1 i a) a where - children' (K1 a) = [a] - descend' f (K1 a) = K1 (f a) - descendM' f (K1 a) = liftM K1 (f a) - transform' f (K1 a) = K1 (transform f a) - transformM' f (K1 a) = liftM K1 (transformM f a) - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - Uniplate' (K1 i a) b where - children' (K1 _) = [] - descend' _ (K1 a) = K1 a - descendM' _ (K1 a) = return (K1 a) - transform' _ (K1 a) = K1 a - transformM' _ (K1 a) = return (K1 a) - -instance (Uniplate' f b) => Uniplate' (M1 i c f) b where - children' (M1 a) = children' a - descend' f (M1 a) = M1 (descend' f a) - descendM' f (M1 a) = liftM M1 (descendM' f a) - transform' f (M1 a) = M1 (transform' f a) - transformM' f (M1 a) = liftM M1 (transformM' f a) - -instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where - children' (L1 a) = children' a - children' (R1 a) = children' a - descend' f (L1 a) = L1 (descend' f a) - descend' f (R1 a) = R1 (descend' f a) - descendM' f (L1 a) = liftM L1 (descendM' f a) - descendM' f (R1 a) = liftM R1 (descendM' f a) - transform' f (L1 a) = L1 (transform' f a) - transform' f (R1 a) = R1 (transform' f a) - transformM' f (L1 a) = liftM L1 (transformM' f a) - transformM' f (R1 a) = liftM R1 (transformM' f a) - -instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where - children' (a :*: b) = children' a ++ children' b - descend' f (a :*: b) = descend' f a :*: descend' f b - descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b) - transform' f (a :*: b) = transform' f a :*: transform' f b - transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b) - - --- Context' is a separate class from Uniplate' since it uses special product --- instances, but the context function still appears in Uniplate. -class Context' f b where - context' :: f a -> [b] -> f a - -instance Context' U1 b where - context' U1 _ = U1 - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - Context' (K1 i a) a where - context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context' (K1 _) (c:_) = K1 c - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - Context' (K1 i a) b where - context' (K1 a) _ = K1 a - -instance (Context' f b) => Context' (M1 i c f) b where - context' (M1 a) cs = M1 (context' a cs) - -instance (Context' f b, Context' g b) => Context' (f :+: g) b where - context' (L1 a) cs = L1 (context' a cs) - context' (R1 a) cs = R1 (context' a cs) - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where - context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - (Context' g b) => Context' (f :*: g) b where - context' (a :*: b) cs = a :*: context' b cs - - -class Uniplate a where - children :: a -> [a] -#if __GLASGOW_HASKELL__ >= 701 - default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] - children = childrendefault -#endif - - context :: a -> [a] -> a -#if __GLASGOW_HASKELL__ >= 701 - default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a - context = contextdefault -#endif - - descend :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - descend = descenddefault -#endif - - descendM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - descendM = descendMdefault -#endif - - transform :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - transform = transformdefault -#endif - - transformM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - transformM = transformMdefault -#endif - -childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] -childrendefault = children' . from - -contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a -contextdefault x cs = to (context' (from x) cs) - -descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -descenddefault f = to . descend' f . from - -descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -descendMdefault f = liftM to . descendM' f . from - -transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -transformdefault f = f . to . transform' f . from - -transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -transformMdefault f = liftM to . transformM' f . from - - --- Derived functions (mostly copied from Neil Michell's code) - -uniplate :: Uniplate a => a -> ([a], [a] -> a) -uniplate a = (children a, context a) - -universe :: Uniplate a => a -> [a] -universe a = build (go a) - where - go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x - -rewrite :: Uniplate a => (a -> Maybe a) -> a -> a -rewrite f = transform g - where - g x = maybe x (rewrite f) (f x) - -rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a -rewriteM f = transformM g - where - g x = f x >>= maybe (return x) (rewriteM f) - -contexts :: Uniplate a => a -> [(a, a -> a)] -contexts a = (a, id) : f (holes a) - where - f xs = [ (ch2, ctx1 . ctx2) - | (ch1, ctx1) <- xs - , (ch2, ctx2) <- contexts ch1] - -holes :: Uniplate a => a -> [(a, a -> a)] -holes a = uncurry f (uniplate a) - where - f [] _ = [] - f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) - -para :: Uniplate a => (a -> [r] -> r) -> a -> r -para f x = f x $ map (para f) $ children x - - --- Base types instances -instance Uniplate Bool where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Char where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Double where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Float where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Int where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate () where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Tuple instances -instance Uniplate (b,c) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g,h) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Parameterized type instances -instance Uniplate (Maybe a) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (Either a b) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - -instance Uniplate [a] where - children [] = [] - children (_:t) = [t] - context _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context [] _ = [] - context (h:_) (t:_) = h:t - descend _ [] = [] - descend f (h:t) = h:f t - descendM _ [] = return [] - descendM f (h:t) = f t >>= \t' -> return (h:t') - transform f [] = f [] - transform f (h:t) = f (h:transform f t) - transformM f [] = f [] - transformM f (h:t) = transformM f t >>= \t' -> f (h:t') - +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ < 709+{-# LANGUAGE OverlappingInstances #-}+#endif++{- |+Module : Generics.Deriving.Uniplate+Copyright : 2011-2012 Universiteit Utrecht, University of Oxford+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Summary: Functions inspired by the Uniplate generic programming library,+mostly implemented by Sean Leather.+-}++module Generics.Deriving.Uniplate (+ -- * Generic Uniplate class+ Uniplate(..)++ -- * Derived functions+ , uniplate+ , universe+ , rewrite+ , rewriteM+ , contexts+ , holes+ , para++ -- * Default definitions+ , childrendefault+ , contextdefault+ , descenddefault+ , descendMdefault+ , transformdefault+ , transformMdefault++ -- * Internal Uniplate class+ , Uniplate'(..)++ -- * Internal Context class+ , Context'(..)+ ) where+++import Generics.Deriving.Base++import Control.Monad (liftM, liftM2)+import GHC.Exts (build)++--------------------------------------------------------------------------------+-- Generic Uniplate+--------------------------------------------------------------------------------++class Uniplate' f b where+ children' :: f a -> [b]+ descend' :: (b -> b) -> f a -> f a+ descendM' :: Monad m => (b -> m b) -> f a -> m (f a)+ transform' :: (b -> b) -> f a -> f a+ transformM' :: Monad m => (b -> m b) -> f a -> m (f a)++instance Uniplate' U1 a where+ children' U1 = []+ descend' _ U1 = U1+ descendM' _ U1 = return U1+ transform' _ U1 = U1+ transformM' _ U1 = return U1++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ (Uniplate a) => Uniplate' (K1 i a) a where+ children' (K1 a) = [a]+ descend' f (K1 a) = K1 (f a)+ descendM' f (K1 a) = liftM K1 (f a)+ transform' f (K1 a) = K1 (transform f a)+ transformM' f (K1 a) = liftM K1 (transformM f a)++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ Uniplate' (K1 i a) b where+ children' (K1 _) = []+ descend' _ (K1 a) = K1 a+ descendM' _ (K1 a) = return (K1 a)+ transform' _ (K1 a) = K1 a+ transformM' _ (K1 a) = return (K1 a)++instance (Uniplate' f b) => Uniplate' (M1 i c f) b where+ children' (M1 a) = children' a+ descend' f (M1 a) = M1 (descend' f a)+ descendM' f (M1 a) = liftM M1 (descendM' f a)+ transform' f (M1 a) = M1 (transform' f a)+ transformM' f (M1 a) = liftM M1 (transformM' f a)++instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where+ children' (L1 a) = children' a+ children' (R1 a) = children' a+ descend' f (L1 a) = L1 (descend' f a)+ descend' f (R1 a) = R1 (descend' f a)+ descendM' f (L1 a) = liftM L1 (descendM' f a)+ descendM' f (R1 a) = liftM R1 (descendM' f a)+ transform' f (L1 a) = L1 (transform' f a)+ transform' f (R1 a) = R1 (transform' f a)+ transformM' f (L1 a) = liftM L1 (transformM' f a)+ transformM' f (R1 a) = liftM R1 (transformM' f a)++instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where+ children' (a :*: b) = children' a ++ children' b+ descend' f (a :*: b) = descend' f a :*: descend' f b+ descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b)+ transform' f (a :*: b) = transform' f a :*: transform' f b+ transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b)+++-- Context' is a separate class from Uniplate' since it uses special product+-- instances, but the context function still appears in Uniplate.+class Context' f b where+ context' :: f a -> [b] -> f a++instance Context' U1 b where+ context' U1 _ = U1++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ Context' (K1 i a) a where+ context' _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context' (K1 _) (c:_) = K1 c++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ Context' (K1 i a) b where+ context' (K1 a) _ = K1 a++instance (Context' f b) => Context' (M1 i c f) b where+ context' (M1 a) cs = M1 (context' a cs)++instance (Context' f b, Context' g b) => Context' (f :+: g) b where+ context' (L1 a) cs = L1 (context' a cs)+ context' (R1 a) cs = R1 (context' a cs)++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where+ context' _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ (Context' g b) => Context' (f :*: g) b where+ context' (a :*: b) cs = a :*: context' b cs+++class Uniplate a where+ children :: a -> [a]+#if __GLASGOW_HASKELL__ >= 701+ default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a]+ children = childrendefault+#endif++ context :: a -> [a] -> a+#if __GLASGOW_HASKELL__ >= 701+ default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a+ context = contextdefault+#endif++ descend :: (a -> a) -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+ descend = descenddefault+#endif++ descendM :: Monad m => (a -> m a) -> a -> m a+#if __GLASGOW_HASKELL__ >= 701+ default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+ descendM = descendMdefault+#endif++ transform :: (a -> a) -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+ transform = transformdefault+#endif++ transformM :: Monad m => (a -> m a) -> a -> m a+#if __GLASGOW_HASKELL__ >= 701+ default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+ transformM = transformMdefault+#endif++childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a]+childrendefault = children' . from++contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a+contextdefault x cs = to (context' (from x) cs)++descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+descenddefault f = to . descend' f . from++descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+descendMdefault f = liftM to . descendM' f . from++transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+transformdefault f = f . to . transform' f . from++transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+transformMdefault f = liftM to . transformM' f . from+++-- Derived functions (mostly copied from Neil Michell's code)++uniplate :: Uniplate a => a -> ([a], [a] -> a)+uniplate a = (children a, context a)++universe :: Uniplate a => a -> [a]+universe a = build (go a)+ where+ go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x++rewrite :: Uniplate a => (a -> Maybe a) -> a -> a+rewrite f = transform g+ where+ g x = maybe x (rewrite f) (f x)++rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a+rewriteM f = transformM g+ where+ g x = f x >>= maybe (return x) (rewriteM f)++contexts :: Uniplate a => a -> [(a, a -> a)]+contexts a = (a, id) : f (holes a)+ where+ f xs = [ (ch2, ctx1 . ctx2)+ | (ch1, ctx1) <- xs+ , (ch2, ctx2) <- contexts ch1]++holes :: Uniplate a => a -> [(a, a -> a)]+holes a = uncurry f (uniplate a)+ where+ f [] _ = []+ f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:))++para :: Uniplate a => (a -> [r] -> r) -> a -> r+para f x = f x $ map (para f) $ children x+++-- Base types instances+instance Uniplate Bool where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Char where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Double where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Float where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Int where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate () where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++-- Tuple instances+instance Uniplate (b,c) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f,g) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f,g,h) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++-- Parameterized type instances+instance Uniplate (Maybe a) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (Either a b) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++instance Uniplate [a] where+ children [] = []+ children (_:t) = [t]+ context _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context [] _ = []+ context (h:_) (t:_) = h:t+ descend _ [] = []+ descend f (h:t) = h:f t+ descendM _ [] = return []+ descendM f (h:t) = f t >>= \t' -> return (h:t')+ transform f [] = f []+ transform f (h:t) = f (h:transform f t)+ transformM f [] = f []+ transformM f (h:t) = transformM f t >>= \t' -> f (h:t')+
tests/DefaultSpec.hs view
@@ -1,161 +1,161 @@--- | --- Module : DefaultSpec --- Description : Ensure that deriving via (Default a) newtype works --- License : BSD-3-Clause --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on --- versions below. --- --- The test check a miscellany of properties of the derived type classes. --- (Testing all the required properties is beyond the scope of this module.) -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -#endif - -module DefaultSpec where - -import Test.Hspec - -#if __GLASGOW_HASKELL__ >= 806 -import Test.Hspec.QuickCheck - -import Data.Semigroup (First(..)) -import Data.Foldable (sequenceA_) -import Generics.Deriving hiding (universe) -import Generics.Deriving.Default () -import Generics.Deriving.Foldable (GFoldable(..)) -import Generics.Deriving.Semigroup (GSemigroup(..)) -#endif - -spec :: Spec -spec = do - describe "DerivingVia Default" $ do - -#if __GLASGOW_HASKELL__ >= 806 - it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $ - let commutative :: GEq a => a -> a -> Expectation - commutative x y = x `geq` y `shouldBe` y `geq` x - - universe :: [MyType] - universe = MyType <$> [False, True] - - in commutative <$> universe <*> universe - - it "GShow for MyType is like Show for Bool with derivingVia (Default MyType) but prefixed with 'MyType '" $ do - gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False "" - gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True "" - - it "GEq is commutative for parameterized derivingVia (Default (MyType1 Bool))" . sequenceA_ $ - let commutative :: GEq a => a -> a -> Expectation - commutative x y = x `geq` y `shouldBe` y `geq` x - - universe :: [MyType1 Bool] - universe = MyType1 <$> [False, True] - - in commutative <$> universe <*> universe - - it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default (MyType1 Bool)) but prefixed with 'MyType1 '" $ do - gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0 False "" - gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True "" - - it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $ - let commutative :: GEq a => a -> a -> Expectation - commutative x y = x `geq` y `shouldBe` y `geq` x - - universe :: [TestEq] - universe = TestEq <$> [False, True] - - in commutative <$> universe <*> universe - - it "GENum is correct for derivingVia (Default Bool)" $ - genum `shouldBe` [TestEnum False, TestEnum True] - - it "GShow for TestShow is the same as Show for Bool with derivingVia (Default Bool)" $ do - gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False "" - gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True "" - - it "GSemigroup is like First when instantiated with derivingVia (First Bool)" . sequenceA_ $ - let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation - first' x y = x `gsappend` y `shouldBe` x - - universe :: [FirstSemigroup] - universe = FirstSemigroup <$> [False, True] - - in first' <$> universe <*> universe - - prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with Maybe (First Bool)" $ \(xs :: [Maybe Bool]) -> - let ys :: [Maybe (First Bool)] - -- Note that there is no Arbitrary instance for this type - ys = fmap First <$> xs - - unTestFoldable :: TestFoldable a -> Maybe a - unTestFoldable (TestFoldable x) = x - - in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys - - it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" . sequenceA_ $ - let universe :: [Maybe Bool] - universe = [Nothing, Just False, Just True] - - functor_prop :: Maybe Bool -> Expectation - functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor (not <$> x) - - in functor_prop <$> universe - -#endif - return () - -#if __GLASGOW_HASKELL__ >= 806 - --- These types all implement instances using `DerivingVia`: most via --- `Default` (one uses `First`). - -newtype TestEq = TestEq Bool - deriving (GEq) via (Default Bool) -newtype TestEnum = TestEnum Bool - deriving stock (Eq, Show) - deriving (GEnum) via (Default Bool) -newtype TestShow = TestShow Bool - deriving (GShow) via (Default Bool) - -newtype FirstSemigroup = FirstSemigroup Bool - deriving stock (Eq, Show) - deriving (GSemigroup) via (First Bool) - -newtype TestFoldable a = TestFoldable (Maybe a) - deriving (GFoldable) via (Default1 Maybe) - -newtype TestFunctor a = TestFunctor (Maybe a) - deriving stock (Eq, Show, Functor) - deriving (GFunctor) via (Default1 Maybe) - -newtype TestHigherEq a = TestHigherEq (Maybe a) - deriving stock (Generic) - deriving (GEq) via (Default (TestHigherEq a)) - --- These types correspond to the hypothetical examples in the module --- documentation. - -data MyType = MyType Bool - deriving (Generic) - deriving (GEq) via (Default MyType) - -deriving via (Default MyType) instance GShow MyType - -data MyType1 a = MyType1 a - deriving (Generic, Generic1) - deriving (GEq) via (Default (MyType1 a)) - deriving (GFunctor) via (Default1 MyType1) - -deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a) -deriving via (Default1 MyType1) instance GFoldable MyType1 -#endif +-- |+-- Module : DefaultSpec+-- Description : Ensure that deriving via (Default a) newtype works+-- License : BSD-3-Clause+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on+-- versions below.+--+-- The test check a miscellany of properties of the derived type classes.+-- (Testing all the required properties is beyond the scope of this module.)+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++module DefaultSpec where++import Test.Hspec++#if __GLASGOW_HASKELL__ >= 806+import Test.Hspec.QuickCheck++import Data.Semigroup (First(..))+import Data.Foldable (sequenceA_)+import Generics.Deriving hiding (universe)+import Generics.Deriving.Default ()+import Generics.Deriving.Foldable (GFoldable(..))+import Generics.Deriving.Semigroup (GSemigroup(..))+#endif++spec :: Spec+spec = do+ describe "DerivingVia Default" $ do++#if __GLASGOW_HASKELL__ >= 806+ it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $+ let commutative :: GEq a => a -> a -> Expectation+ commutative x y = x `geq` y `shouldBe` y `geq` x++ universe :: [MyType]+ universe = MyType <$> [False, True]++ in commutative <$> universe <*> universe++ it "GShow for MyType is like Show for Bool with derivingVia (Default MyType) but prefixed with 'MyType '" $ do+ gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False ""+ gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True ""++ it "GEq is commutative for parameterized derivingVia (Default (MyType1 Bool))" . sequenceA_ $+ let commutative :: GEq a => a -> a -> Expectation+ commutative x y = x `geq` y `shouldBe` y `geq` x++ universe :: [MyType1 Bool]+ universe = MyType1 <$> [False, True]++ in commutative <$> universe <*> universe++ it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default (MyType1 Bool)) but prefixed with 'MyType1 '" $ do+ gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0 False ""+ gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True ""++ it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $+ let commutative :: GEq a => a -> a -> Expectation+ commutative x y = x `geq` y `shouldBe` y `geq` x++ universe :: [TestEq]+ universe = TestEq <$> [False, True]++ in commutative <$> universe <*> universe++ it "GENum is correct for derivingVia (Default Bool)" $+ genum `shouldBe` [TestEnum False, TestEnum True]++ it "GShow for TestShow is the same as Show for Bool with derivingVia (Default Bool)" $ do+ gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False ""+ gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True ""++ it "GSemigroup is like First when instantiated with derivingVia (First Bool)" . sequenceA_ $+ let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation+ first' x y = x `gsappend` y `shouldBe` x++ universe :: [FirstSemigroup]+ universe = FirstSemigroup <$> [False, True]++ in first' <$> universe <*> universe++ prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with Maybe (First Bool)" $ \(xs :: [Maybe Bool]) ->+ let ys :: [Maybe (First Bool)]+ -- Note that there is no Arbitrary instance for this type+ ys = fmap First <$> xs++ unTestFoldable :: TestFoldable a -> Maybe a+ unTestFoldable (TestFoldable x) = x++ in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys++ it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" . sequenceA_ $+ let universe :: [Maybe Bool]+ universe = [Nothing, Just False, Just True]++ functor_prop :: Maybe Bool -> Expectation+ functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor (not <$> x)++ in functor_prop <$> universe++#endif+ return ()++#if __GLASGOW_HASKELL__ >= 806++-- These types all implement instances using `DerivingVia`: most via+-- `Default` (one uses `First`).++newtype TestEq = TestEq Bool+ deriving (GEq) via (Default Bool)+newtype TestEnum = TestEnum Bool+ deriving stock (Eq, Show)+ deriving (GEnum) via (Default Bool)+newtype TestShow = TestShow Bool+ deriving (GShow) via (Default Bool)++newtype FirstSemigroup = FirstSemigroup Bool+ deriving stock (Eq, Show)+ deriving (GSemigroup) via (First Bool)++newtype TestFoldable a = TestFoldable (Maybe a)+ deriving (GFoldable) via (Default1 Maybe)++newtype TestFunctor a = TestFunctor (Maybe a)+ deriving stock (Eq, Show, Functor)+ deriving (GFunctor) via (Default1 Maybe)++newtype TestHigherEq a = TestHigherEq (Maybe a)+ deriving stock (Generic)+ deriving (GEq) via (Default (TestHigherEq a))++-- These types correspond to the hypothetical examples in the module+-- documentation.++data MyType = MyType Bool+ deriving (Generic)+ deriving (GEq) via (Default MyType)++deriving via (Default MyType) instance GShow MyType++data MyType1 a = MyType1 a+ deriving (Generic, Generic1)+ deriving (GEq) via (Default (MyType1 a))+ deriving (GFunctor) via (Default1 MyType1)++deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a)+deriving via (Default1 MyType1) instance GFoldable MyType1+#endif
tests/EmptyCaseSpec.hs view
@@ -1,27 +1,27 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -#endif - -module EmptyCaseSpec (main, spec) where - -import Generics.Deriving.TH -import Test.Hspec - -data Empty a -$(deriveAll0And1Options defaultOptions{emptyCaseOptions = True} - ''Empty) - -main :: IO () -main = hspec spec - -spec :: Spec -spec = return () +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DataKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++module EmptyCaseSpec (main, spec) where++import Generics.Deriving.TH+import Test.Hspec++data Empty a+$(deriveAll0And1Options defaultOptions{emptyCaseOptions = True}+ ''Empty)++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()
tests/ExampleSpec.hs view
@@ -1,421 +1,421 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ >= 705 -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -#endif - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ExampleSpec (main, spec) where - -import Generics.Deriving -import Generics.Deriving.TH - -import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) - -import Prelude hiding (Either(..)) - -import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) - -import qualified Text.Read.Lex (Lexeme) - -------------------------------------------------------------------------------- --- Example: Haskell's lists and Maybe -------------------------------------------------------------------------------- - -hList:: [Int] -hList = [1..10] - -maybe1, maybe2 :: Maybe (Maybe Char) -maybe1 = Nothing -maybe2 = Just (Just 'p') - -double :: [Int] -> [Int] -double [] = [] -double (x:xs) = x:x:xs - -------------------------------------------------------------------------------- --- Example: trees of integers (kind *) -------------------------------------------------------------------------------- - -data Tree = Empty | Branch Int Tree Tree - -$(deriveAll0 ''Tree) - -instance GShow Tree where - gshowsPrec = gshowsPrecdefault - -instance Uniplate Tree where - children = childrendefault - context = contextdefault - descend = descenddefault - descendM = descendMdefault - transform = transformdefault - transformM = transformMdefault - -instance GEnum Tree where - genum = genumDefault - -upgradeTree :: Tree -> Tree -upgradeTree Empty = Branch 0 Empty Empty -upgradeTree (Branch n l r) = Branch (succ n) l r - -tree :: Tree -tree = Branch 2 Empty (Branch 1 Empty Empty) - -------------------------------------------------------------------------------- --- Example: lists (kind * -> *) -------------------------------------------------------------------------------- - -data List a = Nil | Cons a (List a) - -$(deriveAll0And1 ''List) - -instance GFunctor List where - gmap = gmapdefault - -instance (GShow a) => GShow (List a) where - gshowsPrec = gshowsPrecdefault - -instance (Uniplate a) => Uniplate (List a) where - children = childrendefault - context = contextdefault - descend = descenddefault - descendM = descendMdefault - transform = transformdefault - transformM = transformMdefault - -list :: List Char -list = Cons 'p' (Cons 'q' Nil) - -listlist :: List (List Char) -listlist = Cons list (Cons Nil Nil) -- ["pq",""] - -------------------------------------------------------------------------------- --- Example: Type composition -------------------------------------------------------------------------------- - -data Rose a = Rose [a] [Rose a] - -$(deriveAll0And1 ''Rose) - -instance (GShow a) => GShow (Rose a) where - gshowsPrec = gshowsPrecdefault - -instance GFunctor Rose where - gmap = gmapdefault - --- Example usage -rose1 :: Rose Int -rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []] - -------------------------------------------------------------------------------- --- Example: Higher-order kinded datatype, type composition -------------------------------------------------------------------------------- - -data GRose f a = GRose (f a) (f (GRose f a)) -deriving instance Functor f => Functor (GRose f) - -$(deriveMeta ''GRose) -$(deriveRepresentable0 ''GRose) -$(deriveRep1 ''GRose) -instance Functor f => Generic1 (GRose f) where - type Rep1 (GRose f) = $(makeRep1 ''GRose) f - from1 = $(makeFrom1 ''GRose) - to1 = $(makeTo1 ''GRose) - -instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where - gshowsPrec = gshowsPrecdefault - -instance (Functor f, GFunctor f) => GFunctor (GRose f) where - gmap = gmapdefault - -grose1 :: GRose [] Int -grose1 = GRose [1,2] [GRose [3] [], GRose [] []] - -------------------------------------------------------------------------------- --- Example: Two parameters, nested on other parameter -------------------------------------------------------------------------------- - -data Either a b = Left (Either [a] b) | Right b - -$(deriveAll0And1 ''Either) - -instance (GShow a, GShow b) => GShow (Either a b) where - gshowsPrec = gshowsPrecdefault - -instance GFunctor (Either a) where - gmap = gmapdefault - -either1 :: Either Int Char -either1 = Left either2 - -either2 :: Either [Int] Char -either2 = Right 'p' - -------------------------------------------------------------------------------- --- Example: Nested datatype, record selectors -------------------------------------------------------------------------------- - -data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] } - deriving Functor - -$(deriveAll0And1 ''Nested) - -instance (GShow a) => GShow (Nested a) where - gshowsPrec = gshowsPrecdefault - -instance GFunctor Nested where - gmap = gmapdefault - -nested :: Nested Int -nested = Nested { value = 1, rec = Nested [2] (Nested [[3],[4,5],[]] Leaf) } - -------------------------------------------------------------------------------- --- Example: Nested datatype Bush (minimal) -------------------------------------------------------------------------------- - -data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor - -$(deriveAll0And1 ''Bush) - -instance GFunctor Bush where - gmap = gmapdefault - -instance (GShow a) => GShow (Bush a) where - gshowsPrec = gshowsPrecdefault - -bush1 :: Bush Int -bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil) - -------------------------------------------------------------------------------- --- Example: Double type composition (minimal) -------------------------------------------------------------------------------- - -data Weird a = Weird [[[a]]] deriving Show - -$(deriveAll0And1 ''Weird) - -instance GFunctor Weird where - gmap = gmapdefault - --------------------------------------------------------------------------------- --- Temporary tests for TH generation --------------------------------------------------------------------------------- - -data Empty a - -data (:/:) f a = MyType1Nil - | MyType1Cons { _myType1Rec :: (f :/: a), _myType2Rec :: MyType2 } - | MyType1Cons2 (f :/: a) Int a (f a) - | (f :/: a) :/: MyType2 - -infixr 5 :!@!: -data GADTSyntax a b where - GADTPrefix :: d -> c -> GADTSyntax c d - (:!@!:) :: e -> f -> GADTSyntax e f - -data MyType2 = MyType2 Float ([] :/: Int) -data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word# - --- Test to see if generated names are unique -data Lexeme = Lexeme - -#if MIN_VERSION_template_haskell(2,7,0) -data family MyType3 -# if __GLASGOW_HASKELL__ >= 705 - (a :: v) (b :: w) (c :: x) (d :: y) (e :: z) -# else - (a :: *) (b :: *) (c :: * -> *) (d :: *) (e :: *) -# endif -newtype instance MyType3 (f p) (f p) f p (q :: *) = MyType3Newtype q -data instance MyType3 Bool () f p q = MyType3True | MyType3False -data instance MyType3 Int () f p (q :: *) = MyType3Hash q Addr# Char# Double# Float# Int# Word# -#endif - -$(deriveAll0And1 ''Empty) -$(deriveAll0And1 ''(:/:)) -$(deriveAll0And1 ''GADTSyntax) -$(deriveAll0 ''MyType2) -$(deriveAll0And1 ''PlainHash) -$(deriveAll0 ''ExampleSpec.Lexeme) -$(deriveAll0 ''Text.Read.Lex.Lexeme) - -#if MIN_VERSION_template_haskell(2,7,0) -# if __GLASGOW_HASKELL__ < 705 --- We can't use deriveAll0And1 on GHC 7.4 due to an old bug :( -$(deriveMeta 'MyType3Newtype) -$(deriveRep0 'MyType3Newtype) -$(deriveRep1 'MyType3Newtype) -instance Generic (MyType3 (f p) (f p) f p q) where - type Rep (MyType3 (f p) (f p) f p q) = $(makeRep0 'MyType3Newtype) f p q - from = $(makeFrom0 'MyType3Newtype) - to = $(makeTo0 'MyType3Newtype) -instance Generic1 (MyType3 (f p) (f p) f p) where - type Rep1 (MyType3 (f p) (f p) f p) = $(makeRep1 'MyType3Newtype) f p - from1 = $(makeFrom1 'MyType3Newtype) - to1 = $(makeTo1 'MyType3Newtype) -# else -$(deriveAll0And1 'MyType3Newtype) -# endif -$(deriveAll0And1 'MyType3False) -$(deriveAll0And1 'MyType3Hash) -#endif - -------------------------------------------------------------------------------- --- Unit tests -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ do - describe "[] and Maybe tests" $ do - it "gshow hList" $ - gshow hList `shouldBe` - "[1,2,3,4,5,6,7,8,9,10]" - - it "gshow (children maybe2)" $ - gshow (children maybe2) `shouldBe` - "[]" - - it "gshow (transform (const \"abc\") [])" $ - gshow (transform (const "abc") []) `shouldBe` - "\"abc\"" - - it "gshow (transform double hList)" $ - gshow (transform double hList) `shouldBe` - "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]" - - it "gshow (geq hList hList)" $ - gshow (geq hList hList) `shouldBe` - "True" - - it "gshow (geq maybe1 maybe2)" $ - gshow (geq maybe1 maybe2) `shouldBe` - "False" - - it "gshow (take 5 genum)" $ - gshow (take 5 (genum :: [Maybe Int])) `shouldBe` - "[Nothing,Just 0,Just -1,Just 1,Just -2]" - - it "gshow (take 15 genum)" $ - gshow (take 15 (genum :: [[Int]])) `shouldBe` - "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]" - - it "gshow (range ([0], [1]))" $ - gshow (range ([0], [1::Int])) `shouldBe` - "[[0],[0,0],[-1],[0,0,0],[-1,0]]" - - it "gshow (inRange ([0], [3,5]) hList)" $ - gshow (inRange ([0], [3,5::Int]) hList) `shouldBe` - "False" - - describe "Tests for Tree" $ do - it "gshow tree" $ - gshow tree `shouldBe` - "Branch 2 Empty (Branch 1 Empty Empty)" - - it "gshow (children tree)" $ - gshow (children tree) `shouldBe` - "[Empty,Branch 1 Empty Empty]" - - it "gshow (descend (descend (\\_ -> Branch 0 Empty Empty)) tree)" $ - gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) `shouldBe` - "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" - - it "gshow (context tree [Branch 1 Empty Empty,Empty])" $ - gshow (context tree [Branch 1 Empty Empty,Empty]) `shouldBe` - "Branch 2 (Branch 1 Empty Empty) Empty" - - it "gshow (transform upgradeTree tree)" $ - gshow (transform upgradeTree tree) `shouldBe` - "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" - - it "gshow (take 10 genum)" $ do - gshow (take 10 (genum :: [Tree])) `shouldBe` - "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]" - - describe "Tests for List" $ do - it "gshow (gmap fromEnum list)" $ - gshow (gmap fromEnum list) `shouldBe` - "Cons 112 (Cons 113 Nil)" - - it "gshow (gmap gshow listlist)" $ - gshow (gmap gshow listlist) `shouldBe` - "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)" - - it "gshow list" $ - gshow list `shouldBe` - "Cons 'p' (Cons 'q' Nil)" - - it "gshow listlist" $ - gshow listlist `shouldBe` - "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)" - - it "gshow (children list)" $ - gshow (children list) `shouldBe` - "[Cons 'q' Nil]" - - it "gshow (children listlist)" $ - gshow (children listlist) `shouldBe` - "[Cons Nil Nil]" - - describe "Tests for Rose" $ do - it "gshow rose1" $ - gshow rose1 `shouldBe` - "Rose [1,2] [Rose [3,4] [],Rose [5] []]" - - it "gshow (gmap gshow rose1)" $ - gshow (gmap gshow rose1) `shouldBe` - "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]" - - describe "Tests for GRose" $ do - it "gshow grose1" $ - gshow grose1 `shouldBe` - "GRose [1,2] [GRose [3] [],GRose [] []]" - - it "gshow (gmap gshow grose1)" $ - gshow (gmap gshow grose1) `shouldBe` - "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]" - - describe "Tests for Either" $ do - it "gshow either1" $ - gshow either1 `shouldBe` - "Left Right 'p'" - - it "gshow (gmap gshow either1)" $ - gshow (gmap gshow either1) `shouldBe` - "Left Right \"'p'\"" - - describe "Tests for Nested" $ do - it "gshow nested" $ - gshow nested `shouldBe` - "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}" - - it "gshow (gmap gshow nested)" $ - gshow (gmap gshow nested) `shouldBe` - "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}" - - describe "Tests for Bush" $ do - it "gshow bush1" $ - gshow bush1 `shouldBe` - "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)" - - it "gshow (gmap gshow bush1)" $ - gshow (gmap gshow bush1) `shouldBe` - "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)" +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+#endif++{-# OPTIONS_GHC -fno-warn-orphans #-}++module ExampleSpec (main, spec) where++import Generics.Deriving+import Generics.Deriving.TH++import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#)++import Prelude hiding (Either(..))++import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe)++import qualified Text.Read.Lex (Lexeme)++-------------------------------------------------------------------------------+-- Example: Haskell's lists and Maybe+-------------------------------------------------------------------------------++hList:: [Int]+hList = [1..10]++maybe1, maybe2 :: Maybe (Maybe Char)+maybe1 = Nothing+maybe2 = Just (Just 'p')++double :: [Int] -> [Int]+double [] = []+double (x:xs) = x:x:xs++-------------------------------------------------------------------------------+-- Example: trees of integers (kind *)+-------------------------------------------------------------------------------++data Tree = Empty | Branch Int Tree Tree++$(deriveAll0 ''Tree)++instance GShow Tree where+ gshowsPrec = gshowsPrecdefault++instance Uniplate Tree where+ children = childrendefault+ context = contextdefault+ descend = descenddefault+ descendM = descendMdefault+ transform = transformdefault+ transformM = transformMdefault++instance GEnum Tree where+ genum = genumDefault++upgradeTree :: Tree -> Tree+upgradeTree Empty = Branch 0 Empty Empty+upgradeTree (Branch n l r) = Branch (succ n) l r++tree :: Tree+tree = Branch 2 Empty (Branch 1 Empty Empty)++-------------------------------------------------------------------------------+-- Example: lists (kind * -> *)+-------------------------------------------------------------------------------++data List a = Nil | Cons a (List a)++$(deriveAll0And1 ''List)++instance GFunctor List where+ gmap = gmapdefault++instance (GShow a) => GShow (List a) where+ gshowsPrec = gshowsPrecdefault++instance (Uniplate a) => Uniplate (List a) where+ children = childrendefault+ context = contextdefault+ descend = descenddefault+ descendM = descendMdefault+ transform = transformdefault+ transformM = transformMdefault++list :: List Char+list = Cons 'p' (Cons 'q' Nil)++listlist :: List (List Char)+listlist = Cons list (Cons Nil Nil) -- ["pq",""]++-------------------------------------------------------------------------------+-- Example: Type composition+-------------------------------------------------------------------------------++data Rose a = Rose [a] [Rose a]++$(deriveAll0And1 ''Rose)++instance (GShow a) => GShow (Rose a) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor Rose where+ gmap = gmapdefault++-- Example usage+rose1 :: Rose Int+rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []]++-------------------------------------------------------------------------------+-- Example: Higher-order kinded datatype, type composition+-------------------------------------------------------------------------------++data GRose f a = GRose (f a) (f (GRose f a))+deriving instance Functor f => Functor (GRose f)++$(deriveMeta ''GRose)+$(deriveRepresentable0 ''GRose)+$(deriveRep1 ''GRose)+instance Functor f => Generic1 (GRose f) where+ type Rep1 (GRose f) = $(makeRep1 ''GRose) f+ from1 = $(makeFrom1 ''GRose)+ to1 = $(makeTo1 ''GRose)++instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where+ gshowsPrec = gshowsPrecdefault++instance (Functor f, GFunctor f) => GFunctor (GRose f) where+ gmap = gmapdefault++grose1 :: GRose [] Int+grose1 = GRose [1,2] [GRose [3] [], GRose [] []]++-------------------------------------------------------------------------------+-- Example: Two parameters, nested on other parameter+-------------------------------------------------------------------------------++data Either a b = Left (Either [a] b) | Right b++$(deriveAll0And1 ''Either)++instance (GShow a, GShow b) => GShow (Either a b) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor (Either a) where+ gmap = gmapdefault++either1 :: Either Int Char+either1 = Left either2++either2 :: Either [Int] Char+either2 = Right 'p'++-------------------------------------------------------------------------------+-- Example: Nested datatype, record selectors+-------------------------------------------------------------------------------++data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] }+ deriving Functor++$(deriveAll0And1 ''Nested)++instance (GShow a) => GShow (Nested a) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor Nested where+ gmap = gmapdefault++nested :: Nested Int+nested = Nested { value = 1, rec = Nested [2] (Nested [[3],[4,5],[]] Leaf) }++-------------------------------------------------------------------------------+-- Example: Nested datatype Bush (minimal)+-------------------------------------------------------------------------------++data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor++$(deriveAll0And1 ''Bush)++instance GFunctor Bush where+ gmap = gmapdefault++instance (GShow a) => GShow (Bush a) where+ gshowsPrec = gshowsPrecdefault++bush1 :: Bush Int+bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)++-------------------------------------------------------------------------------+-- Example: Double type composition (minimal)+-------------------------------------------------------------------------------++data Weird a = Weird [[[a]]] deriving Show++$(deriveAll0And1 ''Weird)++instance GFunctor Weird where+ gmap = gmapdefault++--------------------------------------------------------------------------------+-- Temporary tests for TH generation+--------------------------------------------------------------------------------++data Empty a++data (:/:) f a = MyType1Nil+ | MyType1Cons { _myType1Rec :: (f :/: a), _myType2Rec :: MyType2 }+ | MyType1Cons2 (f :/: a) Int a (f a)+ | (f :/: a) :/: MyType2++infixr 5 :!@!:+data GADTSyntax a b where+ GADTPrefix :: d -> c -> GADTSyntax c d+ (:!@!:) :: e -> f -> GADTSyntax e f++data MyType2 = MyType2 Float ([] :/: Int)+data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word#++-- Test to see if generated names are unique+data Lexeme = Lexeme++#if MIN_VERSION_template_haskell(2,7,0)+data family MyType3+# if __GLASGOW_HASKELL__ >= 705+ (a :: v) (b :: w) (c :: x) (d :: y) (e :: z)+# else+ (a :: *) (b :: *) (c :: * -> *) (d :: *) (e :: *)+# endif+newtype instance MyType3 (f p) (f p) f p (q :: *) = MyType3Newtype q+data instance MyType3 Bool () f p q = MyType3True | MyType3False+data instance MyType3 Int () f p (q :: *) = MyType3Hash q Addr# Char# Double# Float# Int# Word#+#endif++$(deriveAll0And1 ''Empty)+$(deriveAll0And1 ''(:/:))+$(deriveAll0And1 ''GADTSyntax)+$(deriveAll0 ''MyType2)+$(deriveAll0And1 ''PlainHash)+$(deriveAll0 ''ExampleSpec.Lexeme)+$(deriveAll0 ''Text.Read.Lex.Lexeme)++#if MIN_VERSION_template_haskell(2,7,0)+# if __GLASGOW_HASKELL__ < 705+-- We can't use deriveAll0And1 on GHC 7.4 due to an old bug :(+$(deriveMeta 'MyType3Newtype)+$(deriveRep0 'MyType3Newtype)+$(deriveRep1 'MyType3Newtype)+instance Generic (MyType3 (f p) (f p) f p q) where+ type Rep (MyType3 (f p) (f p) f p q) = $(makeRep0 'MyType3Newtype) f p q+ from = $(makeFrom0 'MyType3Newtype)+ to = $(makeTo0 'MyType3Newtype)+instance Generic1 (MyType3 (f p) (f p) f p) where+ type Rep1 (MyType3 (f p) (f p) f p) = $(makeRep1 'MyType3Newtype) f p+ from1 = $(makeFrom1 'MyType3Newtype)+ to1 = $(makeTo1 'MyType3Newtype)+# else+$(deriveAll0And1 'MyType3Newtype)+# endif+$(deriveAll0And1 'MyType3False)+$(deriveAll0And1 'MyType3Hash)+#endif++-------------------------------------------------------------------------------+-- Unit tests+-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = parallel $ do+ describe "[] and Maybe tests" $ do+ it "gshow hList" $+ gshow hList `shouldBe`+ "[1,2,3,4,5,6,7,8,9,10]"++ it "gshow (children maybe2)" $+ gshow (children maybe2) `shouldBe`+ "[]"++ it "gshow (transform (const \"abc\") [])" $+ gshow (transform (const "abc") []) `shouldBe`+ "\"abc\""++ it "gshow (transform double hList)" $+ gshow (transform double hList) `shouldBe`+ "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]"++ it "gshow (geq hList hList)" $+ gshow (geq hList hList) `shouldBe`+ "True"++ it "gshow (geq maybe1 maybe2)" $+ gshow (geq maybe1 maybe2) `shouldBe`+ "False"++ it "gshow (take 5 genum)" $+ gshow (take 5 (genum :: [Maybe Int])) `shouldBe`+ "[Nothing,Just 0,Just -1,Just 1,Just -2]"++ it "gshow (take 15 genum)" $+ gshow (take 15 (genum :: [[Int]])) `shouldBe`+ "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]"++ it "gshow (range ([0], [1]))" $+ gshow (range ([0], [1::Int])) `shouldBe`+ "[[0],[0,0],[-1],[0,0,0],[-1,0]]"++ it "gshow (inRange ([0], [3,5]) hList)" $+ gshow (inRange ([0], [3,5::Int]) hList) `shouldBe`+ "False"++ describe "Tests for Tree" $ do+ it "gshow tree" $+ gshow tree `shouldBe`+ "Branch 2 Empty (Branch 1 Empty Empty)"++ it "gshow (children tree)" $+ gshow (children tree) `shouldBe`+ "[Empty,Branch 1 Empty Empty]"++ it "gshow (descend (descend (\\_ -> Branch 0 Empty Empty)) tree)" $+ gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) `shouldBe`+ "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))"++ it "gshow (context tree [Branch 1 Empty Empty,Empty])" $+ gshow (context tree [Branch 1 Empty Empty,Empty]) `shouldBe`+ "Branch 2 (Branch 1 Empty Empty) Empty"++ it "gshow (transform upgradeTree tree)" $+ gshow (transform upgradeTree tree) `shouldBe`+ "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))"++ it "gshow (take 10 genum)" $ do+ gshow (take 10 (genum :: [Tree])) `shouldBe`+ "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]"++ describe "Tests for List" $ do+ it "gshow (gmap fromEnum list)" $+ gshow (gmap fromEnum list) `shouldBe`+ "Cons 112 (Cons 113 Nil)"++ it "gshow (gmap gshow listlist)" $+ gshow (gmap gshow listlist) `shouldBe`+ "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)"++ it "gshow list" $+ gshow list `shouldBe`+ "Cons 'p' (Cons 'q' Nil)"++ it "gshow listlist" $+ gshow listlist `shouldBe`+ "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)"++ it "gshow (children list)" $+ gshow (children list) `shouldBe`+ "[Cons 'q' Nil]"++ it "gshow (children listlist)" $+ gshow (children listlist) `shouldBe`+ "[Cons Nil Nil]"++ describe "Tests for Rose" $ do+ it "gshow rose1" $+ gshow rose1 `shouldBe`+ "Rose [1,2] [Rose [3,4] [],Rose [5] []]"++ it "gshow (gmap gshow rose1)" $+ gshow (gmap gshow rose1) `shouldBe`+ "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]"++ describe "Tests for GRose" $ do+ it "gshow grose1" $+ gshow grose1 `shouldBe`+ "GRose [1,2] [GRose [3] [],GRose [] []]"++ it "gshow (gmap gshow grose1)" $+ gshow (gmap gshow grose1) `shouldBe`+ "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]"++ describe "Tests for Either" $ do+ it "gshow either1" $+ gshow either1 `shouldBe`+ "Left Right 'p'"++ it "gshow (gmap gshow either1)" $+ gshow (gmap gshow either1) `shouldBe`+ "Left Right \"'p'\""++ describe "Tests for Nested" $ do+ it "gshow nested" $+ gshow nested `shouldBe`+ "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}"++ it "gshow (gmap gshow nested)" $+ gshow (gmap gshow nested) `shouldBe`+ "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}"++ describe "Tests for Bush" $ do+ it "gshow bush1" $+ gshow bush1 `shouldBe`+ "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)"++ it "gshow (gmap gshow bush1)" $+ gshow (gmap gshow bush1) `shouldBe`+ "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)"
tests/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
tests/T68Spec.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE DataKinds #-} -#endif - -module T68Spec (main, spec) where - -import Generics.Deriving.TH -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = return () - -type family F68 :: * -> * -type instance F68 = Maybe -data T68 a = MkT68 (F68 a) -$(deriveAll1 ''T68) +{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DataKinds #-}+#endif++module T68Spec (main, spec) where++import Generics.Deriving.TH+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()++type family F68 :: * -> *+type instance F68 = Maybe+data T68 a = MkT68 (F68 a)+$(deriveAll1 ''T68)
tests/T80Spec.hs view
@@ -1,22 +1,22 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -#endif - -module T80Spec (main, spec) where - -import Generics.Deriving.TH -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = return () - -newtype T f a b = MkT (f a b) -$(deriveAll1 ''T) +{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+#endif++module T80Spec (main, spec) where++import Generics.Deriving.TH+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()++newtype T f a b = MkT (f a b)+$(deriveAll1 ''T)
tests/T82Spec.hs view
@@ -1,29 +1,29 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -# if __GLASGOW_HASKELL__ < 806 -{-# LANGUAGE TypeInType #-} -# endif -#endif - -module T82Spec (main, spec) where - -import Test.Hspec - -#if MIN_VERSION_base(4,10,0) -import Generics.Deriving.TH -import GHC.Exts (RuntimeRep, TYPE) - -data Code m (a :: TYPE (r :: RuntimeRep)) = Code -$(deriveAll0And1 ''Code) -#endif - -main :: IO () -main = hspec spec - -spec :: Spec -spec = return () +{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+# if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+# endif+#endif++module T82Spec (main, spec) where++import Test.Hspec++#if MIN_VERSION_base(4,10,0)+import Generics.Deriving.TH+import GHC.Exts (RuntimeRep, TYPE)++data Code m (a :: TYPE (r :: RuntimeRep)) = Code+$(deriveAll0And1 ''Code)+#endif++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()
tests/TypeInTypeSpec.hs view
@@ -1,57 +1,57 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -# if __GLASGOW_HASKELL__ < 806 -{-# LANGUAGE TypeInType #-} -# endif -#endif - -module TypeInTypeSpec (main, spec) where - -import Test.Hspec - -#if __GLASGOW_HASKELL__ >= 800 -import Data.Proxy (Proxy(..)) -import Generics.Deriving.TH - -# if MIN_VERSION_base(4,10,0) -import Generics.Deriving (Generic1(..)) -# endif - -data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b) -$(deriveAll0And1 ''TyCon) - -data family TyFam x (a :: x) (b :: k) -data instance TyFam x (a :: x) (b :: k) = TyFam k x (Proxy a) (TyFam x a b) -$(deriveAll0And1 'TyFam) - -# if MIN_VERSION_base(4,10,0) -gen1PolyKinds :: Generic1 f => f 'True -> Rep1 f 'True -gen1PolyKinds = from1 -# endif -#endif - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ do -#if MIN_VERSION_base(4,10,0) - describe "TyCon Bool 'False 'True" $ - it "has an appropriately kinded Generic1 instance" $ - let rep :: Rep1 (TyCon Bool 'False) 'True - rep = gen1PolyKinds $ let x = TyCon True False Proxy x in x - in seq rep () `shouldBe` () - describe "TyFam Bool 'False 'True" $ - it "has an appropriately kinded Generic1 instance" $ - let rep :: Rep1 (TyFam Bool 'False) 'True - rep = gen1PolyKinds $ let x = TyFam True False Proxy x in x - in seq rep () `shouldBe` () -#else - return () -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+# if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+# endif+#endif++module TypeInTypeSpec (main, spec) where++import Test.Hspec++#if __GLASGOW_HASKELL__ >= 800+import Data.Proxy (Proxy(..))+import Generics.Deriving.TH++# if MIN_VERSION_base(4,10,0)+import Generics.Deriving (Generic1(..))+# endif++data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b)+$(deriveAll0And1 ''TyCon)++data family TyFam x (a :: x) (b :: k)+data instance TyFam x (a :: x) (b :: k) = TyFam k x (Proxy a) (TyFam x a b)+$(deriveAll0And1 'TyFam)++# if MIN_VERSION_base(4,10,0)+gen1PolyKinds :: Generic1 f => f 'True -> Rep1 f 'True+gen1PolyKinds = from1+# endif+#endif++main :: IO ()+main = hspec spec++spec :: Spec+spec = parallel $ do+#if MIN_VERSION_base(4,10,0)+ describe "TyCon Bool 'False 'True" $+ it "has an appropriately kinded Generic1 instance" $+ let rep :: Rep1 (TyCon Bool 'False) 'True+ rep = gen1PolyKinds $ let x = TyCon True False Proxy x in x+ in seq rep () `shouldBe` ()+ describe "TyFam Bool 'False 'True" $+ it "has an appropriately kinded Generic1 instance" $+ let rep :: Rep1 (TyFam Bool 'False) 'True+ rep = gen1PolyKinds $ let x = TyFam True False Proxy x in x+ in seq rep () `shouldBe` ()+#else+ return ()+#endif