generic-deriving 1.14.3 → 1.14.4
raw patch · 35 files changed
+13263/−13215 lines, 35 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +220/−213
- LICENSE +28/−28
- README.md +86/−86
- Setup.hs +6/−6
- generic-deriving.cabal +159/−157
- 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 +1144/−1140
- 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 +1227/−1192
- src/Generics/Deriving/TH/Internal.hs +951/−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,213 +1,220 @@-# 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.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,157 +1,159 @@-name: generic-deriving-version: 1.14.3-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.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.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.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
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,1140 +1,1144 @@-{-# 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- genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T])--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.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
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,1192 +1,1227 @@-{-# 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-- fmap (:[]) $- instanceD (cxt []) (conT genericName `appT` return origSigTy)- [return tyIns, funD fromName fcs, funD toName tcs]--{- $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.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! +-}
src/Generics/Deriving/TH/Internal.hs view
@@ -1,951 +1,951 @@-{-# 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 #-} + +{- | +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"
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