generic-deriving-1.14.5/0000755000000000000000000000000007346545000013214 5ustar0000000000000000generic-deriving-1.14.5/CHANGELOG.md0000644000000000000000000002616307346545000015035 0ustar0000000000000000# 1.14.5 [2023.08.06] * Support building with `template-haskell-2.21.*` (GHC 9.8). * The Template Haskell machinery now uses `TemplateHaskellQuotes` when building with GHC 8.0+ instead of manually constructing each Template Haskell `Name`. A consequence of this is that `generic-deriving` will now build with GHC 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template Haskell changes introduced in 9.8. # 1.14.4 [2023.04.30] * Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined, such as the WASM backend. * Place `INLINE [1]` pragmas on `from` and `to` implementations when types don't have too many constructors or fields, following the heuristics that GHC 9.2+ uses for `Generic` deriving. # 1.14.3 [2023.02.27] * Support `th-abstraction-0.5.*`. # 1.14.2 [2022.07.23] * Fix a bug in which `deriveAll1` could generate ill kinded code when using `kindSigOptions=False`, or when using GHC 8.0 or earlier. * Fix a bug in which `deriveAll1` would reject data types whose last type variable has a kind besides `Type` or `k` on GHC 8.2 or later. # 1.14.1 [2021.08.30] * Backport the `Generic(1)` instances introduced for tuples (8 through 15) in `base-4.16`. * Make the test suite compile on GHC 9.2 or later. * Always import `Data.List` qualified to fix the build with recent GHCs. # 1.14 [2020.09.30] * Remove instances for `Data.Semigroup.Option`, which is deprecated as of `base-4.15.0.0`. * Allow building with `template-haskell-2.17.0.0` (GHC 9.0). * Fix a bug in which `deriveAll1` would needlessly reject data types whose last type parameter appears as an oversaturated argument to a type family. # 1.13.1 [2019.11.26] * Backport the `Generic(1)` instances for `Kleisli` introduced in `base-4.14`. # 1.13 [2019.08.27] * Make `GSemigroup` a superclass of `GMonoid`. Similarly, make `GSemigroup'` a superclass of `GMonoid'`. * In the instance `GMonoid (Maybe a)`, relax the constraint on `a` from `GMonoid` to `GSemigroup`. # 1.12.4 [2019.04.26] * Support `th-abstraction-0.3.0.0` or later. # 1.12.3 [2019.02.09] * Support `template-haskell-2.15`. * Add a `gshowList` method to `GShow`, which lets us avoid the need for `OverlappingInstances` in `Generics.Deriving.TH`. As a consequence, the `GShow String` instance has been removed, as it is now fully subsumed by the `GShow [a]` instance (with which it previously overlapped). * Functions in `Generics.Deriving.TH` now balance groups of `(:*:)` and `(:+:)` as much as possible (`deriving Generic` was already performing this optimization, and now `generic-deriving` does too). * Add a `Generics.Deriving.Default` module demonstrating and explaining how and why to use `DerivingVia`. There is also a test suite with further examples. # 1.12.2 [2018.06.28] * Backport the `Generic(1)` instances for `Data.Ord.Down`, introduced in `base-4.12`. Add `GEq`, `GShow`, `GSemigroup`, `GMonoid`, `GFunctor`, `GFoldable`, `GTraversable`, and `GCopoint` instances for `Down`. * Refactor internals using `th-abstraction`. * Adapt to `Maybe` moving to `GHC.Maybe` in GHC 8.6. # 1.12.1 [2018.01.11] * Remove a test that won't work on GHC 8.4. # 1.12 [2017.12.07] * Adapt to the `EmptyDataDeriving` proposal (introduced in GHC 8.4): * `Generics.Deriving.TH` now derives `to(1)` and `from(1)` implementations for empty data types that are strict in the argument. * Introduce an `EmptyCaseOptions` field to `Options` in `Generics.Deriving.TH`, which controls whether generated `from(1)`/`to(1)` implementations for empty data types should use the `EmptyCase` extension or not (as is the case in GHC 8.4). * Add `mkFrom0Options`, `mkFrom1Options`, `mkTo0Options`, and `mkTo1Options` functions to `Generics.Deriving.TH`, which take `EmptyCaseOptions` as arguments. * The backported instances for `V1` are now maximally lazy, as per `EmptyDataDeriving`. (Previously, some instances would unnecessarily force their argument, such as the `Eq` and `Ord` instances.) * Add instances for `V1` in `Generics.Deriving.Copoint`, `.Eq`, `.Foldable`, `.Functor`, `.Show`, and `.Traversable`. * Remove the bitrotting `simplInstance` function from `Generics.Deriving.TH`. # 1.11.2 [2017.04.10] * Add `GEq`, `GShow`, `GEnum`, and `GIx` instances for the new data types in `Foreign.C.Types` (`CBool`) and `System.Posix.Types` (`CBlkSize`, `CBlkCnt`, `CClockId`, `CFsBlkCnt`, `CFsFilCnt`, `CId`, `CKey`, and `CTimer`) introduced in `base-4.10.0.0` # 1.11.1 [2016.09.10] * Fix Template Haskell regression involving data families * Convert examples to test suite * Backport missing `Data` and `Typeable` instances for `Rec1`, `M1`, `(:*:)`, `(:+:)`, and `(:.:)` # 1.11 * The behavior of functions in `Generics.Deriving.TH` have changed with respect to when type synonyms are generated for `Rep(1)` definitions. In particular: * By default, `deriveRepresentable(1)` will no longer define its `Rep(1)` type family instance in terms of the type synonym that has to be generated with `deriveRep(1)`. Similarly, `deriveAll(1)` and `deriveAll0And1` will no longer generate a type synonym. Instead, they will generate `Generic(1)` instances that directly define the `Rep(1)` instance inline. If you wish to revert to the old behavior, you will need to use the variants of those functions suffixed with `-Options`. * New functions `makeRep0Inline` and `makeRep1Inline` have been added which, for most purposes, should replace uses of `makeRep0`/`makeRep0FromType` and `makeRep1`/`makeRep1FromType` (but see the next bullet point for a caveat). * The use of `deriveRep(1)`, `makeRep0`/`makeRep0FromType`, and `makeRep1`/`makeRep1FromType` are now discouraged, but those functions are still available. The reason is that on GHC 7.0/7.2/7.4, it is impossible to use `makeRep0Inline`/`makeRep1Inline` due to a GHC bug. Therefore, you must use `makeRep0`/`makeRep1` and `deriveRep(1)` on GHC 7.0/7.2/7.4 out of necessity. These changes make dealing with `Generic` instances that involve `PolyKinds` and `TypeInType` much easier. * All functions suffixed in `-WithKindSigs` in `Generics.Deriving.TH` have been removed in favor of a more sensible `-Options` suffixing scheme. The ability to toggle whether explicit kind signatures are used on type variable binders has been folded into `KindSigOptions`, which is an explicit argument to `deriveRep0Options`/`deriveRep1Options` and also a field in the more general 'Options' data type. * Furthermore, the behavior of derived instances' kind signatures has changed. By default, the TH code will now _always_ use explicit kind signatures whenever possible, regardless of whether you're working with plain data types or data family instances. This makes working with `TypeInType` less surprising, but at the cost of making it slightly more awkward to work with derived `Generic1` instances that constrain kinds to `*` by means of `(:.:)`. * Since `Generic1` is polykinded on GHC 8.2 and later, the functions in `Generics.Deriving.TH` will no longer unify the kind of the last type parameter to be `*`. * Fix a bug in which `makeRep` (and similarly named functions) would not check whether the argument type can actually have a well kinded `Generic(1)` instance. * Backport missing `Foldable` and `Traversable` instances for `Rec1` # 1.10.7 * Renamed internal modules to avoid using apostrophes (averting this bug: https://github.com/haskell/cabal/issues/3631) # 1.10.6 * A new `base-4-9` Cabal flag was added to more easily facilitate installing `generic-deriving` with manually installed versions of `template-haskell`. # 1.10.5 * Apply an optimization to generated `to(1)`/`from(1)` instances that factors out common occurrences of `M1`. See http://git.haskell.org/ghc.git/commit/9649fc0ae45e006c2ed54cc5ea2414158949fadb * Export internal typeclass names * Fix Haddock issues with GHC 7.8 # 1.10.4.1 * Fix Haddock parsing issue on GHC 8.0 # 1.10.4 * Backported `MonadPlus` and `MonadZip` instances for `U1`, and made the `Functor`, `Foldable`, `Traversable`, `Alternative`, and `Monad` instances for `U1` lazier to correspond with `base-4.9` # 1.10.3 * Backported `Enum`, `Bounded`, `Ix`, `Functor`, `Applicative`, `Monad`, `MonadFix`, `MonadPlus`, `MonadZip`, `Foldable`, `Traversable`, and `Data` instances (introduced in `base-4.9`) for datatypes in the `Generics.Deriving.Base` module # 1.10.2 * Fix TH regression on GHC 7.0 # 1.10.1 * Added `Generics.Deriving.Semigroup` * Added `GMonoid` instance for `Data.Monoid.Alt` * Fixed a bug in the `GEnum` instances for unsigned `Integral` types * Added `Safe`/`Trustworthy` pragmas * Made instances polykinded where possible # 1.10.0 * On GHC 8.0 and up, `Generics.Deriving.TH` uses the new type literal-based machinery * Rewrote the Template Haskell code to be robust. Among other things, this fixes a bug with deriving Generic1 instances on GHC 7.8, and makes it easier to derive Generic1 instances for datatypes that utilize GHC 8.0's `-XTypeInType` extension. * Added `deriveAll0` and `makeRep0` for symmetry with `deriveAll1` and `makeRep1` * Added`makeRep0FromType` and `makeRep1FromType` to make it easier to pass in the type instance (instead of having to pass each individual type variable, which can be error-prone) * Added functions with the suffix `-WithKindSigs` to allow generating type synonyms with explicit kind signatures in the presence of kind-polymorphic type variables. This is necessary for some datatypes that use `-XTypeInType` to have derived `Generic(1)` instances, but is not turned on by default since the TH kind inference is not perfect and would cause otherwise valid code to be rejected. Use only if you know what you are doing. * Fixed bug where a datatype with a single, nullary constructor would generate incorrect `Generic` instances * More sensible `GEnum` instances for fixed-size integral types * Added `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GMonoid`, `GShow`, and `GTraversable` instances for datatypes introduced in GHC 8.0 * Backported `Generic(1)` instances added in GHC 8.0. Specifically, `Generic` instances for `Complex` (`base-4.4` and later) `ExitCode`, and `Version`; and `Generic1` instances for `Complex` (`base-4.4` and later) and `Proxy` (`base-4.7` and later). Added `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GShow`, and `GTraversable` instances for these datatypes where appropriate. # 1.9.0 * Allow deriving of Generic1 using Template Haskell * Allow deriving of Generic(1) for data families * Allow deriving of Generic(1) for constructor-less plain datatypes (but not data families, due to technical restrictions) * Support for unboxed representation types on GHC 7.11+ * More `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GMonoid`, `GShow`, and `GTraversable` instances * The field accessors for the `(:+:)` type in `Generics.Deriving.Base` have been removed to be consistent with `GHC.Generics` * Ensure that TH generates definitions for isNewtype and packageName, if a recent-enough version of GHC is used * Ensure that TH-generated names are unique for a given data type's module and package (similar in spirit to Trac #10487) * Allow building on stage-1 compilers generic-deriving-1.14.5/LICENSE0000644000000000000000000000274107346545000014225 0ustar0000000000000000Copyright (c) 2010 Universiteit Utrecht All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of Universiteit Utrecht nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. generic-deriving-1.14.5/README.md0000644000000000000000000000733607346545000014504 0ustar0000000000000000## `generic-deriving`: Generic programming library for generalised deriving [![Hackage](https://img.shields.io/hackage/v/generic-deriving.svg)][Hackage: generic-deriving] [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/generic-deriving.svg)](http://packdeps.haskellers.com/reverse/generic-deriving) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] [![Build Status](https://github.com/dreixel/generic-deriving/workflows/Haskell-CI/badge.svg)](https://github.com/dreixel/generic-deriving/actions?query=workflow%3AHaskell-CI) [Hackage: generic-deriving]: http://hackage.haskell.org/package/generic-deriving "generic-deriving package on Hackage" [Haskell.org]: http://www.haskell.org "The Haskell Programming Language" [tl;dr Legal: BSD3]: https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" This package provides functionality for generalising the deriving mechanism in Haskell to arbitrary classes. It was first described in the paper: * [A generic deriving mechanism for Haskell](http://dreixel.net/research/pdf/gdmh.pdf). Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10. The current implementation integrates with the new GHC Generics. See http://www.haskell.org/haskellwiki/GHC.Generics for more information. Template Haskell code is provided for supporting older GHCs. This library is organized as follows: * `Generics.Deriving.Base` defines the core functionality for GHC generics, including the `Generic(1)` classes and representation data types. On modern versions of GHC, this simply re-exports `GHC.Generics` from `base`. On older versions of GHC, this module backports parts of `GHC.Generics` that were not included at the time, including `Generic(1)` instances. * `Generics.Deriving.TH` implements Template Haskell functionality for deriving instances of `Generic(1)`. * Educational code: in order to provide examples of how to define and use `GHC.Generics`-based defaults, this library offers a number of modules which define examples of type classes along with default implementations for the classes' methods. Currently, the following modules are provided: * `Generics.Deriving.Copoint` * `Generics.Deriving.ConNames` * `Generics.Deriving.Enum` * `Generics.Deriving.Eq` * `Generics.Deriving.Foldable` * `Generics.Deriving.Functor` * `Generics.Deriving.Monoid` * `Generics.Deriving.Semigroup` * `Generics.Deriving.Show` * `Generics.Deriving.Traversable` * `Generics.Deriving.Uniplate` It is worth emphasizing that these modules are primarly intended for educational purposes. Many of the classes in these modules resemble other commonly used classes—for example, `GShow` from `Generics.Deriving.Show` resembles `Show` from `base`—but in general, the classes that `generic-deriving` defines are not drop-in replacements. Moreover, the generic defaults that `generic-deriving` provide often make simplifying assumptions that may violate expectations of how these classes might work elsewhere. For example, the generic default for `GShow` does not behave exactly like `deriving Show` would. If you are seeking `GHC.Generics`-based defaults for type classes in `base`, consider using the [`generic-data`](http://hackage.haskell.org/package/generic-data) library. * `Generics.Deriving.Default` provides newtypes that allow leveraging the generic defaults in this library using the `DerivingVia` GHC language extension. * `Generics.Deriving` re-exports `Generics.Deriving.Base`, `Generics.Deriving.Default`, and a selection of educational modules. generic-deriving-1.14.5/Setup.hs0000644000000000000000000000012707346545000014650 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain generic-deriving-1.14.5/generic-deriving.cabal0000644000000000000000000001566207346545000017433 0ustar0000000000000000name: generic-deriving version: 1.14.5 synopsis: Generic programming library for generalised deriving. description: This package provides functionality for generalising the deriving mechanism in Haskell to arbitrary classes. It was first described in the paper: . * /A generic deriving mechanism for Haskell/. Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10. . The current implementation integrates with the new GHC Generics. See 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 @@ library. . * "Generics.Deriving.Default" provides newtypes that allow leveraging the generic defaults in this library using the @DerivingVia@ GHC language extension. . * "Generics.Deriving" re-exports "Generics.Deriving.Base", "Generics.Deriving.Default", and a selection of educational modules. homepage: https://github.com/dreixel/generic-deriving bug-reports: https://github.com/dreixel/generic-deriving/issues category: Generics copyright: 2011-2013 Universiteit Utrecht, University of Oxford license: BSD3 license-file: LICENSE author: José Pedro Magalhães maintainer: generics@haskell.org stability: experimental build-type: Simple cabal-version: >= 1.10 tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.5 , GHC == 9.6.2 extra-source-files: CHANGELOG.md , README.md source-repository head type: git location: https://github.com/dreixel/generic-deriving flag base-4-9 description: Use base-4.9 or later. This version of base uses a DataKinds-based encoding of GHC generics metadata. default: True library hs-source-dirs: src exposed-modules: Generics.Deriving Generics.Deriving.Base Generics.Deriving.Instances Generics.Deriving.Copoint Generics.Deriving.ConNames Generics.Deriving.Default Generics.Deriving.Enum Generics.Deriving.Eq Generics.Deriving.Foldable Generics.Deriving.Functor Generics.Deriving.Monoid Generics.Deriving.Semigroup Generics.Deriving.Show Generics.Deriving.Traversable Generics.Deriving.Uniplate Generics.Deriving.TH other-modules: Generics.Deriving.Base.Internal Generics.Deriving.Monoid.Internal Generics.Deriving.Semigroup.Internal Generics.Deriving.TH.Internal Paths_generic_deriving if flag(base-4-9) build-depends: base >= 4.9 && < 5 other-modules: Generics.Deriving.TH.Post4_9 else build-depends: base >= 4.3 && < 4.9 other-modules: Generics.Deriving.TH.Pre4_9 build-depends: containers >= 0.1 && < 0.7 , ghc-prim < 1 , template-haskell >= 2.4 && < 2.22 -- TODO: Eventually, we should bump the lower version -- bounds to >=0.6 so that we can remove some CPP in -- Generics.Deriving.TH.Internal. , th-abstraction >= 0.4 && < 0.7 default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: DefaultSpec EmptyCaseSpec ExampleSpec T68Spec T80Spec T82Spec TypeInTypeSpec build-depends: base >= 4.3 && < 5 , generic-deriving , hspec >= 2 && < 3 , template-haskell >= 2.4 && < 2.22 build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type generic-deriving-1.14.5/src/Generics/0000755000000000000000000000000007346545000015542 5ustar0000000000000000generic-deriving-1.14.5/src/Generics/Deriving.hs0000644000000000000000000000121707346545000017646 0ustar0000000000000000 module Generics.Deriving ( module Generics.Deriving.Base, module Generics.Deriving.Copoint, module Generics.Deriving.ConNames, module Generics.Deriving.Default, module Generics.Deriving.Enum, module Generics.Deriving.Eq, module Generics.Deriving.Functor, module Generics.Deriving.Show, module Generics.Deriving.Uniplate ) where import Generics.Deriving.Base import Generics.Deriving.Copoint import Generics.Deriving.ConNames import Generics.Deriving.Default import Generics.Deriving.Enum import Generics.Deriving.Eq import Generics.Deriving.Functor import Generics.Deriving.Show import Generics.Deriving.Uniplate generic-deriving-1.14.5/src/Generics/Deriving/0000755000000000000000000000000007346545000017311 5ustar0000000000000000generic-deriving-1.14.5/src/Generics/Deriving/Base.hs0000644000000000000000000000045407346545000020522 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Base (module Generics.Deriving.Base.Internal) where import Generics.Deriving.Base.Internal import Generics.Deriving.Instances () generic-deriving-1.14.5/src/Generics/Deriving/Base/0000755000000000000000000000000007346545000020163 5ustar0000000000000000generic-deriving-1.14.5/src/Generics/Deriving/Base/Internal.hs0000644000000000000000000010443707346545000022304 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Base.Internal ( -- * Introduction -- -- | -- -- Datatype-generic functions are are based on the idea of converting values of -- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. -- The type @'Rep' T@ is -- built from a limited set of type constructors, all provided by this module. A -- datatype-generic function is then an overloaded function with instances -- for most of these type constructors, together with a wrapper that performs -- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need -- a few generic instances in order to implement functionality that works for any -- representable type. -- -- Representable types are collected in the 'Generic' class, which defines the -- associated type 'Rep' as well as conversion functions 'from' and 'to'. -- Typically, you will not define 'Generic' instances by hand, but have the compiler -- derive them for you. -- ** Representing datatypes -- -- | -- -- The key to defining your own datatype-generic functions is to understand how to -- represent datatypes using the given set of type constructors. -- -- Let us look at an example first: -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) -- deriving 'Generic' -- @ -- -- The above declaration (which requires the language pragma @DeriveGeneric@) -- causes the following representation to be generated: -- -- @ -- class 'Generic' (Tree a) where -- type 'Rep' (Tree a) = -- 'D1' D1Tree -- ('C1' C1_0Tree -- ('S1' 'NoSelector' ('Par0' a)) -- ':+:' -- 'C1' C1_1Tree -- ('S1' 'NoSelector' ('Rec0' (Tree a)) -- ':*:' -- 'S1' 'NoSelector' ('Rec0' (Tree a)))) -- ... -- @ -- -- /Hint:/ You can obtain information about the code being generated from GHC by passing -- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using -- the @:kind!@ command. -- #if 0 -- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will -- use 'Rec0' everywhere. -- #endif -- This is a lot of information! However, most of it is actually merely meta-information -- that makes names of datatypes and constructors and more available on the type level. -- -- Here is a reduced representation for 'Tree' with nearly all meta-information removed, -- for now keeping only the most essential aspects: -- -- @ -- instance 'Generic' (Tree a) where -- type 'Rep' (Tree a) = -- 'Par0' a -- ':+:' -- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) -- @ -- -- The @Tree@ datatype has two constructors. The representation of individual constructors -- is combined using the binary type constructor ':+:'. -- -- The first constructor consists of a single field, which is the parameter @a@. This is -- represented as @'Par0' a@. -- -- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, -- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using -- the binary type constructor ':*:'. -- -- Now let us explain the additional tags being used in the complete representation: -- -- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with -- this field of the constructor. -- -- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is -- the representation of the first and second constructor of datatype @Tree@, respectively. -- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of -- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful -- because they are instances of the type class 'Constructor'. This type class can be used -- to obtain information about the constructor in question, such as its name -- or infix priority. -- -- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the -- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a -- proxy type, and is useful by being an instance of class 'Datatype', which -- can be used to obtain the name of a datatype, the module it has been defined in, and -- whether it has been defined using @data@ or @newtype@. -- ** Derived and fundamental representation types -- -- | -- -- There are many datatype-generic functions that do not distinguish between positions that -- are parameters or positions that are recursive calls. There are also many datatype-generic -- functions that do not care about the names of datatypes and constructors at all. To keep -- the number of cases to consider in generic functions in such a situation to a minimum, -- it turns out that many of the type constructors introduced above are actually synonyms, -- defining them to be variants of a smaller set of constructors. -- *** Individual fields of constructors: 'K1' -- -- | -- -- The type constructors 'Par0' and 'Rec0' are variants of 'K1': -- -- @ -- type 'Par0' = 'K1' 'P' -- type 'Rec0' = 'K1' 'R' -- @ -- -- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. -- *** Meta information: 'M1' -- -- | -- -- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1': -- -- @ -- type 'S1' = 'M1' 'S' -- type 'C1' = 'M1' 'C' -- type 'D1' = 'M1' 'D' -- @ -- -- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create -- several variants of 'M1'. -- *** Additional generic representation type constructors -- -- | -- -- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur -- in the representations of other datatypes. -- **** Empty datatypes: 'V1' -- -- | -- -- For empty datatypes, 'V1' is used as a representation. For example, -- -- @ -- data Empty deriving 'Generic' -- @ -- -- yields -- -- @ -- instance 'Generic' Empty where -- type 'Rep' Empty = 'D1' D1Empty 'V1' -- @ -- **** Constructors without fields: 'U1' -- -- | -- -- If a constructor has no arguments, then 'U1' is used as its representation. For example -- the representation of 'Bool' is -- -- @ -- instance 'Generic' Bool where -- type 'Rep' Bool = -- 'D1' D1Bool -- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') -- @ -- *** Representation of types with many constructors or many fields -- -- | -- -- As ':+:' and ':*:' are just binary operators, one might ask what happens if the -- datatype has more than two constructors, or a constructor with more than two -- fields. The answer is simple: the operators are used several times, to combine -- all the constructors and fields as needed. However, users /should not rely on -- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is -- free to choose any nesting it prefers. (In practice, the current implementation -- tries to produce a more or less balanced nesting, so that the traversal of the -- structure of the datatype from the root to a particular component can be performed -- in logarithmic rather than linear time.) -- ** Defining datatype-generic functions -- -- | -- -- A datatype-generic function comprises two parts: -- -- 1. /Generic instances/ for the function, implementing it for most of the representation -- type constructors introduced above. -- -- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion -- between the original value and its `Rep`-based representation and then invokes the -- generic instances. -- -- As an example, let us look at a function 'encode' that produces a naive, but lossless -- bit encoding of values of various datatypes. So we are aiming to define a function -- -- @ -- encode :: 'Generic' a => a -> [Bool] -- @ -- -- where we use 'Bool' as our datatype for bits. -- -- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized -- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation -- type constructors operate with kind @* -> *@ as base kind. But the type argument is never -- being used. This may be changed at some point in the future. The class has a single method, -- and we use the type we want our final function to have, but we replace the occurrences of -- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used). -- -- > class Encode' f where -- > encode' :: f p -> [Bool] -- -- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define -- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'. -- *** Definition of the generic representation types -- -- | -- -- In order to be able to do this, we need to know the actual definitions of these types: -- -- @ -- data 'V1' p -- lifted version of Empty -- data 'U1' p = 'U1' -- lifted version of () -- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either' -- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,) -- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c -- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper -- @ -- -- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either', -- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value -- of a specific type @c@, and 'M1' wraps a value of the generic type argument, -- which in the lifted world is an @f p@ (where we do not care about @p@). -- *** Generic instances -- -- | -- -- The instance for 'V1' is slightly awkward (but also rarely used): -- -- @ -- instance Encode' 'V1' where -- encode' x = undefined -- @ -- -- There are no values of type @V1 p@ to pass (except undefined), so this is -- actually impossible. One can ask why it is useful to define an instance for -- 'V1' at all in this case? Well, an empty type can be used as an argument to -- a non-empty type, and you might still want to encode the resulting type. -- As a somewhat contrived example, consider @[Empty]@, which is not an empty -- type, but contains just the empty list. The 'V1' instance ensures that we -- can call the generic function on such types. -- -- There is exactly one value of type 'U1', so encoding it requires no -- knowledge, and we can use zero bits: -- -- @ -- instance Encode' 'U1' where -- encode' 'U1' = [] -- @ -- -- In the case for ':+:', we produce 'False' or 'True' depending on whether -- the constructor of the value provided is located on the left or on the right: -- -- @ -- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where -- encode' ('L1' x) = False : encode' x -- encode' ('R1' x) = True : encode' x -- @ -- -- In the case for ':*:', we append the encodings of the two subcomponents: -- -- @ -- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where -- encode' (x ':*:' y) = encode' x ++ encode' y -- @ -- -- The case for 'K1' is rather interesting. Here, we call the final function -- 'encode' that we yet have to define, recursively. We will use another type -- class 'Encode' for that function: -- -- @ -- instance (Encode c) => Encode' ('K1' i c) where -- encode' ('K1' x) = encode x -- @ -- -- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define -- a uniform instance here. -- -- Similarly, we can define a uniform instance for 'M1', because we completely -- disregard all meta-information: -- -- @ -- instance (Encode' f) => Encode' ('M1' i t f) where -- encode' ('M1' x) = encode' x -- @ -- -- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. -- *** The wrapper and generic default -- -- | -- -- We now define class 'Encode' for the actual 'encode' function: -- -- @ -- class Encode a where -- encode :: a -> [Bool] -- default encode :: ('Generic' a) => a -> [Bool] -- encode x = encode' ('from' x) -- @ -- -- The incoming 'x' is converted using 'from', then we dispatch to the -- generic instances using 'encode''. We use this as a default definition -- for 'encode'. We need the 'default encode' signature because ordinary -- Haskell default methods must not introduce additional class constraints, -- but our generic default does. -- -- Defining a particular instance is now as simple as saying -- -- @ -- instance (Encode a) => Encode (Tree a) -- @ -- #if 0 -- /TODO:/ Add usage example? -- #endif -- The generic default is being used. In the future, it will hopefully be -- possible to use @deriving Encode@ as well, but GHC does not yet support -- that syntax for this situation. -- -- Having 'Encode' as a class has the advantage that we can define -- non-generic special cases, which is particularly useful for abstract -- datatypes that have no structural representation. For example, given -- a suitable integer encoding function 'encodeInt', we can define -- -- @ -- instance Encode Int where -- encode = encodeInt -- @ -- *** Omitting generic instances -- -- | -- -- It is not always required to provide instances for all the generic -- representation types, but omitting instances restricts the set of -- datatypes the functions will work for: -- -- * If no ':+:' instance is given, the function may still work for -- empty datatypes or datatypes that have a single constructor, -- but will fail on datatypes with more than one constructor. -- -- * If no ':*:' instance is given, the function may still work for -- datatypes where each constructor has just zero or one field, -- in particular for enumeration types. -- -- * If no 'K1' instance is given, the function may still work for -- enumeration types, where no constructor has any fields. -- -- * If no 'V1' instance is given, the function may still work for -- any datatype that is not empty. -- -- * If no 'U1' instance is given, the function may still work for -- any datatype where each constructor has at least one field. -- -- An 'M1' instance is always required (but it can just ignore the -- meta-information, as is the case for 'encode' above). #if 0 -- *** Using meta-information -- -- | -- -- TODO #endif -- ** Generic constructor classes -- -- | -- -- Datatype-generic functions as defined above work for a large class -- of datatypes, including parameterized datatypes. (We have used 'Tree' -- as our example above, which is of kind @* -> *@.) However, the -- 'Generic' class ranges over types of kind @*@, and therefore, the -- resulting generic functions (such as 'encode') must be parameterized -- by a generic type argument of kind @*@. -- -- What if we want to define generic classes that range over type -- constructors (such as 'Functor', 'Traversable', or 'Foldable')? -- *** The 'Generic1' class -- -- | -- -- Like 'Generic', there is a class 'Generic1' that defines a -- representation 'Rep1' and conversion functions 'from1' and 'to1', -- only that 'Generic1' ranges over types of kind @* -> *@. -- The 'Generic1' class is also derivable. -- -- The representation 'Rep1' is ever so slightly different from 'Rep'. -- Let us look at 'Tree' as an example again: -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) -- deriving 'Generic1' -- @ -- -- The above declaration causes the following representation to be generated: -- -- class 'Generic1' Tree where -- type 'Rep1' Tree = -- 'D1' D1Tree -- ('C1' C1_0Tree -- ('S1' 'NoSelector' 'Par1') -- ':+:' -- 'C1' C1_1Tree -- ('S1' 'NoSelector' ('Rec1' Tree) -- ':*:' -- 'S1' 'NoSelector' ('Rec1' Tree))) -- ... -- -- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well -- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we -- carry around the dummy type argument for kind-@*@-types, but there are -- already enough different names involved without duplicating each of -- these.) -- -- What's different is that we now use 'Par1' to refer to the parameter -- (and that parameter, which used to be @a@), is not mentioned explicitly -- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@. -- *** Representation of @* -> *@ types -- -- | -- -- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not -- map to 'K1'. They are defined directly, as follows: -- -- @ -- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p -- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper -- @ -- -- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply -- wraps an application of @f@ to @p@. -- -- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation, -- namely when the datatype has a field that does not mention the parameter. -- -- The declaration -- -- @ -- data WithInt a = WithInt Int a -- deriving 'Generic1' -- @ -- -- yields -- -- @ -- class 'Rep1' WithInt where -- type 'Rep1' WithInt = -- 'D1' D1WithInt -- ('C1' C1_0WithInt -- ('S1' 'NoSelector' ('Rec0' Int) -- ':*:' -- 'S1' 'NoSelector' 'Par1')) -- @ -- -- If the parameter @a@ appears underneath a composition of other type constructors, -- then the representation involves composition, too: -- -- @ -- data Rose a = Fork a [Rose a] -- @ -- -- yields -- -- @ -- class 'Rep1' Rose where -- type 'Rep1' Rose = -- 'D1' D1Rose -- ('C1' C1_0Rose -- ('S1' 'NoSelector' 'Par1' -- ':*:' -- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) -- @ -- -- where -- -- @ -- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } -- @ -- *** Representation of unlifted types -- -- | -- -- If one were to attempt to derive a Generic instance for a datatype with an -- unlifted argument (for example, 'Int#'), one might expect the occurrence of -- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, -- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. -- In fact, polymorphism over unlifted types is disallowed completely. -- -- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' -- instead. With this approach, however, the programmer has no way of knowing -- whether the 'Int' is actually an 'Int#' in disguise. -- -- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark -- occurrences of common unlifted types: -- -- @ -- data family URec a p -- -- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } -- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } -- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } -- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } -- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } -- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } -- @ -- -- Several type synonyms are provided for convenience: -- -- @ -- type 'UAddr' = 'URec' ('Ptr' ()) -- type 'UChar' = 'URec' 'Char' -- type 'UDouble' = 'URec' 'Double' -- type 'UFloat' = 'URec' 'Float' -- type 'UInt' = 'URec' 'Int' -- type 'UWord' = 'URec' 'Word' -- @ -- -- The declaration -- -- @ -- data IntHash = IntHash Int# -- deriving 'Generic' -- @ -- -- yields -- -- @ -- instance 'Generic' IntHash where -- type 'Rep' IntHash = -- 'D1' D1IntHash -- ('C1' C1_0IntHash -- ('S1' 'NoSelector' 'UInt')) -- @ -- -- Currently, only the six unlifted types listed above are generated, but this -- may be extended to encompass more unlifted types in the future. #if 0 -- *** Limitations -- -- | -- -- /TODO/ -- -- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion. -- #endif #if !(MIN_VERSION_base(4,4,0)) -- * Generic representation types V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..) -- ** Synonyms for convenience , Rec0, Par0, R, P , D1, C1, S1, D, C, S -- * Meta-information , Datatype(..), Constructor(..), Selector(..), NoSelector , Fixity(..), Associativity(..), Arity(..), prec -- * Generic type classes , Generic(..), Generic1(..), #else module GHC.Generics, #endif #if !(MIN_VERSION_base(4,9,0)) -- ** Unboxed representation types URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord #endif ) where #if MIN_VERSION_base(4,4,0) import GHC.Generics #else import Control.Applicative ( Alternative(..) ) import Control.Monad ( MonadPlus(..) ) import Control.Monad.Fix ( MonadFix(..), fix ) import Data.Data ( Data(..), DataType, constrIndex, mkDataType ) import Data.Ix ( Ix ) import Text.ParserCombinators.ReadPrec (pfail) import Text.Read ( Read(..), parens, readListDefault, readListPrecDefault ) #endif #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ( Applicative(..) ) import Data.Foldable ( Foldable(..) ) import Data.Monoid ( Monoid(..) ) import Data.Traversable ( Traversable(..) ) import Data.Word ( Word ) #endif #if !(MIN_VERSION_base(4,9,0)) import Data.Typeable import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Ptr ( Ptr ) #endif #if !(MIN_VERSION_base(4,4,0)) -------------------------------------------------------------------------------- -- Representation types -------------------------------------------------------------------------------- -- | Void: used for datatypes without constructors data V1 p deriving Typeable -- Implement these instances by hand to get the desired, maximally lazy behavior. instance Functor V1 where fmap _ !_ = error "Void fmap" instance Foldable V1 where foldr _ z _ = z foldMap _ _ = mempty instance Traversable V1 where traverse _ x = pure (case x of !_ -> error "Void traverse") instance Eq (V1 p) where _ == _ = True instance Data p => Data (V1 p) where gfoldl _ _ !_ = error "Void gfoldl" gunfold _ _ c = case constrIndex c of _ -> error "Void gunfold" toConstr !_ = error "Void toConstr" dataTypeOf _ = v1DataType dataCast1 f = gcast1 f v1DataType :: DataType v1DataType = mkDataType "V1" [] instance Ord (V1 p) where compare _ _ = EQ instance Show (V1 p) where showsPrec _ !_ = error "Void showsPrec" -- Implement Read instance manually to get around an old GHC bug -- (Trac #7931) instance Read (V1 p) where readPrec = parens pfail readList = readListDefault readListPrec = readListPrecDefault -- | Unit: used for constructors without arguments data U1 p = U1 deriving (Eq, Ord, Read, Show, Data, Typeable) instance Functor U1 where fmap _ _ = U1 instance Applicative U1 where pure _ = U1 _ <*> _ = U1 instance Alternative U1 where empty = U1 _ <|> _ = U1 instance Monad U1 where return _ = U1 _ >>= _ = U1 instance MonadPlus U1 where mzero = U1 mplus _ _ = U1 instance Foldable U1 where foldMap _ _ = mempty {-# INLINE foldMap #-} fold _ = mempty {-# INLINE fold #-} foldr _ z _ = z {-# INLINE foldr #-} foldl _ z _ = z {-# INLINE foldl #-} foldl1 _ _ = error "foldl1: U1" foldr1 _ _ = error "foldr1: U1" instance Traversable U1 where traverse _ _ = pure U1 {-# INLINE traverse #-} sequenceA _ = pure U1 {-# INLINE sequenceA #-} mapM _ _ = return U1 {-# INLINE mapM #-} sequence _ = return U1 {-# INLINE sequence #-} -- | Used for marking occurrences of the parameter newtype Par1 p = Par1 { unPar1 :: p } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Typeable) instance Applicative Par1 where pure a = Par1 a Par1 f <*> Par1 x = Par1 (f x) instance Monad Par1 where return a = Par1 a Par1 x >>= f = f x instance MonadFix Par1 where mfix f = Par1 (fix (unPar1 . f)) -- | Recursive calls of kind * -> * newtype Rec1 f p = Rec1 { unRec1 :: f p } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance Typeable1 f => Typeable1 (Rec1 f) where typeOf1 t = mkTyConApp rec1TyCon [typeOf1 (f t)] where f :: Rec1 f a -> f a f = undefined rec1TyCon :: TyCon rec1TyCon = mkTyCon "Generics.Deriving.Base.Internal.Rec1" instance Applicative f => Applicative (Rec1 f) where pure a = Rec1 (pure a) Rec1 f <*> Rec1 x = Rec1 (f <*> x) instance Alternative f => Alternative (Rec1 f) where empty = Rec1 empty Rec1 l <|> Rec1 r = Rec1 (l <|> r) instance Monad f => Monad (Rec1 f) where return a = Rec1 (return a) Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a)) instance MonadFix f => MonadFix (Rec1 f) where mfix f = Rec1 (mfix (unRec1 . f)) instance MonadPlus f => MonadPlus (Rec1 f) where mzero = Rec1 mzero mplus (Rec1 a) (Rec1 b) = Rec1 (mplus a b) -- | Constants, additional parameters and recursion of kind * newtype K1 i c p = K1 { unK1 :: c } deriving (Eq, Ord, Read, Show, Functor, Data, Typeable) instance Foldable (K1 i c) where foldr _ z K1{} = z foldMap _ K1{} = mempty instance Traversable (K1 i c) where traverse _ (K1 c) = pure (K1 c) -- | Meta-information (constructor names, etc.) newtype M1 i c f p = M1 { unM1 :: f p } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable i, Typeable c, Typeable1 f) => Typeable1 (M1 i c f) where typeOf1 t = mkTyConApp m1TyCon [typeOf (i t), typeOf (c t), typeOf1 (f t)] where i :: M1 i c f p -> i i = undefined c :: M1 i c f p -> c c = undefined f :: M1 i c f p -> f p f = undefined m1TyCon :: TyCon m1TyCon = mkTyCon "Generics.Deriving.Base.Internal.M1" instance Applicative f => Applicative (M1 i c f) where pure a = M1 (pure a) M1 f <*> M1 x = M1 (f <*> x) instance Alternative f => Alternative (M1 i c f) where empty = M1 empty M1 l <|> M1 r = M1 (l <|> r) instance Monad f => Monad (M1 i c f) where return a = M1 (return a) M1 x >>= f = M1 (x >>= \a -> unM1 (f a)) instance MonadPlus f => MonadPlus (M1 i c f) where mzero = M1 mzero mplus (M1 a) (M1 b) = M1 (mplus a b) instance MonadFix f => MonadFix (M1 i c f) where mfix f = M1 (mfix (unM1. f)) -- | Sums: encode choice between constructors infixr 5 :+: data (:+:) f g p = L1 (f p) | R1 (g p) deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where typeOf1 t = mkTyConApp conSumTyCon [typeOf1 (f t), typeOf1 (g t)] where f :: (f :+: g) p -> f p f = undefined g :: (f :+: g) p -> g p g = undefined conSumTyCon :: TyCon conSumTyCon = mkTyCon "Generics.Deriving.Base.Internal.:+:" -- | Products: encode multiple arguments to constructors infixr 6 :*: data (:*:) f g p = f p :*: g p deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable1 f, Typeable1 g) => Typeable1 (f :*: g) where typeOf1 t = mkTyConApp conProductTyCon [typeOf1 (f t), typeOf1 (g t)] where f :: (f :*: g) p -> f p f = undefined g :: (f :*: g) p -> g p g = undefined conProductTyCon :: TyCon conProductTyCon = mkTyCon "Generics.Deriving.Base.Internal.:*:" instance (Applicative f, Applicative g) => Applicative (f :*: g) where pure a = pure a :*: pure a (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y) instance (Alternative f, Alternative g) => Alternative (f :*: g) where empty = empty :*: empty (x1 :*: y1) <|> (x2 :*: y2) = (x1 <|> x2) :*: (y1 <|> y2) instance (Monad f, Monad g) => Monad (f :*: g) where return a = return a :*: return a (m :*: n) >>= f = (m >>= \a -> fstP (f a)) :*: (n >>= \a -> sndP (f a)) where fstP (a :*: _) = a sndP (_ :*: b) = b instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f)) where fstP (a :*: _) = a sndP (_ :*: b) = b instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) where mzero = mzero :*: mzero (x1 :*: y1) `mplus` (x2 :*: y2) = (x1 `mplus` x2) :*: (y1 `mplus` y2) -- | Composition of functors infixr 7 :.: newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable1 f, Typeable1 g) => Typeable1 (f :.: g) where typeOf1 t = mkTyConApp conComposeTyCon [typeOf1 (f t), typeOf1 (g t)] where f :: (f :.: g) p -> f p f = undefined g :: (f :.: g) p -> g p g = undefined conComposeTyCon :: TyCon conComposeTyCon = mkTyCon "Generics.Deriving.Base.Internal.:.:" instance (Applicative f, Applicative g) => Applicative (f :.: g) where pure x = Comp1 (pure (pure x)) Comp1 f <*> Comp1 x = Comp1 (fmap (<*>) f <*> x) instance (Alternative f, Applicative g) => Alternative (f :.: g) where empty = Comp1 empty Comp1 x <|> Comp1 y = Comp1 (x <|> y) -- | Tag for K1: recursion (of kind *) data R deriving Typeable -- | Tag for K1: parameters (other than the last) data P deriving Typeable -- | Type synonym for encoding recursion (of kind *) type Rec0 = K1 R -- | Type synonym for encoding parameters (other than the last) type Par0 = K1 P -- | Tag for M1: datatype data D deriving Typeable -- | Tag for M1: constructor data C deriving Typeable -- | Tag for M1: record selector data S deriving Typeable -- | Type synonym for encoding meta-information for datatypes type D1 = M1 D -- | Type synonym for encoding meta-information for constructors type C1 = M1 C -- | Type synonym for encoding meta-information for record selectors type S1 = M1 S -- | Class for datatypes that represent datatypes class Datatype d where -- | The name of the datatype, fully qualified datatypeName :: t d (f :: * -> *) a -> String moduleName :: t d (f :: * -> *) a -> String -- | Class for datatypes that represent records class Selector s where -- | The name of the selector selName :: t s (f :: * -> *) a -> String -- | Used for constructor fields without a name data NoSelector deriving Typeable instance Selector NoSelector where selName _ = "" -- | Class for datatypes that represent data constructors class Constructor c where -- | The name of the constructor conName :: t c (f :: * -> *) a -> String -- | The fixity of the constructor conFixity :: t c (f :: * -> *) a -> Fixity conFixity = const Prefix -- | Marks if this constructor is a record conIsRecord :: t c (f :: * -> *) a -> Bool conIsRecord = const False -- | Datatype to represent the arity of a tuple. data Arity = NoArity | Arity Int deriving (Eq, Show, Ord, Read, Typeable) -- | Datatype to represent the fixity of a constructor. An infix -- | declaration directly corresponds to an application of 'Infix'. data Fixity = Prefix | Infix Associativity Int deriving (Eq, Show, Ord, Read, Data, Typeable) -- | Get the precedence of a fixity value. prec :: Fixity -> Int prec Prefix = 10 prec (Infix _ n) = n -- | Datatype to represent the associativity of a constructor data Associativity = LeftAssociative | RightAssociative | NotAssociative deriving (Eq, Show, Ord, Read, Bounded, Enum, Ix, Data, Typeable) -- | Representable types of kind * class Generic a where type Rep a :: * -> * -- | Convert from the datatype to its representation from :: a -> Rep a x -- | Convert from the representation to the datatype to :: Rep a x -> a -- | Representable types of kind * -> * class Generic1 f where type Rep1 f :: * -> * -- | Convert from the datatype to its representation from1 :: f a -> Rep1 f a -- | Convert from the representation to the datatype to1 :: Rep1 f a -> f a #endif #if !(MIN_VERSION_base(4,9,0)) -- | Constants of kind @#@ data family URec (a :: *) (p :: *) # if MIN_VERSION_base(4,7,0) deriving instance Typeable URec # else instance Typeable2 URec where typeOf2 _ = # if MIN_VERSION_base(4,4,0) mkTyConApp (mkTyCon3 "generic-deriving" "Generics.Deriving.Base.Internal" "URec") [] # else mkTyConApp (mkTyCon "Generics.Deriving.Base.Internal.URec") [] # endif # endif -- | Used for marking occurrences of 'Addr#' data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } deriving (Eq, Ord) instance Functor (URec (Ptr ())) where fmap _ (UAddr a) = UAddr a instance Foldable (URec (Ptr ())) where foldr _ z UAddr{} = z foldMap _ UAddr{} = mempty instance Traversable (URec (Ptr ())) where traverse _ (UAddr a) = pure (UAddr a) -- | Used for marking occurrences of 'Char#' data instance URec Char p = UChar { uChar# :: Char# } deriving (Eq, Ord, Show) instance Functor (URec Char) where fmap _ (UChar c) = UChar c instance Foldable (URec Char) where foldr _ z UChar{} = z foldMap _ UChar{} = mempty instance Traversable (URec Char) where traverse _ (UChar c) = pure (UChar c) -- | Used for marking occurrences of 'Double#' data instance URec Double p = UDouble { uDouble# :: Double# } deriving (Eq, Ord, Show) instance Functor (URec Double) where fmap _ (UDouble d) = UDouble d instance Foldable (URec Double) where foldr _ z UDouble{} = z foldMap _ UDouble{} = mempty instance Traversable (URec Double) where traverse _ (UDouble d) = pure (UDouble d) -- | Used for marking occurrences of 'Float#' data instance URec Float p = UFloat { uFloat# :: Float# } deriving (Eq, Ord, Show) instance Functor (URec Float) where fmap _ (UFloat f) = UFloat f instance Foldable (URec Float) where foldr _ z UFloat{} = z foldMap _ UFloat{} = mempty instance Traversable (URec Float) where traverse _ (UFloat f) = pure (UFloat f) -- | Used for marking occurrences of 'Int#' data instance URec Int p = UInt { uInt# :: Int# } deriving (Eq, Ord, Show) instance Functor (URec Int) where fmap _ (UInt i) = UInt i instance Foldable (URec Int) where foldr _ z UInt{} = z foldMap _ UInt{} = mempty instance Traversable (URec Int) where traverse _ (UInt i) = pure (UInt i) -- | Used for marking occurrences of 'Word#' data instance URec Word p = UWord { uWord# :: Word# } deriving (Eq, Ord, Show) instance Functor (URec Word) where fmap _ (UWord w) = UWord w instance Foldable (URec Word) where foldr _ z UWord{} = z foldMap _ UWord{} = mempty instance Traversable (URec Word) where traverse _ (UWord w) = pure (UWord w) -- | Type synonym for 'URec': 'Addr#' type UAddr = URec (Ptr ()) -- | Type synonym for 'URec': 'Char#' type UChar = URec Char -- | Type synonym for 'URec': 'Double#' type UDouble = URec Double -- | Type synonym for 'URec': 'Float#' type UFloat = URec Float -- | Type synonym for 'URec': 'Int#' type UInt = URec Int -- | Type synonym for 'URec': 'Word#' type UWord = URec Word #endif generic-deriving-1.14.5/src/Generics/Deriving/ConNames.hs0000644000000000000000000000360307346545000021352 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif {- | Module : Generics.Deriving.ConNames Copyright : (c) 2012 University of Oxford License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Summary: Return the name of all the constructors of a type. -} module Generics.Deriving.ConNames ( -- * Functionality for retrieving the names of the possible contructors -- of a type or the constructor name of a given value ConNames(..), conNames, conNameOf ) where import Generics.Deriving.Base class ConNames f where gconNames :: f a -> [String] gconNameOf :: f a -> String instance (ConNames f, ConNames g) => ConNames (f :+: g) where gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++ gconNames (undefined :: g a) gconNameOf (L1 x) = gconNameOf x gconNameOf (R1 x) = gconNameOf x instance (ConNames f) => ConNames (D1 c f) where gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a) gconNameOf (M1 x) = gconNameOf x instance (Constructor c) => ConNames (C1 c f) where gconNames x = [conName x] gconNameOf x = conName x -- We should never need any other instances. -- | Return the name of all the constructors of the type of the given term. conNames :: (Generic a, ConNames (Rep a)) => a -> [String] conNames x = gconNames (undefined `asTypeOf` (from x)) -- | Return the name of the constructor of the given term conNameOf :: (ConNames (Rep a), Generic a) => a -> String conNameOf x = gconNameOf (from x) generic-deriving-1.14.5/src/Generics/Deriving/Copoint.hs0000644000000000000000000001036107346545000021261 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Copoint ( -- * GCopoint class GCopoint(..) -- * Default method , gcopointdefault -- * Internal class , GCopoint'(..) ) where import Control.Applicative (WrappedMonad) import Data.Monoid (Dual) import qualified Data.Monoid as Monoid (Sum) import Generics.Deriving.Base #if MIN_VERSION_base(4,6,0) import Data.Ord (Down) #else import GHC.Exts (Down) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Sum as Functor (Sum) import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic copoint -------------------------------------------------------------------------------- -- General copoint may return 'Nothing' class GCopoint' t where gcopoint' :: t a -> Maybe a instance GCopoint' V1 where gcopoint' _ = Nothing instance GCopoint' U1 where gcopoint' U1 = Nothing instance GCopoint' Par1 where gcopoint' (Par1 a) = Just a instance GCopoint' (K1 i c) where gcopoint' _ = Nothing instance GCopoint' f => GCopoint' (M1 i c f) where gcopoint' (M1 a) = gcopoint' a instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where gcopoint' (L1 a) = gcopoint' a gcopoint' (R1 a) = gcopoint' a -- Favours left "hole" for copoint instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where gcopoint' (a :*: b) = case (gcopoint' a) of Just x -> Just x Nothing -> gcopoint' b instance (GCopoint f) => GCopoint' (Rec1 f) where gcopoint' (Rec1 a) = Just $ gcopoint a instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x class GCopoint d where gcopoint :: d a -> a #if __GLASGOW_HASKELL__ >= 701 default gcopoint :: (Generic1 d, GCopoint' (Rep1 d)) => (d a -> a) gcopoint = gcopointdefault #endif gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d)) => d a -> a gcopointdefault x = case (gcopoint' . from1 $ x) of Just x' -> x' Nothing -> error "Data type is not copointed" -- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d -- Base types instances instance GCopoint ((,) a) where gcopoint = gcopointdefault instance GCopoint ((,,) a b) where gcopoint = gcopointdefault instance GCopoint ((,,,) a b c) where gcopoint = gcopointdefault instance GCopoint ((,,,,) a b c d) where gcopoint = gcopointdefault instance GCopoint ((,,,,,) a b c d e) where gcopoint = gcopointdefault instance GCopoint ((,,,,,,) a b c d e f) where gcopoint = gcopointdefault #if MIN_VERSION_base(4,8,0) instance GCopoint f => GCopoint (Alt f) where gcopoint = gcopointdefault #endif #if MIN_VERSION_base(4,9,0) instance GCopoint (Arg a) where gcopoint = gcopointdefault #endif instance GCopoint Down where gcopoint = gcopointdefault instance GCopoint Dual where gcopoint = gcopointdefault #if MIN_VERSION_base(4,9,0) instance GCopoint First where gcopoint = gcopointdefault #endif #if MIN_VERSION_base(4,8,0) instance GCopoint Identity where gcopoint = gcopointdefault #endif #if MIN_VERSION_base(4,9,0) instance GCopoint Last where gcopoint = gcopointdefault instance GCopoint Max where gcopoint = gcopointdefault instance GCopoint Min where gcopoint = gcopointdefault instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where gcopoint = gcopointdefault #endif instance GCopoint Monoid.Sum where gcopoint = gcopointdefault instance GCopoint m => GCopoint (WrappedMonad m) where gcopoint = gcopointdefault #if MIN_VERSION_base(4,9,0) instance GCopoint WrappedMonoid where gcopoint = gcopointdefault #endif generic-deriving-1.14.5/src/Generics/Deriving/Default.hs0000644000000000000000000002571507346545000021243 0ustar0000000000000000-- | -- Module : Generics.Deriving.Default -- Description : Default implementations of generic classes -- License : BSD-3-Clause -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable -- -- GHC 8.6 introduced the -- @@ -- language extension, which means a typeclass instance can be derived from -- an existing instance for an isomorphic type. Any newtype is isomorphic -- to the underlying type. By implementing a typeclass once for the newtype, -- it is possible to derive any typeclass for any type with a 'Generic' instance. -- -- For a number of classes, there are sensible default instantiations. In -- older GHCs, these can be supplied in the class definition, using the -- @@ -- extension. However, only one default can be provided! With -- @@ -- it is now possible to choose from many -- default instantiations. -- -- This package contains a number of such classes. This module demonstrates -- how one might create a family of newtypes ('Default', 'Default1') for -- which such instances are defined. -- -- One might then use -- @@ -- as follows. The implementations of the data types are elided here (they -- are irrelevant). For most cases, either the deriving clause with the -- data type definition or the standalone clause will work (for some types -- it is necessary to supply the context explicitly using the latter form). -- See the source of this module for the implementations of instances for -- the 'Default' family of newtypes and the source of the test suite for -- some types which derive instances via these wrappers. {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} # if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} # else {-# LANGUAGE Trustworthy #-} # endif #endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Generics.Deriving.Default ( -- * Kind @*@ (aka @Type@) -- $default Default(..) , -- * Kind @* -> *@ (aka @Type -> Type@) -- $default1 Default1(..) -- * Other kinds -- $other-kinds ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((<$>)) #endif import Control.Monad (liftM) import Generics.Deriving.Base import Generics.Deriving.Copoint import Generics.Deriving.Enum import Generics.Deriving.Eq import Generics.Deriving.Foldable import Generics.Deriving.Functor import Generics.Deriving.Monoid import Generics.Deriving.Semigroup import Generics.Deriving.Show import Generics.Deriving.Traversable import Generics.Deriving.Uniplate -- $default -- -- For classes which take an argument of kind 'Data.Kind.Type', use -- 'Default'. An example of this class from @base@ would be 'Eq', or -- 'Generic'. -- -- These examples use 'GShow' and 'GEq'; they are interchangeable. -- -- @ -- data MyType = … -- deriving ('Generic') -- deriving ('GEq') via ('Default' MyType) -- -- deriving via ('Default' MyType) instance 'GShow' MyType -- @ -- -- Instances may be parameterized by type variables. -- -- @ -- data MyType1 a = … -- deriving ('Generic') -- deriving ('GShow') via ('Default' (MyType1 a)) -- -- deriving via 'Default' (MyType1 a) instance 'GEq' a => 'GEq' (MyType1 a) -- @ -- -- These types both require instances for 'Generic'. This is because the -- implementations of 'geq' and 'gshowsPrec' for @'Default' b@ have a @'Generic' -- b@ constraint, i.e. the type corresponding to @b@ require a 'Generic' -- instance. For these two types, that means instances for @'Generic' MyType@ -- and @'Generic' (MyType1 a)@ respectively. -- -- It also means the 'Generic' instance is not needed when there is already -- a generic instance for the type used to derive the relevant instances. -- For an example, see the documentation of the 'GShow' instance for -- 'Default', below. -- | This newtype wrapper can be used to derive default instances for -- classes taking an argument of kind 'Data.Kind.Type'. newtype Default a = Default { unDefault :: a } -- $default1 -- -- For classes which take an argument of kind @'Data.Kind.Type' -> -- 'Data.Kind.Type'@, use 'Default1'. An example of this class from @base@ -- would be 'Data.Functor.Classes.Eq1', or 'Generic1'. -- -- Unlike for @MyType1@, there can be no implementation of these classes for @MyType :: 'Data.Kind.Type'@. -- -- @ -- data MyType1 a = … -- deriving ('Generic1') -- deriving ('GFunctor') via ('Default1' MyType1) -- -- deriving via ('Default1' MyType1) instance 'GFoldable' MyType1 -- @ -- -- Note that these instances require a @'Generic1' MyType1@ constraint as -- 'gmap' and 'gfoldMap' have @'Generic1' a@ constraints on the -- implementations for @'Default1' a@. -- | This newtype wrapper can be used to derive default instances for -- classes taking an argument of kind @'Data.Kind.Type' -> 'Data.Kind.Type'@. newtype Default1 f a = Default1 { unDefault1 :: f a } -- $other-kinds -- -- These principles extend to classes taking arguments of other kinds. -------------------------------------------------------------------------------- -- Eq -------------------------------------------------------------------------------- instance (Generic a, GEq' (Rep a)) => GEq (Default a) where -- geq :: Default a -> Default a -> Bool Default x `geq` Default y = x `geqdefault` y -------------------------------------------------------------------------------- -- Enum -------------------------------------------------------------------------------- -- | The 'Enum' class in @base@ is slightly different; it comprises 'toEnum' and -- 'fromEnum'. "Generics.Deriving.Enum" provides functions 'toEnumDefault' -- and 'fromEnumDefault'. instance (Generic a, GEq a, Enum' (Rep a)) => GEnum (Default a) where -- genum :: [Default a] genum = Default . to <$> enum' -------------------------------------------------------------------------------- -- Show -------------------------------------------------------------------------------- -- | For example, with this type: -- -- @ -- newtype TestShow = TestShow 'Bool' -- deriving ('GShow') via ('Default' 'Bool') -- @ -- -- 'gshow' for @TestShow@ would produce the same string as `gshow` for -- 'Bool'. -- -- In this example, @TestShow@ requires no 'Generic' instance, as the -- constraint on 'gshowsPrec' from @'Default' 'Bool'@ is @'Generic' 'Bool'@. -- -- In general, when using a newtype wrapper, the instance can be derived -- via the wrapped type, as here (via @'Default' 'Bool'@ rather than @'Default' -- TestShow@). instance (Generic a, GShow' (Rep a)) => GShow (Default a) where -- gshowsPrec :: Int -> Default a -> ShowS gshowsPrec n (Default x) = gshowsPrecdefault n x -------------------------------------------------------------------------------- -- Semigroup -------------------------------------------------------------------------------- -- | Semigroups often have many sensible implementations of -- 'Data.Semigroup.<>' / 'gsappend', and therefore no sensible default. -- Indeed, there is no 'GSemigroup'' instance for representations of sum -- types. -- -- In other cases, one may wish to use the existing wrapper newtypes in -- @base@, such as the following (using 'Data.Semigroup.First'): -- -- @ -- newtype FirstSemigroup = FirstSemigroup 'Bool' -- deriving stock ('Eq', 'Show') -- deriving ('GSemigroup') via ('Data.Semigroup.First' 'Bool') -- @ -- instance (Generic a, GSemigroup' (Rep a)) => GSemigroup (Default a) where -- gsappend :: Default a -> Default a -> Default a Default x `gsappend` Default y = Default $ x `gsappenddefault` y -------------------------------------------------------------------------------- -- Monoid -------------------------------------------------------------------------------- instance (Generic a, GMonoid' (Rep a)) => GMonoid (Default a) where -- gmempty :: Default a gmempty = Default gmemptydefault -- gmappend :: Default a -> Default a -> Default a Default x `gmappend` Default y = Default $ x `gmappenddefault` y -------------------------------------------------------------------------------- -- Uniplate -------------------------------------------------------------------------------- instance (Generic a, Uniplate' (Rep a) a, Context' (Rep a) a) => Uniplate (Default a) where -- children :: Default a -> [Default a] -- context :: Default a -> [Default a] -> Default a -- descend :: (Default a -> Default a) -> Default a -> Default a -- descendM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a) -- transform :: (Default a -> Default a) -> Default a -> Default a -- transformM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a) children (Default x) = Default <$> childrendefault x context (Default x) ys = Default $ contextdefault x (unDefault <$> ys) descend f (Default x) = Default $ descenddefault (unDefault . f . Default) x descendM f (Default x) = liftM Default $ descendMdefault (liftM unDefault . f . Default) x transform f (Default x) = Default $ transformdefault (unDefault . f . Default) x transformM f (Default x) = liftM Default $ transformMdefault (liftM unDefault . f . Default) x -------------------------------------------------------------------------------- -- Functor -------------------------------------------------------------------------------- instance (Generic1 f, GFunctor' (Rep1 f)) => GFunctor (Default1 f) where -- gmap :: (a -> b) -> (Default1 f) a -> (Default1 f) b gmap f (Default1 fx) = Default1 $ gmapdefault f fx -------------------------------------------------- -- Copoint -------------------------------------------------- instance (Generic1 f, GCopoint' (Rep1 f)) => GCopoint (Default1 f) where -- gcopoint :: Default1 f a -> a gcopoint = gcopointdefault . unDefault1 -------------------------------------------------- -- Foldable -------------------------------------------------- instance (Generic1 t, GFoldable' (Rep1 t)) => GFoldable (Default1 t) where -- gfoldMap :: Monoid m => (a -> m) -> Default1 t a -> m gfoldMap f (Default1 tx) = gfoldMapdefault f tx -------------------------------------------------- -- Traversable -------------------------------------------------- instance (Generic1 t, GFunctor' (Rep1 t), GFoldable' (Rep1 t), GTraversable' (Rep1 t)) => GTraversable (Default1 t) where -- gtraverse :: Applicative f => (a -> f b) -> Default1 t a -> f (Default1 t b) gtraverse f (Default1 fx) = Default1 <$> gtraversedefault f fx generic-deriving-1.14.5/src/Generics/Deriving/Enum.hs0000644000000000000000000006473407346545000020567 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #include "HsBaseConfig.h" module Generics.Deriving.Enum ( -- * Generic enum class GEnum(..) -- * Default definitions for GEnum , genumDefault, toEnumDefault, fromEnumDefault -- * Internal enum class , Enum'(..) -- * Generic Ix class , GIx(..) -- * Default definitions for GIx , rangeDefault, indexDefault, inRangeDefault ) where import Control.Applicative (Const, ZipList) import Data.Int import Data.Maybe (listToMaybe) import Data.Monoid (All, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last) import Data.Word import Foreign.C.Types import Foreign.Ptr import Generics.Deriving.Base import Generics.Deriving.Eq import System.Exit (ExitCode) import System.Posix.Types #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Coerce (coerce) import Data.Proxy (Proxy) #else import Unsafe.Coerce (unsafeCoerce) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) import Numeric.Natural (Natural) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) #endif ----------------------------------------------------------------------------- -- Utility functions for Enum' ----------------------------------------------------------------------------- infixr 5 ||| -- | Interleave elements from two lists. Similar to (++), but swap left and -- right arguments on every recursive application. -- -- From Mark Jones' talk at AFP2008 (|||) :: [a] -> [a] -> [a] [] ||| ys = ys (x:xs) ||| ys = x : ys ||| xs -- | Diagonalization of nested lists. Ensure that some elements from every -- sublist will be included. Handles infinite sublists. -- -- From Mark Jones' talk at AFP2008 diag :: [[a]] -> [a] diag = concat . foldr skew [] . map (map (\x -> [x])) skew :: [[a]] -> [[a]] -> [[a]] skew [] ys = ys skew (x:xs) ys = x : combine (++) xs ys combine :: (a -> a -> a) -> [a] -> [a] -> [a] combine _ xs [] = xs combine _ [] ys = ys combine f (x:xs) (y:ys) = f x y : combine f xs ys findIndex :: (a -> Bool) -> [a] -> Maybe Int findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] in listToMaybe l -------------------------------------------------------------------------------- -- Generic enum -------------------------------------------------------------------------------- class Enum' f where enum' :: [f a] instance Enum' U1 where enum' = [U1] instance (GEnum c) => Enum' (K1 i c) where enum' = map K1 genum instance (Enum' f) => Enum' (M1 i c f) where enum' = map M1 enum' instance (Enum' f, Enum' g) => Enum' (f :+: g) where enum' = map L1 enum' ||| map R1 enum' instance (Enum' f, Enum' g) => Enum' (f :*: g) where enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] genumDefault :: (Generic a, Enum' (Rep a)) => [a] genumDefault = map to enum' toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a toEnumDefault i = let l = enum' in if (length l > i) then to (l !! i) else error "toEnum: invalid index" fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a)) => a -> Int fromEnumDefault x = case findIndex (geq x) (map to enum') of Nothing -> error "fromEnum: no corresponding index" Just i -> i class GEnum a where genum :: [a] #if __GLASGOW_HASKELL__ >= 701 default genum :: (Generic a, Enum' (Rep a)) => [a] genum = genumDefault #endif genumNumUnbounded :: Num a => [a] genumNumUnbounded = pos 0 ||| neg 0 where pos n = n : pos (n + 1) neg n = (n-1) : neg (n - 1) genumNumSigned :: (Bounded a, Enum a, Num a) => [a] genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound] genumNumUnsigned :: (Enum a, Num a) => [a] genumNumUnsigned = [0 ..] #if !(MIN_VERSION_base(4,7,0)) coerce :: a -> b coerce = unsafeCoerce #endif -- Base types instances instance GEnum () where genum = genumDefault instance (GEnum a, GEnum b) => GEnum (a, b) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f) => GEnum (a, b, c, d, e, f) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g) => GEnum (a, b, c, d, e, f, g) where genum = genumDefault instance GEnum a => GEnum [a] where genum = genumDefault instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where genum = genumDefault instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where genum = genumDefault instance GEnum (f (g p)) => GEnum ((f :.: g) p) where genum = genumDefault instance GEnum All where genum = genumDefault #if MIN_VERSION_base(4,8,0) instance GEnum (f a) => GEnum (Alt f a) where genum = genumDefault #endif instance GEnum Any where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance (GEnum a, GEnum b) => GEnum (Arg a b) where genum = genumDefault #endif #if !(MIN_VERSION_base(4,9,0)) instance GEnum Arity where genum = genumDefault #endif instance GEnum Associativity where genum = genumDefault instance GEnum Bool where genum = genumDefault #if defined(HTYPE_CC_T) instance GEnum CCc where genum = coerce (genum :: [HTYPE_CC_T]) #endif instance GEnum CChar where genum = coerce (genum :: [HTYPE_CHAR]) instance GEnum CClock where genum = coerce (genum :: [HTYPE_CLOCK_T]) #if defined(HTYPE_DEV_T) instance GEnum CDev where genum = coerce (genum :: [HTYPE_DEV_T]) #endif instance GEnum CDouble where genum = coerce (genum :: [HTYPE_DOUBLE]) instance GEnum CFloat where genum = coerce (genum :: [HTYPE_FLOAT]) #if defined(HTYPE_GID_T) instance GEnum CGid where genum = coerce (genum :: [HTYPE_GID_T]) #endif #if defined(HTYPE_INO_T) instance GEnum CIno where genum = coerce (genum :: [HTYPE_INO_T]) #endif instance GEnum CInt where genum = coerce (genum :: [HTYPE_INT]) instance GEnum CIntMax where genum = coerce (genum :: [HTYPE_INTMAX_T]) instance GEnum CIntPtr where genum = coerce (genum :: [HTYPE_INTPTR_T]) instance GEnum CLLong where genum = coerce (genum :: [HTYPE_LONG_LONG]) instance GEnum CLong where genum = coerce (genum :: [HTYPE_LONG]) #if defined(HTYPE_MODE_T) instance GEnum CMode where genum = coerce (genum :: [HTYPE_MODE_T]) #endif #if defined(HTYPE_NLINK_T) instance GEnum CNlink where genum = coerce (genum :: [HTYPE_NLINK_T]) #endif #if defined(HTYPE_OFF_T) instance GEnum COff where genum = coerce (genum :: [HTYPE_OFF_T]) #endif #if MIN_VERSION_base(4,4,0) instance GEnum a => GEnum (Complex a) where genum = genumDefault #endif instance GEnum a => GEnum (Const a b) where genum = genumDefault #if defined(HTYPE_PID_T) instance GEnum CPid where genum = coerce (genum :: [HTYPE_PID_T]) #endif instance GEnum CPtrdiff where genum = coerce (genum :: [HTYPE_PTRDIFF_T]) #if defined(HTYPE_RLIM_T) instance GEnum CRLim where genum = coerce (genum :: [HTYPE_RLIM_T]) #endif instance GEnum CSChar where genum = coerce (genum :: [HTYPE_SIGNED_CHAR]) #if defined(HTYPE_SPEED_T) instance GEnum CSpeed where genum = coerce (genum :: [HTYPE_SPEED_T]) #endif #if MIN_VERSION_base(4,4,0) instance GEnum CSUSeconds where genum = coerce (genum :: [HTYPE_SUSECONDS_T]) #endif instance GEnum CShort where genum = coerce (genum :: [HTYPE_SHORT]) instance GEnum CSigAtomic where #if defined(HTYPE_SIG_ATOMIC_T) genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T]) #else genum = coerce (genum :: [Int32]) #endif instance GEnum CSize where genum = coerce (genum :: [HTYPE_SIZE_T]) #if defined(HTYPE_SSIZE_T) instance GEnum CSsize where genum = coerce (genum :: [HTYPE_SSIZE_T]) #endif #if defined(HTYPE_TCFLAG_T) instance GEnum CTcflag where genum = coerce (genum :: [HTYPE_TCFLAG_T]) #endif instance GEnum CTime where genum = coerce (genum :: [HTYPE_TIME_T]) instance GEnum CUChar where genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR]) #if defined(HTYPE_UID_T) instance GEnum CUid where genum = coerce (genum :: [HTYPE_UID_T]) #endif instance GEnum CUInt where genum = coerce (genum :: [HTYPE_UNSIGNED_INT]) instance GEnum CUIntMax where genum = coerce (genum :: [HTYPE_UINTMAX_T]) instance GEnum CUIntPtr where genum = coerce (genum :: [HTYPE_UINTPTR_T]) instance GEnum CULLong where genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG]) instance GEnum CULong where genum = coerce (genum :: [HTYPE_UNSIGNED_LONG]) #if MIN_VERSION_base(4,4,0) instance GEnum CUSeconds where genum = coerce (genum :: [HTYPE_USECONDS_T]) #endif instance GEnum CUShort where genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT]) instance GEnum CWchar where genum = coerce (genum :: [HTYPE_WCHAR_T]) instance GEnum Double where genum = genumNumUnbounded instance GEnum a => GEnum (Dual a) where genum = genumDefault instance (GEnum a, GEnum b) => GEnum (Either a b) where genum = genumDefault instance GEnum ExitCode where genum = genumDefault instance GEnum Fd where genum = coerce (genum :: [CInt]) instance GEnum a => GEnum (Monoid.First a) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Semigroup.First a) where genum = genumDefault #endif instance GEnum Fixity where genum = genumDefault instance GEnum Float where genum = genumNumUnbounded #if MIN_VERSION_base(4,8,0) instance GEnum a => GEnum (Identity a) where genum = genumDefault #endif instance GEnum Int where genum = genumNumSigned instance GEnum Int8 where genum = genumNumSigned instance GEnum Int16 where genum = genumNumSigned instance GEnum Int32 where genum = genumNumSigned instance GEnum Int64 where genum = genumNumSigned instance GEnum Integer where genum = genumNumUnbounded instance GEnum IntPtr where genum = genumNumSigned instance GEnum c => GEnum (K1 i c p) where genum = genumDefault instance GEnum a => GEnum (Monoid.Last a) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Semigroup.Last a) where genum = genumDefault #endif instance GEnum (f p) => GEnum (M1 i c f p) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Max a) where genum = genumDefault #endif instance GEnum a => GEnum (Maybe a) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Min a) where genum = genumDefault #endif #if MIN_VERSION_base(4,8,0) instance GEnum Natural where genum = genumNumUnsigned #endif #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (NonEmpty a) where genum = genumDefault #endif instance GEnum Ordering where genum = genumDefault instance GEnum p => GEnum (Par1 p) where genum = genumDefault instance GEnum a => GEnum (Product a) where genum = genumDefault #if MIN_VERSION_base(4,7,0) instance GEnum # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where genum = genumDefault #endif instance GEnum (f p) => GEnum (Rec1 f p) where genum = genumDefault instance GEnum a => GEnum (Sum a) where genum = genumDefault instance GEnum (U1 p) where genum = genumDefault instance GEnum Word where genum = genumNumUnsigned instance GEnum Word8 where genum = genumNumUnsigned instance GEnum Word16 where genum = genumNumUnsigned instance GEnum Word32 where genum = genumNumUnsigned instance GEnum Word64 where genum = genumNumUnsigned instance GEnum WordPtr where genum = genumNumUnsigned #if MIN_VERSION_base(4,9,0) instance GEnum m => GEnum (WrappedMonoid m) where genum = genumDefault #endif instance GEnum a => GEnum (ZipList a) where genum = genumDefault #if MIN_VERSION_base(4,10,0) instance GEnum CBool where genum = coerce (genum :: [HTYPE_BOOL]) # if defined(HTYPE_BLKSIZE_T) instance GEnum CBlkSize where genum = coerce (genum :: [HTYPE_BLKSIZE_T]) # endif # if defined(HTYPE_BLKCNT_T) instance GEnum CBlkCnt where genum = coerce (genum :: [HTYPE_BLKCNT_T]) # endif # if defined(HTYPE_CLOCKID_T) instance GEnum CClockId where genum = coerce (genum :: [HTYPE_CLOCKID_T]) # endif # if defined(HTYPE_FSBLKCNT_T) instance GEnum CFsBlkCnt where genum = coerce (genum :: [HTYPE_FSBLKCNT_T]) # endif # if defined(HTYPE_FSFILCNT_T) instance GEnum CFsFilCnt where genum = coerce (genum :: [HTYPE_FSFILCNT_T]) # endif # if defined(HTYPE_ID_T) instance GEnum CId where genum = coerce (genum :: [HTYPE_ID_T]) # endif # if defined(HTYPE_KEY_T) instance GEnum CKey where genum = coerce (genum :: [HTYPE_KEY_T]) # endif #endif -------------------------------------------------------------------------------- -- Generic Ix -------------------------------------------------------------------------------- -- Minimal complete instance: 'range', 'index' and 'inRange'. class (Ord a) => GIx a where -- | The list of values in the subrange defined by a bounding pair. range :: (a,a) -> [a] -- | The position of a subscript in the subrange. index :: (a,a) -> a -> Int -- | Returns 'True' the given subscript lies in the range defined -- the bounding pair. inRange :: (a,a) -> a -> Bool #if __GLASGOW_HASKELL__ >= 701 default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] range = rangeDefault default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int index = indexDefault default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool inRange = inRangeDefault #endif rangeDefault :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] rangeDefault = t (map to enum') where t l (x,y) = case (findIndex (geq x) l, findIndex (geq y) l) of (Nothing, _) -> error "rangeDefault: no corresponding index" (_, Nothing) -> error "rangeDefault: no corresponding index" (Just i, Just j) -> take (j-i) (drop i l) indexDefault :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int indexDefault = t (map to enum') where t l (x,y) z = case (findIndex (geq x) l, findIndex (geq y) l) of (Nothing, _) -> error "indexDefault: no corresponding index" (_, Nothing) -> error "indexDefault: no corresponding index" (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of Nothing -> error "indexDefault: index out of range" Just k -> k inRangeDefault :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool inRangeDefault = t (map to enum') where t l (x,y) z = case (findIndex (geq x) l, findIndex (geq y) l) of (Nothing, _) -> error "indexDefault: no corresponding index" (_, Nothing) -> error "indexDefault: no corresponding index" (Just i, Just j) -> maybe False (const True) (findIndex (geq z) (take (j-i) (drop i l))) rangeEnum :: Enum a => (a, a) -> [a] rangeEnum (m,n) = [m..n] indexIntegral :: Integral a => (a, a) -> a -> Int indexIntegral (m,_n) i = fromIntegral (i - m) inRangeOrd :: Ord a => (a, a) -> a -> Bool inRangeOrd (m,n) i = m <= i && i <= n -- Base types instances instance GIx () where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c) => GIx (a, b, c) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d) => GIx (a, b, c, d) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e) => GIx (a, b, c, d, e) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f) => GIx (a, b, c, d, e, f) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f, GEq g, GEnum g, GIx g) => GIx (a, b, c, d, e, f, g) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx [a] where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx All where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,8,0) instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Any where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if !(MIN_VERSION_base(4,9,0)) instance GIx Arity where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Associativity where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Bool where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx CChar where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_GID_T) instance GIx CGid where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_INO_T) instance GIx CIno where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CInt where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CIntMax where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CIntPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CLLong where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CLong where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_MODE_T) instance GIx CMode where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_NLINK_T) instance GIx CNlink where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_OFF_T) instance GIx COff where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_PID_T) instance GIx CPid where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CPtrdiff where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_RLIM_T) instance GIx CRLim where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CSChar where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CShort where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CSigAtomic where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CSize where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_SSIZE_T) instance GIx CSsize where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_TCFLAG_T) instance GIx CTcflag where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CUChar where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_UID_T) instance GIx CUid where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CUInt where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CUIntMax where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CUIntPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CULLong where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CULong where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CUShort where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CWchar where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx ExitCode where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Fd where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Fixity where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,8,0) instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Int where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int8 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int16 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int32 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int64 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Integer where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx IntPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Max a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Min a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if MIN_VERSION_base(4,8,0) instance GIx Natural where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Ordering where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx (Product a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,7,0) instance GIx # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Word where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word8 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word16 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word32 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word64 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx WordPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if MIN_VERSION_base(4,9,0) instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if MIN_VERSION_base(4,10,0) instance GIx CBool where range = rangeEnum index = indexIntegral inRange = inRangeOrd # if defined(HTYPE_BLKSIZE_T) instance GIx CBlkSize where range = rangeEnum index = indexIntegral inRange = inRangeOrd # endif # if defined(HTYPE_BLKCNT_T) instance GIx CBlkCnt where range = rangeEnum index = indexIntegral inRange = inRangeOrd # endif # if defined(HTYPE_CLOCKID_T) instance GIx CClockId where range = rangeEnum index = indexIntegral inRange = inRangeOrd # endif # if defined(HTYPE_FSBLKCNT_T) instance GIx CFsBlkCnt where range = rangeEnum index = indexIntegral inRange = inRangeOrd # endif # if defined(HTYPE_FSFILCNT_T) instance GIx CFsFilCnt where range = rangeEnum index = indexIntegral inRange = inRangeOrd # endif # if defined(HTYPE_ID_T) instance GIx CId where range = rangeEnum index = indexIntegral inRange = inRangeOrd # endif # if defined(HTYPE_KEY_T) instance GIx CKey where range = rangeEnum index = indexIntegral inRange = inRangeOrd # endif #endif generic-deriving-1.14.5/src/Generics/Deriving/Eq.hs0000644000000000000000000002650107346545000020216 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MagicHash #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #include "HsBaseConfig.h" module Generics.Deriving.Eq ( -- * Generic Eq class GEq(..) -- * Default definition , geqdefault -- * Internal Eq class , GEq'(..) ) where import Control.Applicative (Const, ZipList) import Data.Char (GeneralCategory) import Data.Int import qualified Data.Monoid as Monoid (First, Last) import Data.Monoid (All, Any, Dual, Product, Sum) import Data.Version (Version) import Data.Word import Foreign.C.Error import Foreign.C.Types import Foreign.ForeignPtr (ForeignPtr) import Foreign.Ptr import Foreign.StablePtr (StablePtr) import Generics.Deriving.Base import GHC.Exts hiding (Any) import System.Exit (ExitCode) import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) import System.IO.Error (IOErrorType) import System.Posix.Types #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) import Data.Void (Void) import Numeric.Natural (Natural) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg(..), Max, Min, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic show -------------------------------------------------------------------------------- class GEq' f where geq' :: f a -> f a -> Bool instance GEq' V1 where geq' _ _ = True instance GEq' U1 where geq' _ _ = True instance (GEq c) => GEq' (K1 i c) where geq' (K1 a) (K1 b) = geq a b -- No instances for P or Rec because geq is only applicable to types of kind * instance (GEq' a) => GEq' (M1 i c a) where geq' (M1 a) (M1 b) = geq' a b instance (GEq' a, GEq' b) => GEq' (a :+: b) where geq' (L1 a) (L1 b) = geq' a b geq' (R1 a) (R1 b) = geq' a b geq' _ _ = False instance (GEq' a, GEq' b) => GEq' (a :*: b) where geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2 -- Unboxed types instance GEq' UAddr where geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2) instance GEq' UChar where geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2) instance GEq' UDouble where geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2) instance GEq' UFloat where geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2) instance GEq' UInt where geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2) instance GEq' UWord where geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) #if !(MIN_VERSION_base(4,7,0)) isTrue# :: Bool -> Bool isTrue# = id #endif class GEq a where geq :: a -> a -> Bool #if __GLASGOW_HASKELL__ >= 701 default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool geq = geqdefault #endif geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool geqdefault x y = geq' (from x) (from y) -- Base types instances instance GEq () where geq = geqdefault instance (GEq a, GEq b) => GEq (a, b) where geq = geqdefault instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f) => GEq (a, b, c, d, e, f) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g) => GEq (a, b, c, d, e, f, g) where geq = geqdefault instance GEq a => GEq [a] where geq = geqdefault instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where geq = geqdefault instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where geq = geqdefault instance GEq (f (g p)) => GEq ((f :.: g) p) where geq = geqdefault instance GEq All where geq = geqdefault #if MIN_VERSION_base(4,8,0) instance GEq (f a) => GEq (Alt f a) where geq = geqdefault #endif instance GEq Any where geq = geqdefault #if !(MIN_VERSION_base(4,9,0)) instance GEq Arity where geq = geqdefault #endif #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Arg a b) where geq (Arg a _) (Arg b _) = geq a b #endif instance GEq Associativity where geq = geqdefault instance GEq Bool where geq = geqdefault instance GEq BufferMode where geq = (==) #if defined(HTYPE_CC_T) instance GEq CCc where geq = (==) #endif instance GEq CChar where geq = (==) instance GEq CClock where geq = (==) #if defined(HTYPE_DEV_T) instance GEq CDev where geq = (==) #endif instance GEq CDouble where geq = (==) instance GEq CFloat where geq = (==) #if defined(HTYPE_GID_T) instance GEq CGid where geq = (==) #endif instance GEq Char where geq = (==) #if defined(HTYPE_INO_T) instance GEq CIno where geq = (==) #endif instance GEq CInt where geq = (==) instance GEq CIntMax where geq = (==) instance GEq CIntPtr where geq = (==) instance GEq CLLong where geq = (==) instance GEq CLong where geq = (==) #if defined(HTYPE_MODE_T) instance GEq CMode where geq = (==) #endif #if defined(HTYPE_NLINK_T) instance GEq CNlink where geq = (==) #endif #if defined(HTYPE_OFF_T) instance GEq COff where geq = (==) #endif #if MIN_VERSION_base(4,4,0) instance GEq a => GEq (Complex a) where geq = geqdefault #endif instance GEq a => GEq (Const a b) where geq = geqdefault #if defined(HTYPE_PID_T) instance GEq CPid where geq = (==) #endif instance GEq CPtrdiff where geq = (==) #if defined(HTYPE_RLIM_T) instance GEq CRLim where geq = (==) #endif instance GEq CSChar where geq = (==) #if defined(HTYPE_SPEED_T) instance GEq CSpeed where geq = (==) #endif #if MIN_VERSION_base(4,4,0) instance GEq CSUSeconds where geq = (==) #endif instance GEq CShort where geq = (==) instance GEq CSigAtomic where geq = (==) instance GEq CSize where geq = (==) #if defined(HTYPE_SSIZE_T) instance GEq CSsize where geq = (==) #endif #if defined(HTYPE_TCFLAG_T) instance GEq CTcflag where geq = (==) #endif instance GEq CTime where geq = (==) instance GEq CUChar where geq = (==) #if defined(HTYPE_UID_T) instance GEq CUid where geq = (==) #endif instance GEq CUInt where geq = (==) instance GEq CUIntMax where geq = (==) instance GEq CUIntPtr where geq = (==) instance GEq CULLong where geq = (==) instance GEq CULong where geq = (==) #if MIN_VERSION_base(4,4,0) instance GEq CUSeconds where geq = (==) #endif instance GEq CUShort where geq = (==) instance GEq CWchar where geq = (==) #if MIN_VERSION_base(4,9,0) instance GEq DecidedStrictness where geq = geqdefault #endif instance GEq Double where geq = (==) instance GEq a => GEq (Down a) where geq = geqdefault instance GEq a => GEq (Dual a) where geq = geqdefault instance (GEq a, GEq b) => GEq (Either a b) where geq = geqdefault instance GEq Errno where geq = (==) instance GEq ExitCode where geq = geqdefault instance GEq Fd where geq = (==) instance GEq a => GEq (Monoid.First a) where geq = geqdefault #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Semigroup.First a) where geq = geqdefault #endif instance GEq Fixity where geq = geqdefault instance GEq Float where geq = (==) instance GEq (ForeignPtr a) where geq = (==) instance GEq (FunPtr a) where geq = (==) instance GEq GeneralCategory where geq = (==) instance GEq Handle where geq = (==) instance GEq HandlePosn where geq = (==) #if MIN_VERSION_base(4,8,0) instance GEq a => GEq (Identity a) where geq = geqdefault #endif instance GEq Int where geq = (==) instance GEq Int8 where geq = (==) instance GEq Int16 where geq = (==) instance GEq Int32 where geq = (==) instance GEq Int64 where geq = (==) instance GEq Integer where geq = (==) instance GEq IntPtr where geq = (==) instance GEq IOError where geq = (==) instance GEq IOErrorType where geq = (==) instance GEq IOMode where geq = (==) instance GEq c => GEq (K1 i c p) where geq = geqdefault instance GEq a => GEq (Monoid.Last a) where geq = geqdefault #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Semigroup.Last a) where geq = geqdefault #endif instance GEq (f p) => GEq (M1 i c f p) where geq = geqdefault instance GEq a => GEq (Maybe a) where geq = geqdefault #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Max a) where geq = geqdefault instance GEq a => GEq (Min a) where geq = geqdefault #endif #if MIN_VERSION_base(4,8,0) instance GEq Natural where geq = (==) #endif #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (NonEmpty a) where geq = geqdefault #endif instance GEq Ordering where geq = geqdefault instance GEq p => GEq (Par1 p) where geq = geqdefault instance GEq a => GEq (Product a) where geq = geqdefault #if MIN_VERSION_base(4,7,0) instance GEq # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where geq = geqdefault #endif instance GEq (Ptr a) where geq = (==) instance GEq (f p) => GEq (Rec1 f p) where geq = geqdefault instance GEq SeekMode where geq = (==) instance GEq (StablePtr a) where geq = (==) #if MIN_VERSION_base(4,9,0) instance GEq SourceStrictness where geq = geqdefault instance GEq SourceUnpackedness where geq = geqdefault #endif instance GEq a => GEq (Sum a) where geq = geqdefault instance GEq (U1 p) where geq = geqdefault instance GEq (UAddr p) where geq = geqdefault instance GEq (UChar p) where geq = geqdefault instance GEq (UDouble p) where geq = geqdefault instance GEq (UFloat p) where geq = geqdefault instance GEq (UInt p) where geq = geqdefault instance GEq (UWord p) where geq = geqdefault instance GEq Version where geq = (==) #if MIN_VERSION_base(4,8,0) instance GEq Void where geq = (==) #endif instance GEq Word where geq = (==) instance GEq Word8 where geq = (==) instance GEq Word16 where geq = (==) instance GEq Word32 where geq = (==) instance GEq Word64 where geq = (==) instance GEq WordPtr where geq = (==) #if MIN_VERSION_base(4,9,0) instance GEq m => GEq (WrappedMonoid m) where geq = geqdefault #endif instance GEq a => GEq (ZipList a) where geq = geqdefault #if MIN_VERSION_base(4,10,0) instance GEq CBool where geq = (==) # if defined(HTYPE_BLKSIZE_T) instance GEq CBlkSize where geq = (==) # endif # if defined(HTYPE_BLKCNT_T) instance GEq CBlkCnt where geq = (==) # endif # if defined(HTYPE_CLOCKID_T) instance GEq CClockId where geq = (==) # endif # if defined(HTYPE_FSBLKCNT_T) instance GEq CFsBlkCnt where geq = (==) # endif # if defined(HTYPE_FSFILCNT_T) instance GEq CFsFilCnt where geq = (==) # endif # if defined(HTYPE_ID_T) instance GEq CId where geq = (==) # endif # if defined(HTYPE_KEY_T) instance GEq CKey where geq = (==) # endif # if defined(HTYPE_TIMER_T) instance GEq CTimer where geq = (==) # endif #endif generic-deriving-1.14.5/src/Generics/Deriving/Foldable.hs0000644000000000000000000001761207346545000021364 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Foldable ( -- * Generic Foldable class GFoldable(..) -- * Default method , gfoldMapdefault -- * Derived functions , gtoList , gconcat , gconcatMap , gand , gor , gany , gall , gsum , gproduct , gmaximum , gmaximumBy , gminimum , gminimumBy , gelem , gnotElem , gfind -- * Internal Foldable class , GFoldable'(..) ) where import Control.Applicative (Const, ZipList) import Data.Maybe import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..)) import Data.Monoid (All(..), Any(..), Dual(..), Endo(..)) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) #endif import Generics.Deriving.Base #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down) #else import GHC.Exts (Down) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic fold -------------------------------------------------------------------------------- class GFoldable' t where gfoldMap' :: Monoid m => (a -> m) -> t a -> m instance GFoldable' V1 where gfoldMap' _ _ = mempty instance GFoldable' U1 where gfoldMap' _ U1 = mempty instance GFoldable' Par1 where gfoldMap' f (Par1 a) = f a instance GFoldable' (K1 i c) where gfoldMap' _ (K1 _) = mempty instance (GFoldable f) => GFoldable' (Rec1 f) where gfoldMap' f (Rec1 a) = gfoldMap f a instance (GFoldable' f) => GFoldable' (M1 i c f) where gfoldMap' f (M1 a) = gfoldMap' f a instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where gfoldMap' f (L1 a) = gfoldMap' f a gfoldMap' f (R1 a) = gfoldMap' f a instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b) instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x instance GFoldable' UAddr where gfoldMap' _ (UAddr _) = mempty instance GFoldable' UChar where gfoldMap' _ (UChar _) = mempty instance GFoldable' UDouble where gfoldMap' _ (UDouble _) = mempty instance GFoldable' UFloat where gfoldMap' _ (UFloat _) = mempty instance GFoldable' UInt where gfoldMap' _ (UInt _) = mempty instance GFoldable' UWord where gfoldMap' _ (UWord _) = mempty class GFoldable t where gfoldMap :: Monoid m => (a -> m) -> t a -> m #if __GLASGOW_HASKELL__ >= 701 default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) => (a -> m) -> t a -> m gfoldMap = gfoldMapdefault #endif gfold :: Monoid m => t m -> m gfold = gfoldMap id gfoldr :: (a -> b -> b) -> b -> t a -> b gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z gfoldr' :: (a -> b -> b) -> b -> t a -> b gfoldr' f z0 xs = gfoldl f' id xs z0 where f' k x z = k $! f x z gfoldl :: (a -> b -> a) -> a -> t b -> a gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z gfoldl' :: (a -> b -> a) -> a -> t b -> a gfoldl' f z0 xs = gfoldr f' id xs z0 where f' x k z = k $! f z x gfoldr1 :: (a -> a -> a) -> t a -> a gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure") (gfoldr mf Nothing xs) where mf x Nothing = Just x mf x (Just y) = Just (f x y) gfoldl1 :: (a -> a -> a) -> t a -> a gfoldl1 f xs = fromMaybe (error "foldl1: empty structure") (gfoldl mf Nothing xs) where mf Nothing y = Just y mf (Just x) y = Just (f x y) gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) => (a -> m) -> t a -> m gfoldMapdefault f x = gfoldMap' f (from1 x) -- Base types instances instance GFoldable ((,) a) where gfoldMap = gfoldMapdefault instance GFoldable [] where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable (Arg a) where gfoldMap = gfoldMapdefault #endif #if MIN_VERSION_base(4,4,0) instance GFoldable Complex where gfoldMap = gfoldMapdefault #endif instance GFoldable (Const m) where gfoldMap = gfoldMapdefault instance GFoldable Down where gfoldMap = gfoldMapdefault instance GFoldable Dual where gfoldMap = gfoldMapdefault instance GFoldable (Either a) where gfoldMap = gfoldMapdefault instance GFoldable Monoid.First where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable (Semigroup.First) where gfoldMap = gfoldMapdefault #endif #if MIN_VERSION_base(4,8,0) instance GFoldable Identity where gfoldMap = gfoldMapdefault #endif instance GFoldable Monoid.Last where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable Semigroup.Last where gfoldMap = gfoldMapdefault instance GFoldable Max where gfoldMap = gfoldMapdefault #endif instance GFoldable Maybe where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable Min where gfoldMap = gfoldMapdefault instance GFoldable NonEmpty where gfoldMap = gfoldMapdefault #endif instance GFoldable Monoid.Product where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where gfoldMap = gfoldMapdefault #endif #if MIN_VERSION_base(4,7,0) instance GFoldable Proxy where gfoldMap = gfoldMapdefault #endif instance GFoldable Monoid.Sum where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where gfoldMap = gfoldMapdefault instance GFoldable WrappedMonoid where gfoldMap = gfoldMapdefault #endif instance GFoldable ZipList where gfoldMap = gfoldMapdefault gtoList :: GFoldable t => t a -> [a] gtoList = gfoldr (:) [] gconcat :: GFoldable t => t [a] -> [a] gconcat = gfold gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b] gconcatMap = gfoldMap gand :: GFoldable t => t Bool -> Bool gand = getAll . gfoldMap All gor :: GFoldable t => t Bool -> Bool gor = getAny . gfoldMap Any gany :: GFoldable t => (a -> Bool) -> t a -> Bool gany p = getAny . gfoldMap (Any . p) gall :: GFoldable t => (a -> Bool) -> t a -> Bool gall p = getAll . gfoldMap (All . p) gsum :: (GFoldable t, Num a) => t a -> a gsum = Monoid.getSum . gfoldMap Monoid.Sum gproduct :: (GFoldable t, Num a) => t a -> a gproduct = Monoid.getProduct . gfoldMap Monoid.Product gmaximum :: (GFoldable t, Ord a) => t a -> a gmaximum = gfoldr1 max gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a gmaximumBy cmp = gfoldr1 max' where max' x y = case cmp x y of GT -> x _ -> y gminimum :: (GFoldable t, Ord a) => t a -> a gminimum = gfoldr1 min gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a gminimumBy cmp = gfoldr1 min' where min' x y = case cmp x y of GT -> y _ -> x gelem :: (GFoldable t, Eq a) => a -> t a -> Bool gelem = gany . (==) gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool gnotElem x = not . gelem x gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else []) generic-deriving-1.14.5/src/Generics/Deriving/Functor.hs0000644000000000000000000001232507346545000021270 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Functor ( -- * Generic Functor class GFunctor(..) -- * Default method , gmapdefault -- * Internal Functor class , GFunctor'(..) ) where import Control.Applicative (Const, ZipList) import qualified Data.Monoid as Monoid (First, Last, Product, Sum) import Data.Monoid (Dual) import Generics.Deriving.Base #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down) #else import GHC.Exts (Down) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic fmap -------------------------------------------------------------------------------- class GFunctor' f where gmap' :: (a -> b) -> f a -> f b instance GFunctor' V1 where gmap' _ x = case x of #if __GLASGOW_HASKELL__ >= 708 {} #else !_ -> error "Void gmap" #endif instance GFunctor' U1 where gmap' _ U1 = U1 instance GFunctor' Par1 where gmap' f (Par1 a) = Par1 (f a) instance GFunctor' (K1 i c) where gmap' _ (K1 a) = K1 a instance (GFunctor f) => GFunctor' (Rec1 f) where gmap' f (Rec1 a) = Rec1 (gmap f a) instance (GFunctor' f) => GFunctor' (M1 i c f) where gmap' f (M1 a) = M1 (gmap' f a) instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where gmap' f (L1 a) = L1 (gmap' f a) gmap' f (R1 a) = R1 (gmap' f a) instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where gmap' f (a :*: b) = gmap' f a :*: gmap' f b instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x) instance GFunctor' UAddr where gmap' _ (UAddr a) = UAddr a instance GFunctor' UChar where gmap' _ (UChar c) = UChar c instance GFunctor' UDouble where gmap' _ (UDouble d) = UDouble d instance GFunctor' UFloat where gmap' _ (UFloat f) = UFloat f instance GFunctor' UInt where gmap' _ (UInt i) = UInt i instance GFunctor' UWord where gmap' _ (UWord w) = UWord w class GFunctor f where gmap :: (a -> b) -> f a -> f b #if __GLASGOW_HASKELL__ >= 701 default gmap :: (Generic1 f, GFunctor' (Rep1 f)) => (a -> b) -> f a -> f b gmap = gmapdefault #endif gmapdefault :: (Generic1 f, GFunctor' (Rep1 f)) => (a -> b) -> f a -> f b gmapdefault f = to1 . gmap' f . from1 -- Base types instances instance GFunctor ((->) r) where gmap = fmap instance GFunctor ((,) a) where gmap = gmapdefault instance GFunctor [] where gmap = gmapdefault #if MIN_VERSION_base(4,8,0) instance GFunctor f => GFunctor (Alt f) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,9,0) instance GFunctor (Arg a) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,4,0) instance GFunctor Complex where gmap = gmapdefault #endif instance GFunctor (Const m) where gmap = gmapdefault instance GFunctor Down where gmap = gmapdefault instance GFunctor Dual where gmap = gmapdefault instance GFunctor (Either a) where gmap = gmapdefault instance GFunctor Monoid.First where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance GFunctor (Semigroup.First) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,8,0) instance GFunctor Identity where gmap = gmapdefault #endif instance GFunctor IO where gmap = fmap instance GFunctor Monoid.Last where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance GFunctor Semigroup.Last where gmap = gmapdefault instance GFunctor Max where gmap = gmapdefault #endif instance GFunctor Maybe where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance GFunctor Min where gmap = gmapdefault instance GFunctor NonEmpty where gmap = gmapdefault #endif instance GFunctor Monoid.Product where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,7,0) instance GFunctor Proxy where gmap = gmapdefault #endif instance GFunctor Monoid.Sum where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where gmap = gmapdefault instance GFunctor WrappedMonoid where gmap = gmapdefault #endif instance GFunctor ZipList where gmap = gmapdefault generic-deriving-1.14.5/src/Generics/Deriving/Instances.hs0000644000000000000000000046375707346545000021622 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} module Generics.Deriving.Instances ( -- Only instances from Generics.Deriving.Base -- and the Generic1 instances #if !(MIN_VERSION_base(4,16,0)) Rep0Tuple8 , Rep0Tuple9 , Rep0Tuple10 , Rep0Tuple11 , Rep0Tuple12 , Rep0Tuple13 , Rep0Tuple14 , Rep0Tuple15 , Rep1Tuple8 , Rep1Tuple9 , Rep1Tuple10 , Rep1Tuple11 , Rep1Tuple12 , Rep1Tuple13 , Rep1Tuple14 , Rep1Tuple15 #endif #if !(MIN_VERSION_base(4,14,0)) , Rep0Kleisli , Rep1Kleisli #endif #if !(MIN_VERSION_base(4,12,0)) , Rep0Down , Rep1Down #endif #if !(MIN_VERSION_base(4,9,0)) , Rep0ExitCode , Rep0Version , Rep1ConSum , Rep1ConProduct , Rep1ConCompose , Rep1K1 , Rep1M1 , Rep1Par1 , Rep1Rec1 , Rep1U1 , Rep0V1 , Rep1V1 , Rep0UAddr , Rep1UAddr , Rep0UChar , Rep1UChar , Rep0UDouble , Rep1UDouble , Rep0UFloat , Rep1UFloat , Rep0UInt , Rep1UInt , Rep0UWord , Rep1UWord # if MIN_VERSION_base(4,4,0) , Rep0Complex , Rep1Complex # endif # if MIN_VERSION_base(4,7,0) , Rep1Proxy # endif #endif #if !(MIN_VERSION_base(4,7,0)) , Rep0All , Rep0Any , Rep0Arity , Rep0Associativity , Rep0Const , Rep1Const , Rep0Dual , Rep1Dual , Rep0Endo , Rep0First , Rep1First , Rep0Fixity , Rep0Last , Rep1Last , Rep0Product , Rep1Product , Rep0Sum , Rep1Sum , Rep0WrappedArrow , Rep1WrappedArrow , Rep0WrappedMonad , Rep1WrappedMonad , Rep0ZipList , Rep1ZipList , Rep0U1 , Rep0Par1 , Rep0Rec1 , Rep0K1 , Rep0M1 , Rep0ConSum , Rep0ConProduct , Rep0ConCompose #endif #if !(MIN_VERSION_base(4,6,0)) , Rep1Either , Rep1List , Rep1Maybe , Rep1Tuple2 , Rep1Tuple3 , Rep1Tuple4 , Rep1Tuple5 , Rep1Tuple6 , Rep1Tuple7 #endif #if !(MIN_VERSION_base(4,4,0)) , Rep0Bool , Rep0Char , Rep0Double , Rep0Either , Rep0Int , Rep0Float , Rep0List , Rep0Maybe , Rep0Ordering , Rep0Tuple2 , Rep0Tuple3 , Rep0Tuple4 , Rep0Tuple5 , Rep0Tuple6 , Rep0Tuple7 , Rep0Unit #endif ) where #if !(MIN_VERSION_base(4,7,0)) import Control.Applicative import Data.Monoid #endif #if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,9,0)) import Data.Complex (Complex(..)) #endif #if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,9,0)) import Data.Proxy (Proxy(..)) #endif #if !(MIN_VERSION_base(4,9,0)) import Data.Version (Version(..)) import System.Exit (ExitCode(..)) #endif #if !(MIN_VERSION_base(4,12,0)) # if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) # else import GHC.Exts (Down(..)) # endif #endif #if !(MIN_VERSION_base(4,14,0)) import Control.Arrow (Kleisli(..)) #endif #if !(MIN_VERSION_base(4,16,0)) import Generics.Deriving.Base.Internal #endif #if !(MIN_VERSION_base(4,16,0)) # if MIN_VERSION_base(4,6,0) type Rep0Tuple8 a b c d e f g h = Rep (a, b, c, d, e, f, g, h) type Rep0Tuple9 a b c d e f g h i = Rep (a, b, c, d, e, f, g, h, i) type Rep0Tuple10 a b c d e f g h i j = Rep (a, b, c, d, e, f, g, h, i, j) type Rep0Tuple11 a b c d e f g h i j k = Rep (a, b, c, d, e, f, g, h, i, j, k) type Rep0Tuple12 a b c d e f g h i j k l = Rep (a, b, c, d, e, f, g, h, i, j, k, l) type Rep0Tuple13 a b c d e f g h i j k l m = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m) type Rep0Tuple14 a b c d e f g h i j k l m n = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n) type Rep0Tuple15 a b c d e f g h i j k l m n o = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) type Rep1Tuple8 a b c d e f g = Rep1 ((,,,,,,,) a b c d e f g) type Rep1Tuple9 a b c d e f g h = Rep1 ((,,,,,,,,) a b c d e f g h) type Rep1Tuple10 a b c d e f g h i = Rep1 ((,,,,,,,,,) a b c d e f g h i) type Rep1Tuple11 a b c d e f g h i j = Rep1 ((,,,,,,,,,,) a b c d e f g h i j) type Rep1Tuple12 a b c d e f g h i j k = Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k) type Rep1Tuple13 a b c d e f g h i j k l = Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) type Rep1Tuple14 a b c d e f g h i j k l m = Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) type Rep1Tuple15 a b c d e f g h i j k l m n = Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) deriving instance Generic (a, b, c, d, e, f, g, h) deriving instance Generic (a, b, c, d, e, f, g, h, i) deriving instance Generic (a, b, c, d, e, f, g, h, i, j) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) deriving instance Generic1 ((,,,,,,,) a b c d e f g) deriving instance Generic1 ((,,,,,,,,) a b c d e f g h) deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i) deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j) deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k) deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) # else type Rep0Tuple8 a b c d e f g h = D1 D1Tuple8 (C1 C1_0Tuple8 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: S1 NoSelector (Rec0 d))) :*: ((S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)) :*: (S1 NoSelector (Rec0 g) :*: S1 NoSelector (Rec0 h))))) type Rep1Tuple8 a b c d e f g = D1 D1Tuple8 (C1 C1_0Tuple8 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: S1 NoSelector (Rec0 d))) :*: ((S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)) :*: (S1 NoSelector (Rec0 g) :*: S1 NoSelector Par1)))) instance Generic (a, b, c, d, e, f, g, h) where type Rep (a, b, c, d, e, f, g, h) = Rep0Tuple8 a b c d e f g h from x = M1 (case x of { (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) (M1 (K1 g4)))) ((:*:) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))) ((:*:) (M1 (K1 g7)) (M1 (K1 g8))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) (M1 (K1 g4)))) ((:*:) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))) ((:*:) (M1 (K1 g7)) (M1 (K1 g8)))))) -> (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 } instance Generic1 ((,,,,,,,) a b c d e f g) where type Rep1 ((,,,,,,,) a b c d e f g) = Rep1Tuple8 a b c d e f g from1 x = M1 (case x of { (,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) (M1 (K1 g4)))) ((:*:) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))) ((:*:) (M1 (K1 g7)) (M1 (Par1 g8))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) (M1 g2)) ((:*:) (M1 g3) (M1 g4))) ((:*:) ((:*:) (M1 g5) (M1 g6)) ((:*:) (M1 g7) (M1 g8))))) -> (,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unPar1 g8) } data D1Tuple8 data C1_0Tuple8 instance Datatype D1Tuple8 where datatypeName _ = "(,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple8 where conName _ = "(,,,,,,,)" ----- type Rep0Tuple9 a b c d e f g h i = D1 D1Tuple9 (C1 C1_0Tuple9 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: S1 NoSelector (Rec0 d))) :*: ((S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)) :*: (S1 NoSelector (Rec0 g) :*: (S1 NoSelector (Rec0 h) :*: S1 NoSelector (Rec0 i)))))) type Rep1Tuple9 a b c d e f g h = D1 D1Tuple9 (C1 C1_0Tuple9 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: S1 NoSelector (Rec0 d))) :*: ((S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)) :*: (S1 NoSelector (Rec0 g) :*: (S1 NoSelector (Rec0 h) :*: S1 NoSelector Par1))))) instance Generic (a, b, c, d, e, f, g, h, i) where type Rep (a, b, c, d, e, f, g, h, i) = Rep0Tuple9 a b c d e f g h i from x = M1 (case x of { (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) (M1 (K1 g4)))) ((:*:) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9)))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) (M1 (K1 g4)))) ((:*:) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9))))))) -> (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 } instance Generic1 ((,,,,,,,,) a b c d e f g h) where type Rep1 ((,,,,,,,,) a b c d e f g h) = Rep1Tuple9 a b c d e f g h from1 x = M1 (case x of { (,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) (M1 (K1 g4)))) ((:*:) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (Par1 g9)))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) (M1 g2)) ((:*:) (M1 g3) (M1 g4))) ((:*:) ((:*:) (M1 g5) (M1 g6)) ((:*:) (M1 g7) ((:*:) (M1 g8) (M1 g9)))))) -> (,,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unK1 g8) (unPar1 g9) } data D1Tuple9 data C1_0Tuple9 instance Datatype D1Tuple9 where datatypeName _ = "(,,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple9 where conName _ = "(,,,,,,,,)" ----- type Rep0Tuple10 a b c d e f g h i j = D1 D1Tuple10 (C1 C1_0Tuple10 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: (S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)))) :*: ((S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g)) :*: (S1 NoSelector (Rec0 h) :*: (S1 NoSelector (Rec0 i) :*: S1 NoSelector (Rec0 j)))))) type Rep1Tuple10 a b c d e f g h i = D1 D1Tuple10 (C1 C1_0Tuple10 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: (S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)))) :*: ((S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g)) :*: (S1 NoSelector (Rec0 h) :*: (S1 NoSelector (Rec0 i) :*: S1 NoSelector Par1))))) instance Generic (a, b, c, d, e, f, g, h, i, j) where type Rep (a, b, c, d, e, f, g, h, i, j) = Rep0Tuple10 a b c d e f g h i j from x = M1 (case x of { (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))))) ((:*:) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))) ((:*:) (M1 (K1 g8)) ((:*:) (M1 (K1 g9)) (M1 (K1 g10)))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))))) ((:*:) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))) ((:*:) (M1 (K1 g8)) ((:*:) (M1 (K1 g9)) (M1 (K1 g10))))))) -> (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 } instance Generic1 ((,,,,,,,,,) a b c d e f g h i) where type Rep1 ((,,,,,,,,,) a b c d e f g h i) = Rep1Tuple10 a b c d e f g h i from1 x = M1 (case x of { (,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))))) ((:*:) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))) ((:*:) (M1 (K1 g8)) ((:*:) (M1 (K1 g9)) (M1 (Par1 g10)))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) (M1 g2)) ((:*:) (M1 g3) ((:*:) (M1 g4) (M1 g5)))) ((:*:) ((:*:) (M1 g6) (M1 g7)) ((:*:) (M1 g8) ((:*:) (M1 g9) (M1 g10)))))) -> (,,,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unK1 g8) (unK1 g9) (unPar1 g10) } data D1Tuple10 data C1_0Tuple10 instance Datatype D1Tuple10 where datatypeName _ = "(,,,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple10 where conName _ = "(,,,,,,,,,)" ----- type Rep0Tuple11 a b c d e f g h i j k = D1 D1Tuple11 (C1 C1_0Tuple11 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: (S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)))) :*: ((S1 NoSelector (Rec0 f) :*: (S1 NoSelector (Rec0 g) :*: S1 NoSelector (Rec0 h))) :*: (S1 NoSelector (Rec0 i) :*: (S1 NoSelector (Rec0 j) :*: S1 NoSelector (Rec0 k)))))) type Rep1Tuple11 a b c d e f g h i j = D1 D1Tuple11 (C1 C1_0Tuple11 (((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: (S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)))) :*: ((S1 NoSelector (Rec0 f) :*: (S1 NoSelector (Rec0 g) :*: S1 NoSelector (Rec0 h))) :*: (S1 NoSelector (Rec0 i) :*: (S1 NoSelector (Rec0 j) :*: S1 NoSelector Par1))))) instance Generic (a, b, c, d, e, f, g, h, i, j, k) where type Rep (a, b, c, d, e, f, g, h, i, j, k) = Rep0Tuple11 a b c d e f g h i j k from x = M1 (case x of { (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))))) ((:*:) ((:*:) (M1 (K1 g6)) ((:*:) (M1 (K1 g7)) (M1 (K1 g8)))) ((:*:) (M1 (K1 g9)) ((:*:) (M1 (K1 g10)) (M1 (K1 g11)))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))))) ((:*:) ((:*:) (M1 (K1 g6)) ((:*:) (M1 (K1 g7)) (M1 (K1 g8)))) ((:*:) (M1 (K1 g9)) ((:*:) (M1 (K1 g10)) (M1 (K1 g11))))))) -> (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 } instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j) where type Rep1 ((,,,,,,,,,,) a b c d e f g h i j) = Rep1Tuple11 a b c d e f g h i j from1 x = M1 (case x of { (,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) (M1 (K1 g2))) ((:*:) (M1 (K1 g3)) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))))) ((:*:) ((:*:) (M1 (K1 g6)) ((:*:) (M1 (K1 g7)) (M1 (K1 g8)))) ((:*:) (M1 (K1 g9)) ((:*:) (M1 (K1 g10)) (M1 (Par1 g11)))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) (M1 g2)) ((:*:) (M1 g3) ((:*:) (M1 g4) (M1 g5)))) ((:*:) ((:*:) (M1 g6) ((:*:) (M1 g7) (M1 g8))) ((:*:) (M1 g9) ((:*:) (M1 g10) (M1 g11)))))) -> (,,,,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unK1 g8) (unK1 g9) (unK1 g10) (unPar1 g11) } data D1Tuple11 data C1_0Tuple11 instance Datatype D1Tuple11 where datatypeName _ = "(,,,,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple11 where conName _ = "(,,,,,,,,,,)" ----- type Rep0Tuple12 a b c d e f g h i j k l = D1 D1Tuple12 (C1 C1_0Tuple12 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: (S1 NoSelector (Rec0 d) :*: (S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)))) :*: ((S1 NoSelector (Rec0 g) :*: (S1 NoSelector (Rec0 h) :*: S1 NoSelector (Rec0 i))) :*: (S1 NoSelector (Rec0 j) :*: (S1 NoSelector (Rec0 k) :*: S1 NoSelector (Rec0 l)))))) type Rep1Tuple12 a b c d e f g h i j k = D1 D1Tuple12 (C1 C1_0Tuple12 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: (S1 NoSelector (Rec0 d) :*: (S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)))) :*: ((S1 NoSelector (Rec0 g) :*: (S1 NoSelector (Rec0 h) :*: S1 NoSelector (Rec0 i))) :*: (S1 NoSelector (Rec0 j) :*: (S1 NoSelector (Rec0 k) :*: S1 NoSelector Par1))))) instance Generic (a, b, c, d, e, f, g, h, i, j, k, l) where type Rep (a, b, c, d, e, f, g, h, i, j, k, l) = Rep0Tuple12 a b c d e f g h i j k l from x = M1 (case x of { (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) (M1 (K1 g4)) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))))) ((:*:) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9)))) ((:*:) (M1 (K1 g10)) ((:*:) (M1 (K1 g11)) (M1 (K1 g12)))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) (M1 (K1 g4)) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))))) ((:*:) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9)))) ((:*:) (M1 (K1 g10)) ((:*:) (M1 (K1 g11)) (M1 (K1 g12))))))) -> (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 } instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k) where type Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k) = Rep1Tuple12 a b c d e f g h i j k from1 x = M1 (case x of { (,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) (M1 (K1 g4)) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))))) ((:*:) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9)))) ((:*:) (M1 (K1 g10)) ((:*:) (M1 (K1 g11)) (M1 (Par1 g12)))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) ((:*:) (M1 g2) (M1 g3))) ((:*:) (M1 g4) ((:*:) (M1 g5) (M1 g6)))) ((:*:) ((:*:) (M1 g7) ((:*:) (M1 g8) (M1 g9))) ((:*:) (M1 g10) ((:*:) (M1 g11) (M1 g12)))))) -> (,,,,,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unK1 g8) (unK1 g9) (unK1 g10) (unK1 g11) (unPar1 g12) } data D1Tuple12 data C1_0Tuple12 instance Datatype D1Tuple12 where datatypeName _ = "(,,,,,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple12 where conName _ = "(,,,,,,,,,,,)" ----- type Rep0Tuple13 a b c d e f g h i j k l m = D1 D1Tuple13 (C1 C1_0Tuple13 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: (S1 NoSelector (Rec0 d) :*: (S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)))) :*: ((S1 NoSelector (Rec0 g) :*: (S1 NoSelector (Rec0 h) :*: S1 NoSelector (Rec0 i))) :*: ((S1 NoSelector (Rec0 j) :*: S1 NoSelector (Rec0 k)) :*: (S1 NoSelector (Rec0 l) :*: S1 NoSelector (Rec0 m)))))) type Rep1Tuple13 a b c d e f g h i j k l = D1 D1Tuple13 (C1 C1_0Tuple13 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: (S1 NoSelector (Rec0 d) :*: (S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f)))) :*: ((S1 NoSelector (Rec0 g) :*: (S1 NoSelector (Rec0 h) :*: S1 NoSelector (Rec0 i))) :*: ((S1 NoSelector (Rec0 j) :*: S1 NoSelector (Rec0 k)) :*: (S1 NoSelector (Rec0 l) :*: S1 NoSelector Par1))))) data D1Tuple13 data C1_0Tuple13 instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m) where type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m) = Rep0Tuple13 a b c d e f g h i j k l m from x = M1 (case x of { (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) (M1 (K1 g4)) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))))) ((:*:) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9)))) ((:*:) ((:*:) (M1 (K1 g10)) (M1 (K1 g11))) ((:*:) (M1 (K1 g12)) (M1 (K1 g13)))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) (M1 (K1 g4)) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))))) ((:*:) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9)))) ((:*:) ((:*:) (M1 (K1 g10)) (M1 (K1 g11))) ((:*:) (M1 (K1 g12)) (M1 (K1 g13))))))) -> (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 } instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) where type Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) = Rep1Tuple13 a b c d e f g h i j k l from1 x = M1 (case x of { (,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) (M1 (K1 g4)) ((:*:) (M1 (K1 g5)) (M1 (K1 g6))))) ((:*:) ((:*:) (M1 (K1 g7)) ((:*:) (M1 (K1 g8)) (M1 (K1 g9)))) ((:*:) ((:*:) (M1 (K1 g10)) (M1 (K1 g11))) ((:*:) (M1 (K1 g12)) (M1 (Par1 g13)))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) ((:*:) (M1 g2) (M1 g3))) ((:*:) (M1 g4) ((:*:) (M1 g5) (M1 g6)))) ((:*:) ((:*:) (M1 g7) ((:*:) (M1 g8) (M1 g9))) ((:*:) ((:*:) (M1 g10) (M1 g11)) ((:*:) (M1 g12) (M1 g13)))))) -> (,,,,,,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unK1 g8) (unK1 g9) (unK1 g10) (unK1 g11) (unK1 g12) (unPar1 g13) } instance Datatype D1Tuple13 where datatypeName _ = "(,,,,,,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple13 where conName _ = "(,,,,,,,,,,,,)" ----- type Rep0Tuple14 a b c d e f g h i j k l m n = D1 D1Tuple14 (C1 C1_0Tuple14 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: ((S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)) :*: (S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g)))) :*: ((S1 NoSelector (Rec0 h) :*: (S1 NoSelector (Rec0 i) :*: S1 NoSelector (Rec0 j))) :*: ((S1 NoSelector (Rec0 k) :*: S1 NoSelector (Rec0 l)) :*: (S1 NoSelector (Rec0 m) :*: S1 NoSelector (Rec0 n)))))) type Rep1Tuple14 a b c d e f g h i j k l m = D1 D1Tuple14 (C1 C1_0Tuple14 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: ((S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)) :*: (S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g)))) :*: ((S1 NoSelector (Rec0 h) :*: (S1 NoSelector (Rec0 i) :*: S1 NoSelector (Rec0 j))) :*: ((S1 NoSelector (Rec0 k) :*: S1 NoSelector (Rec0 l)) :*: (S1 NoSelector (Rec0 m) :*: S1 NoSelector Par1))))) instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = Rep0Tuple14 a b c d e f g h i j k l m n from x = M1 (case x of { (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))))) ((:*:) ((:*:) (M1 (K1 g8)) ((:*:) (M1 (K1 g9)) (M1 (K1 g10)))) ((:*:) ((:*:) (M1 (K1 g11)) (M1 (K1 g12))) ((:*:) (M1 (K1 g13)) (M1 (K1 g14)))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))))) ((:*:) ((:*:) (M1 (K1 g8)) ((:*:) (M1 (K1 g9)) (M1 (K1 g10)))) ((:*:) ((:*:) (M1 (K1 g11)) (M1 (K1 g12))) ((:*:) (M1 (K1 g13)) (M1 (K1 g14))))))) -> (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 } instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where type Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) = Rep1Tuple14 a b c d e f g h i j k l m from1 x = M1 (case x of { (,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))))) ((:*:) ((:*:) (M1 (K1 g8)) ((:*:) (M1 (K1 g9)) (M1 (K1 g10)))) ((:*:) ((:*:) (M1 (K1 g11)) (M1 (K1 g12))) ((:*:) (M1 (K1 g13)) (M1 (Par1 g14)))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) ((:*:) (M1 g2) (M1 g3))) ((:*:) ((:*:) (M1 g4) (M1 g5)) ((:*:) (M1 g6) (M1 g7)))) ((:*:) ((:*:) (M1 g8) ((:*:) (M1 g9) (M1 g10))) ((:*:) ((:*:) (M1 g11) (M1 g12)) ((:*:) (M1 g13) (M1 g14)))))) -> (,,,,,,,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unK1 g8) (unK1 g9) (unK1 g10) (unK1 g11) (unK1 g12) (unK1 g13) (unPar1 g14) } data D1Tuple14 data C1_0Tuple14 instance Datatype D1Tuple14 where datatypeName _ = "(,,,,,,,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple14 where conName _ = "(,,,,,,,,,,,,,)" ----- type Rep0Tuple15 a b c d e f g h i j k l m n o = D1 D1Tuple15 (C1 C1_0Tuple15 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: ((S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)) :*: (S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g)))) :*: (((S1 NoSelector (Rec0 h) :*: S1 NoSelector (Rec0 i)) :*: (S1 NoSelector (Rec0 j) :*: S1 NoSelector (Rec0 k))) :*: ((S1 NoSelector (Rec0 l) :*: S1 NoSelector (Rec0 m)) :*: (S1 NoSelector (Rec0 n) :*: S1 NoSelector (Rec0 o)))))) type Rep1Tuple15 a b c d e f g h i j k l m n = D1 D1Tuple15 (C1 C1_0Tuple15 (((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: ((S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)) :*: (S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g)))) :*: (((S1 NoSelector (Rec0 h) :*: S1 NoSelector (Rec0 i)) :*: (S1 NoSelector (Rec0 j) :*: S1 NoSelector (Rec0 k))) :*: ((S1 NoSelector (Rec0 l) :*: S1 NoSelector (Rec0 m)) :*: (S1 NoSelector (Rec0 n) :*: S1 NoSelector Par1))))) instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where type Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = Rep0Tuple15 a b c d e f g h i j k l m n o from x = M1 (case x of { (,,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))))) ((:*:) ((:*:) ((:*:) (M1 (K1 g8)) (M1 (K1 g9))) ((:*:) (M1 (K1 g10)) (M1 (K1 g11)))) ((:*:) ((:*:) (M1 (K1 g12)) (M1 (K1 g13))) ((:*:) (M1 (K1 g14)) (M1 (K1 g15)))))) }) to (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))))) ((:*:) ((:*:) ((:*:) (M1 (K1 g8)) (M1 (K1 g9))) ((:*:) (M1 (K1 g10)) (M1 (K1 g11)))) ((:*:) ((:*:) (M1 (K1 g12)) (M1 (K1 g13))) ((:*:) (M1 (K1 g14)) (M1 (K1 g15))))))) -> (,,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 } instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where type Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) = Rep1Tuple15 a b c d e f g h i j k l m n from1 x = M1 (case x of { (,,,,,,,,,,,,,,) g1 g2 g3 g4 g5 g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 -> M1 ((:*:) ((:*:) ((:*:) (M1 (K1 g1)) ((:*:) (M1 (K1 g2)) (M1 (K1 g3)))) ((:*:) ((:*:) (M1 (K1 g4)) (M1 (K1 g5))) ((:*:) (M1 (K1 g6)) (M1 (K1 g7))))) ((:*:) ((:*:) ((:*:) (M1 (K1 g8)) (M1 (K1 g9))) ((:*:) (M1 (K1 g10)) (M1 (K1 g11)))) ((:*:) ((:*:) (M1 (K1 g12)) (M1 (K1 g13))) ((:*:) (M1 (K1 g14)) (M1 (Par1 g15)))))) }) to1 (M1 x) = case x of { (M1 ((:*:) ((:*:) ((:*:) (M1 g1) ((:*:) (M1 g2) (M1 g3))) ((:*:) ((:*:) (M1 g4) (M1 g5)) ((:*:) (M1 g6) (M1 g7)))) ((:*:) ((:*:) ((:*:) (M1 g8) (M1 g9)) ((:*:) (M1 g10) (M1 g11))) ((:*:) ((:*:) (M1 g12) (M1 g13)) ((:*:) (M1 g14) (M1 g15)))))) -> (,,,,,,,,,,,,,,) (unK1 g1) (unK1 g2) (unK1 g3) (unK1 g4) (unK1 g5) (unK1 g6) (unK1 g7) (unK1 g8) (unK1 g9) (unK1 g10) (unK1 g11) (unK1 g12) (unK1 g13) (unK1 g14) (unPar1 g15) } data D1Tuple15 data C1_0Tuple15 instance Datatype D1Tuple15 where datatypeName _ = "(,,,,,,,,,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple15 where conName _ = "(,,,,,,,,,,,,,,)" # endif #endif #if !(MIN_VERSION_base(4,14,0)) # if MIN_VERSION_base(4,6,0) type Rep0Kleisli m a b = Rep (Kleisli m a b) type Rep1Kleisli m a = Rep1 (Kleisli m a) deriving instance Generic (Kleisli m a b) deriving instance Generic1 (Kleisli m a) # else type Rep0Kleisli m a b = D1 D1Kleisli (C1 C1_0Kleisli (S1 S1_0_0Kleisli (Rec0 (a -> m b)))) type Rep1Kleisli m a = D1 D1Kleisli (C1 C1_0Kleisli (S1 S1_0_0Kleisli ((->) a :.: Rec1 m))) instance Generic (Kleisli m a b) where type Rep (Kleisli m a b) = Rep0Kleisli m a b from x = M1 (case x of Kleisli g -> M1 (M1 (K1 g))) to (M1 x) = case x of M1 (M1 (K1 g)) -> Kleisli g instance Generic1 (Kleisli m a) where type Rep1 (Kleisli m a) = Rep1Kleisli m a from1 x = M1 (case x of Kleisli g -> M1 (M1 (Comp1 (fmap Rec1 g)))) to1 (M1 x) = case x of M1 (M1 g) -> Kleisli (fmap unRec1 (unComp1 g)) data D1Kleisli data C1_0Kleisli data S1_0_0Kleisli instance Datatype D1Kleisli where datatypeName _ = "Kleisli" moduleName _ = "Control.Arrow" instance Constructor C1_0Kleisli where conName _ = "Kleisli" conIsRecord _ = True instance Selector S1_0_0Kleisli where selName _ = "runKleisli" # endif #endif #if !(MIN_VERSION_base(4,12,0)) # if MIN_VERSION_base(4,6,0) type Rep0Down a = Rep (Down a) type Rep1Down = Rep1 Down deriving instance Generic (Down a) deriving instance Generic1 Down # else type Rep0Down a = D1 D1Down (C1 C1_0Down (S1 NoSelector (Rec0 a))) type Rep1Down = D1 D1Down (C1 C1_0Down (S1 NoSelector Par1)) instance Generic (Down a) where type Rep (Down a) = Rep0Down a from x = M1 (case x of Down g -> M1 (M1 (K1 g))) to (M1 x) = case x of M1 (M1 (K1 g)) -> Down g instance Generic1 Down where type Rep1 Down = Rep1Down from1 x = M1 (case x of Down g -> M1 (M1 (Par1 g))) to1 (M1 x) = case x of M1 (M1 g) -> Down (unPar1 g) data D1Down data C1_0Down instance Datatype D1Down where datatypeName _ = "Down" moduleName _ = "GHC.Exts" instance Constructor C1_0Down where conName _ = "Down" # endif #endif ----- #if !(MIN_VERSION_base(4,9,0)) type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1 :+: C1 C1_1ExitCode (S1 NoSelector (Rec0 Int))) instance Generic ExitCode where type Rep ExitCode = Rep0ExitCode from x = M1 (case x of ExitSuccess -> L1 (M1 U1) ExitFailure g -> R1 (M1 (M1 (K1 g)))) to (M1 x) = case x of L1 (M1 U1) -> ExitSuccess R1 (M1 (M1 (K1 g))) -> ExitFailure g data D1ExitCode data C1_0ExitCode data C1_1ExitCode instance Datatype D1ExitCode where datatypeName _ = "ExitCode" moduleName _ = "GHC.IO.Exception" instance Constructor C1_0ExitCode where conName _ = "ExitSuccess" instance Constructor C1_1ExitCode where conName _ = "ExitFailure" ----- type Rep0Version = D1 D1Version (C1 C1_0Version (S1 S1_0_0Version (Rec0 [Int]) :*: S1 S1_0_1Version (Rec0 [String]))) instance Generic Version where type Rep Version = Rep0Version from (Version b t) = M1 (M1 (M1 (K1 b) :*: M1 (K1 t))) to (M1 (M1 (M1 (K1 b) :*: M1 (K1 t)))) = Version b t data D1Version data C1_0Version data S1_0_0Version data S1_0_1Version instance Datatype D1Version where datatypeName _ = "Version" moduleName _ = "Data.Version" instance Constructor C1_0Version where conName _ = "Version" conIsRecord _ = True instance Selector S1_0_0Version where selName _ = "versionBranch" instance Selector S1_0_1Version where selName _ = "versionTags" ----- type Rep1ConSum f g = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec1 f)) :+: C1 C1_1ConSum (S1 NoSelector (Rec1 g))) instance Generic1 (f :+: g) where type Rep1 (f :+: g) = Rep1ConSum f g from1 x = M1 (case x of L1 l -> L1 (M1 (M1 (Rec1 l))) R1 r -> R1 (M1 (M1 (Rec1 r)))) to1 (M1 x) = case x of L1 (M1 (M1 l)) -> L1 (unRec1 l) R1 (M1 (M1 r)) -> R1 (unRec1 r) data D1ConSum data C1_0ConSum data C1_1ConSum instance Datatype D1ConSum where datatypeName _ = ":+:" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0ConSum where conName _ = "L1" instance Constructor C1_1ConSum where conName _ = "R1" ----- type Rep1ConProduct f g = D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g))) instance Generic1 (f :*: g) where type Rep1 (f :*: g) = Rep1ConProduct f g from1 (f :*: g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) to1 (M1 (M1 (M1 f :*: M1 g))) = unRec1 f :*: unRec1 g data D1ConProduct data C1_ConProduct instance Datatype D1ConProduct where datatypeName _ = ":*:" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_ConProduct where conName _ = ":*:" conFixity _ = Infix RightAssociative 6 ----- type Rep1ConCompose f g = D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (f :.: Rec1 g))) instance Functor f => Generic1 (f :.: g) where type Rep1 (f :.: g) = Rep1ConCompose f g from1 (Comp1 c) = M1 (M1 (M1 (Comp1 (fmap Rec1 c)))) to1 (M1 (M1 (M1 c))) = Comp1 (fmap unRec1 (unComp1 c)) data D1ConCompose data C1_0ConCompose data S1_0_0ConCompose instance Datatype D1ConCompose where datatypeName _ = ":.:" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0ConCompose where conName _ = "Comp1" conIsRecord _ = True instance Selector S1_0_0ConCompose where selName _ = "unComp1" ----- type Rep1K1 i c = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) instance Generic1 (K1 i c) where type Rep1 (K1 i c) = Rep1K1 i c from1 (K1 c) = M1 (M1 (M1 (K1 c))) to1 (M1 (M1 (M1 c))) = K1 (unK1 c) data D1K1 data C1_0K1 data S1_0_0K1 instance Datatype D1K1 where datatypeName _ = "K1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0K1 where conName _ = "K1" conIsRecord _ = True instance Selector S1_0_0K1 where selName _ = "unK1" ----- type Rep1M1 i c f = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec1 f))) instance Generic1 (M1 i c f) where type Rep1 (M1 i c f) = Rep1M1 i c f from1 (M1 m) = M1 (M1 (M1 (Rec1 m))) to1 (M1 (M1 (M1 m))) = M1 (unRec1 m) data D1M1 data C1_0M1 data S1_0_0M1 instance Datatype D1M1 where datatypeName _ = "M1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0M1 where conName _ = "M1" conIsRecord _ = True instance Selector S1_0_0M1 where selName _ = "unM1" ----- type Rep1Par1 = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 Par1)) instance Generic1 Par1 where type Rep1 Par1 = Rep1Par1 from1 (Par1 p) = M1 (M1 (M1 (Par1 p))) to1 (M1 (M1 (M1 p))) = Par1 (unPar1 p) data D1Par1 data C1_0Par1 data S1_0_0Par1 instance Datatype D1Par1 where datatypeName _ = "Par1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0Par1 where conName _ = "Par1" conIsRecord _ = True instance Selector S1_0_0Par1 where selName _ = "unPar1" ----- type Rep1Rec1 f = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec1 f))) instance Generic1 (Rec1 f) where type Rep1 (Rec1 f) = Rep1Rec1 f from1 (Rec1 r) = M1 (M1 (M1 (Rec1 r))) to1 (M1 (M1 (M1 r))) = Rec1 (unRec1 r) data D1Rec1 data C1_0Rec1 data S1_0_0Rec1 instance Datatype D1Rec1 where datatypeName _ = "Rec1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0Rec1 where conName _ = "Rec1" conIsRecord _ = True instance Selector S1_0_0Rec1 where selName _ = "unRec1" ----- type Rep1U1 = D1 D1U1 (C1 C1_0U1 U1) instance Generic1 U1 where type Rep1 U1 = Rep1U1 from1 U1 = M1 (M1 U1) to1 (M1 (M1 U1)) = U1 data D1U1 data C1_0U1 instance Datatype D1U1 where datatypeName _ = "U1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0U1 where conName _ = "U1" ----- type Rep0V1 p = D1 D1V1 V1 type Rep1V1 = D1 D1V1 V1 instance Generic (V1 p) where type Rep (V1 p) = Rep0V1 p from x = M1 (case x of !_ -> error "No generic representation for empty datatype V1") to (M1 !_) = error "No values for empty datatype V1" instance Generic1 V1 where type Rep1 V1 = Rep1V1 from1 x = M1 (case x of !_ -> error "No generic representation for empty datatype V1") to1 (M1 !_) = error "No values for empty datatype V1" data D1V1 instance Datatype D1V1 where datatypeName _ = "V1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif ----- type Rep0UAddr p = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr)) type Rep1UAddr = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr)) instance Generic (UAddr p) where type Rep (UAddr p) = Rep0UAddr p from (UAddr a) = M1 (M1 (M1 (UAddr a))) to (M1 (M1 (M1 (UAddr a)))) = UAddr a instance Generic1 UAddr where type Rep1 UAddr = Rep1UAddr from1 (UAddr a) = M1 (M1 (M1 (UAddr a))) to1 (M1 (M1 (M1 (UAddr a)))) = UAddr a data D1UAddr data C1_0UAddr data S1_0_0UAddr instance Datatype D1UAddr where datatypeName _ = "UAddr" moduleName _ = "Generics.Deriving.Base.Internal" instance Constructor C1_0UAddr where conName _ = "UAddr" conIsRecord _ = True instance Selector S1_0_0UAddr where selName _ = "uAddr#" ----- type Rep0UChar p = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar)) type Rep1UChar = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar)) instance Generic (UChar p) where type Rep (UChar p) = Rep0UChar p from (UChar c) = M1 (M1 (M1 (UChar c))) to (M1 (M1 (M1 (UChar c)))) = UChar c instance Generic1 UChar where type Rep1 UChar = Rep1UChar from1 (UChar c) = M1 (M1 (M1 (UChar c))) to1 (M1 (M1 (M1 (UChar c)))) = UChar c data D1UChar data C1_0UChar data S1_0_0UChar instance Datatype D1UChar where datatypeName _ = "UChar" moduleName _ = "Generics.Deriving.Base.Internal" instance Constructor C1_0UChar where conName _ = "UChar" conIsRecord _ = True instance Selector S1_0_0UChar where selName _ = "uChar#" ----- type Rep0UDouble p = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble)) type Rep1UDouble = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble)) instance Generic (UDouble p) where type Rep (UDouble p) = Rep0UDouble p from (UDouble d) = M1 (M1 (M1 (UDouble d))) to (M1 (M1 (M1 (UDouble d)))) = UDouble d instance Generic1 UDouble where type Rep1 UDouble = Rep1UDouble from1 (UDouble d) = M1 (M1 (M1 (UDouble d))) to1 (M1 (M1 (M1 (UDouble d)))) = UDouble d data D1UDouble data C1_0UDouble data S1_0_0UDouble instance Datatype D1UDouble where datatypeName _ = "UDouble" moduleName _ = "Generics.Deriving.Base.Internal" instance Constructor C1_0UDouble where conName _ = "UDouble" conIsRecord _ = True instance Selector S1_0_0UDouble where selName _ = "uDouble#" ----- type Rep0UFloat p = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat)) type Rep1UFloat = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat)) instance Generic (UFloat p) where type Rep (UFloat p) = Rep0UFloat p from (UFloat f) = M1 (M1 (M1 (UFloat f))) to (M1 (M1 (M1 (UFloat f)))) = UFloat f instance Generic1 UFloat where type Rep1 UFloat = Rep1UFloat from1 (UFloat f) = M1 (M1 (M1 (UFloat f))) to1 (M1 (M1 (M1 (UFloat f)))) = UFloat f data D1UFloat data C1_0UFloat data S1_0_0UFloat instance Datatype D1UFloat where datatypeName _ = "UFloat" moduleName _ = "Generics.Deriving.Base.Internal" instance Constructor C1_0UFloat where conName _ = "UFloat" conIsRecord _ = True instance Selector S1_0_0UFloat where selName _ = "uFloat#" ----- type Rep0UInt p = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt)) type Rep1UInt = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt)) instance Generic (UInt p) where type Rep (UInt p) = Rep0UInt p from (UInt i) = M1 (M1 (M1 (UInt i))) to (M1 (M1 (M1 (UInt i)))) = UInt i instance Generic1 UInt where type Rep1 UInt = Rep1UInt from1 (UInt i) = M1 (M1 (M1 (UInt i))) to1 (M1 (M1 (M1 (UInt i)))) = UInt i data D1UInt data C1_0UInt data S1_0_0UInt instance Datatype D1UInt where datatypeName _ = "UInt" moduleName _ = "Generics.Deriving.Base.Internal" instance Constructor C1_0UInt where conName _ = "UInt" conIsRecord _ = True instance Selector S1_0_0UInt where selName _ = "uInt#" ----- type Rep0UWord p = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord)) type Rep1UWord = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord)) instance Generic (UWord p) where type Rep (UWord p) = Rep0UWord p from (UWord w) = M1 (M1 (M1 (UWord w))) to (M1 (M1 (M1 (UWord w)))) = UWord w instance Generic1 UWord where type Rep1 UWord = Rep1UWord from1 (UWord w) = M1 (M1 (M1 (UWord w))) to1 (M1 (M1 (M1 (UWord w)))) = UWord w data D1UWord data C1_0UWord data S1_0_0UWord instance Datatype D1UWord where datatypeName _ = "UWord" moduleName _ = "Generics.Deriving.Base.Internal" instance Constructor C1_0UWord where conName _ = "UWord" conIsRecord _ = True instance Selector S1_0_0UWord where selName _ = "uWord#" ----- # if MIN_VERSION_base(4,4,0) type Rep0Complex a = D1 D1Complex (C1 C1_0Complex (S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 a))) type Rep1Complex = D1 D1Complex (C1 C1_0Complex (S1 NoSelector Par1 :*: S1 NoSelector Par1)) instance Generic (Complex a) where type Rep (Complex a) = Rep0Complex a from (a :+ b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = a :+ b instance Generic1 Complex where type Rep1 Complex = Rep1Complex from1 (a :+ b) = M1 (M1 (M1 (Par1 a) :*: M1 (Par1 b))) to1 (M1 (M1 (M1 a :*: M1 b))) = unPar1 a :+ unPar1 b data D1Complex data C1_0Complex instance Datatype D1Complex where datatypeName _ = "Complex" moduleName _ = "Data.Complex" instance Constructor C1_0Complex where conName _ = ":+" conFixity _ = Infix LeftAssociative 9 # endif ----- # if MIN_VERSION_base(4,7,0) type Rep1Proxy = D1 D1Proxy (C1 C1_0Proxy U1) instance Generic1 Proxy where type Rep1 Proxy = Rep1Proxy from1 Proxy = M1 (M1 U1) to1 (M1 (M1 U1)) = Proxy data D1Proxy data C1_0Proxy instance Datatype D1Proxy where datatypeName _ = "Proxy" moduleName _ = "Data.Proxy" instance Constructor C1_0Proxy where conName _ = "Proxy" # endif #endif ----- #if !(MIN_VERSION_base(4,7,0)) -------------------------------------------------------------------------------- -- Representations for base types -------------------------------------------------------------------------------- type Rep0All = D1 D1All (C1 C1_0All (S1 S1_0_0All (Rec0 Bool))) instance Generic All where type Rep All = Rep0All from (All a) = M1 (M1 (M1 (K1 a))) to (M1 (M1 (M1 (K1 a)))) = All a data D1All data C1_0All data S1_0_0All instance Datatype D1All where datatypeName _ = "All" moduleName _ = "Data.Monoid" instance Constructor C1_0All where conName _ = "All" conIsRecord _ = True instance Selector S1_0_0All where selName _ = "getAll" ----- type Rep0Any = D1 D1Any (C1 C1_0Any (S1 S1_0_0Any (Rec0 Bool))) instance Generic Any where type Rep Any = Rep0Any from (Any a) = M1 (M1 (M1 (K1 a))) to (M1 (M1 (M1 (K1 a)))) = Any a data D1Any data C1_0Any data S1_0_0Any instance Datatype D1Any where datatypeName _ = "Any" moduleName _ = "Data.Monoid" instance Constructor C1_0Any where conName _ = "Any" conIsRecord _ = True instance Selector S1_0_0Any where selName _ = "getAny" ----- type Rep0Arity = D1 D1Arity (C1 C1_0Arity U1 :+: C1 C1_1Arity (S1 NoSelector (Rec0 Int))) instance Generic Arity where type Rep Arity = Rep0Arity from x = M1 (case x of NoArity -> L1 (M1 U1) Arity a -> R1 (M1 (M1 (K1 a)))) to (M1 x) = case x of L1 (M1 U1) -> NoArity R1 (M1 (M1 (K1 a))) -> Arity a data D1Arity data C1_0Arity data C1_1Arity instance Datatype D1Arity where datatypeName _ = "Arity" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0Arity where conName _ = "NoArity" instance Constructor C1_1Arity where conName _ = "Arity" ----- type Rep0Associativity = D1 D1Associativity (C1 C1_0Associativity U1 :+: (C1 C1_1Associativity U1 :+: C1 C1_2Associativity U1)) instance Generic Associativity where type Rep Associativity = Rep0Associativity from x = M1 (case x of LeftAssociative -> L1 (M1 U1) RightAssociative -> R1 (L1 (M1 U1)) NotAssociative -> R1 (R1 (M1 U1))) to (M1 x) = case x of L1 (M1 U1) -> LeftAssociative R1 (L1 (M1 U1)) -> RightAssociative R1 (R1 (M1 U1)) -> NotAssociative data D1Associativity data C1_0Associativity data C1_1Associativity data C1_2Associativity instance Datatype D1Associativity where datatypeName _ = "Associativity" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0Associativity where conName _ = "LeftAssociative" instance Constructor C1_1Associativity where conName _ = "RightAssociative" instance Constructor C1_2Associativity where conName _ = "NotAssociative" ----- type Rep0Const a b = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) type Rep1Const a = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) instance Generic (Const a b) where type Rep (Const a b) = Rep0Const a b from (Const a) = M1 (M1 (M1 (K1 a))) to (M1 (M1 (M1 (K1 a)))) = Const a instance Generic1 (Const a) where type Rep1 (Const a) = Rep1Const a from1 (Const a) = M1 (M1 (M1 (K1 a))) to1 (M1 (M1 (M1 (K1 a)))) = Const a data D1Const data C1_0Const data S1_0_0Const instance Datatype D1Const where datatypeName _ = "Const" moduleName _ = "Control.Applicative" instance Constructor C1_0Const where conName _ = "Const" conIsRecord _ = True instance Selector S1_0_0Const where selName _ = "getConst" ----- type Rep0Dual a = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual (Rec0 a))) type Rep1Dual = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual Par1)) instance Generic (Dual a) where type Rep (Dual a) = Rep0Dual a from (Dual d) = M1 (M1 (M1 (K1 d))) to (M1 (M1 (M1 (K1 d)))) = Dual d instance Generic1 Dual where type Rep1 Dual = Rep1Dual from1 (Dual d) = M1 (M1 (M1 (Par1 d))) to1 (M1 (M1 (M1 (Par1 d)))) = Dual d data D1Dual data C1_0Dual data S1_0_0Dual instance Datatype D1Dual where datatypeName _ = "Dual" moduleName _ = "Data.Monoid" instance Constructor C1_0Dual where conName _ = "Dual" conIsRecord _ = True instance Selector S1_0_0Dual where selName _ = "getDual" ----- type Rep0Endo a = D1 D1Endo (C1 C1_0Endo (S1 S1_0_0Endo (Rec0 (a -> a)))) instance Generic (Endo a) where type Rep (Endo a) = Rep0Endo a from (Endo e) = M1 (M1 (M1 (K1 e))) to (M1 (M1 (M1 (K1 e)))) = Endo e data D1Endo data C1_0Endo data S1_0_0Endo instance Datatype D1Endo where datatypeName _ = "Endo" moduleName _ = "Data.Monoid" instance Constructor C1_0Endo where conName _ = "Endo" conIsRecord _ = True instance Selector S1_0_0Endo where selName _ = "appEndo" ----- type Rep0First a = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec0 (Maybe a)))) type Rep1First = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec1 Maybe))) instance Generic (First a) where type Rep (First a) = Rep0First a from (First f) = M1 (M1 (M1 (K1 f))) to (M1 (M1 (M1 (K1 f)))) = First f instance Generic1 First where type Rep1 First = Rep1First from1 (First f) = M1 (M1 (M1 (Rec1 f))) to1 (M1 (M1 (M1 (Rec1 f)))) = First f data D1First data C1_0First data S1_0_0First instance Datatype D1First where datatypeName _ = "First" moduleName _ = "Data.Monoid" instance Constructor C1_0First where conName _ = "First" conIsRecord _ = True instance Selector S1_0_0First where selName _ = "getFirst" ----- type Rep0Fixity = D1 D1Fixity (C1 C1_0Fixity U1 :+: C1 C1_1Fixity (S1 NoSelector (Rec0 Associativity) :*: S1 NoSelector (Rec0 Int))) instance Generic Fixity where type Rep Fixity = Rep0Fixity from x = M1 (case x of Prefix -> L1 (M1 U1) Infix a i -> R1 (M1 (M1 (K1 a) :*: M1 (K1 i)))) to (M1 x) = case x of L1 (M1 U1) -> Prefix R1 (M1 (M1 (K1 a) :*: M1 (K1 i))) -> Infix a i data D1Fixity data C1_0Fixity data C1_1Fixity instance Datatype D1Fixity where datatypeName _ = "Fixity" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0Fixity where conName _ = "Prefix" instance Constructor C1_1Fixity where conName _ = "Infix" ----- type Rep0Last a = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec0 (Maybe a)))) type Rep1Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec1 Maybe))) instance Generic (Last a) where type Rep (Last a) = Rep0Last a from (Last l) = M1 (M1 (M1 (K1 l))) to (M1 (M1 (M1 (K1 l)))) = Last l instance Generic1 Last where type Rep1 Last = Rep1Last from1 (Last l) = M1 (M1 (M1 (Rec1 l))) to1 (M1 (M1 (M1 (Rec1 l)))) = Last l data D1Last data C1_0Last data S1_0_0Last instance Datatype D1Last where datatypeName _ = "Last" moduleName _ = "Data.Monoid" instance Constructor C1_0Last where conName _ = "Last" conIsRecord _ = True instance Selector S1_0_0Last where selName _ = "getLast" ----- type Rep0Product a = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product (Rec0 a))) type Rep1Product = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product Par1)) instance Generic (Product a) where type Rep (Product a) = Rep0Product a from (Product p) = M1 (M1 (M1 (K1 p))) to (M1 (M1 (M1 (K1 p)))) = Product p instance Generic1 Product where type Rep1 Product = Rep1Product from1 (Product p) = M1 (M1 (M1 (Par1 p))) to1 (M1 (M1 (M1 (Par1 p)))) = Product p data D1Product data C1_0Product data S1_0_0Product instance Datatype D1Product where datatypeName _ = "Product" moduleName _ = "Data.Monoid" instance Constructor C1_0Product where conName _ = "Product" conIsRecord _ = True instance Selector S1_0_0Product where selName _ = "getProduct" ----- type Rep0Sum a = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum (Rec0 a))) type Rep1Sum = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum Par1)) instance Generic (Sum a) where type Rep (Sum a) = Rep0Sum a from (Sum s) = M1 (M1 (M1 (K1 s))) to (M1 (M1 (M1 (K1 s)))) = Sum s instance Generic1 Sum where type Rep1 Sum = Rep1Sum from1 (Sum s) = M1 (M1 (M1 (Par1 s))) to1 (M1 (M1 (M1 (Par1 s)))) = Sum s data D1Sum data C1_0Sum data S1_0_0Sum instance Datatype D1Sum where datatypeName _ = "Sum" moduleName _ = "Data.Monoid" instance Constructor C1_0Sum where conName _ = "Sum" conIsRecord _ = True instance Selector S1_0_0Sum where selName _ = "getSum" ----- type Rep0WrappedArrow a b c = D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec0 (a b c)))) type Rep1WrappedArrow a b = D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec1 (a b)))) instance Generic (WrappedArrow a b c) where type Rep (WrappedArrow a b c) = Rep0WrappedArrow a b c from (WrapArrow a) = M1 (M1 (M1 (K1 a))) to (M1 (M1 (M1 (K1 a)))) = WrapArrow a instance Generic1 (WrappedArrow a b) where type Rep1 (WrappedArrow a b) = Rep1WrappedArrow a b from1 (WrapArrow a) = M1 (M1 (M1 (Rec1 a))) to1 (M1 (M1 (M1 (Rec1 a)))) = WrapArrow a data D1WrappedArrow data C1_0WrappedArrow data S1_0_0WrappedArrow instance Datatype D1WrappedArrow where datatypeName _ = "WrappedArrow" moduleName _ = "Control.Applicative" instance Constructor C1_0WrappedArrow where conName _ = "WrapArrow" conIsRecord _ = True instance Selector S1_0_0WrappedArrow where selName _ = "unwrapArrow" ----- type Rep0WrappedMonad m a = D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec0 (m a)))) type Rep1WrappedMonad m = D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec1 m))) instance Generic (WrappedMonad m a) where type Rep (WrappedMonad m a) = Rep0WrappedMonad m a from (WrapMonad m) = M1 (M1 (M1 (K1 m))) to (M1 (M1 (M1 (K1 m)))) = WrapMonad m instance Generic1 (WrappedMonad m) where type Rep1 (WrappedMonad m) = Rep1WrappedMonad m from1 (WrapMonad m) = M1 (M1 (M1 (Rec1 m))) to1 (M1 (M1 (M1 (Rec1 m)))) = WrapMonad m data D1WrappedMonad data C1_0WrappedMonad data S1_0_0WrappedMonad instance Datatype D1WrappedMonad where datatypeName _ = "WrappedMonad" moduleName _ = "Control.Applicative" instance Constructor C1_0WrappedMonad where conName _ = "WrapMonad" conIsRecord _ = True instance Selector S1_0_0WrappedMonad where selName _ = "unwrapMonad" ----- type Rep0ZipList a = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec0 [a]))) type Rep1ZipList = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec1 []))) instance Generic (ZipList a) where type Rep (ZipList a) = Rep0ZipList a from (ZipList z) = M1 (M1 (M1 (K1 z))) to (M1 (M1 (M1 (K1 z)))) = ZipList z instance Generic1 ZipList where type Rep1 ZipList = Rep1ZipList from1 (ZipList z) = M1 (M1 (M1 (Rec1 z))) to1 (M1 (M1 (M1 (Rec1 z)))) = ZipList z data D1ZipList data C1_0ZipList data S1_0_0ZipList instance Datatype D1ZipList where datatypeName _ = "ZipList" moduleName _ = "Control.Applicative" instance Constructor C1_0ZipList where conName _ = "ZipList" conIsRecord _ = True instance Selector S1_0_0ZipList where selName _ = "getZipList" ----- type Rep0U1 p = D1 D1U1 (C1 C1_0U1 U1) instance Generic (U1 p) where type Rep (U1 p) = Rep0U1 p from U1 = M1 (M1 U1) to (M1 (M1 U1)) = U1 ----- type Rep0Par1 p = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 (Rec0 p))) instance Generic (Par1 p) where type Rep (Par1 p) = Rep0Par1 p from (Par1 p) = M1 (M1 (M1 (K1 p))) to (M1 (M1 (M1 (K1 p)))) = Par1 p ----- type Rep0Rec1 f p = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec0 (f p)))) instance Generic (Rec1 f p) where type Rep (Rec1 f p) = Rep0Rec1 f p from (Rec1 r) = M1 (M1 (M1 (K1 r))) to (M1 (M1 (M1 (K1 r)))) = Rec1 r ----- type Rep0K1 i c p = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) instance Generic (K1 i c p) where type Rep (K1 i c p) = Rep0K1 i c p from (K1 c) = M1 (M1 (M1 (K1 c))) to (M1 (M1 (M1 (K1 c)))) = K1 c ----- type Rep0M1 i c f p = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec0 (f p)))) instance Generic (M1 i c f p) where type Rep (M1 i c f p) = Rep0M1 i c f p from (M1 m) = M1 (M1 (M1 (K1 m))) to (M1 (M1 (M1 (K1 m)))) = M1 m ----- type Rep0ConSum f g p = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec0 (f p))) :+: C1 C1_1ConSum (S1 NoSelector (Rec0 (g p)))) instance Generic ((f :+: g) p) where type Rep ((f :+: g) p) = Rep0ConSum f g p from x = M1 (case x of L1 l -> L1 (M1 (M1 (K1 l))) R1 r -> R1 (M1 (M1 (K1 r)))) to (M1 x) = case x of L1 (M1 (M1 (K1 l))) -> L1 l R1 (M1 (M1 (K1 r))) -> R1 r ----- type Rep0ConProduct f g p = D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec0 (f p)) :*: S1 NoSelector (Rec0 (g p)))) instance Generic ((f :*: g) p) where type Rep ((f :*: g) p) = Rep0ConProduct f g p from (f :*: g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g))) to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = f :*: g ----- type Rep0ConCompose f g p = D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (Rec0 (f (g p))))) instance Generic ((f :.: g) p) where type Rep ((f :.: g) p) = Rep0ConCompose f g p from (Comp1 c) = M1 (M1 (M1 (K1 c))) to (M1 (M1 (M1 (K1 c)))) = Comp1 c #endif ----- #if !(MIN_VERSION_base(4,6,0)) type Rep1List = D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector Par1 :*: S1 NoSelector (Rec1 []))) instance Generic1 [] where type Rep1 [] = Rep1List from1 x = M1 (case x of [] -> L1 (M1 U1) h:t -> R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t)))) to1 (M1 x) = case x of L1 (M1 U1) -> [] R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))) -> h : t data D1List data C1_0List data C1_1List instance Datatype D1List where datatypeName _ = "[]" moduleName _ = "GHC.Types" instance Constructor C1_0List where conName _ = "[]" instance Constructor C1_1List where conName _ = ":" conFixity _ = Infix RightAssociative 5 ----- type Rep1Either a = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) :+: C1 C1_1Either (S1 NoSelector Par1)) instance Generic1 (Either a) where type Rep1 (Either a) = Rep1Either a from1 x = M1 (case x of Left l -> L1 (M1 (M1 (K1 l))) Right r -> R1 (M1 (M1 (Par1 r)))) to1 (M1 x) = case x of L1 (M1 (M1 (K1 l))) -> Left l R1 (M1 (M1 (Par1 r))) -> Right r data D1Either data C1_0Either data C1_1Either instance Datatype D1Either where datatypeName _ = "Either" moduleName _ = "Data.Either" instance Constructor C1_0Either where conName _ = "Left" instance Constructor C1_1Either where conName _ = "Right" ----- type Rep1Maybe = D1 D1Maybe (C1 C1_0Maybe U1 :+: C1 C1_1Maybe (S1 NoSelector Par1)) instance Generic1 Maybe where type Rep1 Maybe = Rep1Maybe from1 x = M1 (case x of Nothing -> L1 (M1 U1) Just j -> R1 (M1 (M1 (Par1 j)))) to1 (M1 x) = case x of L1 (M1 U1) -> Nothing R1 (M1 (M1 (Par1 j))) -> Just j data D1Maybe data C1_0Maybe data C1_1Maybe instance Datatype D1Maybe where datatypeName _ = "Maybe" -- As of base-4.7.0.0, Maybe is actually located in GHC.Base. -- We don't need to worry about this for the versions of base -- that this instance is defined for, however. moduleName _ = "Data.Maybe" instance Constructor C1_0Maybe where conName _ = "Nothing" instance Constructor C1_1Maybe where conName _ = "Just" ----- type Rep1Tuple2 a = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) :*: S1 NoSelector Par1)) instance Generic1 ((,) a) where type Rep1 ((,) a) = Rep1Tuple2 a from1 (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b))) to1 (M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))) = (a, b) data D1Tuple2 data C1_0Tuple2 instance Datatype D1Tuple2 where datatypeName _ = "(,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple2 where conName _ = "(,)" ----- type Rep1Tuple3 a b = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector Par1))) instance Generic1 ((,,) a b) where type Rep1 ((,,) a b) = Rep1Tuple3 a b from1 (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c)))) to1 (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))) = (a, b, c) data D1Tuple3 data C1_0Tuple3 instance Datatype D1Tuple3 where datatypeName _ = "(,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple3 where conName _ = "(,,)" ----- type Rep1Tuple4 a b c = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: S1 NoSelector Par1))) instance Generic1 ((,,,) a b c) where type Rep1 ((,,,) a b c) = Rep1Tuple4 a b c from1 (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: M1 (Par1 d)))) to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: M1 (Par1 d))))) = (a, b, c, d) data D1Tuple4 data C1_0Tuple4 instance Datatype D1Tuple4 where datatypeName _ = "(,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple4 where conName _ = "(,,,)" ----- type Rep1Tuple5 a b c d = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: (S1 NoSelector (Rec0 d) :*: S1 NoSelector Par1)))) instance Generic1 ((,,,,) a b c d) where type Rep1 ((,,,,) a b c d) = Rep1Tuple5 a b c d from1 (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e))))) to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e)))))) = (a, b, c, d, e) data D1Tuple5 data C1_0Tuple5 instance Datatype D1Tuple5 where datatypeName _ = "(,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple5 where conName _ = "(,,,,)" ----- type Rep1Tuple6 a b c d e = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: (S1 NoSelector (Rec0 d) :*: (S1 NoSelector (Rec0 e) :*: S1 NoSelector Par1)))) instance Generic1 ((,,,,,) a b c d e) where type Rep1 ((,,,,,) a b c d e) = Rep1Tuple6 a b c d e from1 (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f))))) to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f)))))) = (a, b, c, d, e, f) data D1Tuple6 data C1_0Tuple6 instance Datatype D1Tuple6 where datatypeName _ = "(,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple6 where conName _ = "(,,,,,)" ----- type Rep1Tuple7 a b c d e f = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: ((S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)) :*: (S1 NoSelector (Rec0 f) :*: S1 NoSelector Par1)))) instance Generic1 ((,,,,,,) a b c d e f) where type Rep1 ((,,,,,,) a b c d e f) = Rep1Tuple7 a b c d e f from1 (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g))))) to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g)))))) = (a, b, c, d, e, f, g) data D1Tuple7 data C1_0Tuple7 instance Datatype D1Tuple7 where datatypeName _ = "(,,,,,,)" moduleName _ = "GHC.Tuple" instance Constructor C1_0Tuple7 where conName _ = "(,,,,,,)" #endif ----- #if !(MIN_VERSION_base(4,4,0)) type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1) instance Generic Bool where type Rep Bool = Rep0Bool from x = M1 (case x of False -> L1 (M1 U1) True -> R1 (M1 U1)) to (M1 x) = case x of L1 (M1 U1) -> False R1 (M1 U1) -> True data D1Bool data C1_0Bool data C1_1Bool instance Datatype D1Bool where datatypeName _ = "Bool" moduleName _ = "GHC.Bool" instance Constructor C1_0Bool where conName _ = "False" instance Constructor C1_1Bool where conName _ = "True" ----- data D_Char data C_Char instance Datatype D_Char where datatypeName _ = "Char" moduleName _ = "GHC.Base" instance Constructor C_Char where conName _ = "" -- JPM: I'm not sure this is the right implementation... type Rep0Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char))) instance Generic Char where type Rep Char = Rep0Char from x = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = x ----- data D_Double data C_Double instance Datatype D_Double where datatypeName _ = "Double" moduleName _ = "GHC.Float" instance Constructor C_Double where conName _ = "" -- JPM: I'm not sure this is the right implementation... type Rep0Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double))) instance Generic Double where type Rep Double = Rep0Double from x = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = x ----- type Rep0Either a b = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) :+: C1 C1_1Either (S1 NoSelector (Rec0 b))) instance Generic (Either a b) where type Rep (Either a b) = Rep0Either a b from x = M1 (case x of Left l -> L1 (M1 (M1 (K1 l))) Right r -> R1 (M1 (M1 (K1 r)))) to (M1 x) = case x of L1 (M1 (M1 (K1 l))) -> Left l R1 (M1 (M1 (K1 r))) -> Right r ----- data D_Int data C_Int instance Datatype D_Int where datatypeName _ = "Int" moduleName _ = "GHC.Int" instance Constructor C_Int where conName _ = "" -- JPM: I'm not sure this is the right implementation... type Rep0Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int))) instance Generic Int where type Rep Int = Rep0Int from x = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = x ----- data D_Float data C_Float instance Datatype D_Float where datatypeName _ = "Float" moduleName _ = "GHC.Float" instance Constructor C_Float where conName _ = "" -- JPM: I'm not sure this is the right implementation... type Rep0Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float))) instance Generic Float where type Rep Float = Rep0Float from x = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = x ----- type Rep0List a = D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 [a]))) instance Generic [a] where type Rep [a] = Rep0List a from x = M1 (case x of [] -> L1 (M1 U1) h:t -> R1 (M1 (M1 (K1 h) :*: M1 (K1 t)))) to (M1 x) = case x of L1 (M1 U1) -> [] R1 (M1 (M1 (K1 h) :*: M1 (K1 t))) -> h : t ----- type Rep0Maybe a = D1 D1Maybe (C1 C1_0Maybe U1 :+: C1 C1_1Maybe (S1 NoSelector (Rec0 a))) instance Generic (Maybe a) where type Rep (Maybe a) = Rep0Maybe a from x = M1 (case x of Nothing -> L1 (M1 U1) Just j -> R1 (M1 (M1 (K1 j)))) to (M1 x) = case x of L1 (M1 U1) -> Nothing R1 (M1 (M1 (K1 j))) -> Just j ----- type Rep0Ordering = D1 D1Ordering (C1 C1_0Ordering U1 :+: (C1 C1_1Ordering U1 :+: C1 C1_2Ordering U1)) instance Generic Ordering where type Rep Ordering = Rep0Ordering from x = M1 (case x of LT -> L1 (M1 U1) EQ -> R1 (L1 (M1 U1)) GT -> R1 (R1 (M1 U1))) to (M1 x) = case x of L1 (M1 U1) -> LT R1 (L1 (M1 U1)) -> EQ R1 (R1 (M1 U1)) -> GT data D1Ordering data C1_0Ordering data C1_1Ordering data C1_2Ordering instance Datatype D1Ordering where datatypeName _ = "Ordering" moduleName _ = "GHC.Ordering" instance Constructor C1_0Ordering where conName _ = "LT" instance Constructor C1_1Ordering where conName _ = "EQ" instance Constructor C1_2Ordering where conName _ = "GT" ----- type Rep0Unit = D1 D1Unit (C1 C1_0Unit U1) instance Generic () where type Rep () = Rep0Unit from () = M1 (M1 U1) to (M1 (M1 U1)) = () data D1Unit data C1_0Unit instance Datatype D1Unit where datatypeName _ = "()" moduleName _ = "GHC.Tuple" instance Constructor C1_0Unit where conName _ = "()" ----- type Rep0Tuple2 a b = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b))) instance Generic (a, b) where type Rep (a, b) = Rep0Tuple2 a b from (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = (a, b) ----- type Rep0Tuple3 a b c = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c)))) instance Generic (a, b, c) where type Rep (a, b, c) = Rep0Tuple3 a b c from (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))) to (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))) = (a, b, c) ----- type Rep0Tuple4 a b c d = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: S1 NoSelector (Rec0 d)))) instance Generic (a, b, c, d) where type Rep (a, b, c, d) = Rep0Tuple4 a b c d from (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: M1 (K1 d)))) to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: M1 (K1 d))))) = (a, b, c, d) ----- type Rep0Tuple5 a b c d e = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: (S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e))))) instance Generic (a, b, c, d, e) where type Rep (a, b, c, d, e) = Rep0Tuple5 a b c d e from (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e))))) to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e)))))) = (a, b, c, d, e) ----- type Rep0Tuple6 a b c d e f = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: (S1 NoSelector (Rec0 d) :*: (S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f))))) instance Generic (a, b, c, d, e, f) where type Rep (a, b, c, d, e, f) = Rep0Tuple6 a b c d e f from (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f))))) to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f)))))) = (a, b, c, d, e, f) ----- type Rep0Tuple7 a b c d e f g = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: ((S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)) :*: (S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g))))) instance Generic (a, b, c, d, e, f, g) where type Rep (a, b, c, d, e, f, g) = Rep0Tuple7 a b c d e f g from (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g))))) to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g)))))) = (a, b, c, d, e, f, g) #endif generic-deriving-1.14.5/src/Generics/Deriving/Monoid.hs0000644000000000000000000000123707346545000021075 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Monoid (module Generics.Deriving.Monoid.Internal) where import Generics.Deriving.Monoid.Internal import Generics.Deriving.Semigroup (GSemigroup(..)) #if MIN_VERSION_base(4,9,0) import Data.Semigroup (WrappedMonoid) #endif instance GSemigroup a => GMonoid (Maybe a) where gmempty = Nothing gmappend = gsappend #if MIN_VERSION_base(4,9,0) instance GMonoid m => GMonoid (WrappedMonoid m) where gmempty = gmemptydefault gmappend = gmappenddefault #endif generic-deriving-1.14.5/src/Generics/Deriving/Monoid/0000755000000000000000000000000007346545000020536 5ustar0000000000000000generic-deriving-1.14.5/src/Generics/Deriving/Monoid/Internal.hs0000644000000000000000000001775107346545000022661 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Monoid.Internal ( -- * Introduction {- | This module provides two main features: 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances of the types from "Data.Monoid" 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend' The generic defaults only work for types without alternatives (i.e. they have only one constructor). We cannot in general know how to deal with different constructors. -} -- * GMonoid type class GMonoid(..), -- * Default definitions -- ** GMonoid gmemptydefault, gmappenddefault, -- * Internal auxiliary class for GMonoid GMonoid'(..), -- ** Monoid {- | These functions can be used in a 'Monoid' instance. For example: @ -- LANGUAGE DeriveGeneric import Generics.Deriving.Base (Generic) import Generics.Deriving.Monoid data T a = C a (Maybe a) deriving Generic instance Monoid a => Monoid (T a) where mempty = memptydefault mappend = mappenddefault @ -} memptydefault, mappenddefault, -- * Internal auxiliary class for Monoid Monoid'(..), -- * The Monoid module -- | This is exported for convenient access to the various wrapper types. module Data.Monoid, ) where -------------------------------------------------------------------------------- import Control.Applicative import Data.Monoid import Generics.Deriving.Base import Generics.Deriving.Semigroup.Internal #if MIN_VERSION_base(4,6,0) import Data.Ord (Down) #else import GHC.Exts (Down) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) #endif -------------------------------------------------------------------------------- class GSemigroup' f => GMonoid' f where gmempty' :: f x gmappend' :: f x -> f x -> f x instance GMonoid' U1 where gmempty' = U1 gmappend' U1 U1 = U1 instance GMonoid a => GMonoid' (K1 i a) where gmempty' = K1 gmempty gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y) instance GMonoid' f => GMonoid' (M1 i c f) where gmempty' = M1 gmempty' gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y) instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where gmempty' = gmempty' :*: gmempty' gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2 -------------------------------------------------------------------------------- gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a gmemptydefault = to gmempty' gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a gmappenddefault x y = to (gmappend' (from x) (from y)) -------------------------------------------------------------------------------- class Monoid' f where mempty' :: f x mappend' :: f x -> f x -> f x instance Monoid' U1 where mempty' = U1 mappend' U1 U1 = U1 instance Monoid a => Monoid' (K1 i a) where mempty' = K1 mempty mappend' (K1 x) (K1 y) = K1 (x `mappend` y) instance Monoid' f => Monoid' (M1 i c f) where mempty' = M1 mempty' mappend' (M1 x) (M1 y) = M1 (x `mappend'` y) instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where mempty' = mempty' :*: mempty' mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2 -------------------------------------------------------------------------------- memptydefault :: (Generic a, Monoid' (Rep a)) => a memptydefault = to mempty' mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a mappenddefault x y = to (mappend' (from x) (from y)) -------------------------------------------------------------------------------- class GSemigroup a => GMonoid a where -- | Generic 'mempty' gmempty :: a -- | Generic 'mappend' gmappend :: a -> a -> a -- | Generic 'mconcat' gmconcat :: [a] -> a gmconcat = foldr gmappend gmempty #if __GLASGOW_HASKELL__ >= 701 default gmempty :: (Generic a, GMonoid' (Rep a)) => a gmempty = to gmempty' default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a gmappend x y = to (gmappend' (from x) (from y)) #endif -------------------------------------------------------------------------------- -- Instances that reuse Monoid instance GMonoid Ordering where gmempty = mempty gmappend = mappend instance GMonoid () where gmempty = mempty gmappend = mappend instance GMonoid Any where gmempty = mempty gmappend = mappend instance GMonoid All where gmempty = mempty gmappend = mappend instance GMonoid (First a) where gmempty = mempty gmappend = mappend instance GMonoid (Last a) where gmempty = mempty gmappend = mappend instance Num a => GMonoid (Sum a) where gmempty = mempty gmappend = mappend instance Num a => GMonoid (Product a) where gmempty = mempty gmappend = mappend instance GMonoid [a] where gmempty = mempty gmappend = mappend instance GMonoid (Endo a) where gmempty = mempty gmappend = mappend #if MIN_VERSION_base(4,8,0) instance Alternative f => GMonoid (Alt f a) where gmempty = mempty gmappend = mappend #endif -- Handwritten instances instance GMonoid a => GMonoid (Dual a) where gmempty = Dual gmempty gmappend (Dual x) (Dual y) = Dual (gmappend y x) instance GMonoid b => GMonoid (a -> b) where gmempty _ = gmempty gmappend f g x = gmappend (f x) (g x) instance GMonoid a => GMonoid (Const a b) where gmempty = gmemptydefault gmappend = gmappenddefault instance GMonoid a => GMonoid (Down a) where gmempty = gmemptydefault gmappend = gmappenddefault #if MIN_VERSION_base(4,7,0) instance GMonoid # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where gmempty = memptydefault gmappend = mappenddefault #endif #if MIN_VERSION_base(4,8,0) instance GMonoid a => GMonoid (Identity a) where gmempty = gmemptydefault gmappend = gmappenddefault #endif -- Tuple instances instance (GMonoid a,GMonoid b) => GMonoid (a,b) where gmempty = (gmempty,gmempty) gmappend (a1,b1) (a2,b2) = (gmappend a1 a2,gmappend b1 b2) instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where gmempty = (gmempty,gmempty,gmempty) gmappend (a1,b1,c1) (a2,b2,c2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where gmempty = (gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2) generic-deriving-1.14.5/src/Generics/Deriving/Semigroup.hs0000644000000000000000000000107707346545000021624 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Semigroup (module Generics.Deriving.Semigroup.Internal) where import Generics.Deriving.Semigroup.Internal #if MIN_VERSION_base(4,9,0) import Data.Semigroup (WrappedMonoid(..)) import Generics.Deriving.Monoid.Internal (GMonoid(..)) instance GMonoid m => GSemigroup (WrappedMonoid m) where gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b) #endif generic-deriving-1.14.5/src/Generics/Deriving/Semigroup/0000755000000000000000000000000007346545000021263 5ustar0000000000000000generic-deriving-1.14.5/src/Generics/Deriving/Semigroup/Internal.hs0000644000000000000000000001472007346545000023377 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Semigroup.Internal ( -- * Generic semigroup class GSemigroup(..) -- * Default definition , gsappenddefault -- * Internal semigroup class , GSemigroup'(..) ) where import Control.Applicative import Data.Monoid as Monoid #if MIN_VERSION_base(4,5,0) hiding ((<>)) #endif import Generics.Deriving.Base #if MIN_VERSION_base(4,6,0) import Data.Ord (Down) #else import GHC.Exts (Down) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Void (Void) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup as Semigroup #endif ------------------------------------------------------------------------------- infixr 6 `gsappend'` class GSemigroup' f where gsappend' :: f x -> f x -> f x instance GSemigroup' U1 where gsappend' U1 U1 = U1 instance GSemigroup a => GSemigroup' (K1 i a) where gsappend' (K1 x) (K1 y) = K1 (gsappend x y) instance GSemigroup' f => GSemigroup' (M1 i c f) where gsappend' (M1 x) (M1 y) = M1 (gsappend' x y) instance (GSemigroup' f, GSemigroup' g) => GSemigroup' (f :*: g) where gsappend' (x1 :*: y1) (x2 :*: y2) = gsappend' x1 x2 :*: gsappend' y1 y2 ------------------------------------------------------------------------------- infixr 6 `gsappend` class GSemigroup a where gsappend :: a -> a -> a #if __GLASGOW_HASKELL__ >= 701 default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a gsappend = gsappenddefault #endif gstimes :: Integral b => b -> a -> a gstimes y0 x0 | y0 <= 0 = error "gstimes: positive multiplier expected" | otherwise = f x0 y0 where f x y | even y = f (gsappend x x) (y `quot` 2) | y == 1 = x | otherwise = g (gsappend x x) (pred y `quot` 2) x g x y z | even y = g (gsappend x x) (y `quot` 2) z | y == 1 = gsappend x z | otherwise = g (gsappend x x) (pred y `quot` 2) (gsappend x z) #if MIN_VERSION_base(4,9,0) -- | Only available with @base-4.9@ or later gsconcat :: NonEmpty a -> a gsconcat (a :| as) = go a as where go b (c:cs) = gsappend b (go c cs) go b [] = b #endif infixr 6 `gsappenddefault` gsappenddefault :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a gsappenddefault x y = to (gsappend' (from x) (from y)) ------------------------------------------------------------------------------- -- Instances that reuse Monoid instance GSemigroup Ordering where gsappend = mappend instance GSemigroup () where gsappend = mappend instance GSemigroup Any where gsappend = mappend instance GSemigroup All where gsappend = mappend instance GSemigroup (Monoid.First a) where gsappend = mappend instance GSemigroup (Monoid.Last a) where gsappend = mappend instance Num a => GSemigroup (Sum a) where gsappend = mappend instance Num a => GSemigroup (Product a) where gsappend = mappend instance GSemigroup [a] where gsappend = mappend instance GSemigroup (Endo a) where gsappend = mappend #if MIN_VERSION_base(4,8,0) instance Alternative f => GSemigroup (Alt f a) where gsappend = mappend #endif -- Handwritten instances instance GSemigroup a => GSemigroup (Dual a) where gsappend (Dual x) (Dual y) = Dual (gsappend y x) instance GSemigroup a => GSemigroup (Maybe a) where gsappend Nothing x = x gsappend x Nothing = x gsappend (Just x) (Just y) = Just (gsappend x y) instance GSemigroup b => GSemigroup (a -> b) where gsappend f g x = gsappend (f x) (g x) instance GSemigroup a => GSemigroup (Const a b) where gsappend = gsappenddefault instance GSemigroup a => GSemigroup (Down a) where gsappend = gsappenddefault instance GSemigroup (Either a b) where gsappend Left{} b = b gsappend a _ = a #if MIN_VERSION_base(4,7,0) instance GSemigroup # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where gsappend = gsappenddefault #endif #if MIN_VERSION_base(4,8,0) instance GSemigroup a => GSemigroup (Identity a) where gsappend = gsappenddefault instance GSemigroup Void where gsappend a _ = a #endif #if MIN_VERSION_base(4,9,0) instance GSemigroup (Semigroup.First a) where gsappend = (<>) instance GSemigroup (Semigroup.Last a) where gsappend = (<>) instance Ord a => GSemigroup (Max a) where gsappend = (<>) instance Ord a => GSemigroup (Min a) where gsappend = (<>) instance GSemigroup (NonEmpty a) where gsappend = (<>) #endif -- Tuple instances instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where gsappend (a1,b1) (a2,b2) = (gsappend a1 a2,gsappend b1 b2) instance (GSemigroup a,GSemigroup b,GSemigroup c) => GSemigroup (a,b,c) where gsappend (a1,b1,c1) (a2,b2,c2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d) => GSemigroup (a,b,c,d) where gsappend (a1,b1,c1,d1) (a2,b2,c2,d2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e) => GSemigroup (a,b,c,d,e) where gsappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f) => GSemigroup (a,b,c,d,e,f) where gsappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g) => GSemigroup (a,b,c,d,e,f,g) where gsappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g,GSemigroup h) => GSemigroup (a,b,c,d,e,f,g,h) where gsappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2,gsappend h1 h2) generic-deriving-1.14.5/src/Generics/Deriving/Show.hs0000644000000000000000000003721207346545000020572 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif module Generics.Deriving.Show ( -- * Generic show class GShow(..) -- * Default definition , gshowsPrecdefault -- * Internal show class , GShow'(..) ) where import Control.Applicative (Const, ZipList) import Data.Char (GeneralCategory) import Data.Int import Data.Monoid (All, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last) import Data.Version (Version) import Data.Word import Foreign.C.Types import Foreign.ForeignPtr (ForeignPtr) import Foreign.Ptr import Generics.Deriving.Base import GHC.Exts hiding (Any) import System.Exit (ExitCode) import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) import System.IO.Error (IOErrorType) import System.Posix.Types #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) import Data.Void (Void) import Numeric.Natural (Natural) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic show -------------------------------------------------------------------------------- intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse _ [h] = [h] intersperse x (h:t) = h : x : (intersperse x t) appPrec :: Int appPrec = 2 data Type = Rec | Tup | Pref | Inf String class GShow' f where gshowsPrec' :: Type -> Int -> f a -> ShowS isNullary :: f a -> Bool isNullary = error "generic show (isNullary): unnecessary case" instance GShow' V1 where gshowsPrec' _ _ x = case x of #if __GLASGOW_HASKELL__ >= 708 {} #else !_ -> error "Void gshowsPrec" #endif instance GShow' U1 where gshowsPrec' _ _ U1 = id isNullary _ = True instance (GShow c) => GShow' (K1 i c) where gshowsPrec' _ n (K1 a) = gshowsPrec n a isNullary _ = False -- No instances for P or Rec because gshow is only applicable to types of kind * instance (GShow' a, Constructor c) => GShow' (M1 C c a) where gshowsPrec' _ n c@(M1 x) = case fixity of Prefix -> showParen (n > appPrec && not (isNullary x)) ( showString (conName c) . if (isNullary x) then id else showChar ' ' . showBraces t (gshowsPrec' t appPrec x)) Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x)) where fixity = conFixity c t = if (conIsRecord c) then Rec else case (conIsTuple c) of True -> Tup False -> case fixity of Prefix -> Pref Infix _ _ -> Inf (show (conName c)) showBraces :: Type -> ShowS -> ShowS showBraces Rec p = showChar '{' . p . showChar '}' showBraces Tup p = showChar '(' . p . showChar ')' showBraces Pref p = p showBraces (Inf _) p = p conIsTuple :: C1 c f p -> Bool conIsTuple y = tupleName (conName y) where tupleName ('(':',':_) = True tupleName _ = False instance (Selector s, GShow' a) => GShow' (M1 S s a) where gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec) (gshowsPrec' t n x) | otherwise = showString (selName s) . showString " = " . gshowsPrec' t 0 x isNullary (M1 x) = isNullary x instance (GShow' a) => GShow' (M1 D d a) where gshowsPrec' t n (M1 x) = gshowsPrec' t n x instance (GShow' a, GShow' b) => GShow' (a :+: b) where gshowsPrec' t n (L1 x) = gshowsPrec' t n x gshowsPrec' t n (R1 x) = gshowsPrec' t n x instance (GShow' a, GShow' b) => GShow' (a :*: b) where gshowsPrec' t@Rec n (a :*: b) = gshowsPrec' t n a . showString ", " . gshowsPrec' t n b gshowsPrec' t@(Inf s) n (a :*: b) = gshowsPrec' t n a . showString s . gshowsPrec' t n b gshowsPrec' t@Tup n (a :*: b) = gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b gshowsPrec' t@Pref n (a :*: b) = gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b -- If we have a product then it is not a nullary constructor isNullary _ = False -- Unboxed types instance GShow' UChar where gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' instance GShow' UDouble where gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" instance GShow' UFloat where gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' instance GShow' UInt where gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' instance GShow' UWord where gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##" class GShow a where gshowsPrec :: Int -> a -> ShowS #if __GLASGOW_HASKELL__ >= 701 default gshowsPrec :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS gshowsPrec = gshowsPrecdefault #endif gshows :: a -> ShowS gshows = gshowsPrec 0 gshow :: a -> String gshow x = gshows x "" gshowList :: [a] -> ShowS gshowList l = showChar '[' . foldr (.) id (intersperse (showChar ',') (map (gshowsPrec 0) l)) . showChar ']' gshowsPrecdefault :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS gshowsPrecdefault n = gshowsPrec' Pref n . from -- Base types instances -- Base types instances instance GShow () where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b) => GShow (a, b) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f) => GShow (a, b, c, d, e, f) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g) => GShow (a, b, c, d, e, f, g) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow [a] where gshowsPrec _ = gshowList instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where gshowsPrec = gshowsPrecdefault instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where gshowsPrec = gshowsPrecdefault instance GShow (f (g p)) => GShow ((f :.: g) p) where gshowsPrec = gshowsPrecdefault instance GShow All where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,8,0) instance GShow (f a) => GShow (Alt f a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Any where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance (GShow a, GShow b) => GShow (Arg a b) where gshowsPrec = gshowsPrecdefault #endif #if !(MIN_VERSION_base(4,9,0)) instance GShow Arity where gshowsPrec = gshowsPrecdefault #endif instance GShow Associativity where gshowsPrec = gshowsPrecdefault instance GShow Bool where gshowsPrec = gshowsPrecdefault instance GShow BufferMode where gshowsPrec = showsPrec #if defined(HTYPE_CC_T) instance GShow CCc where gshowsPrec = showsPrec #endif instance GShow CChar where gshowsPrec = showsPrec instance GShow CClock where gshowsPrec = showsPrec #if defined(HTYPE_DEV_T) instance GShow CDev where gshowsPrec = showsPrec #endif instance GShow CDouble where gshowsPrec = showsPrec instance GShow CFloat where gshowsPrec = showsPrec #if defined(HTYPE_GID_T) instance GShow CGid where gshowsPrec = showsPrec #endif instance GShow Char where gshowsPrec = showsPrec gshowList = showList #if defined(HTYPE_INO_T) instance GShow CIno where gshowsPrec = showsPrec #endif instance GShow CInt where gshowsPrec = showsPrec instance GShow CIntMax where gshowsPrec = showsPrec instance GShow CIntPtr where gshowsPrec = showsPrec instance GShow CLLong where gshowsPrec = showsPrec instance GShow CLong where gshowsPrec = showsPrec #if defined(HTYPE_MODE_T) instance GShow CMode where gshowsPrec = showsPrec #endif #if defined(HTYPE_NLINK_T) instance GShow CNlink where gshowsPrec = showsPrec #endif #if defined(HTYPE_OFF_T) instance GShow COff where gshowsPrec = showsPrec #endif #if MIN_VERSION_base(4,4,0) instance GShow a => GShow (Complex a) where gshowsPrec = gshowsPrecdefault #endif instance GShow a => GShow (Const a b) where gshowsPrec = gshowsPrecdefault #if defined(HTYPE_PID_T) instance GShow CPid where gshowsPrec = showsPrec #endif instance GShow CPtrdiff where gshowsPrec = showsPrec #if defined(HTYPE_RLIM_T) instance GShow CRLim where gshowsPrec = showsPrec #endif instance GShow CSChar where gshowsPrec = showsPrec #if defined(HTYPE_SPEED_T) instance GShow CSpeed where gshowsPrec = showsPrec #endif #if MIN_VERSION_base(4,4,0) instance GShow CSUSeconds where gshowsPrec = showsPrec #endif instance GShow CShort where gshowsPrec = showsPrec instance GShow CSigAtomic where gshowsPrec = showsPrec instance GShow CSize where gshowsPrec = showsPrec #if defined(HTYPE_SSIZE_T) instance GShow CSsize where gshowsPrec = showsPrec #endif #if defined(HTYPE_TCFLAG_T) instance GShow CTcflag where gshowsPrec = showsPrec #endif instance GShow CTime where gshowsPrec = showsPrec instance GShow CUChar where gshowsPrec = showsPrec #if defined(HTYPE_UID_T) instance GShow CUid where gshowsPrec = showsPrec #endif instance GShow CUInt where gshowsPrec = showsPrec instance GShow CUIntMax where gshowsPrec = showsPrec instance GShow CUIntPtr where gshowsPrec = showsPrec instance GShow CULLong where gshowsPrec = showsPrec instance GShow CULong where gshowsPrec = showsPrec #if MIN_VERSION_base(4,4,0) instance GShow CUSeconds where gshowsPrec = showsPrec #endif instance GShow CUShort where gshowsPrec = showsPrec instance GShow CWchar where gshowsPrec = showsPrec instance GShow Double where gshowsPrec = showsPrec instance GShow a => GShow (Down a) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Dual a) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b) => GShow (Either a b) where gshowsPrec = gshowsPrecdefault instance GShow ExitCode where gshowsPrec = gshowsPrecdefault instance GShow Fd where gshowsPrec = showsPrec instance GShow a => GShow (Monoid.First a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Semigroup.First a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Fixity where gshowsPrec = gshowsPrecdefault instance GShow Float where gshowsPrec = showsPrec instance GShow (ForeignPtr a) where gshowsPrec = showsPrec instance GShow (FunPtr a) where gshowsPrec = showsPrec instance GShow GeneralCategory where gshowsPrec = showsPrec instance GShow Handle where gshowsPrec = showsPrec instance GShow HandlePosn where gshowsPrec = showsPrec #if MIN_VERSION_base(4,8,0) instance GShow a => GShow (Identity a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Int where gshowsPrec = showsPrec instance GShow Int8 where gshowsPrec = showsPrec instance GShow Int16 where gshowsPrec = showsPrec instance GShow Int32 where gshowsPrec = showsPrec instance GShow Int64 where gshowsPrec = showsPrec instance GShow Integer where gshowsPrec = showsPrec instance GShow IntPtr where gshowsPrec = showsPrec instance GShow IOError where gshowsPrec = showsPrec instance GShow IOErrorType where gshowsPrec = showsPrec instance GShow IOMode where gshowsPrec = showsPrec instance GShow c => GShow (K1 i c p) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Monoid.Last a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Semigroup.Last a) where gshowsPrec = gshowsPrecdefault #endif instance GShow (f p) => GShow (M1 i c f p) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Max a) where gshowsPrec = gshowsPrecdefault #endif instance GShow a => GShow (Maybe a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Min a) where gshowsPrec = gshowsPrecdefault #endif #if MIN_VERSION_base(4,8,0) instance GShow Natural where gshowsPrec = showsPrec #endif #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (NonEmpty a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Ordering where gshowsPrec = gshowsPrecdefault instance GShow p => GShow (Par1 p) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Product a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,7,0) instance GShow (Proxy s) where gshowsPrec = gshowsPrecdefault #endif instance GShow (Ptr a) where gshowsPrec = showsPrec instance GShow (f p) => GShow (Rec1 f p) where gshowsPrec = gshowsPrecdefault instance GShow SeekMode where gshowsPrec = showsPrec instance GShow a => GShow (Sum a) where gshowsPrec = gshowsPrecdefault instance GShow (U1 p) where gshowsPrec = gshowsPrecdefault instance GShow (UChar p) where gshowsPrec = gshowsPrecdefault instance GShow (UDouble p) where gshowsPrec = gshowsPrecdefault instance GShow (UFloat p) where gshowsPrec = gshowsPrecdefault instance GShow (UInt p) where gshowsPrec = gshowsPrecdefault instance GShow (UWord p) where gshowsPrec = gshowsPrecdefault instance GShow Version where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,8,0) instance GShow Void where gshowsPrec = showsPrec #endif instance GShow Word where gshowsPrec = showsPrec instance GShow Word8 where gshowsPrec = showsPrec instance GShow Word16 where gshowsPrec = showsPrec instance GShow Word32 where gshowsPrec = showsPrec instance GShow Word64 where gshowsPrec = showsPrec instance GShow WordPtr where gshowsPrec = showsPrec #if MIN_VERSION_base(4,9,0) instance GShow m => GShow (WrappedMonoid m) where gshowsPrec = gshowsPrecdefault #endif instance GShow a => GShow (ZipList a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,10,0) instance GShow CBool where gshowsPrec = showsPrec # if defined(HTYPE_BLKSIZE_T) instance GShow CBlkSize where gshowsPrec = showsPrec # endif # if defined(HTYPE_BLKCNT_T) instance GShow CBlkCnt where gshowsPrec = showsPrec # endif # if defined(HTYPE_CLOCKID_T) instance GShow CClockId where gshowsPrec = showsPrec # endif # if defined(HTYPE_FSBLKCNT_T) instance GShow CFsBlkCnt where gshowsPrec = showsPrec # endif # if defined(HTYPE_FSFILCNT_T) instance GShow CFsFilCnt where gshowsPrec = showsPrec # endif # if defined(HTYPE_ID_T) instance GShow CId where gshowsPrec = showsPrec # endif # if defined(HTYPE_KEY_T) instance GShow CKey where gshowsPrec = showsPrec # endif # if defined(HTYPE_TIMER_T) instance GShow CTimer where gshowsPrec = showsPrec # endif #endif generic-deriving-1.14.5/src/Generics/Deriving/TH.hs0000644000000000000000000013042207346545000020162 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {- | Module : Generics.Deriving.TH Copyright : (c) 2008--2009 Universiteit Utrecht License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable This module contains Template Haskell code that can be used to automatically generate the boilerplate code for the generic deriving library. To use these functions, pass the name of a data type as an argument: @ {-# LANGUAGE TemplateHaskell #-} data Example a = Example Int Char a $('deriveAll0' ''Example) -- Derives Generic instance $('deriveAll1' ''Example) -- Derives Generic1 instance $('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances @ On GHC 7.4 or later, this code can also be used with data families. To derive for a data family instance, pass the name of one of the instance's constructors: @ {-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} data family Family a b newtype instance Family Char x = FamilyChar Char data instance Family Bool x = FamilyTrue | FamilyFalse $('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ... $('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ... -- Alternatively, one could type $(deriveAll1 'FamilyFalse) @ -} -- Adapted from Generics.Regular.TH module Generics.Deriving.TH ( -- * @derive@- functions deriveMeta , deriveData , deriveConstructors , deriveSelectors , deriveAll , deriveAll0 , deriveAll1 , deriveAll0And1 , deriveRepresentable0 , deriveRepresentable1 , deriveRep0 , deriveRep1 -- * @make@- functions -- $make , makeRep0Inline , makeRep0 , makeRep0FromType , makeFrom , makeFrom0 , makeTo , makeTo0 , makeRep1Inline , makeRep1 , makeRep1FromType , makeFrom1 , makeTo1 -- * Options -- $options -- ** Option types , Options(..) , defaultOptions , RepOptions(..) , defaultRepOptions , KindSigOptions , defaultKindSigOptions , EmptyCaseOptions , defaultEmptyCaseOptions -- ** Functions with optional arguments , deriveAll0Options , deriveAll1Options , deriveAll0And1Options , deriveRepresentable0Options , deriveRepresentable1Options , deriveRep0Options , deriveRep1Options , makeFrom0Options , makeTo0Options , makeFrom1Options , makeTo1Options ) where import Control.Monad ((>=>), unless, when) import qualified Data.Map as Map (empty, fromList) import Generics.Deriving.TH.Internal #if MIN_VERSION_base(4,9,0) import Generics.Deriving.TH.Post4_9 #else import Generics.Deriving.TH.Pre4_9 #endif import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH {- $options 'Options' gives you a way to further tweak derived 'Generic' and 'Generic1' instances: * 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit the code directly (the 'InlineRep' option). One can also choose to emit a separate type synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and 'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the 'TypeSynonymRep' option). * 'EmptyCaseOptions': By default, all derived instances for empty data types (i.e., data types with no constructors) use 'error' in @from(1)@/@to(1)@. For instance, @data Empty@ would have this derived 'Generic' instance: @ instance Generic Empty where type Rep Empty = D1 ('MetaData ...) V1 from _ = M1 (error "No generic representation for empty datatype Empty") to (M1 _) = error "No generic representation for empty datatype Empty" @ This matches the behavior of GHC up until 8.4, when derived @Generic(1)@ instances began to use the @EmptyCase@ extension. In GHC 8.4, the derived 'Generic' instance for @Empty@ would instead be: @ instance Generic Empty where type Rep Empty = D1 ('MetaData ...) V1 from x = M1 (case x of {}) to (M1 x) = case x of {} @ This is a slightly better encoding since, for example, any divergent computations passed to 'from' will actually diverge (as opposed to before, where the result would always be a call to 'error'). On the other hand, using this encoding in @generic-deriving@ has one large drawback: it requires enabling @EmptyCase@, an extension which was only introduced in GHC 7.8 (and only received reliable pattern-match coverage checking in 8.2). The 'EmptyCaseOptions' field controls whether code should be emitted that uses @EmptyCase@ (i.e., 'EmptyCaseOptions' set to 'True') or not ('False'). The default value is 'False'. Note that even if set to 'True', this option has no effect on GHCs before 7.8, as @EmptyCase@ did not exist then. * 'KindSigOptions': By default, all derived instances will use explicit kind signatures (when the 'KindSigOptions' is 'True'). You might wish to set the 'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at a particular kind that GHC will infer correctly, but the functions in this module won't guess correctly. You probably won't ever need this option unless you are a power user. -} -- | Additional options for configuring derived 'Generic'/'Generic1' instances -- using Template Haskell. data Options = Options { repOptions :: RepOptions , kindSigOptions :: KindSigOptions , emptyCaseOptions :: EmptyCaseOptions } deriving (Eq, Ord, Read, Show) -- | Sensible default 'Options'. defaultOptions :: Options defaultOptions = Options { repOptions = defaultRepOptions , kindSigOptions = defaultKindSigOptions , emptyCaseOptions = defaultEmptyCaseOptions } -- | Configures whether 'Rep'/'Rep1' type instances should be defined inline in a -- derived 'Generic'/'Generic1' instance ('InlineRep') or defined in terms of a -- type synonym ('TypeSynonymRep'). data RepOptions = InlineRep | TypeSynonymRep deriving (Eq, Ord, Read, Show) -- | 'InlineRep', a sensible default 'RepOptions'. defaultRepOptions :: RepOptions defaultRepOptions = InlineRep -- | 'True' if explicit kind signatures should be used in derived -- 'Generic'/'Generic1' instances, 'False' otherwise. type KindSigOptions = Bool -- | 'True', a sensible default 'KindSigOptions'. defaultKindSigOptions :: KindSigOptions defaultKindSigOptions = True -- | 'True' if generated code for empty data types should use the @EmptyCase@ -- extension, 'False' otherwise. This has no effect on GHCs before 7.8, since -- @EmptyCase@ is only available in 7.8 or later. type EmptyCaseOptions = Bool -- | Sensible default 'EmptyCaseOptions'. defaultEmptyCaseOptions :: EmptyCaseOptions defaultEmptyCaseOptions = False -- | A backwards-compatible synonym for 'deriveAll0'. deriveAll :: Name -> Q [Dec] deriveAll = deriveAll0 -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, and the 'Representable0' instance. deriveAll0 :: Name -> Q [Dec] deriveAll0 = deriveAll0Options defaultOptions -- | Like 'deriveAll0', but takes an 'Options' argument. deriveAll0Options :: Options -> Name -> Q [Dec] deriveAll0Options = deriveAllCommon True False -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, and the 'Representable1' instance. deriveAll1 :: Name -> Q [Dec] deriveAll1 = deriveAll1Options defaultOptions -- | Like 'deriveAll1', but takes an 'Options' argument. deriveAll1Options :: Options -> Name -> Q [Dec] deriveAll1Options = deriveAllCommon False True -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, the 'Representable0' instance, and the 'Representable1' instance. deriveAll0And1 :: Name -> Q [Dec] deriveAll0And1 = deriveAll0And1Options defaultOptions -- | Like 'deriveAll0And1', but takes an 'Options' argument. deriveAll0And1Options :: Options -> Name -> Q [Dec] deriveAll0And1Options = deriveAllCommon True True deriveAllCommon :: Bool -> Bool -> Options -> Name -> Q [Dec] deriveAllCommon generic generic1 opts n = do a <- deriveMeta n b <- if generic then deriveRepresentableCommon Generic opts n else return [] c <- if generic1 then deriveRepresentableCommon Generic1 opts n else return [] return (a ++ b ++ c) -- | Given the type and the name (as string) for the Representable0 type -- synonym to derive, generate the 'Representable0' instance. deriveRepresentable0 :: Name -> Q [Dec] deriveRepresentable0 = deriveRepresentable0Options defaultOptions -- | Like 'deriveRepresentable0', but takes an 'Options' argument. deriveRepresentable0Options :: Options -> Name -> Q [Dec] deriveRepresentable0Options = deriveRepresentableCommon Generic -- | Given the type and the name (as string) for the Representable1 type -- synonym to derive, generate the 'Representable1' instance. deriveRepresentable1 :: Name -> Q [Dec] deriveRepresentable1 = deriveRepresentable1Options defaultOptions -- | Like 'deriveRepresentable1', but takes an 'Options' argument. deriveRepresentable1Options :: Options -> Name -> Q [Dec] deriveRepresentable1Options = deriveRepresentableCommon Generic1 deriveRepresentableCommon :: GenericClass -> Options -> Name -> Q [Dec] deriveRepresentableCommon gClass opts n = do rep <- if repOptions opts == InlineRep then return [] else deriveRepCommon gClass (kindSigOptions opts) n inst <- deriveInst gClass opts n return (rep ++ inst) -- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0' -- is used. deriveRep0 :: Name -> Q [Dec] deriveRep0 = deriveRep0Options defaultKindSigOptions -- | Like 'deriveRep0', but takes an 'KindSigOptions' argument. deriveRep0Options :: KindSigOptions -> Name -> Q [Dec] deriveRep0Options = deriveRepCommon Generic -- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1' -- is used. deriveRep1 :: Name -> Q [Dec] deriveRep1 = deriveRep1Options defaultKindSigOptions -- | Like 'deriveRep1', but takes an 'KindSigOptions' argument. deriveRep1Options :: KindSigOptions -> Name -> Q [Dec] deriveRep1Options = deriveRepCommon Generic1 deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec] deriveRepCommon gClass useKindSigs n = do i <- reifyDataInfo n let (name, instTys, cons, dv) = either error id i gt = mkGenericTvbs gClass instTys -- See Note [Forcing buildTypeInstance] !_ <- buildTypeInstance gClass useKindSigs name instTys -- See Note [Kind signatures in derived instances] let tySynVars = genericInitTvbs gt tySynVars' = if useKindSigs then tySynVars else map unKindedTV tySynVars fmap (:[]) $ tySynD (genRepName gClass dv name) (changeTVFlags bndrReq tySynVars') (repType gt dv name Map.empty cons) deriveInst :: GenericClass -> Options -> Name -> Q [Dec] deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName deriveInst Generic1 = deriveInstCommon generic1TypeName rep1TypeName Generic1 from1ValName to1ValName deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Options -> Name -> Q [Dec] deriveInstCommon genericName repName gClass fromName toName opts n = do i <- reifyDataInfo n let (name, instTys, cons, dv) = either error id i gt = mkGenericTvbs gClass instTys useKindSigs = kindSigOptions opts -- See Note [Forcing buildTypeInstance] !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name instTys tyInsRHS <- if repOptions opts == InlineRep then repType gt dv name Map.empty cons else makeRepTySynApp gClass dv name origTy let origSigTy = if useKindSigs then SigT origTy origKind else origTy tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return tyInsRHS) let ecOptions = emptyCaseOptions opts mkBody maker = [clause [] (normalB $ mkCaseExp $ maker gt ecOptions name cons) []] fcs = mkBody mkFrom tcs = mkBody mkTo inline_pragmas | inlining_useful cons #if MIN_VERSION_template_haskell(2,7,0) = map (\fun_name -> pragInlD fun_name # if MIN_VERSION_template_haskell(2,8,0) Inline FunLike (FromPhase 1) # else (inlineSpecPhase True False True 1) # endif ) [fromName, toName] #else = [] -- Sadly, GHC 7.0 and 7.2 appear to suffer from a bug that -- prevents them from attaching INLINE pragmas to class methods -- via Template Haskell, so don't bother generating any pragmas at -- all for these GHC versions. #endif | otherwise = [] fmap (:[]) $ instanceD (cxt []) (conT genericName `appT` return origSigTy) (inline_pragmas ++ [return tyIns, funD fromName fcs, funD toName tcs]) where -- Adapted from inlining_useful in GHC.Tc.Deriv.Generics.mkBindsRep in the -- GHC source code: -- -- https://gitlab.haskell.org/ghc/ghc/-/blob/80729d96e47c99dc38e83612dfcfe01cf565eac0/compiler/GHC/Tc/Deriv/Generics.hs#L368-386 inlining_useful cons | ncons <= 1 = True | ncons <= 4 = max_fields <= 5 | ncons <= 8 = max_fields <= 2 | ncons <= 16 = max_fields <= 1 | ncons <= 24 = max_fields == 0 | otherwise = False where ncons = length cons max_fields = maximum $ map (length . constructorFields) cons {- $make There are some data types for which the Template Haskell deriver functions in this module are not sophisticated enough to infer the correct 'Generic' or 'Generic1' instances. As an example, consider this data type: @ newtype Fix f a = Fix (f (Fix f a)) @ A proper 'Generic1' instance would look like this: @ instance Functor f => Generic1 (Fix f) where ... @ Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint. One can still define a 'Generic1' instance for @Fix@, however, by using the functions in this module that are prefixed with @make@-. For example: @ $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) instance Functor f => Generic1 (Fix f) where type Rep1 (Fix f) = $('makeRep1Inline' ''Fix [t| Fix f |]) from1 = $('makeFrom1' ''Fix) to1 = $('makeTo1' ''Fix) @ Note that due to the lack of type-level lambdas in Haskell, one must manually apply @'makeRep1Inline' ''Fix@ to the type @Fix f@. Be aware that there is a bug on GHC 7.0, 7.2, and 7.4 which might prevent you from using 'makeRep0Inline' and 'makeRep1Inline'. In the @Fix@ example above, you would experience the following error: @ Kinded thing `f' used as a type In the Template Haskell quotation [t| Fix f |] @ Then a workaround is to use 'makeRep1' instead, which requires you to: 1. Invoke 'deriveRep1' beforehand 2. Pass as arguments the type variables that occur in the instance, in order from left to right, topologically sorted, excluding duplicates. (Normally, 'makeRep1Inline' would figure this out for you.) Using the above example: @ $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) instance Functor f => Generic1 (Fix f) where type Rep1 (Fix f) = $('makeRep1' ''Fix) f from1 = $('makeFrom1' ''Fix) to1 = $('makeTo1' ''Fix) @ On GHC 7.4, you might encounter more complicated examples involving data families. For instance: @ data family Fix a b c d newtype instance Fix b (f c) (g b) a = Fix (f (Fix b (f c) (g b) a)) $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) instance Functor f => Generic1 (Fix b (f c) (g b)) where type Rep1 (Fix b (f c) (g b)) = $('makeRep1' 'Fix) b f c g from1 = $('makeFrom1' 'Fix) to1 = $('makeTo1' 'Fix) @ Note that you don't pass @b@ twice, only once. -} -- | Generates the full 'Rep' type inline. Since this type can be quite -- large, it is recommended you only use this to define 'Rep', e.g., -- -- @ -- type Rep (Foo (a :: k) b) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) b |]) -- @ -- -- You can then simply refer to @Rep (Foo a b)@ elsewhere. -- -- Note that the type passed as an argument to 'makeRep0Inline' must match the -- type argument of 'Rep' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep0Inline' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! makeRep0Inline :: Name -> Q Type -> Q Type makeRep0Inline n = makeRepCommon Generic InlineRep n . Just -- | Generates the full 'Rep1' type inline. Since this type can be quite -- large, it is recommended you only use this to define 'Rep1', e.g., -- -- @ -- type Rep1 (Foo (a :: k)) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) |]) -- @ -- -- You can then simply refer to @Rep1 (Foo a)@ elsewhere. -- -- Note that the type passed as an argument to 'makeRep1Inline' must match the -- type argument of 'Rep1' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep1Inline' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! makeRep1Inline :: Name -> Q Type -> Q Type makeRep1Inline n = makeRepCommon Generic1 InlineRep n . Just -- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', -- which generates the type synonym declaration). After splicing it into -- Haskell source, it expects types as arguments. For example: -- -- @ -- type Rep (Foo a b) = $('makeRep0' ''Foo) a b -- @ -- -- The use of 'makeRep0' is generally discouraged, as it can sometimes be -- difficult to predict the order in which you are expected to pass type -- variables. As a result, 'makeRep0Inline' is recommended instead. However, -- 'makeRep0Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, -- so 'makeRep0' still exists for GHC 7.0, 7.2, and 7.4 users. makeRep0 :: Name -> Q Type makeRep0 n = makeRepCommon Generic TypeSynonymRep n Nothing -- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', -- which generates the type synonym declaration). After splicing it into -- Haskell source, it expects types as arguments. For example: -- -- @ -- type Rep1 (Foo a) = $('makeRep1' ''Foo) a -- @ -- -- The use of 'makeRep1' is generally discouraged, as it can sometimes be -- difficult to predict the order in which you are expected to pass type -- variables. As a result, 'makeRep1Inline' is recommended instead. However, -- 'makeRep1Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, -- so 'makeRep1' still exists for GHC 7.0, 7.2, and 7.4 users. makeRep1 :: Name -> Q Type makeRep1 n = makeRepCommon Generic1 TypeSynonymRep n Nothing -- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', -- which generates the type synonym declaration) applied to its type arguments. -- Unlike 'makeRep0', this also takes a quoted 'Type' as an argument, e.g., -- -- @ -- type Rep (Foo (a :: k) b) = $('makeRep0FromType' ''Foo [t| Foo (a :: k) b |]) -- @ -- -- Note that the type passed as an argument to 'makeRep0FromType' must match the -- type argument of 'Rep' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep0FromType' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! -- -- The use of 'makeRep0FromType' is generally discouraged, since 'makeRep0Inline' -- does exactly the same thing but without having to go through an intermediate -- type synonym, and as a result, 'makeRep0Inline' tends to be less buggy. makeRep0FromType :: Name -> Q Type -> Q Type makeRep0FromType n = makeRepCommon Generic TypeSynonymRep n . Just -- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', -- which generates the type synonym declaration) applied to its type arguments. -- Unlike 'makeRep1', this also takes a quoted 'Type' as an argument, e.g., -- -- @ -- type Rep1 (Foo (a :: k)) = $('makeRep1FromType' ''Foo [t| Foo (a :: k) |]) -- @ -- -- Note that the type passed as an argument to 'makeRep1FromType' must match the -- type argument of 'Rep' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep1FromType' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! -- -- The use of 'makeRep1FromType' is generally discouraged, since 'makeRep1Inline' -- does exactly the same thing but without having to go through an intermediate -- type synonym, and as a result, 'makeRep1Inline' tends to be less buggy. makeRep1FromType :: Name -> Q Type -> Q Type makeRep1FromType n = makeRepCommon Generic1 TypeSynonymRep n . Just makeRepCommon :: GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type makeRepCommon gClass repOpts n mbQTy = do i <- reifyDataInfo n let (name, instTys, cons, dv) = either error id i gt = mkGenericTvbs gClass instTys -- See Note [Forcing buildTypeInstance] !_ <- buildTypeInstance gClass False name instTys case (mbQTy, repOpts) of (Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name (Just qTy, InlineRep) -> qTy >>= makeRepInline gt dv name cons (Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name (Nothing, InlineRep) -> fail "makeRepCommon" makeRepInline :: GenericTvbs -> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Type -> Q Type makeRepInline gt dv name cons ty = do let instVars = freeVariablesWellScoped [ty] tySynVars = genericInitTvbs gt typeSubst :: TypeSubst typeSubst = Map.fromList $ zip (map tvName tySynVars) (map (VarT . tvName) instVars) repType gt dv name typeSubst cons makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type makeRepTySynApp gClass dv name ty = -- Here, we figure out the distinct type variables (in order from left-to-right) -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind -- inferencer can figure out the kinds perfectly well, so we don't need to -- give anything here explicit kind signatures. let instTvbs = map unKindedTV $ freeVariablesWellScoped [ty] in return $ applyTyToTvbs (genRepName gClass dv name) instTvbs -- | A backwards-compatible synonym for 'makeFrom0'. makeFrom :: Name -> Q Exp makeFrom = makeFrom0 -- | Generates a lambda expression which behaves like 'from'. makeFrom0 :: Name -> Q Exp makeFrom0 = makeFrom0Options defaultEmptyCaseOptions -- | Like 'makeFrom0Options', but takes an 'EmptyCaseOptions' argument. makeFrom0Options :: EmptyCaseOptions -> Name -> Q Exp makeFrom0Options = makeFunCommon mkFrom Generic -- | A backwards-compatible synonym for 'makeTo0'. makeTo :: Name -> Q Exp makeTo = makeTo0 -- | Generates a lambda expression which behaves like 'to'. makeTo0 :: Name -> Q Exp makeTo0 = makeTo0Options defaultEmptyCaseOptions -- | Like 'makeTo0Options', but takes an 'EmptyCaseOptions' argument. makeTo0Options :: EmptyCaseOptions -> Name -> Q Exp makeTo0Options = makeFunCommon mkTo Generic -- | Generates a lambda expression which behaves like 'from1'. makeFrom1 :: Name -> Q Exp makeFrom1 = makeFrom1Options defaultEmptyCaseOptions -- | Like 'makeFrom1Options', but takes an 'EmptyCaseOptions' argument. makeFrom1Options :: EmptyCaseOptions -> Name -> Q Exp makeFrom1Options = makeFunCommon mkFrom Generic1 -- | Generates a lambda expression which behaves like 'to1'. makeTo1 :: Name -> Q Exp makeTo1 = makeTo1Options defaultEmptyCaseOptions -- | Like 'makeTo1Options', but takes an 'EmptyCaseOptions' argument. makeTo1Options :: EmptyCaseOptions -> Name -> Q Exp makeTo1Options = makeFunCommon mkTo Generic1 makeFunCommon :: (GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match) -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp makeFunCommon maker gClass ecOptions n = do i <- reifyDataInfo n let (name, instTys, cons, _) = either error id i gt = mkGenericTvbs gClass instTys -- See Note [Forcing buildTypeInstance] buildTypeInstance gClass False name instTys `seq` mkCaseExp (maker gt ecOptions name cons) genRepName :: GenericClass -> DatatypeVariant_ -> Name -> Name genRepName gClass dv n = mkName . showsDatatypeVariant dv . (("Rep" ++ show (fromEnum gClass)) ++) . ((showNameQual n ++ "_") ++) . sanitizeName $ nameBase n repType :: GenericTvbs -> DatatypeVariant_ -> Name -> TypeSubst -> [ConstructorInfo] -> Q Type repType gt dv dt typeSubst cs = conT d1TypeName `appT` mkMetaDataType dv dt `appT` foldBal sum' (conT v1TypeName) (map (repCon gt dv dt typeSubst) cs) where sum' :: Q Type -> Q Type -> Q Type sum' a b = conT sumTypeName `appT` a `appT` b repCon :: GenericTvbs -> DatatypeVariant_ -> Name -> TypeSubst -> ConstructorInfo -> Q Type repCon gt dv dt typeSubst (ConstructorInfo { constructorName = n , constructorVars = vars , constructorContext = ctxt , constructorStrictness = bangs , constructorFields = ts , constructorVariant = cv }) = do checkExistentialContext n vars ctxt let mbSelNames = case cv of NormalConstructor -> Nothing InfixConstructor -> Nothing RecordConstructor selNames -> Just selNames isRecord = case cv of NormalConstructor -> False InfixConstructor -> False RecordConstructor _ -> True isInfix = case cv of NormalConstructor -> False InfixConstructor -> True RecordConstructor _ -> False ssis <- reifySelStrictInfo n bangs repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix repConWith :: GenericTvbs -> DatatypeVariant_ -> Name -> Name -> TypeSubst -> Maybe [Name] -> [SelStrictInfo] -> [Type] -> Bool -> Bool -> Q Type repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do let structureType :: Q Type structureType = foldBal prodT (conT u1TypeName) f f :: [Q Type] f = case mbSelNames of Just selNames -> zipWith3 (repField gt dv dt n typeSubst . Just) selNames ssis ts Nothing -> zipWith (repField gt dv dt n typeSubst Nothing) ssis ts conT c1TypeName `appT` mkMetaConsType dv dt n isRecord isInfix `appT` structureType prodT :: Q Type -> Q Type -> Q Type prodT a b = conT productTypeName `appT` a `appT` b repField :: GenericTvbs -> DatatypeVariant_ -> Name -> Name -> TypeSubst -> Maybe Name -> SelStrictInfo -> Type -> Q Type repField gt dv dt ns typeSubst mbF ssi t = conT s1TypeName `appT` mkMetaSelType dv dt ns mbF ssi `appT` (repFieldArg gt =<< resolveTypeSynonyms t'') where -- See Note [Generic1 is polykinded in base-4.10] t', t'' :: Type t' = case gt of Gen1{gen1LastTvbKindVar = Just _kvName} -> #if MIN_VERSION_base(4,10,0) t #else substNameWithKind _kvName starK t #endif _ -> t t'' = applySubstitution typeSubst t' repFieldArg :: GenericTvbs -> Type -> Q Type repFieldArg Gen0{} t = boxT t repFieldArg (Gen1{gen1LastTvbName = name}) (dustOff -> t0) = go t0 >>= \res -> case res of NoPar -> boxT t0 ArgRes _ r -> return r where -- | Returns NoPar if the parameter doesn't appear. -- Expects its argument to have been dusted. go :: Type -> Q (ArgRes Type) go ForallT{} = rankNError #if MIN_VERSION_template_haskell(2,16,0) go ForallVisT{} = rankNError #endif go (VarT t) | t == name = ArgRes True `fmap` conT par1TypeName go (AppT f x) = do when (not (f `ground` name)) outOfPlaceTyVarError mxr <- go (dustOff x) case mxr of NoPar -> return NoPar ArgRes arg_is_param xr -> do itf <- isUnsaturatedType f when itf typeFamilyApplicationError ArgRes False `fmap` if arg_is_param then conT rec1TypeName `appT` return f else conT composeTypeName `appT` return f `appT` return xr go _ = return NoPar -- | The result of checking the argument. This NoPar -- means the parameter wasn't there. The Bool is True -- if the argument *is* the parameter, and False otherwise. data ArgRes a = NoPar | ArgRes !Bool a boxT :: Type -> Q Type boxT ty = case unboxedRepNames ty of Just (boxTyName, _, _) -> conT boxTyName Nothing -> conT rec0TypeName `appT` return ty mkCaseExp :: Q Match -> Q Exp mkCaseExp qMatch = do val <- newName "val" lam1E (varP val) $ caseE (varE val) [qMatch] mkFrom :: GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match mkFrom gt ecOptions dt cs = do y <- newName "y" match (varP y) (normalB $ conE m1DataName `appE` caseE (varE y) cases) [] where cases = case cs of [] -> errorFrom ecOptions dt _ -> zipWith (fromCon gt id (length cs)) [1..] cs errorFrom :: EmptyCaseOptions -> Name -> [Q Match] errorFrom useEmptyCase dt | useEmptyCase && ghc7'8OrLater = [] | otherwise = [do z <- newName "z" match (varP z) (normalB $ appE (varE seqValName) (varE z) `appE` appE (varE errorValName) (stringE $ "No generic representation for empty datatype " ++ nameBase dt)) []] mkTo :: GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match mkTo gt ecOptions dt cs = do y <- newName "y" match (conP m1DataName [varP y]) (normalB $ caseE (varE y) cases) [] where cases = case cs of [] -> errorTo ecOptions dt _ -> zipWith (toCon gt id (length cs)) [1..] cs errorTo :: EmptyCaseOptions -> Name -> [Q Match] errorTo useEmptyCase dt | useEmptyCase && ghc7'8OrLater = [] | otherwise = [do z <- newName "z" match (varP z) (normalB $ appE (varE seqValName) (varE z) `appE` appE (varE errorValName) (stringE $ "No values for empty datatype " ++ nameBase dt)) []] ghc7'8OrLater :: Bool #if __GLASGOW_HASKELL__ >= 708 ghc7'8OrLater = True #else ghc7'8OrLater = False #endif fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match fromCon gt wrap m i (ConstructorInfo { constructorName = cn , constructorVars = vars , constructorContext = ctxt , constructorFields = ts }) = do checkExistentialContext cn vars ctxt fNames <- newNameList "f" $ length ts match (conP cn (map varP fNames)) (normalB $ wrap $ lrE i m $ conE m1DataName `appE` foldBal prodE (conE u1DataName) (zipWith (fromField gt) fNames ts)) [] prodE :: Q Exp -> Q Exp -> Q Exp prodE x y = conE productDataName `appE` x `appE` y fromField :: GenericTvbs -> Name -> Type -> Q Exp fromField gt nr t = conE m1DataName `appE` (fromFieldWrap gt nr =<< resolveTypeSynonyms t) fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp fromFieldWrap _ _ ForallT{} = rankNError fromFieldWrap gt nr (SigT t _) = fromFieldWrap gt nr t fromFieldWrap Gen0{} nr t = conE (boxRepName t) `appE` varE nr fromFieldWrap (Gen1{gen1LastTvbName = name}) nr t = wC t name `appE` varE nr wC :: Type -> Name -> Q Exp wC (dustOff -> t0) name = go t0 >>= \res -> case res of NoPar -> conE $ boxRepName t0 ArgRes _ r -> return r where -- | Returns NoPar if the parameter doesn't appear. -- Expects its argument to have been dusted. go :: Type -> Q (ArgRes Exp) go ForallT{} = rankNError #if MIN_VERSION_template_haskell(2,16,0) go ForallVisT{} = rankNError #endif go (VarT t) | t == name = ArgRes True `fmap` conE par1DataName go (AppT f x) = do when (not (f `ground` name)) outOfPlaceTyVarError mxr <- go (dustOff x) case mxr of NoPar -> return NoPar ArgRes arg_is_param xr -> do itf <- isUnsaturatedType f when itf typeFamilyApplicationError ArgRes False `fmap` if arg_is_param then conE rec1DataName else infixApp (conE comp1DataName) (varE composeValName) (varE fmapValName `appE` return xr) go _ = return NoPar boxRepName :: Type -> Name boxRepName = maybe k1DataName snd3 . unboxedRepNames toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match toCon gt wrap m i (ConstructorInfo { constructorName = cn , constructorVars = vars , constructorContext = ctxt , constructorFields = ts }) = do checkExistentialContext cn vars ctxt fNames <- newNameList "f" $ length ts match (wrap $ lrP i m $ conP m1DataName [foldBal prod (conP u1DataName []) (zipWith (toField gt) fNames ts)]) (normalB $ foldl appE (conE cn) (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gt nr) fNames ts)) [] where prod x y = conP productDataName [x,y] toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp toConUnwC Gen0{} nr _ = varE nr toConUnwC (Gen1{gen1LastTvbName = name}) nr t = unwC t name `appE` varE nr toField :: GenericTvbs -> Name -> Type -> Q Pat toField gt nr t = conP m1DataName [toFieldWrap gt nr t] toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat toFieldWrap Gen0{} nr t = conP (boxRepName t) [varP nr] toFieldWrap Gen1{} nr _ = varP nr unwC :: Type -> Name -> Q Exp unwC (dustOff -> t0) name = go t0 >>= \res -> case res of NoPar -> varE $ unboxRepName t0 ArgRes _ r -> return r where -- | Returns NoPar if the parameter doesn't appear. -- Expects its argument to have been dusted. go :: Type -> Q (ArgRes Exp) go ForallT{} = rankNError #if MIN_VERSION_template_haskell(2,16,0) go ForallVisT{} = rankNError #endif go (VarT t) | t == name = ArgRes True `fmap` varE unPar1ValName go (AppT f x) = do when (not (f `ground` name)) outOfPlaceTyVarError mxr <- go (dustOff x) case mxr of NoPar -> return NoPar ArgRes arg_is_param xr -> do itf <- isUnsaturatedType f when itf typeFamilyApplicationError ArgRes False `fmap` if arg_is_param then varE unRec1ValName else infixApp (varE fmapValName `appE` return xr) (varE composeValName) (varE unComp1ValName) go _ = return NoPar unboxRepName :: Type -> Name unboxRepName = maybe unK1ValName trd3 . unboxedRepNames lrP :: Int -> Int -> (Q Pat -> Q Pat) lrP i n p | n == 0 = fail "lrP: impossible" | n == 1 = p | i <= div n 2 = conP l1DataName [lrP i (div n 2) p] | otherwise = conP r1DataName [lrP (i-m) (n-m) p] where m = div n 2 lrE :: Int -> Int -> (Q Exp -> Q Exp) lrE i n e | n == 0 = fail "lrE: impossible" | n == 1 = e | i <= div n 2 = conE l1DataName `appE` lrE i (div n 2) e | otherwise = conE r1DataName `appE` lrE (i-m) (n-m) e where m = div n 2 unboxedRepNames :: Type -> Maybe (Name, Name, Name) unboxedRepNames ty | ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName) | ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName) | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName) | ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName) | ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName) | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName) | otherwise = Nothing -- For the given Types, deduces the instance type (and kind) to use for a -- Generic(1) instance. Coming up with the instance type isn't as simple as -- dropping the last types, as you need to be wary of kinds being instantiated -- with *. -- See Note [Type inference in derived instances] buildTypeInstance :: GenericClass -- ^ Generic or Generic1 -> KindSigOptions -- ^ Whether or not to use explicit kind signatures in the instance type -> Name -- ^ The type constructor or data family name -> [Type] -- ^ The types to instantiate the instance with -> Q (Type, Kind) buildTypeInstance gClass useKindSigs tyConName varTysOrig = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.) varTysExp <- mapM resolveTypeSynonyms varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - fromEnum gClass #if !(MIN_VERSION_base(4,10,0)) droppedTysExp :: [Type] droppedTysExp = drop remainingLength varTysExp droppedStarKindStati :: [StarKindStatus] droppedStarKindStati = map canRealizeKindStar droppedTysExp #endif -- Check that: -- -- 1. There are enough types to drop -- -- 2. If using GHC 8.0 or earlier, all types are either of kind * or kind k -- (for some kind variable k). See Note [Generic1 is polykinded in base-4.10]. -- -- If either of these checks fail, throw an error. when (remainingLength < 0 #if !(MIN_VERSION_base(4,10,0)) || any (== OtherKind) droppedStarKindStati #endif ) $ derivingKindError tyConName -- Substitute kind * for any dropped kind variables let varTysExpSubst :: [Type] -- See Note [Generic1 is polykinded in base-4.10] #if MIN_VERSION_base(4,10,0) varTysExpSubst = varTysExp #else varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp droppedKindVarNames :: [Name] droppedKindVarNames = catKindVarNames droppedStarKindStati #endif let remainingTysExpSubst, droppedTysExpSubst :: [Type] (remainingTysExpSubst, droppedTysExpSubst) = splitAt remainingLength varTysExpSubst -- See Note [Generic1 is polykinded in base-4.10] #if !(MIN_VERSION_base(4,10,0)) -- If any of the dropped types were polykinded, ensure that there are of -- kind * after substituting * for the dropped kind variables. If not, -- throw an error. unless (all hasKindStar droppedTysExpSubst) $ derivingKindError tyConName #endif -- We now substitute all of the specialized-to-* kind variable names -- with *, but in the original types, not the synonym-expanded types. The reason -- we do this is a superficial one: we want the derived instance to resemble -- the datatype written in source code as closely as possible. For example, -- for the following data family instance: -- -- data family Fam a -- newtype instance Fam String = Fam String -- -- We'd want to generate the instance: -- -- instance C (Fam String) -- -- Not: -- -- instance C (Fam [Char]) let varTysOrigSubst :: [Type] varTysOrigSubst = -- See Note [Generic1 is polykinded in base-4.10] #if MIN_VERSION_base(4,10,0) id #else map (substNamesWithKindStar droppedKindVarNames) #endif $ varTysOrig remainingTysOrigSubst, droppedTysOrigSubst :: [Type] (remainingTysOrigSubst, droppedTysOrigSubst) = splitAt remainingLength varTysOrigSubst remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the useKindSigs check. remainingTysOrigSubst' = if useKindSigs then remainingTysOrigSubst else map unSigT remainingTysOrigSubst instanceType :: Type instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst' -- See Note [Kind signatures in derived instances] instanceKind :: Kind instanceKind = makeFunKind (map typeKind droppedTysOrigSubst) starK -- Ensure the dropped types can be safely eta-reduced. Otherwise, -- throw an error. unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $ etaReductionError instanceType return (instanceType, instanceKind) {- Note [Forcing buildTypeInstance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sometimes, we don't explicitly need to generate a Generic(1) type instance, but we force buildTypeInstance nevertheless. This is because it performs some checks for whether or not the provided datatype can actually have Generic(1) implemented for it, and produces errors if it can't. Otherwise, laziness would cause these checks to be skipped entirely, which could result in some indecipherable type errors down the road. Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We generally include explicit type signatures in derived instances. One reason for doing so is that in the case of certain data family instances, not including kind signatures can result in ambiguity. For example, consider the following two data family instances that are distinguished by their kinds: data family Fam (a :: k) data instance Fam (a :: * -> *) data instance Fam (a :: *) If we dropped the kind signature for a in a derived instance for Fam a, then GHC would have no way of knowing which instance we are talking about. In addition to using explicit kind signatures in the instance head, we also put explicit kinds in the associated Rep(1) instance. For example, this data type: data S (a :: k) = S k Will have the following Generic1 instance generated for it: instance Generic1 (S :: k -> *) where type Rep1 (S :: k -> *) = ... (Rec0 k) Why do we do this? Imagine what the instance would be without the explicit kind annotation in the Rep1 instance: instance Generic1 S where type Rep1 S = ... (Rec0 k) This is an error, since the variable k is now out-of-scope! In the rare event that attaching explicit kind annotations does the wrong thing, there are variants of the TH functions that allow configuring the KindSigOptions. If KindSigOptions is set to False, then generated instances will not include explicit kind signatures, leaving it up to GHC's kind inference machinery to figure out the correct kinds. Note [Generic1 is polykinded in base-4.10] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Prior to base-4.10, Generic1 :: (* -> *) -> Constraint. This means that if a Generic1 instance is defined for a polykinded data type like so: data Proxy k (a :: k) = Proxy Then k is unified with *, and this has an effect on the generated Generic1 instance: instance Generic1 (Proxy *) where ... We must take great care to ensure that all occurrences of k are substituted with *, or else the generated instance will be ill kinded. In base-4.10 and later, Generic1 :: (k -> *) -> Constraint. This means we don't have to do any of this kind unification trickery anymore! Hooray! -} generic-deriving-1.14.5/src/Generics/Deriving/TH/0000755000000000000000000000000007346545000017624 5ustar0000000000000000generic-deriving-1.14.5/src/Generics/Deriving/TH/Internal.hs0000644000000000000000000010243307346545000021737 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} #endif {- | Module : Generics.Deriving.TH.Internal Copyright : (c) 2008--2009 Universiteit Utrecht License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Template Haskell-related utilities. -} module Generics.Deriving.TH.Internal where import Control.Monad (unless) import Data.Char (isAlphaNum, ord) import Data.Foldable (foldr') import qualified Data.List as List import qualified Data.Map as Map import Data.Map as Map (Map) import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax #if __GLASGOW_HASKELL__ >= 800 import qualified Generics.Deriving as GD import Generics.Deriving hiding ( DecidedStrictness(..), Fixity(Infix) , SourceStrictness(..), SourceUnpackedness(..) , datatypeName ) import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) #else # ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_generic_deriving (version) # endif #endif ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- type TypeSubst = Map Name Type applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0) applySubstitutionKind = applySubstitution #else applySubstitutionKind _ t = t #endif substNameWithKind :: Name -> Kind -> Type -> Type substNameWithKind n k = applySubstitutionKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns ------------------------------------------------------------------------------- -- StarKindStatus ------------------------------------------------------------------------------- -- | Whether a type is of kind @*@, a kind variable, or some other kind. The -- kind variable case is given special treatment solely to support GHC 8.0 and -- earlier, in which Generic1 was not poly-kinded. In order to support deriving -- Generic1 instances on these versions of GHC, we must substitute such kinds -- with @*@ to ensure that the resulting instance is well kinded. -- See @Note [Generic1 is polykinded in base-4.10]@ in "Generics.Deriving.TH". data StarKindStatus = KindStar | IsKindVar Name | OtherKind deriving Eq -- | Does a Type have kind * or k (for some kind variable k)? canRealizeKindStar :: Type -> StarKindStatus canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of #if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k #endif _ -> OtherKind -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. -- Otherwise, returns 'Nothing'. starKindStatusToName :: StarKindStatus -> Maybe Name starKindStatusToName (IsKindVar n) = Just n starKindStatusToName _ = Nothing -- | Concat together all of the StarKindStatuses that are IsKindVar and extract -- the kind variables' Names out. catKindVarNames :: [StarKindStatus] -> [Name] catKindVarNames = mapMaybe starKindStatusToName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True #if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True #else hasKindStar (SigT _ StarK) = True #endif hasKindStar _ = False -- | Converts a VarT or a SigT into Just the corresponding TyVarBndr. -- Converts other Types to Nothing. typeToTyVarBndr :: Type -> Maybe TyVarBndrUnit typeToTyVarBndr (VarT n) = Just (plainTV n) typeToTyVarBndr (SigT (VarT n) k) = Just (kindedTV n k) typeToTyVarBndr _ = Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. typeKind :: Type -> Kind typeKind (SigT _ k) = k typeKind _ = starK -- | Turns -- -- @ -- [a, b] c -- @ -- -- into -- -- @ -- a -> b -> c -- @ makeFunType :: [Type] -> Type -> Type makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys -- | Turns -- -- @ -- [k1, k2] k3 -- @ -- -- into -- -- @ -- k1 -> k2 -> k3 -- @ makeFunKind :: [Kind] -> Kind -> Kind #if MIN_VERSION_template_haskell(2,8,0) makeFunKind = makeFunType #else makeFunKind argKinds resKind = foldr' ArrowK resKind argKinds #endif -- | Remove any outer `SigT` and `ParensT` constructors, and turn -- an outermost `InfixT` constructor into plain applications. dustOff :: Type -> Type dustOff (SigT ty _) = dustOff ty #if MIN_VERSION_template_haskell(2,11,0) dustOff (ParensT ty) = dustOff ty dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2 #endif dustOff ty = ty -- | Checks whether a type is an unsaturated type family -- application. isUnsaturatedType :: Type -> Q Bool isUnsaturatedType = go 0 . dustOff where -- Expects its argument to be dusted go :: Int -> Type -> Q Bool go d t = case t of ConT tcName -> check d tcName AppT f _ -> go (d + 1) (dustOff f) _ -> return False check :: Int -> Name -> Q Bool check d tcName = do mbinders <- getTypeFamilyBinders tcName return $ case mbinders of Just bndrs -> length bndrs > d Nothing -> False -- | Given a name, check if that name is a type family. If -- so, return a list of its binders. getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndrVis]) getTypeFamilyBinders tcName = do info <- reify tcName return $ case info of #if MIN_VERSION_template_haskell(2,11,0) FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ -> Just bndrs #elif MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD TypeFam _ bndrs _) _ -> Just bndrs #else TyConI (FamilyD TypeFam _ bndrs _) -> Just bndrs #endif #if MIN_VERSION_template_haskell(2,11,0) FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ -> Just bndrs #elif MIN_VERSION_template_haskell(2,9,0) FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ -> Just bndrs #endif _ -> Nothing -- | True if the type does not mention the Name ground :: Type -> Name -> Bool ground ty name = name `notElem` freeVariables ty -- | Construct a type via curried application. applyTyToTys :: Type -> [Type] -> Type applyTyToTys = List.foldl' AppT -- | Apply a type constructor name to type variable binders. applyTyToTvbs :: Name -> [TyVarBndr_ flag] -> Type applyTyToTvbs = List.foldl' (\a -> AppT a . tyVarBndrToType) . ConT -- | Split a type signature by the arrows on its spine. For example, this: -- -- @ -- forall a b. (a -> b) -> Char -> () -- @ -- -- would split to this: -- -- @ -- ([a, b], [a -> b, Char, ()]) -- @ uncurryTy :: Type -> ([TyVarBndrSpec], [Type]) uncurryTy (AppT (AppT ArrowT t1) t2) = let (tvbs, tys) = uncurryTy t2 in (tvbs, t1:tys) uncurryTy (SigT t _) = uncurryTy t uncurryTy (ForallT tvbs _ t) = let (tvbs', tys) = uncurryTy t in (tvbs ++ tvbs', tys) uncurryTy t = ([], [t]) -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> ([TyVarBndrSpec], [Kind]) #if MIN_VERSION_template_haskell(2,8,0) uncurryKind = uncurryTy #else uncurryKind (ArrowK k1 k2) = let (kvbs, ks) = uncurryKind k2 in (kvbs, k1:ks) uncurryKind k = ([], [k]) #endif tyVarBndrToType :: TyVarBndr_ flag -> Type tyVarBndrToType = elimTV VarT (\n k -> SigT (VarT n) k) -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions: -- -- (1) All of the dropped types are type variables -- (2) All of the dropped types are distinct -- (3) None of the remaining types mention any of the dropped types canEtaReduce :: [Type] -> [Type] -> Bool canEtaReduce remaining dropped = all isTyVar dropped -- Make sure not to pass something of type [Type], since Type -- didn't have an Ord instance until template-haskell-2.10.0.0 && allDistinct droppedNames && not (any (`mentionsName` droppedNames) remaining) where droppedNames :: [Name] droppedNames = map varTToName dropped -- | Extract the Name from a type variable. If the argument Type is not a -- type variable, throw an error. varTToName :: Type -> Name varTToName (VarT n) = n varTToName (SigT t _) = varTToName t varTToName _ = error "Not a type variable!" -- | Is the given type a variable? isTyVar :: Type -> Bool isTyVar VarT{} = True isTyVar (SigT t _) = isTyVar t isTyVar _ = False -- | Is the given kind a variable? isKindVar :: Kind -> Bool #if MIN_VERSION_template_haskell(2,8,0) isKindVar = isTyVar #else isKindVar _ = False -- There are no kind variables #endif -- | Returns 'True' is a 'Type' contains no type variables. isTypeMonomorphic :: Type -> Bool isTypeMonomorphic = go where go :: Type -> Bool go (AppT t1 t2) = go t1 && go t2 go (SigT t _k) = go t #if MIN_VERSION_template_haskell(2,8,0) && go _k #endif go VarT{} = False go _ = True -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type unSigT (SigT t _) = t unSigT t = t -- | Peel off a kind signature from a TyVarBndr (if it has one). unKindedTV :: TyVarBndrUnit -> TyVarBndrUnit unKindedTV tvb = elimTV (\_ -> tvb) (\n _ -> plainTV n) tvb -- | Does the given type mention any of the Names in the list? mentionsName :: Type -> [Name] -> Bool mentionsName = go where go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names go (SigT t _k) names = go t names #if MIN_VERSION_template_haskell(2,8,0) || go _k names #endif go (VarT n) names = n `elem` names go _ _ = False -- | Are all of the items in a list (which have an ordering) distinct? -- -- This uses Set (as opposed to nub) for better asymptotic time complexity. allDistinct :: Ord a => [a] -> Bool allDistinct = allDistinct' Set.empty where allDistinct' :: Ord a => Set a -> [a] -> Bool allDistinct' uniqs (x:xs) | x `Set.member` uniqs = False | otherwise = allDistinct' (Set.insert x uniqs) xs allDistinct' _ _ = True fst3 :: (a, b, c) -> a fst3 (a, _, _) = a snd3 :: (a, b, c) -> b snd3 (_, b, _) = b trd3 :: (a, b, c) -> c trd3 (_, _, c) = c shrink :: (a, b, c) -> (b, c) shrink (_, b, c) = (b, c) foldBal :: (a -> a -> a) -> a -> [a] -> a {-# INLINE foldBal #-} -- inlined to produce specialised code for each op foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0 where fold_bal op x !n xs = case xs of [] -> x [a] -> a _ -> let !nl = n `div` 2 !nr = n - nl (l,r) = splitAt nl xs in fold_bal op x nl l `op` fold_bal op x nr r isNewtypeVariant :: DatatypeVariant_ -> Bool isNewtypeVariant Datatype_ = False isNewtypeVariant Newtype_ = True isNewtypeVariant (DataInstance_ {}) = False isNewtypeVariant (NewtypeInstance_ {}) = True -- | Indicates whether Generic or Generic1 is being derived. data GenericClass = Generic | Generic1 deriving Enum -- | Records information about the type variables of a data type with a -- 'Generic' or 'Generic1' instance. data GenericTvbs -- | Information about a data type with a 'Generic' instance. = Gen0 { gen0Tvbs :: [TyVarBndrUnit] -- ^ All of the type variable arguments to the data type. } -- | Information about a data type with a 'Generic1' instance. | Gen1 { gen1InitTvbs :: [TyVarBndrUnit] -- ^ All of the type variable arguments to the data type except the -- last one. In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the -- 'gen1InitTvbs' would be @[a_1, ..., a_(n-1)]@. , gen1LastTvbName :: Name -- ^ The name of the last type variable argument to the data type. -- In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the -- 'gen1LastTvbName' name would be @a_n@. , gen1LastTvbKindVar :: Maybe Name -- ^ If the 'gen1LastTvbName' has kind @k@, where @k@ is some kind -- variable, then the 'gen1LastTvbKindVar' is @'Just' k@. Otherwise, -- the 'gen1LastTvbKindVar' is 'Nothing'. } -- | Compute 'GenericTvbs' from a 'GenericClass' and the type variable -- arguments to a data type. mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs mkGenericTvbs gClass tySynVars = case gClass of Generic -> Gen0{gen0Tvbs = freeVariablesWellScoped tySynVars} Generic1 -> Gen1{ gen1InitTvbs = freeVariablesWellScoped initArgs , gen1LastTvbName = varTToName lastArg , gen1LastTvbKindVar = mbLastArgKindName } where -- Everything below is only used for Generic1. initArgs :: [Type] initArgs = init tySynVars lastArg :: Type lastArg = last tySynVars mbLastArgKindName :: Maybe Name mbLastArgKindName = starKindStatusToName $ canRealizeKindStar lastArg -- | Return the type variable arguments to a data type that appear in a -- 'Generic' or 'Generic1' instance. For a 'Generic' instance, this consists of -- all the type variable arguments. For a 'Generic1' instance, this consists of -- all the type variable arguments except for the last one. genericInitTvbs :: GenericTvbs -> [TyVarBndrUnit] genericInitTvbs (Gen0{gen0Tvbs = tvbs}) = tvbs genericInitTvbs (Gen1{gen1InitTvbs = tvbs}) = tvbs -- | A version of 'DatatypeVariant' in which the data family instance -- constructors come equipped with the 'ConstructorInfo' of the first -- constructor in the family instance (for 'Name' generation purposes). data DatatypeVariant_ = Datatype_ | Newtype_ | DataInstance_ ConstructorInfo | NewtypeInstance_ ConstructorInfo showsDatatypeVariant :: DatatypeVariant_ -> ShowS showsDatatypeVariant variant = (++ '_':label) where dataPlain :: String dataPlain = "Plain" dataFamily :: ConstructorInfo -> String dataFamily con = "Family_" ++ sanitizeName (nameBase $ constructorName con) label :: String label = case variant of Datatype_ -> dataPlain Newtype_ -> dataPlain DataInstance_ con -> dataFamily con NewtypeInstance_ con -> dataFamily con showNameQual :: Name -> String showNameQual = sanitizeName . showQual where showQual (Name _ (NameQ m)) = modString m showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m showQual _ = "" -- | Credit to Víctor López Juan for this trick sanitizeName :: String -> String sanitizeName nb = 'N':( nb >>= \x -> case x of c | isAlphaNum c || c == '\''-> [c] '_' -> "__" c -> "_" ++ show (ord c)) -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet). etaReductionError :: Type -> Q a etaReductionError instanceType = fail $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -- | Either the given data type doesn't have enough type variables, or one of -- the type variables to be eta-reduced cannot realize kind *. derivingKindError :: Name -> Q a derivingKindError tyConName = fail . showString "Cannot derive well-kinded instance of form ‘Generic1 " . showParen True ( showString (nameBase tyConName) . showString " ..." ) . showString "‘\n\tClass Generic1 expects an argument of kind " #if MIN_VERSION_base(4,10,0) . showString "k -> *" #else . showString "* -> *" #endif $ "" -- | The data type mentions the last type variable in a place other -- than the last position of a data type in a constructor's field. outOfPlaceTyVarError :: Q a outOfPlaceTyVarError = fail . showString "Constructor must only use its last type variable as" . showString " the last argument of a data type" $ "" -- | The data type mentions the last type variable in a type family -- application. typeFamilyApplicationError :: Q a typeFamilyApplicationError = fail . showString "Constructor must not apply its last type variable" . showString " to an unsaturated type family" $ "" -- | We cannot define implementations for @from(1)@ or @to(1)@ at the term level -- for @type data@ declarations, which only exist at the type level. typeDataError :: Name -> Q a typeDataError dataName = fail . showString "Cannot derive instance for ‘" . showString (nameBase dataName) . showString "‘, which is a ‘type data‘ declaration" $ "" -- | Cannot have a constructor argument of form (forall a1 ... an. ) -- when deriving Generic(1) rankNError :: Q a rankNError = fail "Cannot have polymorphic arguments" -- | Boilerplate for top level splices. -- -- The given Name must meet one of two criteria: -- -- 1. It must be the name of a type constructor of a plain data type or newtype. -- 2. It must be the name of a data family instance or newtype instance constructor. -- -- Any other value will result in an exception. reifyDataInfo :: Name -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)) reifyDataInfo name = do return $ Left $ ns ++ " Could not reify " ++ nameBase name `recover` do DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName , datatypeInstTypes = tys , datatypeVariant = variant , datatypeCons = cons } <- reifyDatatype name variant_ <- case variant of Datatype -> return Datatype_ Newtype -> return Newtype_ DataInstance -> return $ DataInstance_ $ headDataFamInstCon parentName cons NewtypeInstance -> return $ NewtypeInstance_ $ headDataFamInstCon parentName cons #if MIN_VERSION_th_abstraction(0,5,0) Datatype.TypeData -> typeDataError parentName #endif checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_) where ns :: String ns = "Generics.Deriving.TH.reifyDataInfo: " -- This isn't total, but the API requires that the data family instance have -- at least one constructor anyways, so this will always succeed. headDataFamInstCon :: Name -> [ConstructorInfo] -> ConstructorInfo headDataFamInstCon dataFamName cons = case cons of con:_ -> con [] -> error $ "reified data family instance without a data constructor: " ++ nameBase dataFamName -- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts, -- so check to make sure the Cxt field of a datatype is null. checkDataContext :: Name -> Cxt -> a -> Q a checkDataContext _ [] x = return x checkDataContext dataName _ _ = fail $ nameBase dataName ++ " must not have a datatype context" -- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs. checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q () checkExistentialContext constrName vars ctxt = unless (null vars && null ctxt) $ fail $ nameBase constrName ++ " must be a vanilla data constructor" #if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0)) type TyVarBndrVis = TyVarBndrUnit bndrReq :: () bndrReq = () #endif ------------------------------------------------------------------------------- -- Quoted names ------------------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 800 -- With GHC 8.0 or later, we can simply use TemplateHaskellQuotes to quote each -- name. Life is good. comp1DataName :: Name comp1DataName = 'Comp1 infixDataName :: Name infixDataName = 'GD.Infix k1DataName :: Name k1DataName = 'K1 l1DataName :: Name l1DataName = 'L1 leftAssociativeDataName :: Name leftAssociativeDataName = 'LeftAssociative m1DataName :: Name m1DataName = 'M1 notAssociativeDataName :: Name notAssociativeDataName = 'NotAssociative par1DataName :: Name par1DataName = 'Par1 prefixDataName :: Name prefixDataName = 'Prefix productDataName :: Name productDataName = '(:*:) r1DataName :: Name r1DataName = 'R1 rec1DataName :: Name rec1DataName = 'Rec1 rightAssociativeDataName :: Name rightAssociativeDataName = 'RightAssociative u1DataName :: Name u1DataName = 'U1 uAddrDataName :: Name uAddrDataName = 'UAddr uCharDataName :: Name uCharDataName = 'UChar uDoubleDataName :: Name uDoubleDataName = 'UDouble uFloatDataName :: Name uFloatDataName = 'UFloat uIntDataName :: Name uIntDataName = 'UInt uWordDataName :: Name uWordDataName = 'UWord c1TypeName :: Name c1TypeName = ''C1 composeTypeName :: Name composeTypeName = ''(:.:) constructorTypeName :: Name constructorTypeName = ''Constructor d1TypeName :: Name d1TypeName = ''D1 genericTypeName :: Name genericTypeName = ''Generic generic1TypeName :: Name generic1TypeName = ''Generic1 datatypeTypeName :: Name datatypeTypeName = ''Datatype par1TypeName :: Name par1TypeName = ''Par1 productTypeName :: Name productTypeName = ''(:*:) rec0TypeName :: Name rec0TypeName = ''Rec0 rec1TypeName :: Name rec1TypeName = ''Rec1 repTypeName :: Name repTypeName = ''Rep rep1TypeName :: Name rep1TypeName = ''Rep1 s1TypeName :: Name s1TypeName = ''S1 selectorTypeName :: Name selectorTypeName = ''Selector sumTypeName :: Name sumTypeName = ''(:+:) u1TypeName :: Name u1TypeName = ''U1 uAddrTypeName :: Name uAddrTypeName = ''UAddr uCharTypeName :: Name uCharTypeName = ''UChar uDoubleTypeName :: Name uDoubleTypeName = ''UDouble uFloatTypeName :: Name uFloatTypeName = ''UFloat uIntTypeName :: Name uIntTypeName = ''UInt uWordTypeName :: Name uWordTypeName = ''UWord v1TypeName :: Name v1TypeName = ''V1 conFixityValName :: Name conFixityValName = 'conFixity conIsRecordValName :: Name conIsRecordValName = 'conIsRecord conNameValName :: Name conNameValName = 'GD.conName datatypeNameValName :: Name datatypeNameValName = 'GD.datatypeName isNewtypeValName :: Name isNewtypeValName = 'isNewtype fromValName :: Name fromValName = 'from from1ValName :: Name from1ValName = 'from1 moduleNameValName :: Name moduleNameValName = 'moduleName selNameValName :: Name selNameValName = 'selName seqValName :: Name seqValName = 'seq toValName :: Name toValName = 'to to1ValName :: Name to1ValName = 'to1 uAddrHashValName :: Name uAddrHashValName = 'uAddr# uCharHashValName :: Name uCharHashValName = 'uChar# uDoubleHashValName :: Name uDoubleHashValName = 'uDouble# uFloatHashValName :: Name uFloatHashValName = 'uFloat# uIntHashValName :: Name uIntHashValName = 'uInt# uWordHashValName :: Name uWordHashValName = 'uWord# unComp1ValName :: Name unComp1ValName = 'unComp1 unK1ValName :: Name unK1ValName = 'unK1 unPar1ValName :: Name unPar1ValName = 'unPar1 unRec1ValName :: Name unRec1ValName = 'unRec1 trueDataName, falseDataName :: Name trueDataName = 'True falseDataName = 'False nothingDataName, justDataName :: Name nothingDataName = 'Nothing justDataName = 'Just addrHashTypeName :: Name addrHashTypeName = ''Addr# charHashTypeName :: Name charHashTypeName = ''Char# doubleHashTypeName :: Name doubleHashTypeName = ''Double# floatHashTypeName :: Name floatHashTypeName = ''Float# intHashTypeName :: Name intHashTypeName = ''Int# wordHashTypeName :: Name wordHashTypeName = ''Word# composeValName :: Name composeValName = '(.) errorValName :: Name errorValName = 'error fmapValName :: Name fmapValName = 'fmap undefinedValName :: Name undefinedValName = 'undefined decidedLazyDataName :: Name decidedLazyDataName = 'GD.DecidedLazy decidedStrictDataName :: Name decidedStrictDataName = 'GD.DecidedStrict decidedUnpackDataName :: Name decidedUnpackDataName = 'GD.DecidedUnpack infixIDataName :: Name infixIDataName = 'InfixI metaConsDataName :: Name metaConsDataName = 'MetaCons metaDataDataName :: Name metaDataDataName = 'MetaData metaSelDataName :: Name metaSelDataName = 'MetaSel noSourceStrictnessDataName :: Name noSourceStrictnessDataName = 'GD.NoSourceStrictness noSourceUnpackednessDataName :: Name noSourceUnpackednessDataName = 'GD.NoSourceUnpackedness prefixIDataName :: Name prefixIDataName = 'PrefixI sourceLazyDataName :: Name sourceLazyDataName = 'GD.SourceLazy sourceNoUnpackDataName :: Name sourceNoUnpackDataName = 'GD.SourceNoUnpack sourceStrictDataName :: Name sourceStrictDataName = 'GD.SourceStrict sourceUnpackDataName :: Name sourceUnpackDataName = 'GD.SourceUnpack packageNameValName :: Name packageNameValName = 'packageName #else -- On pre-8.0 GHCs, we do not have access to the TemplateHaskellQuotes -- extension, so we construct the Template Haskell names by hand. -- By manually generating these names we avoid needing to use the -- TemplateHaskell language extension when compiling the generic-deriving library. -- This allows the library to be used in stage1 cross-compilers. gdPackageKey :: String # ifdef CURRENT_PACKAGE_KEY gdPackageKey = CURRENT_PACKAGE_KEY # else gdPackageKey = "generic-deriving-" ++ showVersion version # endif mkGD4'4_d :: String -> Name # if MIN_VERSION_base(4,6,0) mkGD4'4_d = mkNameG_d "base" "GHC.Generics" # elif MIN_VERSION_base(4,4,0) mkGD4'4_d = mkNameG_d "ghc-prim" "GHC.Generics" # else mkGD4'4_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" # endif mkGD4'9_d :: String -> Name mkGD4'9_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" mkGD4'4_tc :: String -> Name # if MIN_VERSION_base(4,6,0) mkGD4'4_tc = mkNameG_tc "base" "GHC.Generics" # elif MIN_VERSION_base(4,4,0) mkGD4'4_tc = mkNameG_tc "ghc-prim" "GHC.Generics" # else mkGD4'4_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" # endif mkGD4'9_tc :: String -> Name mkGD4'9_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" mkGD4'4_v :: String -> Name # if MIN_VERSION_base(4,6,0) mkGD4'4_v = mkNameG_v "base" "GHC.Generics" # elif MIN_VERSION_base(4,4,0) mkGD4'4_v = mkNameG_v "ghc-prim" "GHC.Generics" # else mkGD4'4_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" # endif mkGD4'9_v :: String -> Name mkGD4'9_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" mkBaseName_d :: String -> String -> Name mkBaseName_d = mkNameG_d "base" mkGHCPrimName_d :: String -> String -> Name mkGHCPrimName_d = mkNameG_d "ghc-prim" mkGHCPrimName_tc :: String -> String -> Name mkGHCPrimName_tc = mkNameG_tc "ghc-prim" mkGHCPrimName_v :: String -> String -> Name mkGHCPrimName_v = mkNameG_v "ghc-prim" comp1DataName :: Name comp1DataName = mkGD4'4_d "Comp1" infixDataName :: Name infixDataName = mkGD4'4_d "Infix" k1DataName :: Name k1DataName = mkGD4'4_d "K1" l1DataName :: Name l1DataName = mkGD4'4_d "L1" leftAssociativeDataName :: Name leftAssociativeDataName = mkGD4'4_d "LeftAssociative" m1DataName :: Name m1DataName = mkGD4'4_d "M1" notAssociativeDataName :: Name notAssociativeDataName = mkGD4'4_d "NotAssociative" par1DataName :: Name par1DataName = mkGD4'4_d "Par1" prefixDataName :: Name prefixDataName = mkGD4'4_d "Prefix" productDataName :: Name productDataName = mkGD4'4_d ":*:" r1DataName :: Name r1DataName = mkGD4'4_d "R1" rec1DataName :: Name rec1DataName = mkGD4'4_d "Rec1" rightAssociativeDataName :: Name rightAssociativeDataName = mkGD4'4_d "RightAssociative" u1DataName :: Name u1DataName = mkGD4'4_d "U1" uAddrDataName :: Name uAddrDataName = mkGD4'9_d "UAddr" uCharDataName :: Name uCharDataName = mkGD4'9_d "UChar" uDoubleDataName :: Name uDoubleDataName = mkGD4'9_d "UDouble" uFloatDataName :: Name uFloatDataName = mkGD4'9_d "UFloat" uIntDataName :: Name uIntDataName = mkGD4'9_d "UInt" uWordDataName :: Name uWordDataName = mkGD4'9_d "UWord" c1TypeName :: Name c1TypeName = mkGD4'4_tc "C1" composeTypeName :: Name composeTypeName = mkGD4'4_tc ":.:" constructorTypeName :: Name constructorTypeName = mkGD4'4_tc "Constructor" d1TypeName :: Name d1TypeName = mkGD4'4_tc "D1" genericTypeName :: Name genericTypeName = mkGD4'4_tc "Generic" generic1TypeName :: Name generic1TypeName = mkGD4'4_tc "Generic1" datatypeTypeName :: Name datatypeTypeName = mkGD4'4_tc "Datatype" -- This is only used prior to GHC 8.0. noSelectorTypeName :: Name noSelectorTypeName = mkGD4'4_tc "NoSelector" par1TypeName :: Name par1TypeName = mkGD4'4_tc "Par1" productTypeName :: Name productTypeName = mkGD4'4_tc ":*:" rec0TypeName :: Name rec0TypeName = mkGD4'4_tc "Rec0" rec1TypeName :: Name rec1TypeName = mkGD4'4_tc "Rec1" repTypeName :: Name repTypeName = mkGD4'4_tc "Rep" rep1TypeName :: Name rep1TypeName = mkGD4'4_tc "Rep1" s1TypeName :: Name s1TypeName = mkGD4'4_tc "S1" selectorTypeName :: Name selectorTypeName = mkGD4'4_tc "Selector" sumTypeName :: Name sumTypeName = mkGD4'4_tc ":+:" u1TypeName :: Name u1TypeName = mkGD4'4_tc "U1" uAddrTypeName :: Name uAddrTypeName = mkGD4'9_tc "UAddr" uCharTypeName :: Name uCharTypeName = mkGD4'9_tc "UChar" uDoubleTypeName :: Name uDoubleTypeName = mkGD4'9_tc "UDouble" uFloatTypeName :: Name uFloatTypeName = mkGD4'9_tc "UFloat" uIntTypeName :: Name uIntTypeName = mkGD4'9_tc "UInt" uWordTypeName :: Name uWordTypeName = mkGD4'9_tc "UWord" v1TypeName :: Name v1TypeName = mkGD4'4_tc "V1" conFixityValName :: Name conFixityValName = mkGD4'4_v "conFixity" conIsRecordValName :: Name conIsRecordValName = mkGD4'4_v "conIsRecord" conNameValName :: Name conNameValName = mkGD4'4_v "conName" datatypeNameValName :: Name datatypeNameValName = mkGD4'4_v "datatypeName" isNewtypeValName :: Name isNewtypeValName = mkGD4'4_v "isNewtype" fromValName :: Name fromValName = mkGD4'4_v "from" from1ValName :: Name from1ValName = mkGD4'4_v "from1" moduleNameValName :: Name moduleNameValName = mkGD4'4_v "moduleName" selNameValName :: Name selNameValName = mkGD4'4_v "selName" seqValName :: Name seqValName = mkGHCPrimName_v "GHC.Prim" "seq" toValName :: Name toValName = mkGD4'4_v "to" to1ValName :: Name to1ValName = mkGD4'4_v "to1" uAddrHashValName :: Name uAddrHashValName = mkGD4'9_v "uAddr#" uCharHashValName :: Name uCharHashValName = mkGD4'9_v "uChar#" uDoubleHashValName :: Name uDoubleHashValName = mkGD4'9_v "uDouble#" uFloatHashValName :: Name uFloatHashValName = mkGD4'9_v "uFloat#" uIntHashValName :: Name uIntHashValName = mkGD4'9_v "uInt#" uWordHashValName :: Name uWordHashValName = mkGD4'9_v "uWord#" unComp1ValName :: Name unComp1ValName = mkGD4'4_v "unComp1" unK1ValName :: Name unK1ValName = mkGD4'4_v "unK1" unPar1ValName :: Name unPar1ValName = mkGD4'4_v "unPar1" unRec1ValName :: Name unRec1ValName = mkGD4'4_v "unRec1" trueDataName, falseDataName :: Name # if MIN_VERSION_base(4,4,0) trueDataName = mkGHCPrimName_d "GHC.Types" "True" falseDataName = mkGHCPrimName_d "GHC.Types" "False" # else trueDataName = mkGHCPrimName_d "GHC.Bool" "True" falseDataName = mkGHCPrimName_d "GHC.Bool" "False" # endif nothingDataName, justDataName :: Name # if MIN_VERSION_base(4,8,0) nothingDataName = mkBaseName_d "GHC.Base" "Nothing" justDataName = mkBaseName_d "GHC.Base" "Just" # else nothingDataName = mkBaseName_d "Data.Maybe" "Nothing" justDataName = mkBaseName_d "Data.Maybe" "Just" # endif mkGHCPrim_tc :: String -> Name mkGHCPrim_tc = mkNameG_tc "ghc-prim" "GHC.Prim" addrHashTypeName :: Name addrHashTypeName = mkGHCPrim_tc "Addr#" charHashTypeName :: Name charHashTypeName = mkGHCPrim_tc "Char#" doubleHashTypeName :: Name doubleHashTypeName = mkGHCPrim_tc "Double#" floatHashTypeName :: Name floatHashTypeName = mkGHCPrim_tc "Float#" intHashTypeName :: Name intHashTypeName = mkGHCPrim_tc "Int#" wordHashTypeName :: Name wordHashTypeName = mkGHCPrim_tc "Word#" composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." errorValName :: Name errorValName = mkNameG_v "base" "GHC.Err" "error" fmapValName :: Name fmapValName = mkNameG_v "base" "GHC.Base" "fmap" undefinedValName :: Name undefinedValName = mkNameG_v "base" "GHC.Err" "undefined" decidedLazyDataName :: Name decidedLazyDataName = mkGD4'9_d "DecidedLazy" decidedStrictDataName :: Name decidedStrictDataName = mkGD4'9_d "DecidedStrict" decidedUnpackDataName :: Name decidedUnpackDataName = mkGD4'9_d "DecidedUnpack" infixIDataName :: Name infixIDataName = mkGD4'9_d "InfixI" metaConsDataName :: Name metaConsDataName = mkGD4'9_d "MetaCons" metaDataDataName :: Name metaDataDataName = mkGD4'9_d "MetaData" metaSelDataName :: Name metaSelDataName = mkGD4'9_d "MetaSel" noSourceStrictnessDataName :: Name noSourceStrictnessDataName = mkGD4'9_d "NoSourceStrictness" noSourceUnpackednessDataName :: Name noSourceUnpackednessDataName = mkGD4'9_d "NoSourceUnpackedness" prefixIDataName :: Name prefixIDataName = mkGD4'9_d "PrefixI" sourceLazyDataName :: Name sourceLazyDataName = mkGD4'9_d "SourceLazy" sourceNoUnpackDataName :: Name sourceNoUnpackDataName = mkGD4'9_d "SourceNoUnpack" sourceStrictDataName :: Name sourceStrictDataName = mkGD4'9_d "SourceStrict" sourceUnpackDataName :: Name sourceUnpackDataName = mkGD4'9_d "SourceUnpack" packageNameValName :: Name packageNameValName = mkGD4'4_v "packageName" #endif generic-deriving-1.14.5/src/Generics/Deriving/TH/Post4_9.hs0000644000000000000000000001163707346545000021431 0ustar0000000000000000{- | Module : Generics.Deriving.TH.Post4_9 Copyright : (c) 2008--2009 Universiteit Utrecht License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Template Haskell machinery for the type-literal-based variant of GHC generics introduced in @base-4.9@. -} module Generics.Deriving.TH.Post4_9 ( deriveMeta , deriveData , deriveConstructors , deriveSelectors , mkMetaDataType , mkMetaConsType , mkMetaSelType , SelStrictInfo(..) , reifySelStrictInfo ) where import Data.Maybe (fromMaybe) import Generics.Deriving.TH.Internal import Language.Haskell.TH.Datatype as THAbs import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type mkMetaDataType dv n = promotedT metaDataDataName `appT` litT (strTyLit (nameBase n)) `appT` litT (strTyLit m) `appT` litT (strTyLit pkg) `appT` promoteBool (isNewtypeVariant dv) where m, pkg :: String m = fromMaybe (error "Cannot fetch module name!") (nameModule n) pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type mkMetaConsType _ _ n conIsRecord conIsInfix = do mbFi <- reifyFixity n promotedT metaConsDataName `appT` litT (strTyLit (nameBase n)) `appT` fixityIPromotedType mbFi conIsInfix `appT` promoteBool conIsRecord promoteBool :: Bool -> Q Type promoteBool True = promotedT trueDataName promoteBool False = promotedT falseDataName fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type fixityIPromotedType mbFi True = promotedT infixIDataName `appT` promoteAssociativity a `appT` litT (numTyLit (toInteger n)) where Fixity n a = fromMaybe defaultFixity mbFi fixityIPromotedType _ False = promotedT prefixIDataName promoteAssociativity :: FixityDirection -> Q Type promoteAssociativity InfixL = promotedT leftAssociativeDataName promoteAssociativity InfixR = promotedT rightAssociativeDataName promoteAssociativity InfixN = promotedT notAssociativeDataName mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) = let mbSelNameT = case mbF of Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f)) Nothing -> promotedT nothingDataName in promotedT metaSelDataName `appT` mbSelNameT `appT` promoteUnpackedness su `appT` promoteStrictness ss `appT` promoteDecidedStrictness ds data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness promoteUnpackedness :: Unpackedness -> Q Type promoteUnpackedness UnspecifiedUnpackedness = promotedT noSourceUnpackednessDataName promoteUnpackedness NoUnpack = promotedT sourceNoUnpackDataName promoteUnpackedness Unpack = promotedT sourceUnpackDataName promoteStrictness :: Strictness -> Q Type promoteStrictness UnspecifiedStrictness = promotedT noSourceStrictnessDataName promoteStrictness Lazy = promotedT sourceLazyDataName promoteStrictness THAbs.Strict = promotedT sourceStrictDataName promoteDecidedStrictness :: DecidedStrictness -> Q Type promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo] reifySelStrictInfo conName fs = do dcdStrs <- reifyConStrictness conName let srcUnpks = map fieldUnpackedness fs srcStrs = map fieldStrictness fs return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' -- instances. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveMeta :: Name -> Q [Dec] deriveMeta _ = return [] -- | Given a datatype name, derive a datatype and instance of class 'Datatype'. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveData :: Name -> Q [Dec] deriveData _ = return [] -- | Given a datatype name, derive datatypes and -- instances of class 'Constructor'. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveConstructors :: Name -> Q [Dec] deriveConstructors _ = return [] -- | Given a datatype name, derive datatypes and instances of class 'Selector'. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveSelectors :: Name -> Q [Dec] deriveSelectors _ = return [] generic-deriving-1.14.5/src/Generics/Deriving/TH/Pre4_9.hs0000644000000000000000000001662507346545000021234 0ustar0000000000000000{-# 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) generic-deriving-1.14.5/src/Generics/Deriving/Traversable.hs0000644000000000000000000001447207346545000022127 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Traversable ( -- * Generic Traversable class GTraversable(..) -- * Default method , gtraversedefault -- * Internal Traversable class , GTraversable'(..) ) where import Control.Applicative (Const, WrappedMonad(..), ZipList) #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative(..), (<$>)) #endif import qualified Data.Monoid as Monoid (First, Last, Product, Sum) import Data.Monoid (Dual) import Generics.Deriving.Base import Generics.Deriving.Foldable import Generics.Deriving.Functor #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down) #else import GHC.Exts (Down) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic traverse -------------------------------------------------------------------------------- class GTraversable' t where gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b) instance GTraversable' V1 where gtraverse' _ x = pure $ case x of #if __GLASGOW_HASKELL__ >= 708 {} #else !_ -> error "Void gtraverse" #endif instance GTraversable' U1 where gtraverse' _ U1 = pure U1 instance GTraversable' Par1 where gtraverse' f (Par1 a) = Par1 <$> f a instance GTraversable' (K1 i c) where gtraverse' _ (K1 a) = pure (K1 a) instance (GTraversable f) => GTraversable' (Rec1 f) where gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a instance (GTraversable' f) => GTraversable' (M1 i c f) where gtraverse' f (M1 a) = M1 <$> gtraverse' f a instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where gtraverse' f (L1 a) = L1 <$> gtraverse' f a gtraverse' f (R1 a) = R1 <$> gtraverse' f a instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x instance GTraversable' UAddr where gtraverse' _ (UAddr a) = pure (UAddr a) instance GTraversable' UChar where gtraverse' _ (UChar c) = pure (UChar c) instance GTraversable' UDouble where gtraverse' _ (UDouble d) = pure (UDouble d) instance GTraversable' UFloat where gtraverse' _ (UFloat f) = pure (UFloat f) instance GTraversable' UInt where gtraverse' _ (UInt i) = pure (UInt i) instance GTraversable' UWord where gtraverse' _ (UWord w) = pure (UWord w) class (GFunctor t, GFoldable t) => GTraversable t where gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b) #if __GLASGOW_HASKELL__ >= 701 default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) => (a -> f b) -> t a -> f (t b) gtraverse = gtraversedefault #endif gsequenceA :: Applicative f => t (f a) -> f (t a) gsequenceA = gtraverse id gmapM :: Monad m => (a -> m b) -> t a -> m (t b) gmapM f = unwrapMonad . gtraverse (WrapMonad . f) gsequence :: Monad m => t (m a) -> m (t a) gsequence = gmapM id gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) => (a -> f b) -> t a -> f (t b) gtraversedefault f x = to1 <$> gtraverse' f (from1 x) -- Base types instances instance GTraversable ((,) a) where gtraverse = gtraversedefault instance GTraversable [] where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable (Arg a) where gtraverse = gtraversedefault #endif #if MIN_VERSION_base(4,4,0) instance GTraversable Complex where gtraverse = gtraversedefault #endif instance GTraversable (Const m) where gtraverse = gtraversedefault instance GTraversable Down where gtraverse = gtraversedefault instance GTraversable Dual where gtraverse = gtraversedefault instance GTraversable (Either a) where gtraverse = gtraversedefault instance GTraversable Monoid.First where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable (Semigroup.First) where gtraverse = gtraversedefault #endif #if MIN_VERSION_base(4,8,0) instance GTraversable Identity where gtraverse = gtraversedefault #endif instance GTraversable Monoid.Last where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable Semigroup.Last where gtraverse = gtraversedefault instance GTraversable Max where gtraverse = gtraversedefault #endif instance GTraversable Maybe where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable Min where gtraverse = gtraversedefault instance GTraversable NonEmpty where gtraverse = gtraversedefault #endif instance GTraversable Monoid.Product where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where gtraverse = gtraversedefault #endif #if MIN_VERSION_base(4,7,0) instance GTraversable Proxy where gtraverse = gtraversedefault #endif instance GTraversable Monoid.Sum where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where gtraverse = gtraversedefault instance GTraversable WrappedMonoid where gtraverse = gtraversedefault #endif instance GTraversable ZipList where gtraverse = gtraversedefault generic-deriving-1.14.5/src/Generics/Deriving/Uniplate.hs0000644000000000000000000002437007346545000021434 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ < 709 {-# LANGUAGE OverlappingInstances #-} #endif {- | Module : Generics.Deriving.Uniplate Copyright : 2011-2012 Universiteit Utrecht, University of Oxford License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Summary: Functions inspired by the Uniplate generic programming library, mostly implemented by Sean Leather. -} module Generics.Deriving.Uniplate ( -- * Generic Uniplate class Uniplate(..) -- * Derived functions , uniplate , universe , rewrite , rewriteM , contexts , holes , para -- * Default definitions , childrendefault , contextdefault , descenddefault , descendMdefault , transformdefault , transformMdefault -- * Internal Uniplate class , Uniplate'(..) -- * Internal Context class , Context'(..) ) where import Generics.Deriving.Base import Control.Monad (liftM, liftM2) import GHC.Exts (build) -------------------------------------------------------------------------------- -- Generic Uniplate -------------------------------------------------------------------------------- class Uniplate' f b where children' :: f a -> [b] descend' :: (b -> b) -> f a -> f a descendM' :: Monad m => (b -> m b) -> f a -> m (f a) transform' :: (b -> b) -> f a -> f a transformM' :: Monad m => (b -> m b) -> f a -> m (f a) instance Uniplate' U1 a where children' U1 = [] descend' _ U1 = U1 descendM' _ U1 = return U1 transform' _ U1 = U1 transformM' _ U1 = return U1 instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPING #-} #endif (Uniplate a) => Uniplate' (K1 i a) a where children' (K1 a) = [a] descend' f (K1 a) = K1 (f a) descendM' f (K1 a) = liftM K1 (f a) transform' f (K1 a) = K1 (transform f a) transformM' f (K1 a) = liftM K1 (transformM f a) instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPABLE #-} #endif Uniplate' (K1 i a) b where children' (K1 _) = [] descend' _ (K1 a) = K1 a descendM' _ (K1 a) = return (K1 a) transform' _ (K1 a) = K1 a transformM' _ (K1 a) = return (K1 a) instance (Uniplate' f b) => Uniplate' (M1 i c f) b where children' (M1 a) = children' a descend' f (M1 a) = M1 (descend' f a) descendM' f (M1 a) = liftM M1 (descendM' f a) transform' f (M1 a) = M1 (transform' f a) transformM' f (M1 a) = liftM M1 (transformM' f a) instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where children' (L1 a) = children' a children' (R1 a) = children' a descend' f (L1 a) = L1 (descend' f a) descend' f (R1 a) = R1 (descend' f a) descendM' f (L1 a) = liftM L1 (descendM' f a) descendM' f (R1 a) = liftM R1 (descendM' f a) transform' f (L1 a) = L1 (transform' f a) transform' f (R1 a) = R1 (transform' f a) transformM' f (L1 a) = liftM L1 (transformM' f a) transformM' f (R1 a) = liftM R1 (transformM' f a) instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where children' (a :*: b) = children' a ++ children' b descend' f (a :*: b) = descend' f a :*: descend' f b descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b) transform' f (a :*: b) = transform' f a :*: transform' f b transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b) -- Context' is a separate class from Uniplate' since it uses special product -- instances, but the context function still appears in Uniplate. class Context' f b where context' :: f a -> [b] -> f a instance Context' U1 b where context' U1 _ = U1 instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPING #-} #endif Context' (K1 i a) a where context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" context' (K1 _) (c:_) = K1 c instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPABLE #-} #endif Context' (K1 i a) b where context' (K1 a) _ = K1 a instance (Context' f b) => Context' (M1 i c f) b where context' (M1 a) cs = M1 (context' a cs) instance (Context' f b, Context' g b) => Context' (f :+: g) b where context' (L1 a) cs = L1 (context' a cs) context' (R1 a) cs = R1 (context' a cs) instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPING #-} #endif (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPABLE #-} #endif (Context' g b) => Context' (f :*: g) b where context' (a :*: b) cs = a :*: context' b cs class Uniplate a where children :: a -> [a] #if __GLASGOW_HASKELL__ >= 701 default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] children = childrendefault #endif context :: a -> [a] -> a #if __GLASGOW_HASKELL__ >= 701 default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a context = contextdefault #endif descend :: (a -> a) -> a -> a #if __GLASGOW_HASKELL__ >= 701 default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a descend = descenddefault #endif descendM :: Monad m => (a -> m a) -> a -> m a #if __GLASGOW_HASKELL__ >= 701 default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a descendM = descendMdefault #endif transform :: (a -> a) -> a -> a #if __GLASGOW_HASKELL__ >= 701 default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a transform = transformdefault #endif transformM :: Monad m => (a -> m a) -> a -> m a #if __GLASGOW_HASKELL__ >= 701 default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a transformM = transformMdefault #endif childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] childrendefault = children' . from contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a contextdefault x cs = to (context' (from x) cs) descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a descenddefault f = to . descend' f . from descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a descendMdefault f = liftM to . descendM' f . from transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a transformdefault f = f . to . transform' f . from transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a transformMdefault f = liftM to . transformM' f . from -- Derived functions (mostly copied from Neil Michell's code) uniplate :: Uniplate a => a -> ([a], [a] -> a) uniplate a = (children a, context a) universe :: Uniplate a => a -> [a] universe a = build (go a) where go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x rewrite :: Uniplate a => (a -> Maybe a) -> a -> a rewrite f = transform g where g x = maybe x (rewrite f) (f x) rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a rewriteM f = transformM g where g x = f x >>= maybe (return x) (rewriteM f) contexts :: Uniplate a => a -> [(a, a -> a)] contexts a = (a, id) : f (holes a) where f xs = [ (ch2, ctx1 . ctx2) | (ch1, ctx1) <- xs , (ch2, ctx2) <- contexts ch1] holes :: Uniplate a => a -> [(a, a -> a)] holes a = uncurry f (uniplate a) where f [] _ = [] f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) para :: Uniplate a => (a -> [r] -> r) -> a -> r para f x = f x $ map (para f) $ children x -- Base types instances instance Uniplate Bool where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Char where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Double where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Float where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Int where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate () where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return -- Tuple instances instance Uniplate (b,c) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e,f) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e,f,g) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e,f,g,h) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return -- Parameterized type instances instance Uniplate (Maybe a) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (Either a b) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate [a] where children [] = [] children (_:t) = [t] context _ [] = error "Generics.Deriving.Uniplate.context: empty list" context [] _ = [] context (h:_) (t:_) = h:t descend _ [] = [] descend f (h:t) = h:f t descendM _ [] = return [] descendM f (h:t) = f t >>= \t' -> return (h:t') transform f [] = f [] transform f (h:t) = f (h:transform f t) transformM f [] = f [] transformM f (h:t) = transformM f t >>= \t' -> f (h:t') generic-deriving-1.14.5/tests/0000755000000000000000000000000007346545000014356 5ustar0000000000000000generic-deriving-1.14.5/tests/DefaultSpec.hs0000644000000000000000000001272607346545000017121 0ustar0000000000000000-- | -- Module : DefaultSpec -- Description : Ensure that deriving via (Default a) newtype works -- License : BSD-3-Clause -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable -- -- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on -- versions below. -- -- The test check a miscellany of properties of the derived type classes. -- (Testing all the required properties is beyond the scope of this module.) {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} #endif module DefaultSpec where import Test.Hspec #if __GLASGOW_HASKELL__ >= 806 import Test.Hspec.QuickCheck import Data.Semigroup (First(..)) import Data.Foldable (sequenceA_) import Generics.Deriving hiding (universe) import Generics.Deriving.Default () import Generics.Deriving.Foldable (GFoldable(..)) import Generics.Deriving.Semigroup (GSemigroup(..)) #endif spec :: Spec spec = do describe "DerivingVia Default" $ do #if __GLASGOW_HASKELL__ >= 806 it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $ let commutative :: GEq a => a -> a -> Expectation commutative x y = x `geq` y `shouldBe` y `geq` x universe :: [MyType] universe = MyType <$> [False, True] in commutative <$> universe <*> universe it "GShow for MyType is like Show for Bool with derivingVia (Default MyType) but prefixed with 'MyType '" $ do gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False "" gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True "" it "GEq is commutative for parameterized derivingVia (Default (MyType1 Bool))" . sequenceA_ $ let commutative :: GEq a => a -> a -> Expectation commutative x y = x `geq` y `shouldBe` y `geq` x universe :: [MyType1 Bool] universe = MyType1 <$> [False, True] in commutative <$> universe <*> universe it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default (MyType1 Bool)) but prefixed with 'MyType1 '" $ do gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0 False "" gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True "" it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $ let commutative :: GEq a => a -> a -> Expectation commutative x y = x `geq` y `shouldBe` y `geq` x universe :: [TestEq] universe = TestEq <$> [False, True] in commutative <$> universe <*> universe it "GENum is correct for derivingVia (Default Bool)" $ genum `shouldBe` [TestEnum False, TestEnum True] it "GShow for TestShow is the same as Show for Bool with derivingVia (Default Bool)" $ do gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False "" gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True "" it "GSemigroup is like First when instantiated with derivingVia (First Bool)" . sequenceA_ $ let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation first' x y = x `gsappend` y `shouldBe` x universe :: [FirstSemigroup] universe = FirstSemigroup <$> [False, True] in first' <$> universe <*> universe prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with Maybe (First Bool)" $ \(xs :: [Maybe Bool]) -> let ys :: [Maybe (First Bool)] -- Note that there is no Arbitrary instance for this type ys = fmap First <$> xs unTestFoldable :: TestFoldable a -> Maybe a unTestFoldable (TestFoldable x) = x in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" . sequenceA_ $ let universe :: [Maybe Bool] universe = [Nothing, Just False, Just True] functor_prop :: Maybe Bool -> Expectation functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor (not <$> x) in functor_prop <$> universe #endif return () #if __GLASGOW_HASKELL__ >= 806 -- These types all implement instances using `DerivingVia`: most via -- `Default` (one uses `First`). newtype TestEq = TestEq Bool deriving (GEq) via (Default Bool) newtype TestEnum = TestEnum Bool deriving stock (Eq, Show) deriving (GEnum) via (Default Bool) newtype TestShow = TestShow Bool deriving (GShow) via (Default Bool) newtype FirstSemigroup = FirstSemigroup Bool deriving stock (Eq, Show) deriving (GSemigroup) via (First Bool) newtype TestFoldable a = TestFoldable (Maybe a) deriving (GFoldable) via (Default1 Maybe) newtype TestFunctor a = TestFunctor (Maybe a) deriving stock (Eq, Show, Functor) deriving (GFunctor) via (Default1 Maybe) newtype TestHigherEq a = TestHigherEq (Maybe a) deriving stock (Generic) deriving (GEq) via (Default (TestHigherEq a)) -- These types correspond to the hypothetical examples in the module -- documentation. data MyType = MyType Bool deriving (Generic) deriving (GEq) via (Default MyType) deriving via (Default MyType) instance GShow MyType data MyType1 a = MyType1 a deriving (Generic, Generic1) deriving (GEq) via (Default (MyType1 a)) deriving (GFunctor) via (Default1 MyType1) deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a) deriving via (Default1 MyType1) instance GFoldable MyType1 #endif generic-deriving-1.14.5/tests/EmptyCaseSpec.hs0000644000000000000000000000100207346545000017410 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DataKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif module EmptyCaseSpec (main, spec) where import Generics.Deriving.TH import Test.Hspec data Empty a $(deriveAll0And1Options defaultOptions{emptyCaseOptions = True} ''Empty) main :: IO () main = hspec spec spec :: Spec spec = return () generic-deriving-1.14.5/tests/ExampleSpec.hs0000644000000000000000000003261707346545000017131 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} module ExampleSpec (main, spec) where import Generics.Deriving import Generics.Deriving.TH import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) import Prelude hiding (Either(..)) import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) import qualified Text.Read.Lex (Lexeme) ------------------------------------------------------------------------------- -- Example: Haskell's lists and Maybe ------------------------------------------------------------------------------- hList:: [Int] hList = [1..10] maybe1, maybe2 :: Maybe (Maybe Char) maybe1 = Nothing maybe2 = Just (Just 'p') double :: [Int] -> [Int] double [] = [] double (x:xs) = x:x:xs ------------------------------------------------------------------------------- -- Example: trees of integers (kind *) ------------------------------------------------------------------------------- data Tree = Empty | Branch Int Tree Tree $(deriveAll0 ''Tree) instance GShow Tree where gshowsPrec = gshowsPrecdefault instance Uniplate Tree where children = childrendefault context = contextdefault descend = descenddefault descendM = descendMdefault transform = transformdefault transformM = transformMdefault instance GEnum Tree where genum = genumDefault upgradeTree :: Tree -> Tree upgradeTree Empty = Branch 0 Empty Empty upgradeTree (Branch n l r) = Branch (succ n) l r tree :: Tree tree = Branch 2 Empty (Branch 1 Empty Empty) ------------------------------------------------------------------------------- -- Example: lists (kind * -> *) ------------------------------------------------------------------------------- data List a = Nil | Cons a (List a) $(deriveAll0And1 ''List) instance GFunctor List where gmap = gmapdefault instance (GShow a) => GShow (List a) where gshowsPrec = gshowsPrecdefault instance (Uniplate a) => Uniplate (List a) where children = childrendefault context = contextdefault descend = descenddefault descendM = descendMdefault transform = transformdefault transformM = transformMdefault list :: List Char list = Cons 'p' (Cons 'q' Nil) listlist :: List (List Char) listlist = Cons list (Cons Nil Nil) -- ["pq",""] ------------------------------------------------------------------------------- -- Example: Type composition ------------------------------------------------------------------------------- data Rose a = Rose [a] [Rose a] $(deriveAll0And1 ''Rose) instance (GShow a) => GShow (Rose a) where gshowsPrec = gshowsPrecdefault instance GFunctor Rose where gmap = gmapdefault -- Example usage rose1 :: Rose Int rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []] ------------------------------------------------------------------------------- -- Example: Higher-order kinded datatype, type composition ------------------------------------------------------------------------------- data GRose f a = GRose (f a) (f (GRose f a)) deriving instance Functor f => Functor (GRose f) $(deriveMeta ''GRose) $(deriveRepresentable0 ''GRose) $(deriveRep1 ''GRose) instance Functor f => Generic1 (GRose f) where type Rep1 (GRose f) = $(makeRep1 ''GRose) f from1 = $(makeFrom1 ''GRose) to1 = $(makeTo1 ''GRose) instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where gshowsPrec = gshowsPrecdefault instance (Functor f, GFunctor f) => GFunctor (GRose f) where gmap = gmapdefault grose1 :: GRose [] Int grose1 = GRose [1,2] [GRose [3] [], GRose [] []] ------------------------------------------------------------------------------- -- Example: Two parameters, nested on other parameter ------------------------------------------------------------------------------- data Either a b = Left (Either [a] b) | Right b $(deriveAll0And1 ''Either) instance (GShow a, GShow b) => GShow (Either a b) where gshowsPrec = gshowsPrecdefault instance GFunctor (Either a) where gmap = gmapdefault either1 :: Either Int Char either1 = Left either2 either2 :: Either [Int] Char either2 = Right 'p' ------------------------------------------------------------------------------- -- Example: Nested datatype, record selectors ------------------------------------------------------------------------------- data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] } deriving Functor $(deriveAll0And1 ''Nested) instance (GShow a) => GShow (Nested a) where gshowsPrec = gshowsPrecdefault instance GFunctor Nested where gmap = gmapdefault nested :: Nested Int nested = Nested { value = 1, rec = Nested [2] (Nested [[3],[4,5],[]] Leaf) } ------------------------------------------------------------------------------- -- Example: Nested datatype Bush (minimal) ------------------------------------------------------------------------------- data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor $(deriveAll0And1 ''Bush) instance GFunctor Bush where gmap = gmapdefault instance (GShow a) => GShow (Bush a) where gshowsPrec = gshowsPrecdefault bush1 :: Bush Int bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil) ------------------------------------------------------------------------------- -- Example: Double type composition (minimal) ------------------------------------------------------------------------------- data Weird a = Weird [[[a]]] deriving Show $(deriveAll0And1 ''Weird) instance GFunctor Weird where gmap = gmapdefault -------------------------------------------------------------------------------- -- Temporary tests for TH generation -------------------------------------------------------------------------------- data Empty a data (:/:) f a = MyType1Nil | MyType1Cons { _myType1Rec :: (f :/: a), _myType2Rec :: MyType2 } | MyType1Cons2 (f :/: a) Int a (f a) | (f :/: a) :/: MyType2 infixr 5 :!@!: data GADTSyntax a b where GADTPrefix :: d -> c -> GADTSyntax c d (:!@!:) :: e -> f -> GADTSyntax e f data MyType2 = MyType2 Float ([] :/: Int) data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word# -- Test to see if generated names are unique data Lexeme = Lexeme #if MIN_VERSION_template_haskell(2,7,0) data family MyType3 # if __GLASGOW_HASKELL__ >= 705 (a :: v) (b :: w) (c :: x) (d :: y) (e :: z) # else (a :: *) (b :: *) (c :: * -> *) (d :: *) (e :: *) # endif newtype instance MyType3 (f p) (f p) f p (q :: *) = MyType3Newtype q data instance MyType3 Bool () f p q = MyType3True | MyType3False data instance MyType3 Int () f p (q :: *) = MyType3Hash q Addr# Char# Double# Float# Int# Word# #endif $(deriveAll0And1 ''Empty) $(deriveAll0And1 ''(:/:)) $(deriveAll0And1 ''GADTSyntax) $(deriveAll0 ''MyType2) $(deriveAll0And1 ''PlainHash) $(deriveAll0 ''ExampleSpec.Lexeme) $(deriveAll0 ''Text.Read.Lex.Lexeme) #if MIN_VERSION_template_haskell(2,7,0) # if __GLASGOW_HASKELL__ < 705 -- We can't use deriveAll0And1 on GHC 7.4 due to an old bug :( $(deriveMeta 'MyType3Newtype) $(deriveRep0 'MyType3Newtype) $(deriveRep1 'MyType3Newtype) instance Generic (MyType3 (f p) (f p) f p q) where type Rep (MyType3 (f p) (f p) f p q) = $(makeRep0 'MyType3Newtype) f p q from = $(makeFrom0 'MyType3Newtype) to = $(makeTo0 'MyType3Newtype) instance Generic1 (MyType3 (f p) (f p) f p) where type Rep1 (MyType3 (f p) (f p) f p) = $(makeRep1 'MyType3Newtype) f p from1 = $(makeFrom1 'MyType3Newtype) to1 = $(makeTo1 'MyType3Newtype) # else $(deriveAll0And1 'MyType3Newtype) # endif $(deriveAll0And1 'MyType3False) $(deriveAll0And1 'MyType3Hash) #endif ------------------------------------------------------------------------------- -- Unit tests ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = parallel $ do describe "[] and Maybe tests" $ do it "gshow hList" $ gshow hList `shouldBe` "[1,2,3,4,5,6,7,8,9,10]" it "gshow (children maybe2)" $ gshow (children maybe2) `shouldBe` "[]" it "gshow (transform (const \"abc\") [])" $ gshow (transform (const "abc") []) `shouldBe` "\"abc\"" it "gshow (transform double hList)" $ gshow (transform double hList) `shouldBe` "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]" it "gshow (geq hList hList)" $ gshow (geq hList hList) `shouldBe` "True" it "gshow (geq maybe1 maybe2)" $ gshow (geq maybe1 maybe2) `shouldBe` "False" it "gshow (take 5 genum)" $ gshow (take 5 (genum :: [Maybe Int])) `shouldBe` "[Nothing,Just 0,Just -1,Just 1,Just -2]" it "gshow (take 15 genum)" $ gshow (take 15 (genum :: [[Int]])) `shouldBe` "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]" it "gshow (range ([0], [1]))" $ gshow (range ([0], [1::Int])) `shouldBe` "[[0],[0,0],[-1],[0,0,0],[-1,0]]" it "gshow (inRange ([0], [3,5]) hList)" $ gshow (inRange ([0], [3,5::Int]) hList) `shouldBe` "False" describe "Tests for Tree" $ do it "gshow tree" $ gshow tree `shouldBe` "Branch 2 Empty (Branch 1 Empty Empty)" it "gshow (children tree)" $ gshow (children tree) `shouldBe` "[Empty,Branch 1 Empty Empty]" it "gshow (descend (descend (\\_ -> Branch 0 Empty Empty)) tree)" $ gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) `shouldBe` "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" it "gshow (context tree [Branch 1 Empty Empty,Empty])" $ gshow (context tree [Branch 1 Empty Empty,Empty]) `shouldBe` "Branch 2 (Branch 1 Empty Empty) Empty" it "gshow (transform upgradeTree tree)" $ gshow (transform upgradeTree tree) `shouldBe` "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" it "gshow (take 10 genum)" $ do gshow (take 10 (genum :: [Tree])) `shouldBe` "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]" describe "Tests for List" $ do it "gshow (gmap fromEnum list)" $ gshow (gmap fromEnum list) `shouldBe` "Cons 112 (Cons 113 Nil)" it "gshow (gmap gshow listlist)" $ gshow (gmap gshow listlist) `shouldBe` "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)" it "gshow list" $ gshow list `shouldBe` "Cons 'p' (Cons 'q' Nil)" it "gshow listlist" $ gshow listlist `shouldBe` "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)" it "gshow (children list)" $ gshow (children list) `shouldBe` "[Cons 'q' Nil]" it "gshow (children listlist)" $ gshow (children listlist) `shouldBe` "[Cons Nil Nil]" describe "Tests for Rose" $ do it "gshow rose1" $ gshow rose1 `shouldBe` "Rose [1,2] [Rose [3,4] [],Rose [5] []]" it "gshow (gmap gshow rose1)" $ gshow (gmap gshow rose1) `shouldBe` "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]" describe "Tests for GRose" $ do it "gshow grose1" $ gshow grose1 `shouldBe` "GRose [1,2] [GRose [3] [],GRose [] []]" it "gshow (gmap gshow grose1)" $ gshow (gmap gshow grose1) `shouldBe` "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]" describe "Tests for Either" $ do it "gshow either1" $ gshow either1 `shouldBe` "Left Right 'p'" it "gshow (gmap gshow either1)" $ gshow (gmap gshow either1) `shouldBe` "Left Right \"'p'\"" describe "Tests for Nested" $ do it "gshow nested" $ gshow nested `shouldBe` "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}" it "gshow (gmap gshow nested)" $ gshow (gmap gshow nested) `shouldBe` "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}" describe "Tests for Bush" $ do it "gshow bush1" $ gshow bush1 `shouldBe` "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)" it "gshow (gmap gshow bush1)" $ gshow (gmap gshow bush1) `shouldBe` "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)" generic-deriving-1.14.5/tests/Spec.hs0000644000000000000000000000005407346545000015603 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} generic-deriving-1.14.5/tests/T68Spec.hs0000644000000000000000000000061407346545000016107 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DataKinds #-} #endif module T68Spec (main, spec) where import Generics.Deriving.TH import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = return () type family F68 :: * -> * type instance F68 = Maybe data T68 a = MkT68 (F68 a) $(deriveAll1 ''T68) generic-deriving-1.14.5/tests/T80Spec.hs0000644000000000000000000000056407346545000016105 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} #endif module T80Spec (main, spec) where import Generics.Deriving.TH import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = return () newtype T f a b = MkT (f a b) $(deriveAll1 ''T) generic-deriving-1.14.5/tests/T82Spec.hs0000644000000000000000000000103107346545000016075 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} # if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} # endif #endif module T82Spec (main, spec) where import Test.Hspec #if MIN_VERSION_base(4,10,0) import Generics.Deriving.TH import GHC.Exts (RuntimeRep, TYPE) data Code m (a :: TYPE (r :: RuntimeRep)) = Code $(deriveAll0And1 ''Code) #endif main :: IO () main = hspec spec spec :: Spec spec = return () generic-deriving-1.14.5/tests/TypeInTypeSpec.hs0000644000000000000000000000274407346545000017606 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} # if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} # endif #endif module TypeInTypeSpec (main, spec) where import Test.Hspec #if __GLASGOW_HASKELL__ >= 800 import Data.Proxy (Proxy(..)) import Generics.Deriving.TH # if MIN_VERSION_base(4,10,0) import Generics.Deriving (Generic1(..)) # endif data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b) $(deriveAll0And1 ''TyCon) data family TyFam x (a :: x) (b :: k) data instance TyFam x (a :: x) (b :: k) = TyFam k x (Proxy a) (TyFam x a b) $(deriveAll0And1 'TyFam) # if MIN_VERSION_base(4,10,0) gen1PolyKinds :: Generic1 f => f 'True -> Rep1 f 'True gen1PolyKinds = from1 # endif #endif main :: IO () main = hspec spec spec :: Spec spec = parallel $ do #if MIN_VERSION_base(4,10,0) describe "TyCon Bool 'False 'True" $ it "has an appropriately kinded Generic1 instance" $ let rep :: Rep1 (TyCon Bool 'False) 'True rep = gen1PolyKinds $ let x = TyCon True False Proxy x in x in seq rep () `shouldBe` () describe "TyFam Bool 'False 'True" $ it "has an appropriately kinded Generic1 instance" $ let rep :: Rep1 (TyFam Bool 'False) 'True rep = gen1PolyKinds $ let x = TyFam True False Proxy x in x in seq rep () `shouldBe` () #else return () #endif