generic-deriving 1.13.1 → 1.14.7
raw patch · 30 files changed
Files
- CHANGELOG.md +44/−0
- README.md +61/−1
- generic-deriving.cabal +73/−29
- src/Generics/Deriving/Base.hs +3/−8
- src/Generics/Deriving/Base/Internal.hs +0/−1136
- src/Generics/Deriving/ConNames.hs +2/−11
- src/Generics/Deriving/Copoint.hs +7/−45
- src/Generics/Deriving/Default.hs +1/−11
- src/Generics/Deriving/Enum.hs +23/−132
- src/Generics/Deriving/Eq.hs +14/−86
- src/Generics/Deriving/Foldable.hs +11/−66
- src/Generics/Deriving/Functor.hs +12/−75
- src/Generics/Deriving/Instances.hs +103/−1884
- src/Generics/Deriving/Monoid.hs +3/−13
- src/Generics/Deriving/Monoid/Internal.hs +6/−43
- src/Generics/Deriving/Semigroup.hs +3/−11
- src/Generics/Deriving/Semigroup/Internal.hs +8/−59
- src/Generics/Deriving/Show.hs +14/−77
- src/Generics/Deriving/TH.hs +254/−247
- src/Generics/Deriving/TH/Internal.hs +281/−324
- src/Generics/Deriving/TH/Pre4_9.hs +0/−241
- src/Generics/Deriving/Traversable.hs +14/−77
- src/Generics/Deriving/Uniplate.hs +9/−56
- tests/DefaultSpec.hs +2/−2
- tests/EmptyCaseSpec.hs +2/−9
- tests/ExampleSpec.hs +7/−35
- tests/T68Spec.hs +19/−0
- tests/T80Spec.hs +18/−0
- tests/T82Spec.hs +27/−0
- tests/TypeInTypeSpec.hs +7/−8
CHANGELOG.md view
@@ -1,3 +1,47 @@+# 1.14.7 [2026.01.03]+* Allow building with GHC 9.14.+* Remove unused `ghc-prim` dependency.++# 1.14.6 [2024.12.05]+* Drop support for GHC 7.10 and earlier.++# 1.14.5 [2023.08.06]+* Support building with `template-haskell-2.21.*` (GHC 9.8).+* The Template Haskell machinery now uses `TemplateHaskellQuotes` when+ building with GHC 8.0+ instead of manually constructing each Template Haskell+ `Name`. A consequence of this is that `generic-deriving` will now build with+ GHC 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template+ Haskell changes introduced in 9.8.++# 1.14.4 [2023.04.30]+* Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined,+ such as the WASM backend.+* Place `INLINE [1]` pragmas on `from` and `to` implementations when types+ don't have too many constructors or fields, following the heuristics that GHC+ 9.2+ uses for `Generic` deriving.++# 1.14.3 [2023.02.27]+* Support `th-abstraction-0.5.*`.++# 1.14.2 [2022.07.23]+* Fix a bug in which `deriveAll1` could generate ill kinded code when using+ `kindSigOptions=False`, or when using GHC 8.0 or earlier.+* Fix a bug in which `deriveAll1` would reject data types whose last type+ variable has a kind besides `Type` or `k` on GHC 8.2 or later.++# 1.14.1 [2021.08.30]+* Backport the `Generic(1)` instances introduced for tuples (8 through 15) in+ `base-4.16`.+* Make the test suite compile on GHC 9.2 or later.+* Always import `Data.List` qualified to fix the build with recent GHCs.++# 1.14 [2020.09.30]+* Remove instances for `Data.Semigroup.Option`, which is deprecated as of+ `base-4.15.0.0`.+* Allow building with `template-haskell-2.17.0.0` (GHC 9.0).+* Fix a bug in which `deriveAll1` would needlessly reject data types whose last+ type parameter appears as an oversaturated argument to a type family.+ # 1.13.1 [2019.11.26] * Backport the `Generic(1)` instances for `Kleisli` introduced in `base-4.14`.
README.md view
@@ -3,7 +3,7 @@ [](http://packdeps.haskellers.com/reverse/generic-deriving) [][Haskell.org] [][tl;dr Legal: BSD3]-[](https://travis-ci.org/dreixel/generic-deriving)+[](https://github.com/dreixel/generic-deriving/actions?query=workflow%3AHaskell-CI) [Hackage: generic-deriving]: http://hackage.haskell.org/package/generic-deriving@@ -24,3 +24,63 @@ 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.cabal view
@@ -1,5 +1,5 @@ name: generic-deriving-version: 1.13.1+version: 1.14.7 synopsis: Generic programming library for generalised deriving. description: @@ -13,6 +13,50 @@ 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@@ -25,18 +69,22 @@ 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+tested-with:+ GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.1- , GHC == 8.10.1+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1+ extra-source-files: CHANGELOG.md , README.md @@ -44,11 +92,6 @@ 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@@ -69,22 +112,19 @@ Generics.Deriving.TH - other-modules: Generics.Deriving.Base.Internal- Generics.Deriving.Monoid.Internal+ other-modules: Generics.Deriving.Monoid.Internal Generics.Deriving.Semigroup.Internal Generics.Deriving.TH.Internal+ Generics.Deriving.TH.Post4_9 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.17- , th-abstraction >= 0.3 && < 0.4+ build-depends: base >= 4.9 && < 5+ , containers >= 0.1 && < 0.9+ , template-haskell >= 2.11 && < 2.25+ -- TODO: Eventually, we should bump the lower version+ -- bounds to >=0.6 so that we can remove some CPP in+ -- Generics.Deriving.TH.Internal.+ , th-abstraction >= 0.4 && < 0.8 default-language: Haskell2010 ghc-options: -Wall@@ -95,12 +135,16 @@ other-modules: DefaultSpec EmptyCaseSpec ExampleSpec+ T68Spec+ T80Spec+ T82Spec TypeInTypeSpec- build-depends: base >= 4.3 && < 5+ build-depends: base , generic-deriving , hspec >= 2 && < 3- , template-haskell >= 2.4 && < 2.17 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/Base.hs view
@@ -1,12 +1,7 @@-{-# 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+module Generics.Deriving.Base (module GHC.Generics) where -import Generics.Deriving.Base.Internal+import GHC.Generics+ import Generics.Deriving.Instances ()
− src/Generics/Deriving/Base/Internal.hs
@@ -1,1136 +0,0 @@-{-# 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 associativy 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,19 +1,10 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# 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
src/Generics/Deriving/Copoint.hs view
@@ -1,21 +1,9 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# 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+{-# LANGUAGE TypeOperators #-} module Generics.Deriving.Copoint ( -- * GCopoint class@@ -31,27 +19,15 @@ 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.Monoid (Alt, Dual)+import qualified Data.Monoid as Monoid (Sum)+import Data.Ord (Down) import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid)-#endif +import Generics.Deriving.Base+ -------------------------------------------------------------------------------- -- Generic copoint --------------------------------------------------------------------------------@@ -94,11 +70,9 @@ 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@@ -127,15 +101,11 @@ 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@@ -143,17 +113,12 @@ 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 @@ -165,7 +130,6 @@ instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where gcopoint = gcopointdefault-#endif instance GCopoint Monoid.Sum where gcopoint = gcopointdefault@@ -173,7 +137,5 @@ 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
@@ -36,16 +36,9 @@ -- 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 Safe #-} {-# LANGUAGE UndecidableInstances #-} module Generics.Deriving.Default@@ -66,9 +59,6 @@ -- $other-kinds ) where -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative ((<$>))-#endif import Control.Monad (liftM) import Generics.Deriving.Base
src/Generics/Deriving/Enum.hs view
@@ -1,19 +1,13 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-} {-# 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 (@@ -37,10 +31,18 @@ import Control.Applicative (Const, ZipList) +import Data.Coerce (coerce)+import Data.Complex (Complex)+import Data.Functor.Identity (Identity) import Data.Int-import Data.Monoid (All, Any, Dual, Product, Sum)+import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (listToMaybe)+import Data.Monoid (All, Alt, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last)-import Data.Word+import Data.Proxy (Proxy)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+import Data.Word import Foreign.C.Types import Foreign.Ptr@@ -48,31 +50,10 @@ 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, Option, WrappedMonoid)-#endif+import System.Exit (ExitCode)+import System.Posix.Types ----------------------------------------------------------------------------- -- Utility functions for Enum'@@ -106,9 +87,7 @@ 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)+ in listToMaybe l -------------------------------------------------------------------------------- -- Generic enum@@ -151,10 +130,8 @@ 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@@ -167,11 +144,6 @@ 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@@ -211,24 +183,15 @@ 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 @@ -297,10 +260,8 @@ 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@@ -326,16 +287,18 @@ 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])@@ -376,10 +339,8 @@ 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])@@ -405,10 +366,8 @@ 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@@ -416,10 +375,8 @@ 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@@ -448,40 +405,27 @@ 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 -instance GEnum a => GEnum (Option a) where- genum = genumDefault-#endif- instance GEnum Ordering where genum = genumDefault @@ -491,16 +435,8 @@ 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+instance GEnum (Proxy s) where genum = genumDefault-#endif instance GEnum (f p) => GEnum (Rec1 f p) where genum = genumDefault@@ -529,10 +465,8 @@ 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@@ -590,7 +524,7 @@ -- | 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 @@ -599,7 +533,6 @@ 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]@@ -696,32 +629,21 @@ 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@@ -922,24 +844,20 @@ 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@@ -981,53 +899,36 @@ 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 -#if MIN_VERSION_base(4,9,0)-instance (GEq a, GEnum a, GIx a) => GIx (Option a) where- range = rangeDefault- index = indexDefault- inRange = inRangeDefault-#endif- instance GIx Ordering where range = rangeDefault index = indexDefault@@ -1038,18 +939,10 @@ 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+instance GIx (Proxy s) where range = rangeDefault index = indexDefault inRange = inRangeDefault-#endif instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where range = rangeDefault@@ -1086,12 +979,10 @@ 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
src/Generics/Deriving/Eq.hs view
@@ -1,21 +1,15 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-} {-# 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 (@@ -33,10 +27,17 @@ import Control.Applicative (Const, ZipList) import Data.Char (GeneralCategory)+import Data.Complex (Complex)+import Data.Functor.Identity (Identity) import Data.Int+import Data.List.NonEmpty (NonEmpty) import qualified Data.Monoid as Monoid (First, Last)-import Data.Monoid (All, Any, Dual, Product, Sum)+import Data.Monoid (All, Alt, Any, Dual, Product, Sum)+import Data.Proxy (Proxy)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg(..), Max, Min, WrappedMonoid) import Data.Version (Version)+import Data.Void (Void) import Data.Word import Foreign.C.Error@@ -49,32 +50,13 @@ import GHC.Exts hiding (Any) +import Numeric.Natural (Natural)+ 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, Option, WrappedMonoid)-#endif- -------------------------------------------------------------------------------- -- Generic show --------------------------------------------------------------------------------@@ -118,20 +100,12 @@ 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)@@ -175,23 +149,14 @@ 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@@ -267,10 +232,8 @@ 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@@ -296,10 +259,8 @@ geq = (==) #endif -#if MIN_VERSION_base(4,4,0) instance GEq CSUSeconds where geq = (==)-#endif instance GEq CShort where geq = (==)@@ -346,10 +307,8 @@ instance GEq CULong where geq = (==) -#if MIN_VERSION_base(4,4,0) instance GEq CUSeconds where geq = (==)-#endif instance GEq CUShort where geq = (==)@@ -357,10 +316,8 @@ instance GEq CWchar where geq = (==) -#if MIN_VERSION_base(4,9,0) instance GEq DecidedStrictness where geq = geqdefault-#endif instance GEq Double where geq = (==)@@ -386,10 +343,8 @@ 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@@ -412,10 +367,8 @@ 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 = (==)@@ -453,10 +406,8 @@ 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@@ -464,27 +415,18 @@ 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 -instance GEq a => GEq (Option a) where- geq = geqdefault-#endif- instance GEq Ordering where geq = geqdefault @@ -494,16 +436,8 @@ 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+instance GEq (Proxy s) where geq = geqdefault-#endif instance GEq (Ptr a) where geq = (==)@@ -517,13 +451,11 @@ 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@@ -552,10 +484,8 @@ instance GEq Version where geq = (==) -#if MIN_VERSION_base(4,8,0) instance GEq Void where geq = (==)-#endif instance GEq Word where geq = (==)@@ -575,10 +505,8 @@ 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
src/Generics/Deriving/Foldable.hs view
@@ -1,22 +1,10 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# 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+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-} module Generics.Deriving.Foldable ( -- * Generic Foldable class@@ -49,41 +37,21 @@ 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 Data.Maybe+import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..))+import Data.Monoid (All(..), Any(..), Dual(..), Endo(..))+import Data.Ord (Down)+import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last)-import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)-#endif+import Data.Semigroup (Arg, Max, Min, WrappedMonoid) +import Generics.Deriving.Base+ -------------------------------------------------------------------------------- -- Generic fold --------------------------------------------------------------------------------@@ -139,11 +107,9 @@ 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@@ -187,15 +153,11 @@ 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@@ -212,64 +174,47 @@ 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 -instance GFoldable Option 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
src/Generics/Deriving/Functor.hs view
@@ -1,27 +1,12 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyCase #-} {-# 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+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-} module Generics.Deriving.Functor ( -- * Generic Functor class@@ -37,38 +22,20 @@ 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.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Alt, Dual)+import Data.Ord (Down)+import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last)-import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)-#endif+import Data.Semigroup (Arg, Max, Min, WrappedMonoid) +import Generics.Deriving.Base+ -------------------------------------------------------------------------------- -- Generic fmap --------------------------------------------------------------------------------@@ -77,12 +44,7 @@ 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+ gmap' _ x = case x of {} instance GFunctor' U1 where gmap' _ U1 = U1@@ -129,11 +91,9 @@ 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@@ -149,20 +109,14 @@ 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@@ -179,15 +133,11 @@ 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@@ -195,51 +145,38 @@ 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 -instance GFunctor Option 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,1887 +1,106 @@ {-# 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,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,14,0))-import Generics.Deriving.Base.Internal-#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)-+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Generics.Deriving.Instances (+-- Only instances from GHC.Generics+-- 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+ ) where++#if !(MIN_VERSION_base(4,12,0))+import Data.Ord (Down(..))+#endif++#if !(MIN_VERSION_base(4,14,0))+import Control.Arrow (Kleisli(..))+#endif++#if !(MIN_VERSION_base(4,16,0))+import GHC.Generics+#endif++#if !(MIN_VERSION_base(4,16,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)+#endif++#if !(MIN_VERSION_base(4,14,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)+#endif++#if !(MIN_VERSION_base(4,12,0))+type Rep0Down a = Rep (Down a)+type Rep1Down = Rep1 Down+deriving instance Generic (Down a)+deriving instance Generic1 Down #endif
src/Generics/Deriving/Monoid.hs view
@@ -1,27 +1,17 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# OPTIONS_GHC -Wno-orphans #-} module Generics.Deriving.Monoid (module Generics.Deriving.Monoid.Internal) where +import Data.Semigroup (WrappedMonoid)+ 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,21 +1,9 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# 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+{-# LANGUAGE TypeOperators #-} module Generics.Deriving.Monoid.Internal ( @@ -74,23 +62,12 @@ -------------------------------------------------------------------------------- import Control.Applicative+import Data.Functor.Identity (Identity) 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+import Generics.Deriving.Base+import Generics.Deriving.Semigroup.Internal -------------------------------------------------------------------------------- @@ -166,13 +143,11 @@ 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 -------------------------------------------------------------------------------- @@ -207,11 +182,9 @@ 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@@ -227,23 +200,13 @@ 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+instance GMonoid (Proxy s) 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
src/Generics/Deriving/Semigroup.hs view
@@ -1,20 +1,12 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# OPTIONS_GHC -Wno-orphans #-} 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(..))+import Generics.Deriving.Semigroup.Internal 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,21 +1,9 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# 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+{-# LANGUAGE TypeOperators #-} module Generics.Deriving.Semigroup.Internal ( -- * Generic semigroup class@@ -30,31 +18,14 @@ ) 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.Monoid as Monoid hiding ((<>))+import Data.Ord (Down)+import Data.Proxy (Proxy) import Data.Semigroup as Semigroup-#endif+import Data.Void (Void)+import Generics.Deriving.Base ------------------------------------------------------------------------------- @@ -79,10 +50,8 @@ 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@@ -98,13 +67,10 @@ | 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@@ -133,10 +99,8 @@ 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@@ -155,26 +119,15 @@ 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+instance GSemigroup (Proxy s) 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 = (<>) @@ -189,10 +142,6 @@ instance GSemigroup (NonEmpty a) where gsappend = (<>)--instance GSemigroup a => GSemigroup (Option a) where- gsappend (Option a) (Option b) = Option (gsappend a b)-#endif -- Tuple instances instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where
src/Generics/Deriving/Show.hs view
@@ -1,21 +1,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-} {-# 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(..)@@ -31,10 +25,17 @@ import Control.Applicative (Const, ZipList) import Data.Char (GeneralCategory)+import Data.Complex (Complex)+import Data.Functor.Identity (Identity) import Data.Int-import Data.Monoid (All, Any, Dual, Product, Sum)+import Data.List.NonEmpty (NonEmpty)+import Data.Monoid (All, Alt, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last)+import Data.Proxy (Proxy)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid) import Data.Version (Version)+import Data.Void (Void) import Data.Word import Foreign.C.Types@@ -45,32 +46,13 @@ import GHC.Exts hiding (Any) +import Numeric.Natural (Natural)+ 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, Option, WrappedMonoid)-#endif- -------------------------------------------------------------------------------- -- Generic show --------------------------------------------------------------------------------@@ -91,12 +73,7 @@ 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+ gshowsPrec' _ _ x = case x of {} instance GShow' U1 where gshowsPrec' _ _ U1 = id@@ -177,11 +154,9 @@ 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@@ -240,24 +215,15 @@ 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 @@ -333,10 +299,8 @@ 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@@ -362,10 +326,8 @@ gshowsPrec = showsPrec #endif -#if MIN_VERSION_base(4,4,0) instance GShow CSUSeconds where gshowsPrec = showsPrec-#endif instance GShow CShort where gshowsPrec = showsPrec@@ -412,10 +374,8 @@ 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@@ -444,10 +404,8 @@ 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@@ -470,10 +428,8 @@ 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@@ -511,40 +467,27 @@ 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 -instance GShow a => GShow (Option a) where- gshowsPrec = gshowsPrecdefault-#endif- instance GShow Ordering where gshowsPrec = gshowsPrecdefault @@ -554,10 +497,8 @@ 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@@ -592,10 +533,8 @@ 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@@ -615,10 +554,8 @@ 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
src/Generics/Deriving/TH.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} {- | Module : Generics.Deriving.TH@@ -105,70 +106,62 @@ import qualified Data.Map as Map (empty, fromList) import Generics.Deriving.TH.Internal-#if MIN_VERSION_base(4,9,0) import Generics.Deriving.TH.Post4_9-#else-import Generics.Deriving.TH.Pre4_9-#endif import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH {- $options 'Options' gives you a way to further tweak derived 'Generic' and 'Generic1' instances: -* 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit the code- directly (the 'InlineRep' option). One can also choose to emit a separate type- synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and- 'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the- 'TypeSynonymRep' option).--* '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. For example, the following example will only- compile with 'KindSigOptions' set to 'False':+* '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). - @- newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a))- $('deriveAll1Options' False ''Compose)- @+* '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: -* '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"+ @ - @- 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: - 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 {}+ @ - @- 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). - 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. - 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@@ -308,17 +301,18 @@ 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, gk) = genericKind gClass instTys+ let tySynVars = genericInitTvbs gt tySynVars' = if useKindSigs then tySynVars else map unKindedTV tySynVars fmap (:[]) $ tySynD (genRepName gClass dv name)- tySynVars'- (repType gk dv name Map.empty cons)+ (changeTVFlags bndrReq tySynVars')+ (repType gt dv name Map.empty cons) deriveInst :: GenericClass -> Options -> Name -> Q [Dec] deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName@@ -335,30 +329,54 @@ 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 makeRepInline gClass dv name instTys cons origTy- else makeRepTySynApp gClass dv name origTy+ 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-#if MIN_VERSION_th_abstraction(0,3,0)- Nothing-#endif- [return origSigTy] (return tyInsRHS)+ tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return tyInsRHS) let ecOptions = emptyCaseOptions opts- mkBody maker = [clause [] (normalB $- mkCaseExp gClass ecOptions name instTys cons maker) []]+ mkBody maker = [clause []+ (normalB $+ mkCaseExp $+ maker gt ecOptions name cons)+ []] fcs = mkBody mkFrom tcs = mkBody mkTo + inline_pragmas+ | inlining_useful cons+ = map (\fun_name ->+ pragInlD fun_name+ Inline FunLike (FromPhase 1)+ ) [fromName, toName]+ | otherwise+ = []+ fmap (:[]) $ instanceD (cxt []) (conT genericName `appT` return origSigTy)- [return tyIns, funD fromName fcs, funD toName tcs]+ (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 @@ -552,32 +570,32 @@ 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 gClass dv name instTys cons+ (Just qTy, InlineRep) -> qTy >>= makeRepInline gt dv name cons (Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name (Nothing, InlineRep) -> fail "makeRepCommon" -makeRepInline :: GenericClass+makeRepInline :: GenericTvbs -> DatatypeVariant_ -> Name- -> [Type] -> [ConstructorInfo] -> Type -> Q Type-makeRepInline gClass dv name instTys cons ty = do+makeRepInline gt dv name cons ty = do let instVars = freeVariablesWellScoped [ty]- (tySynVars, gk) = genericKind gClass instTys+ tySynVars = genericInitTvbs gt typeSubst :: TypeSubst typeSubst = Map.fromList $ zip (map tvName tySynVars) (map (VarT . tvName) instVars) - repType gk dv name typeSubst cons+ repType gt dv name typeSubst cons makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type@@ -630,15 +648,15 @@ makeTo1Options = makeFunCommon mkTo Generic1 makeFunCommon- :: (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]- -> [ConstructorInfo] -> Q Match)+ :: (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 gClass ecOptions name instTys cons maker+ `seq` mkCaseExp (maker gt ecOptions name cons) genRepName :: GenericClass -> DatatypeVariant_ -> Name -> Name@@ -650,26 +668,26 @@ . sanitizeName $ nameBase n -repType :: GenericKind+repType :: GenericTvbs -> DatatypeVariant_ -> Name -> TypeSubst -> [ConstructorInfo] -> Q Type-repType gk dv dt typeSubst cs =+repType gt dv dt typeSubst cs = conT d1TypeName `appT` mkMetaDataType dv dt `appT`- foldBal sum' (conT v1TypeName) (map (repCon gk dv dt typeSubst) cs)+ 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 :: GenericKind+repCon :: GenericTvbs -> DatatypeVariant_ -> Name -> TypeSubst -> ConstructorInfo -> Q Type-repCon gk dv dt typeSubst+repCon gt dv dt typeSubst (ConstructorInfo { constructorName = n , constructorVars = vars , constructorContext = ctxt@@ -691,9 +709,9 @@ InfixConstructor -> True RecordConstructor _ -> False ssis <- reifySelStrictInfo n bangs- repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix+ repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix -repConWith :: GenericKind+repConWith :: GenericTvbs -> DatatypeVariant_ -> Name -> Name@@ -704,15 +722,15 @@ -> Bool -> Bool -> Q Type-repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do+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 gk dv dt n typeSubst . Just)+ Just selNames -> zipWith3 (repField gt dv dt n typeSubst . Just) selNames ssis ts- Nothing -> zipWith (repField gk dv dt n typeSubst Nothing)+ Nothing -> zipWith (repField gt dv dt n typeSubst Nothing) ssis ts conT c1TypeName@@ -722,7 +740,7 @@ prodT :: Q Type -> Q Type -> Q Type prodT a b = conT productTypeName `appT` a `appT` b -repField :: GenericKind+repField :: GenericTvbs -> DatatypeVariant_ -> Name -> Name@@ -731,15 +749,15 @@ -> SelStrictInfo -> Type -> Q Type-repField gk dv dt ns typeSubst mbF ssi t =+repField gt dv dt ns typeSubst mbF ssi t = conT s1TypeName `appT` mkMetaSelType dv dt ns mbF ssi- `appT` (repFieldArg gk =<< resolveTypeSynonyms t'')+ `appT` (repFieldArg gt =<< resolveTypeSynonyms t'') where -- See Note [Generic1 is polykinded in base-4.10] t', t'' :: Type- t' = case gk of- Gen1 _ (Just _kvName) ->+ t' = case gt of+ Gen1{gen1LastTvbKindVar = Just _kvName} -> #if MIN_VERSION_base(4,10,0) t #else@@ -748,54 +766,55 @@ _ -> t t'' = applySubstitution typeSubst t' -repFieldArg :: GenericKind -> Type -> Q Type-repFieldArg _ ForallT{} = rankNError-repFieldArg gk (SigT t _) = repFieldArg gk t-repFieldArg Gen0 t = boxT t-repFieldArg (Gen1 name _) (VarT t) | t == name = conT par1TypeName-repFieldArg gk@(Gen1 name _) t = do- let tyHead:tyArgs = unapplyTy t- numLastArgs = min 1 $ length tyArgs- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs- rec0Type = boxT t- phiType = return $ applyTyToTys tyHead lhsArgs-- inspectTy :: Type -> Q Type- inspectTy (VarT a)- | a == name- = conT rec1TypeName `appT` phiType- inspectTy (SigT ty _) = inspectTy ty- inspectTy beta- | not (ground beta name)- = conT composeTypeName `appT` phiType- `appT` repFieldArg gk beta- inspectTy _ = rec0Type+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 - itf <- isTyFamily tyHead- if any (not . (`ground` name)) lhsArgs- || any (not . (`ground` name)) tyArgs && itf- then outOfPlaceTyVarError- else case rhsArgs of- [] -> rec0Type- ty:_ -> inspectTy ty+-- | 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- :: GenericClass -> EmptyCaseOptions -> Name -> [Type] -> [ConstructorInfo]- -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]- -> [ConstructorInfo] -> Q Match)- -> Q Exp-mkCaseExp gClass ecOptions dt instTys cs matchmaker = do+mkCaseExp :: Q Match -> Q Exp+mkCaseExp qMatch = do val <- newName "val"- lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 1 dt instTys cs]+ lam1E (varP val) $ caseE (varE val) [qMatch] -mkFrom :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+mkFrom :: GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match-mkFrom gClass ecOptions m i dt instTys cs = do+mkFrom gt ecOptions dt cs = do y <- newName "y" match (varP y) (normalB $ conE m1DataName `appE` caseE (varE y) cases)@@ -803,13 +822,11 @@ where cases = case cs of [] -> errorFrom ecOptions dt- _ -> zipWith (fromCon gk wrapE (length cs)) [1..] cs- wrapE e = lrE i m e- (_, gk) = genericKind gClass instTys+ _ -> zipWith (fromCon gt id (length cs)) [1..] cs errorFrom :: EmptyCaseOptions -> Name -> [Q Match] errorFrom useEmptyCase dt- | useEmptyCase && ghc7'8OrLater+ | useEmptyCase = [] | otherwise = [do z <- newName "z"@@ -822,9 +839,9 @@ ++ nameBase dt)) []] -mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+mkTo :: GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match-mkTo gClass ecOptions m i dt instTys cs = do+mkTo gt ecOptions dt cs = do y <- newName "y" match (conP m1DataName [varP y]) (normalB $ caseE (varE y) cases)@@ -832,13 +849,11 @@ where cases = case cs of [] -> errorTo ecOptions dt- _ -> zipWith (toCon gk wrapP (length cs)) [1..] cs- wrapP p = lrP i m p- (_, gk) = genericKind gClass instTys+ _ -> zipWith (toCon gt id (length cs)) [1..] cs errorTo :: EmptyCaseOptions -> Name -> [Q Match] errorTo useEmptyCase dt- | useEmptyCase && ghc7'8OrLater+ | useEmptyCase = [] | otherwise = [do z <- newName "z"@@ -850,16 +865,9 @@ (stringE $ "No values for empty datatype " ++ nameBase dt)) []] -ghc7'8OrLater :: Bool-#if __GLASGOW_HASKELL__ >= 708-ghc7'8OrLater = True-#else-ghc7'8OrLater = False-#endif--fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int+fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match-fromCon gk wrap m i+fromCon gt wrap m i (ConstructorInfo { constructorName = cn , constructorVars = vars , constructorContext = ctxt@@ -869,53 +877,56 @@ 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 gk) fNames ts)) []+ 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 :: GenericKind -> Name -> Type -> Q Exp-fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< resolveTypeSynonyms t)+fromField :: GenericTvbs -> Name -> Type -> Q Exp+fromField gt nr t = conE m1DataName `appE` (fromFieldWrap gt nr =<< resolveTypeSynonyms t) -fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp-fromFieldWrap _ _ ForallT{} = rankNError-fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t-fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE nr-fromFieldWrap (Gen1 name _) nr t = wC t name `appE` varE nr+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 (VarT t) name | t == name = conE par1DataName-wC t name- | ground t name = conE $ boxRepName t- | otherwise = do- let tyHead:tyArgs = unapplyTy t- numLastArgs = min 1 $ length tyArgs- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- inspectTy :: Type -> Q Exp- inspectTy ForallT{} = rankNError- inspectTy (SigT ty _) = inspectTy ty- inspectTy (VarT a)- | a == name- = conE rec1DataName- inspectTy beta = infixApp (conE comp1DataName)- (varE composeValName)- (varE fmapValName `appE` wC beta name)-- itf <- isTyFamily tyHead- if any (not . (`ground` name)) lhsArgs- || any (not . (`ground` name)) tyArgs && itf- then outOfPlaceTyVarError- else case rhsArgs of- [] -> conE $ boxRepName t- ty:_ -> inspectTy ty+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 :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int+toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match-toCon gk wrap m i+toCon gt wrap m i (ConstructorInfo { constructorName = cn , constructorVars = vars , constructorContext = ctxt@@ -924,50 +935,54 @@ checkExistentialContext cn vars ctxt fNames <- newNameList "f" $ length ts match (wrap $ lrP i m $ conP m1DataName- [foldBal prod (conP u1DataName []) (zipWith (toField gk) fNames ts)])+ [foldBal prod (conP u1DataName []) (zipWith (toField gt) fNames ts)]) (normalB $ foldl appE (conE cn)- (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gk nr)+ (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gt nr) fNames ts)) [] where prod x y = conP productDataName [x,y] -toConUnwC :: GenericKind -> Name -> Type -> Q Exp-toConUnwC Gen0 nr _ = varE nr-toConUnwC (Gen1 name _) nr t = unwC t name `appE` varE nr+toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp+toConUnwC Gen0{} nr _ = varE nr+toConUnwC (Gen1{gen1LastTvbName = name}) nr t = unwC t name `appE` varE nr -toField :: GenericKind -> Name -> Type -> Q Pat-toField gk nr t = conP m1DataName [toFieldWrap gk nr t]+toField :: GenericTvbs -> Name -> Type -> Q Pat+toField gt nr t = conP m1DataName [toFieldWrap gt nr t] -toFieldWrap :: GenericKind -> Name -> Type -> Q Pat-toFieldWrap Gen0 nr t = conP (boxRepName t) [varP nr]+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 (SigT t _) name = unwC t name-unwC (VarT t) name | t == name = varE unPar1ValName-unwC t name- | ground t name = varE $ unboxRepName t- | otherwise = do- let tyHead:tyArgs = unapplyTy t- numLastArgs = min 1 $ length tyArgs- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- inspectTy :: Type -> Q Exp- inspectTy ForallT{} = rankNError- inspectTy (SigT ty _) = inspectTy ty- inspectTy (VarT a)- | a == name- = varE unRec1ValName- inspectTy beta = infixApp (varE fmapValName `appE` unwC beta name)- (varE composeValName)- (varE unComp1ValName)-- itf <- isTyFamily tyHead- if any (not . (`ground` name)) lhsArgs- || any (not . (`ground` name)) tyArgs && itf- then outOfPlaceTyVarError- else case rhsArgs of- [] -> varE $ unboxRepName t- ty:_ -> inspectTy ty+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@@ -1022,15 +1037,27 @@ 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 there are enough types to drop and that all of them are either of- -- kind * or kind k (for some kind variable k). If not, throw an error.- when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $+ -- 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@@ -1135,52 +1162,32 @@ 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. -Another motivation for explicit kind signatures is the -XTypeInType extension.-With -XTypeInType, dropping kind signatures can completely change the meaning-of some data types. For example, there is a substantial difference between these-two data types:+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 T k (a :: k) = T k- data T k a = T k+ data S (a :: k) = S k -In addition to using explicit kind signatures on type variables, we also put-explicit return kinds in the instance head, so generated instances will look-something like this:+Will have the following Generic1 instance generated for it: - data S (a :: k) = S k 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 return kind:+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! -Although explicit kind signatures are the right thing to do in most cases, there-are sadly some degenerate cases where this isn't true. Consider this example:-- newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a))--The Rep1 type instance in a Generic1 instance for Compose would involve the type-(f :.: Rec1 g), which forces (f :: * -> *). But this library doesn't have very-sophisticated kind inference machinery (other than what is mentioned in-Note [Generic1 is polykinded in base-4.10]), so at the moment we-have no way of actually unifying k1 with *. So the naïve generated Generic1-instance would be:-- instance Generic1 (Compose (f :: k2 -> *) (g :: k1 -> k2)) where- type Rep1 (Compose f g) = ... (f :.: Rec1 g)--This is wrong, since f's kind is overly generalized. To get around this issue,-there are variants of the TH functions that allow you to configure 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.+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:
src/Generics/Deriving/TH/Internal.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {- | Module : Generics.Deriving.TH.Internal@@ -18,23 +21,28 @@ import Data.Char (isAlphaNum, ord) import Data.Foldable (foldr')-import Data.List+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+import qualified Generics.Deriving as GD+import Generics.Deriving hiding+ ( DecidedStrictness(..), Fixity(Infix)+ , SourceStrictness(..), SourceUnpackedness(..)+ , datatypeName+ )++import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#)++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 -------------------------------------------------------------------------------@@ -42,11 +50,7 @@ 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)@@ -58,10 +62,15 @@ -- StarKindStatus ------------------------------------------------------------------------------- --- | Whether a type is not of kind *, is of kind *, or is a kind variable.-data StarKindStatus = NotKindStar- | KindStar+-- | 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)?@@ -69,10 +78,8 @@ canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of-#if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k-#endif- _ -> NotKindStar+ _ -> OtherKind -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. -- Otherwise, returns 'Nothing'.@@ -92,18 +99,14 @@ -- | 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 TyVarBndr-typeToTyVarBndr (VarT n) = Just (PlainTV n)-typeToTyVarBndr (SigT (VarT n) k) = Just (KindedTV n k)+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 *.@@ -137,65 +140,58 @@ -- 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 --- | Is the given type a type family constructor (and not a data family constructor)?-isTyFamily :: Type -> Q Bool-isTyFamily (ConT n) = do- info <- reify n- return $ case info of-#if MIN_VERSION_template_haskell(2,11,0)- FamilyI OpenTypeFamilyD{} _ -> True-#elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ _ _) _ -> True-#else- TyConI (FamilyD TypeFam _ _ _) -> True-#endif-#if MIN_VERSION_template_haskell(2,9,0)- FamilyI ClosedTypeFamilyD{} _ -> True-#endif- _ -> False-isTyFamily _ = return False+-- | Remove any outer `SigT` and `ParensT` constructors, and turn+-- an outermost `InfixT` constructor into plain applications.+dustOff :: Type -> Type+dustOff (SigT ty _) = dustOff ty+dustOff (ParensT ty) = dustOff ty+dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2+dustOff ty = ty +-- | Checks whether a type is an unsaturated type family+-- application.+isUnsaturatedType :: Type -> Q Bool+isUnsaturatedType = go 0 . dustOff+ where+ -- Expects its argument to be dusted+ go :: Int -> Type -> Q Bool+ go d t = case t of+ ConT tcName -> check d tcName+ AppT f _ -> go (d + 1) (dustOff f)+ _ -> return False++ check :: Int -> Name -> Q Bool+ check d tcName = do+ mbinders <- getTypeFamilyBinders tcName+ return $ case mbinders of+ Just bndrs -> length bndrs > d+ Nothing -> False++-- | Given a name, check if that name is a type family. If+-- so, return a list of its binders.+getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndrVis])+getTypeFamilyBinders tcName = do+ info <- reify tcName+ return $ case info of+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> Just bndrs+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> Just bndrs+ _ -> Nothing+ -- | True if the type does not mention the Name ground :: Type -> Name -> Bool-ground (AppT t1 t2) name = ground t1 name && ground t2 name-ground (SigT t _) name = ground t name-ground (VarT t) name = t /= name-ground ForallT{} _ = rankNError-ground _ _ = True+ground ty name = name `notElem` freeVariables ty -- | Construct a type via curried application. applyTyToTys :: Type -> [Type] -> Type-applyTyToTys = foldl' AppT+applyTyToTys = List.foldl' AppT -- | Apply a type constructor name to type variable binders.-applyTyToTvbs :: Name -> [TyVarBndr] -> Type-applyTyToTvbs = foldl' (\a -> AppT a . tyVarBndrToType) . ConT---- | Split an applied type into its individual components. For example, this:------ @--- Either Int Char--- @------ would split to this:------ @--- [Either, Int, Char]--- @-unapplyTy :: Type -> [Type]-unapplyTy = reverse . go- where- go :: Type -> [Type]- go (AppT t1 t2) = t2 : go t1- go (SigT t _) = go t- go (ForallT _ _ t) = go t- go t = [t]+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: --@@ -208,7 +204,7 @@ -- @ -- ([a, b], [a -> b, Char, ()]) -- @-uncurryTy :: Type -> ([TyVarBndr], [Type])+uncurryTy :: Type -> ([TyVarBndrSpec], [Type]) uncurryTy (AppT (AppT ArrowT t1) t2) = let (tvbs, tys) = uncurryTy t2 in (tvbs, t1:tys)@@ -219,19 +215,11 @@ uncurryTy t = ([], [t]) -- | Like uncurryType, except on a kind level.-uncurryKind :: Kind -> ([TyVarBndr], [Kind])-#if MIN_VERSION_template_haskell(2,8,0)+uncurryKind :: Kind -> ([TyVarBndrSpec], [Kind]) uncurryKind = uncurryTy-#else-uncurryKind (ArrowK k1 k2) =- let (kvbs, ks) = uncurryKind k2- in (kvbs, k1:ks)-uncurryKind k = ([], [k])-#endif -tyVarBndrToType :: TyVarBndr -> Type-tyVarBndrToType (PlainTV n) = VarT n-tyVarBndrToType (KindedTV n k) = SigT (VarT n) k+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]@@ -269,11 +257,7 @@ -- | 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@@ -281,10 +265,7 @@ 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 (SigT t k) = go t && go k go VarT{} = False go _ = True @@ -294,9 +275,8 @@ unSigT t = t -- | Peel off a kind signature from a TyVarBndr (if it has one).-unKindedTV :: TyVarBndr -> TyVarBndr-unKindedTV (KindedTV n _) = PlainTV n-unKindedTV tvb = tvb+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@@ -304,10 +284,7 @@ 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 (SigT t k) names = go t names || go k names go (VarT n) names = n `elem` names go _ _ = False @@ -336,10 +313,17 @@ shrink (_, b, c) = (b, c) foldBal :: (a -> a -> a) -> a -> [a] -> a-foldBal _ x [] = x-foldBal _ _ [y] = y-foldBal op x l = let (a,b) = splitAt (length l `div` 2) l- in foldBal op x a `op` foldBal op x b+{-# 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@@ -350,22 +334,40 @@ -- | Indicates whether Generic or Generic1 is being derived. data GenericClass = Generic | Generic1 deriving Enum --- | Like 'GenericArity', but bundling two things in the 'Gen1' case:------ 1. The 'Name' of the last type parameter.--- 2. If that last type parameter had kind k (where k is some kind variable),--- then it has 'Just' the kind variable 'Name'. Otherwise, it has 'Nothing'.-data GenericKind = Gen0- | Gen1 Name (Maybe Name)+-- | 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'.+ } --- Determines the universally quantified type variables (possibly after--- substituting * in the case of Generic1) and the last type parameter name--- (if there is one).-genericKind :: GenericClass -> [Type] -> ([TyVarBndr], GenericKind)-genericKind gClass tySynVars =+-- | 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 -> (freeVariablesWellScoped tySynVars, Gen0)- Generic1 -> (freeVariablesWellScoped initArgs, Gen1 (varTToName lastArg) mbLastArgKindName)+ 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]@@ -378,6 +380,14 @@ 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).@@ -434,17 +444,43 @@ ( showString (nameBase tyConName) . showString " ..." )- . showString "‘\n\tClass Generic1 expects an argument of kind * -> *"+ . 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- "Type applied to an argument involving the last parameter is not of kind * -> *"+ . 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 :: a-rankNError = error "Cannot have polymorphic arguments"+rankNError :: Q a+rankNError = fail "Cannot have polymorphic arguments" -- | Boilerplate for top level splices. --@@ -465,19 +501,29 @@ , datatypeVariant = variant , datatypeCons = cons } <- reifyDatatype name- let variant_ = case variant of- Datatype -> Datatype_- Newtype -> 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 -> DataInstance_ $ head cons- NewtypeInstance -> NewtypeInstance_ $ head cons+ variant_ <-+ case variant of+ Datatype -> return Datatype_+ Newtype -> return Newtype_+ DataInstance -> return $ DataInstance_ $ headDataFamInstCon parentName cons+ NewtypeInstance -> return $ NewtypeInstance_ $ headDataFamInstCon parentName cons+#if MIN_VERSION_th_abstraction(0,5,0)+ Datatype.TypeData -> typeDataError parentName+#endif checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_) where ns :: String ns = "Generics.Deriving.TH.reifyDataInfo: " + -- This isn't total, but the API requires that the data family instance have+ -- at least one constructor anyways, so this will always succeed.+ headDataFamInstCon :: Name -> [ConstructorInfo] -> ConstructorInfo+ headDataFamInstCon dataFamName cons =+ case cons of+ con:_ -> con+ [] -> error $ "reified data family instance without a data constructor: "+ ++ nameBase dataFamName+ -- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts, -- so check to make sure the Cxt field of a datatype is null. checkDataContext :: Name -> Cxt -> a -> Q a@@ -486,388 +532,299 @@ nameBase dataName ++ " must not have a datatype context" -- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs.-checkExistentialContext :: Name -> [TyVarBndr] -> Cxt -> Q ()-checkExistentialContext conName vars ctxt =+checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q ()+checkExistentialContext constrName 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+ nameBase constrName ++ " must be a vanilla data constructor" -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+#if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0))+type TyVarBndrVis = TyVarBndrUnit -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"+bndrReq :: ()+bndrReq = () #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"+-------------------------------------------------------------------------------+-- Quoted names+------------------------------------------------------------------------------- comp1DataName :: Name-comp1DataName = mkGD4'4_d "Comp1"+comp1DataName = 'Comp1 infixDataName :: Name-infixDataName = mkGD4'4_d "Infix"+infixDataName = 'GD.Infix k1DataName :: Name-k1DataName = mkGD4'4_d "K1"+k1DataName = 'K1 l1DataName :: Name-l1DataName = mkGD4'4_d "L1"+l1DataName = 'L1 leftAssociativeDataName :: Name-leftAssociativeDataName = mkGD4'4_d "LeftAssociative"+leftAssociativeDataName = 'LeftAssociative m1DataName :: Name-m1DataName = mkGD4'4_d "M1"+m1DataName = 'M1 notAssociativeDataName :: Name-notAssociativeDataName = mkGD4'4_d "NotAssociative"+notAssociativeDataName = 'NotAssociative par1DataName :: Name-par1DataName = mkGD4'4_d "Par1"+par1DataName = 'Par1 prefixDataName :: Name-prefixDataName = mkGD4'4_d "Prefix"+prefixDataName = 'Prefix productDataName :: Name-productDataName = mkGD4'4_d ":*:"+productDataName = '(:*:) r1DataName :: Name-r1DataName = mkGD4'4_d "R1"+r1DataName = 'R1 rec1DataName :: Name-rec1DataName = mkGD4'4_d "Rec1"+rec1DataName = 'Rec1 rightAssociativeDataName :: Name-rightAssociativeDataName = mkGD4'4_d "RightAssociative"+rightAssociativeDataName = 'RightAssociative u1DataName :: Name-u1DataName = mkGD4'4_d "U1"+u1DataName = 'U1 uAddrDataName :: Name-uAddrDataName = mkGD4'9_d "UAddr"+uAddrDataName = 'UAddr uCharDataName :: Name-uCharDataName = mkGD4'9_d "UChar"+uCharDataName = 'UChar uDoubleDataName :: Name-uDoubleDataName = mkGD4'9_d "UDouble"+uDoubleDataName = 'UDouble uFloatDataName :: Name-uFloatDataName = mkGD4'9_d "UFloat"+uFloatDataName = 'UFloat uIntDataName :: Name-uIntDataName = mkGD4'9_d "UInt"+uIntDataName = 'UInt uWordDataName :: Name-uWordDataName = mkGD4'9_d "UWord"+uWordDataName = 'UWord c1TypeName :: Name-c1TypeName = mkGD4'4_tc "C1"+c1TypeName = ''C1 composeTypeName :: Name-composeTypeName = mkGD4'4_tc ":.:"+composeTypeName = ''(:.:) constructorTypeName :: Name-constructorTypeName = mkGD4'4_tc "Constructor"+constructorTypeName = ''Constructor d1TypeName :: Name-d1TypeName = mkGD4'4_tc "D1"+d1TypeName = ''D1 genericTypeName :: Name-genericTypeName = mkGD4'4_tc "Generic"+genericTypeName = ''Generic generic1TypeName :: Name-generic1TypeName = mkGD4'4_tc "Generic1"+generic1TypeName = ''Generic1 datatypeTypeName :: Name-datatypeTypeName = mkGD4'4_tc "Datatype"--noSelectorTypeName :: Name-noSelectorTypeName = mkGD4'4_tc "NoSelector"+datatypeTypeName = ''Datatype par1TypeName :: Name-par1TypeName = mkGD4'4_tc "Par1"+par1TypeName = ''Par1 productTypeName :: Name-productTypeName = mkGD4'4_tc ":*:"+productTypeName = ''(:*:) rec0TypeName :: Name-rec0TypeName = mkGD4'4_tc "Rec0"+rec0TypeName = ''Rec0 rec1TypeName :: Name-rec1TypeName = mkGD4'4_tc "Rec1"+rec1TypeName = ''Rec1 repTypeName :: Name-repTypeName = mkGD4'4_tc "Rep"+repTypeName = ''Rep rep1TypeName :: Name-rep1TypeName = mkGD4'4_tc "Rep1"+rep1TypeName = ''Rep1 s1TypeName :: Name-s1TypeName = mkGD4'4_tc "S1"+s1TypeName = ''S1 selectorTypeName :: Name-selectorTypeName = mkGD4'4_tc "Selector"+selectorTypeName = ''Selector sumTypeName :: Name-sumTypeName = mkGD4'4_tc ":+:"+sumTypeName = ''(:+:) u1TypeName :: Name-u1TypeName = mkGD4'4_tc "U1"+u1TypeName = ''U1 uAddrTypeName :: Name-uAddrTypeName = mkGD4'9_tc "UAddr"+uAddrTypeName = ''UAddr uCharTypeName :: Name-uCharTypeName = mkGD4'9_tc "UChar"+uCharTypeName = ''UChar uDoubleTypeName :: Name-uDoubleTypeName = mkGD4'9_tc "UDouble"+uDoubleTypeName = ''UDouble uFloatTypeName :: Name-uFloatTypeName = mkGD4'9_tc "UFloat"+uFloatTypeName = ''UFloat uIntTypeName :: Name-uIntTypeName = mkGD4'9_tc "UInt"+uIntTypeName = ''UInt uWordTypeName :: Name-uWordTypeName = mkGD4'9_tc "UWord"+uWordTypeName = ''UWord v1TypeName :: Name-v1TypeName = mkGD4'4_tc "V1"+v1TypeName = ''V1 conFixityValName :: Name-conFixityValName = mkGD4'4_v "conFixity"+conFixityValName = 'conFixity conIsRecordValName :: Name-conIsRecordValName = mkGD4'4_v "conIsRecord"+conIsRecordValName = 'conIsRecord conNameValName :: Name-conNameValName = mkGD4'4_v "conName"+conNameValName = 'GD.conName datatypeNameValName :: Name-datatypeNameValName = mkGD4'4_v "datatypeName"+datatypeNameValName = 'GD.datatypeName isNewtypeValName :: Name-isNewtypeValName = mkGD4'4_v "isNewtype"+isNewtypeValName = 'isNewtype fromValName :: Name-fromValName = mkGD4'4_v "from"+fromValName = 'from from1ValName :: Name-from1ValName = mkGD4'4_v "from1"+from1ValName = 'from1 moduleNameValName :: Name-moduleNameValName = mkGD4'4_v "moduleName"+moduleNameValName = 'moduleName selNameValName :: Name-selNameValName = mkGD4'4_v "selName"+selNameValName = 'selName seqValName :: Name-seqValName = mkGHCPrimName_v "GHC.Prim" "seq"+seqValName = 'seq toValName :: Name-toValName = mkGD4'4_v "to"+toValName = 'to to1ValName :: Name-to1ValName = mkGD4'4_v "to1"+to1ValName = 'to1 uAddrHashValName :: Name-uAddrHashValName = mkGD4'9_v "uAddr#"+uAddrHashValName = 'uAddr# uCharHashValName :: Name-uCharHashValName = mkGD4'9_v "uChar#"+uCharHashValName = 'uChar# uDoubleHashValName :: Name-uDoubleHashValName = mkGD4'9_v "uDouble#"+uDoubleHashValName = 'uDouble# uFloatHashValName :: Name-uFloatHashValName = mkGD4'9_v "uFloat#"+uFloatHashValName = 'uFloat# uIntHashValName :: Name-uIntHashValName = mkGD4'9_v "uInt#"+uIntHashValName = 'uInt# uWordHashValName :: Name-uWordHashValName = mkGD4'9_v "uWord#"+uWordHashValName = 'uWord# unComp1ValName :: Name-unComp1ValName = mkGD4'4_v "unComp1"+unComp1ValName = 'unComp1 unK1ValName :: Name-unK1ValName = mkGD4'4_v "unK1"+unK1ValName = 'unK1 unPar1ValName :: Name-unPar1ValName = mkGD4'4_v "unPar1"+unPar1ValName = 'unPar1 unRec1ValName :: Name-unRec1ValName = mkGD4'4_v "unRec1"+unRec1ValName = '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+trueDataName = 'True+falseDataName = 'False 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"+nothingDataName = 'Nothing+justDataName = 'Just addrHashTypeName :: Name-addrHashTypeName = mkGHCPrim_tc "Addr#"+addrHashTypeName = ''Addr# charHashTypeName :: Name-charHashTypeName = mkGHCPrim_tc "Char#"+charHashTypeName = ''Char# doubleHashTypeName :: Name-doubleHashTypeName = mkGHCPrim_tc "Double#"+doubleHashTypeName = ''Double# floatHashTypeName :: Name-floatHashTypeName = mkGHCPrim_tc "Float#"+floatHashTypeName = ''Float# intHashTypeName :: Name-intHashTypeName = mkGHCPrim_tc "Int#"+intHashTypeName = ''Int# wordHashTypeName :: Name-wordHashTypeName = mkGHCPrim_tc "Word#"+wordHashTypeName = ''Word# composeValName :: Name-composeValName = mkNameG_v "base" "GHC.Base" "."+composeValName = '(.) errorValName :: Name-errorValName = mkNameG_v "base" "GHC.Err" "error"+errorValName = 'error fmapValName :: Name-fmapValName = mkNameG_v "base" "GHC.Base" "fmap"+fmapValName = 'fmap undefinedValName :: Name-undefinedValName = mkNameG_v "base" "GHC.Err" "undefined"--starKindName :: Name-starKindName = mkGHCPrimName_tc "GHC.Prim" "*"+undefinedValName = 'undefined decidedLazyDataName :: Name-decidedLazyDataName = mkGD4'9_d "DecidedLazy"+decidedLazyDataName = 'GD.DecidedLazy decidedStrictDataName :: Name-decidedStrictDataName = mkGD4'9_d "DecidedStrict"+decidedStrictDataName = 'GD.DecidedStrict decidedUnpackDataName :: Name-decidedUnpackDataName = mkGD4'9_d "DecidedUnpack"+decidedUnpackDataName = 'GD.DecidedUnpack infixIDataName :: Name-infixIDataName = mkGD4'9_d "InfixI"+infixIDataName = 'InfixI metaConsDataName :: Name-metaConsDataName = mkGD4'9_d "MetaCons"+metaConsDataName = 'MetaCons metaDataDataName :: Name-metaDataDataName = mkGD4'9_d "MetaData"--metaNoSelDataName :: Name-metaNoSelDataName = mkGD4'9_d "MetaNoSel"+metaDataDataName = 'MetaData metaSelDataName :: Name-metaSelDataName = mkGD4'9_d "MetaSel"+metaSelDataName = 'MetaSel noSourceStrictnessDataName :: Name-noSourceStrictnessDataName = mkGD4'9_d "NoSourceStrictness"+noSourceStrictnessDataName = 'GD.NoSourceStrictness noSourceUnpackednessDataName :: Name-noSourceUnpackednessDataName = mkGD4'9_d "NoSourceUnpackedness"+noSourceUnpackednessDataName = 'GD.NoSourceUnpackedness prefixIDataName :: Name-prefixIDataName = mkGD4'9_d "PrefixI"+prefixIDataName = 'PrefixI sourceLazyDataName :: Name-sourceLazyDataName = mkGD4'9_d "SourceLazy"+sourceLazyDataName = 'GD.SourceLazy sourceNoUnpackDataName :: Name-sourceNoUnpackDataName = mkGD4'9_d "SourceNoUnpack"+sourceNoUnpackDataName = 'GD.SourceNoUnpack sourceStrictDataName :: Name-sourceStrictDataName = mkGD4'9_d "SourceStrict"+sourceStrictDataName = 'GD.SourceStrict sourceUnpackDataName :: Name-sourceUnpackDataName = mkGD4'9_d "SourceUnpack"+sourceUnpackDataName = 'GD.SourceUnpack packageNameValName :: Name-packageNameValName = mkGD4'4_v "packageName"+packageNameValName = 'packageName
− src/Generics/Deriving/TH/Pre4_9.hs
@@ -1,241 +0,0 @@-{-# 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,27 +1,12 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyCase #-} {-# 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+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-} module Generics.Deriving.Traversable ( -- * Generic Traversable class@@ -36,43 +21,23 @@ ) 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.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)+import Data.Ord (Down)+import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last)-import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)-#endif+import Data.Semigroup (Arg, Max, Min, WrappedMonoid) +import Generics.Deriving.Base+import Generics.Deriving.Foldable+import Generics.Deriving.Functor+ -------------------------------------------------------------------------------- -- Generic traverse --------------------------------------------------------------------------------@@ -81,12 +46,7 @@ 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+ gtraverse' _ x = pure $ case x of {} instance GTraversable' U1 where gtraverse' _ U1 = pure U1@@ -133,11 +93,9 @@ 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@@ -159,15 +117,11 @@ 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@@ -184,64 +138,47 @@ 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 -instance GTraversable Option 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,23 +1,12 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-} {-# 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@@ -83,22 +72,14 @@ transform' _ U1 = U1 transformM' _ U1 = return U1 -instance-#if __GLASGOW_HASKELL__ >= 709- {-# OVERLAPPING #-}-#endif- (Uniplate a) => Uniplate' (K1 i a) a where+instance {-# OVERLAPPING #-} (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+instance {-# OVERLAPPABLE #-} Uniplate' (K1 i a) b where children' (K1 _) = [] descend' _ (K1 a) = K1 a descendM' _ (K1 a) = return (K1 a)@@ -140,19 +121,11 @@ instance Context' U1 b where context' U1 _ = U1 -instance-#if __GLASGOW_HASKELL__ >= 709- {-# OVERLAPPING #-}-#endif- Context' (K1 i a) a where+instance {-# OVERLAPPING #-} 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+instance {-# OVERLAPPABLE #-} Context' (K1 i a) b where context' (K1 a) _ = K1 a instance (Context' f b) => Context' (M1 i c f) b where@@ -162,58 +135,38 @@ 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+instance {-# OVERLAPPING #-} (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+instance {-# OVERLAPPABLE #-} (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
tests/DefaultSpec.hs view
@@ -28,7 +28,7 @@ #if __GLASGOW_HASKELL__ >= 806 import Test.Hspec.QuickCheck -import Data.Semigroup (First(..), Option(..))+import Data.Semigroup (First(..)) import Data.Foldable (sequenceA_) import Generics.Deriving hiding (universe) import Generics.Deriving.Default ()@@ -132,7 +132,7 @@ deriving (GSemigroup) via (First Bool) newtype TestFoldable a = TestFoldable (Maybe a)- deriving (GFoldable) via (Default1 Option)+ deriving (GFoldable) via (Default1 Maybe) newtype TestFunctor a = TestFunctor (Maybe a) deriving stock (Eq, Show, Functor)
tests/EmptyCaseSpec.hs view
@@ -1,15 +1,8 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-} {-# 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
tests/ExampleSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}@@ -6,18 +6,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 705-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-#endif--{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module ExampleSpec (main, spec) where @@ -234,17 +230,10 @@ -- 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+data family MyType3 (a :: v) (b :: w) (c :: x) (d :: y) (e :: z)+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# $(deriveAll0And1 ''Empty) $(deriveAll0And1 ''(:/:))@@ -254,26 +243,9 @@ $(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
+ tests/T68Spec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++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
@@ -0,0 +1,18 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++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
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#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,23 +1,23 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module TypeInTypeSpec (main, spec) where -import Test.Hspec--#if __GLASGOW_HASKELL__ >= 800 import Data.Proxy (Proxy(..)) import Generics.Deriving.TH+import Test.Hspec -# if MIN_VERSION_base(4,10,0)+#if MIN_VERSION_base(4,10,0) import Generics.Deriving (Generic1(..))-# endif+#endif data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b) $(deriveAll0And1 ''TyCon)@@ -26,10 +26,9 @@ 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)+#if MIN_VERSION_base(4,10,0) gen1PolyKinds :: Generic1 f => f 'True -> Rep1 f 'True gen1PolyKinds = from1-# endif #endif main :: IO ()