generic-deriving-1.14.6/0000755000000000000000000000000007346545000013215 5ustar0000000000000000generic-deriving-1.14.6/CHANGELOG.md0000644000000000000000000002626307346545000015037 0ustar0000000000000000# 1.14.6 [2024.12.05] * Drop support for GHC 7.10 and earlier. # 1.14.5 [2023.08.06] * Support building with `template-haskell-2.21.*` (GHC 9.8). * The Template Haskell machinery now uses `TemplateHaskellQuotes` when building with GHC 8.0+ instead of manually constructing each Template Haskell `Name`. A consequence of this is that `generic-deriving` will now build with GHC 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template Haskell changes introduced in 9.8. # 1.14.4 [2023.04.30] * Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined, such as the WASM backend. * Place `INLINE [1]` pragmas on `from` and `to` implementations when types don't have too many constructors or fields, following the heuristics that GHC 9.2+ uses for `Generic` deriving. # 1.14.3 [2023.02.27] * Support `th-abstraction-0.5.*`. # 1.14.2 [2022.07.23] * Fix a bug in which `deriveAll1` could generate ill kinded code when using `kindSigOptions=False`, or when using GHC 8.0 or earlier. * Fix a bug in which `deriveAll1` would reject data types whose last type variable has a kind besides `Type` or `k` on GHC 8.2 or later. # 1.14.1 [2021.08.30] * Backport the `Generic(1)` instances introduced for tuples (8 through 15) in `base-4.16`. * Make the test suite compile on GHC 9.2 or later. * Always import `Data.List` qualified to fix the build with recent GHCs. # 1.14 [2020.09.30] * Remove instances for `Data.Semigroup.Option`, which is deprecated as of `base-4.15.0.0`. * Allow building with `template-haskell-2.17.0.0` (GHC 9.0). * Fix a bug in which `deriveAll1` would needlessly reject data types whose last type parameter appears as an oversaturated argument to a type family. # 1.13.1 [2019.11.26] * Backport the `Generic(1)` instances for `Kleisli` introduced in `base-4.14`. # 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.6/LICENSE0000644000000000000000000000274107346545000014226 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.6/README.md0000644000000000000000000000733607346545000014505 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.6/Setup.hs0000644000000000000000000000012707346545000014651 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain generic-deriving-1.14.6/generic-deriving.cabal0000644000000000000000000001467507346545000017437 0ustar0000000000000000name: generic-deriving version: 1.14.6 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 == 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.8 , GHC == 9.6.6 , GHC == 9.8.4 , GHC == 9.10.1 , GHC == 9.12.1 extra-source-files: CHANGELOG.md , README.md source-repository head type: git location: https://github.com/dreixel/generic-deriving 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.Monoid.Internal Generics.Deriving.Semigroup.Internal Generics.Deriving.TH.Internal Generics.Deriving.TH.Post4_9 Paths_generic_deriving build-depends: base >= 4.9 && < 5 , containers >= 0.1 && < 0.8 , ghc-prim < 1 , template-haskell >= 2.11 && < 2.24 -- TODO: Eventually, we should bump the lower version -- bounds to >=0.6 so that we can remove some CPP in -- Generics.Deriving.TH.Internal. , th-abstraction >= 0.4 && < 0.8 default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: DefaultSpec EmptyCaseSpec ExampleSpec T68Spec T80Spec T82Spec TypeInTypeSpec build-depends: base , generic-deriving , hspec >= 2 && < 3 , template-haskell 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.6/src/Generics/0000755000000000000000000000000007346545000015543 5ustar0000000000000000generic-deriving-1.14.6/src/Generics/Deriving.hs0000644000000000000000000000121707346545000017647 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.6/src/Generics/Deriving/0000755000000000000000000000000007346545000017312 5ustar0000000000000000generic-deriving-1.14.6/src/Generics/Deriving/Base.hs0000644000000000000000000000021507346545000020516 0ustar0000000000000000{-# LANGUAGE Safe #-} module Generics.Deriving.Base (module GHC.Generics) where import GHC.Generics import Generics.Deriving.Instances () generic-deriving-1.14.6/src/Generics/Deriving/ConNames.hs0000644000000000000000000000334207346545000021353 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {- | 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.6/src/Generics/Deriving/Copoint.hs0000644000000000000000000000720007346545000021260 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} module Generics.Deriving.Copoint ( -- * GCopoint class GCopoint(..) -- * Default method , gcopointdefault -- * Internal class , GCopoint'(..) ) where import Control.Applicative (WrappedMonad) import Data.Functor.Identity (Identity) import qualified Data.Functor.Sum as Functor (Sum) import Data.Monoid (Alt, Dual) import qualified Data.Monoid as Monoid (Sum) import Data.Ord (Down) import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid) import Generics.Deriving.Base -------------------------------------------------------------------------------- -- 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 default gcopoint :: (Generic1 d, GCopoint' (Rep1 d)) => (d a -> a) gcopoint = gcopointdefault 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 instance GCopoint f => GCopoint (Alt f) where gcopoint = gcopointdefault instance GCopoint (Arg a) where gcopoint = gcopointdefault instance GCopoint Down where gcopoint = gcopointdefault instance GCopoint Dual where gcopoint = gcopointdefault instance GCopoint First where gcopoint = gcopointdefault instance GCopoint Identity where gcopoint = gcopointdefault 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 instance GCopoint Monoid.Sum where gcopoint = gcopointdefault instance GCopoint m => GCopoint (WrappedMonad m) where gcopoint = gcopointdefault instance GCopoint WrappedMonoid where gcopoint = gcopointdefault generic-deriving-1.14.6/src/Generics/Deriving/Default.hs0000644000000000000000000002537507346545000021246 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 DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Safe #-} {-# LANGUAGE UndecidableInstances #-} module Generics.Deriving.Default ( -- * Kind @*@ (aka @Type@) -- $default Default(..) , -- * Kind @* -> *@ (aka @Type -> Type@) -- $default1 Default1(..) -- * Other kinds -- $other-kinds ) where 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.6/src/Generics/Deriving/Enum.hs0000644000000000000000000006137707346545000020570 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #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.Coerce (coerce) import Data.Complex (Complex) import Data.Functor.Identity (Identity) import Data.Int import Data.List.NonEmpty (NonEmpty) import Data.Maybe (listToMaybe) import Data.Monoid (All, Alt, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last) import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) import Data.Word import Foreign.C.Types import Foreign.Ptr import Generics.Deriving.Base import Generics.Deriving.Eq import Numeric.Natural (Natural) import System.Exit (ExitCode) import System.Posix.Types ----------------------------------------------------------------------------- -- 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] default genum :: (Generic a, Enum' (Rep a)) => [a] genum = genumDefault 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 ..] -- 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 instance GEnum (f a) => GEnum (Alt f a) where genum = genumDefault instance GEnum Any where genum = genumDefault instance (GEnum a, GEnum b) => GEnum (Arg a b) where genum = genumDefault 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 instance GEnum a => GEnum (Complex a) where genum = genumDefault 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 instance GEnum CSUSeconds where genum = coerce (genum :: [HTYPE_SUSECONDS_T]) 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]) instance GEnum CUSeconds where genum = coerce (genum :: [HTYPE_USECONDS_T]) 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 instance GEnum a => GEnum (Semigroup.First a) where genum = genumDefault instance GEnum Fixity where genum = genumDefault instance GEnum Float where genum = genumNumUnbounded instance GEnum a => GEnum (Identity a) where genum = genumDefault 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 instance GEnum a => GEnum (Semigroup.Last a) where genum = genumDefault instance GEnum (f p) => GEnum (M1 i c f p) where genum = genumDefault instance GEnum a => GEnum (Max a) where genum = genumDefault instance GEnum a => GEnum (Maybe a) where genum = genumDefault instance GEnum a => GEnum (Min a) where genum = genumDefault instance GEnum Natural where genum = genumNumUnsigned instance GEnum a => GEnum (NonEmpty a) where genum = genumDefault instance GEnum Ordering where genum = genumDefault instance GEnum p => GEnum (Par1 p) where genum = genumDefault instance GEnum a => GEnum (Product a) where genum = genumDefault instance GEnum (Proxy s) where genum = genumDefault 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 instance GEnum m => GEnum (WrappedMonoid m) where genum = genumDefault 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 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 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 instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Any where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where range = rangeDefault index = indexDefault inRange = inRangeDefault 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 instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Fixity where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where range = rangeDefault index = indexDefault inRange = inRangeDefault 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 instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx (Max a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx (Min a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Natural where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where range = rangeDefault index = indexDefault inRange = inRangeDefault 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 instance GIx (Proxy s) where range = rangeDefault index = indexDefault inRange = inRangeDefault 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 instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where range = rangeDefault index = indexDefault inRange = inRangeDefault #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.6/src/Generics/Deriving/Eq.hs0000644000000000000000000002435407346545000020223 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MagicHash #-} #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.Complex (Complex) import Data.Functor.Identity (Identity) import Data.Int import Data.List.NonEmpty (NonEmpty) import qualified Data.Monoid as Monoid (First, Last) import Data.Monoid (All, Alt, Any, Dual, Product, Sum) import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg(..), Max, Min, WrappedMonoid) import Data.Version (Version) import Data.Void (Void) import Data.Word import Foreign.C.Error 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 Numeric.Natural (Natural) import System.Exit (ExitCode) import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) import System.IO.Error (IOErrorType) import System.Posix.Types -------------------------------------------------------------------------------- -- 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) class GEq a where geq :: a -> a -> Bool default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool geq = geqdefault 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 instance GEq (f a) => GEq (Alt f a) where geq = geqdefault instance GEq Any where geq = geqdefault instance GEq a => GEq (Arg a b) where geq (Arg a _) (Arg b _) = geq a b 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 instance GEq a => GEq (Complex a) where geq = geqdefault 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 instance GEq CSUSeconds where geq = (==) 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 = (==) instance GEq CUSeconds where geq = (==) instance GEq CUShort where geq = (==) instance GEq CWchar where geq = (==) instance GEq DecidedStrictness where geq = geqdefault 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 instance GEq a => GEq (Semigroup.First a) where geq = geqdefault 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 = (==) instance GEq a => GEq (Identity a) where geq = geqdefault 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 instance GEq a => GEq (Semigroup.Last a) where geq = geqdefault instance GEq (f p) => GEq (M1 i c f p) where geq = geqdefault instance GEq a => GEq (Maybe a) where geq = geqdefault instance GEq a => GEq (Max a) where geq = geqdefault instance GEq a => GEq (Min a) where geq = geqdefault instance GEq Natural where geq = (==) instance GEq a => GEq (NonEmpty a) where geq = geqdefault instance GEq Ordering where geq = geqdefault instance GEq p => GEq (Par1 p) where geq = geqdefault instance GEq a => GEq (Product a) where geq = geqdefault instance GEq (Proxy s) where geq = geqdefault 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 = (==) instance GEq SourceStrictness where geq = geqdefault instance GEq SourceUnpackedness where geq = geqdefault 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 = (==) instance GEq Void where geq = (==) 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 = (==) instance GEq m => GEq (WrappedMonoid m) where geq = geqdefault 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.6/src/Generics/Deriving/Foldable.hs0000644000000000000000000001606607346545000021367 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} 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.Complex (Complex) import Data.Functor.Identity (Identity) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import Data.Maybe import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..)) import Data.Monoid (All(..), Any(..), Dual(..), Endo(..)) import Data.Ord (Down) import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) import Generics.Deriving.Base -------------------------------------------------------------------------------- -- 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 default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) => (a -> m) -> t a -> m gfoldMap = gfoldMapdefault 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 instance GFoldable (Arg a) where gfoldMap = gfoldMapdefault instance GFoldable Complex where gfoldMap = gfoldMapdefault 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 instance GFoldable (Semigroup.First) where gfoldMap = gfoldMapdefault instance GFoldable Identity where gfoldMap = gfoldMapdefault instance GFoldable Monoid.Last where gfoldMap = gfoldMapdefault instance GFoldable Semigroup.Last where gfoldMap = gfoldMapdefault instance GFoldable Max where gfoldMap = gfoldMapdefault instance GFoldable Maybe where gfoldMap = gfoldMapdefault instance GFoldable Min where gfoldMap = gfoldMapdefault instance GFoldable NonEmpty where gfoldMap = gfoldMapdefault instance GFoldable Monoid.Product where gfoldMap = gfoldMapdefault instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where gfoldMap = gfoldMapdefault instance GFoldable Proxy where gfoldMap = gfoldMapdefault instance GFoldable Monoid.Sum where gfoldMap = gfoldMapdefault instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where gfoldMap = gfoldMapdefault instance GFoldable WrappedMonoid where gfoldMap = gfoldMapdefault 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.6/src/Generics/Deriving/Functor.hs0000644000000000000000000001040507346545000021266 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} module Generics.Deriving.Functor ( -- * Generic Functor class GFunctor(..) -- * Default method , gmapdefault -- * Internal Functor class , GFunctor'(..) ) where import Control.Applicative (Const, ZipList) import Data.Complex (Complex) import Data.Functor.Identity (Identity) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Monoid as Monoid (First, Last, Product, Sum) import Data.Monoid (Alt, Dual) import Data.Ord (Down) import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) import Generics.Deriving.Base -------------------------------------------------------------------------------- -- Generic fmap -------------------------------------------------------------------------------- class GFunctor' f where gmap' :: (a -> b) -> f a -> f b instance GFunctor' V1 where gmap' _ x = case x of {} 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 default gmap :: (Generic1 f, GFunctor' (Rep1 f)) => (a -> b) -> f a -> f b gmap = gmapdefault 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 instance GFunctor f => GFunctor (Alt f) where gmap = gmapdefault instance GFunctor (Arg a) where gmap = gmapdefault instance GFunctor Complex where gmap = gmapdefault 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 instance GFunctor (Semigroup.First) where gmap = gmapdefault instance GFunctor Identity where gmap = gmapdefault instance GFunctor IO where gmap = fmap instance GFunctor Monoid.Last where gmap = gmapdefault instance GFunctor Semigroup.Last where gmap = gmapdefault instance GFunctor Max where gmap = gmapdefault instance GFunctor Maybe where gmap = gmapdefault instance GFunctor Min where gmap = gmapdefault instance GFunctor NonEmpty where gmap = gmapdefault instance GFunctor Monoid.Product where gmap = gmapdefault instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where gmap = gmapdefault instance GFunctor Proxy where gmap = gmapdefault instance GFunctor Monoid.Sum where gmap = gmapdefault instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where gmap = gmapdefault instance GFunctor WrappedMonoid where gmap = gmapdefault instance GFunctor ZipList where gmap = gmapdefault generic-deriving-1.14.6/src/Generics/Deriving/Instances.hs0000644000000000000000000000762107346545000021603 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Generics.Deriving.Instances ( -- Only instances from GHC.Generics -- and the Generic1 instances #if !(MIN_VERSION_base(4,16,0)) Rep0Tuple8 , Rep0Tuple9 , Rep0Tuple10 , Rep0Tuple11 , Rep0Tuple12 , Rep0Tuple13 , Rep0Tuple14 , Rep0Tuple15 , Rep1Tuple8 , Rep1Tuple9 , Rep1Tuple10 , Rep1Tuple11 , Rep1Tuple12 , Rep1Tuple13 , Rep1Tuple14 , Rep1Tuple15 #endif #if !(MIN_VERSION_base(4,14,0)) , Rep0Kleisli , Rep1Kleisli #endif #if !(MIN_VERSION_base(4,12,0)) , Rep0Down , Rep1Down #endif ) where #if !(MIN_VERSION_base(4,12,0)) import Data.Ord (Down(..)) #endif #if !(MIN_VERSION_base(4,14,0)) import Control.Arrow (Kleisli(..)) #endif #if !(MIN_VERSION_base(4,16,0)) import GHC.Generics #endif #if !(MIN_VERSION_base(4,16,0)) type Rep0Tuple8 a b c d e f g h = Rep (a, b, c, d, e, f, g, h) type Rep0Tuple9 a b c d e f g h i = Rep (a, b, c, d, e, f, g, h, i) type Rep0Tuple10 a b c d e f g h i j = Rep (a, b, c, d, e, f, g, h, i, j) type Rep0Tuple11 a b c d e f g h i j k = Rep (a, b, c, d, e, f, g, h, i, j, k) type Rep0Tuple12 a b c d e f g h i j k l = Rep (a, b, c, d, e, f, g, h, i, j, k, l) type Rep0Tuple13 a b c d e f g h i j k l m = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m) type Rep0Tuple14 a b c d e f g h i j k l m n = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n) type Rep0Tuple15 a b c d e f g h i j k l m n o = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) type Rep1Tuple8 a b c d e f g = Rep1 ((,,,,,,,) a b c d e f g) type Rep1Tuple9 a b c d e f g h = Rep1 ((,,,,,,,,) a b c d e f g h) type Rep1Tuple10 a b c d e f g h i = Rep1 ((,,,,,,,,,) a b c d e f g h i) type Rep1Tuple11 a b c d e f g h i j = Rep1 ((,,,,,,,,,,) a b c d e f g h i j) type Rep1Tuple12 a b c d e f g h i j k = Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k) type Rep1Tuple13 a b c d e f g h i j k l = Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) type Rep1Tuple14 a b c d e f g h i j k l m = Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) type Rep1Tuple15 a b c d e f g h i j k l m n = Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) deriving instance Generic (a, b, c, d, e, f, g, h) deriving instance Generic (a, b, c, d, e, f, g, h, i) deriving instance Generic (a, b, c, d, e, f, g, h, i, j) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n) deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) deriving instance Generic1 ((,,,,,,,) a b c d e f g) deriving instance Generic1 ((,,,,,,,,) a b c d e f g h) deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i) deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j) deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k) deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) #endif #if !(MIN_VERSION_base(4,14,0)) type Rep0Kleisli m a b = Rep (Kleisli m a b) type Rep1Kleisli m a = Rep1 (Kleisli m a) deriving instance Generic (Kleisli m a b) deriving instance Generic1 (Kleisli m a) #endif #if !(MIN_VERSION_base(4,12,0)) type Rep0Down a = Rep (Down a) type Rep1Down = Rep1 Down deriving instance Generic (Down a) deriving instance Generic1 Down #endif generic-deriving-1.14.6/src/Generics/Deriving/Monoid.hs0000644000000000000000000000073207346545000021075 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -Wno-orphans #-} module Generics.Deriving.Monoid (module Generics.Deriving.Monoid.Internal) where import Data.Semigroup (WrappedMonoid) import Generics.Deriving.Monoid.Internal import Generics.Deriving.Semigroup (GSemigroup(..)) instance GSemigroup a => GMonoid (Maybe a) where gmempty = Nothing gmappend = gsappend instance GMonoid m => GMonoid (WrappedMonoid m) where gmempty = gmemptydefault gmappend = gmappenddefault generic-deriving-1.14.6/src/Generics/Deriving/Monoid/0000755000000000000000000000000007346545000020537 5ustar0000000000000000generic-deriving-1.14.6/src/Generics/Deriving/Monoid/Internal.hs0000644000000000000000000001663107346545000022656 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} 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.Functor.Identity (Identity) import Data.Monoid import Data.Ord (Down) import Data.Proxy (Proxy) import Generics.Deriving.Base import Generics.Deriving.Semigroup.Internal -------------------------------------------------------------------------------- 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 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)) -------------------------------------------------------------------------------- -- 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 instance Alternative f => GMonoid (Alt f a) where gmempty = mempty gmappend = mappend -- 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 instance GMonoid (Proxy s) where gmempty = memptydefault gmappend = mappenddefault instance GMonoid a => GMonoid (Identity a) where gmempty = gmemptydefault gmappend = gmappenddefault -- 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.6/src/Generics/Deriving/Semigroup.hs0000644000000000000000000000063507346545000021624 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -Wno-orphans #-} module Generics.Deriving.Semigroup (module Generics.Deriving.Semigroup.Internal) where import Data.Semigroup (WrappedMonoid(..)) import Generics.Deriving.Monoid.Internal (GMonoid(..)) import Generics.Deriving.Semigroup.Internal instance GMonoid m => GSemigroup (WrappedMonoid m) where gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b) generic-deriving-1.14.6/src/Generics/Deriving/Semigroup/0000755000000000000000000000000007346545000021264 5ustar0000000000000000generic-deriving-1.14.6/src/Generics/Deriving/Semigroup/Internal.hs0000644000000000000000000001330207346545000023373 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} module Generics.Deriving.Semigroup.Internal ( -- * Generic semigroup class GSemigroup(..) -- * Default definition , gsappenddefault -- * Internal semigroup class , GSemigroup'(..) ) where import Control.Applicative import Data.Functor.Identity (Identity) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid as Monoid hiding ((<>)) import Data.Ord (Down) import Data.Proxy (Proxy) import Data.Semigroup as Semigroup import Data.Void (Void) import Generics.Deriving.Base ------------------------------------------------------------------------------- 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 default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a gsappend = gsappenddefault 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) gsconcat :: NonEmpty a -> a gsconcat (a :| as) = go a as where go b (c:cs) = gsappend b (go c cs) go b [] = b 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 instance Alternative f => GSemigroup (Alt f a) where gsappend = mappend -- 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 instance GSemigroup (Proxy s) where gsappend = gsappenddefault instance GSemigroup a => GSemigroup (Identity a) where gsappend = gsappenddefault instance GSemigroup Void where gsappend a _ = a 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 = (<>) -- 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.6/src/Generics/Deriving/Show.hs0000644000000000000000000003517707346545000020603 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} 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.Complex (Complex) import Data.Functor.Identity (Identity) import Data.Int import Data.List.NonEmpty (NonEmpty) import Data.Monoid (All, Alt, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last) import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) import Data.Version (Version) import Data.Void (Void) import Data.Word import Foreign.C.Types import Foreign.ForeignPtr (ForeignPtr) import Foreign.Ptr import Generics.Deriving.Base import GHC.Exts hiding (Any) import Numeric.Natural (Natural) import System.Exit (ExitCode) import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) import System.IO.Error (IOErrorType) import System.Posix.Types -------------------------------------------------------------------------------- -- 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 {} 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 default gshowsPrec :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS gshowsPrec = gshowsPrecdefault 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 instance GShow (f a) => GShow (Alt f a) where gshowsPrec = gshowsPrecdefault instance GShow Any where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b) => GShow (Arg a b) where gshowsPrec = gshowsPrecdefault 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 instance GShow a => GShow (Complex a) where gshowsPrec = gshowsPrecdefault 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 instance GShow CSUSeconds where gshowsPrec = showsPrec 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 instance GShow CUSeconds where gshowsPrec = showsPrec 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 instance GShow a => GShow (Semigroup.First a) where gshowsPrec = gshowsPrecdefault 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 instance GShow a => GShow (Identity a) where gshowsPrec = gshowsPrecdefault 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 instance GShow a => GShow (Semigroup.Last a) where gshowsPrec = gshowsPrecdefault instance GShow (f p) => GShow (M1 i c f p) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Max a) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Maybe a) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Min a) where gshowsPrec = gshowsPrecdefault instance GShow Natural where gshowsPrec = showsPrec instance GShow a => GShow (NonEmpty a) where gshowsPrec = gshowsPrecdefault instance GShow Ordering where gshowsPrec = gshowsPrecdefault instance GShow p => GShow (Par1 p) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Product a) where gshowsPrec = gshowsPrecdefault instance GShow (Proxy s) where gshowsPrec = gshowsPrecdefault 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 instance GShow Void where gshowsPrec = showsPrec 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 instance GShow m => GShow (WrappedMonoid m) where gshowsPrec = gshowsPrecdefault 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.6/src/Generics/Deriving/TH.hs0000644000000000000000000012716107346545000020171 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 import Generics.Deriving.TH.Post4_9 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 = map (\fun_name -> pragInlD fun_name Inline FunLike (FromPhase 1) ) [fromName, toName] | 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 = [] | 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 = [] | 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)) []] 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.6/src/Generics/Deriving/TH/0000755000000000000000000000000007346545000017625 5ustar0000000000000000generic-deriving-1.14.6/src/Generics/Deriving/TH/Internal.hs0000644000000000000000000005673707346545000021757 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskellQuotes #-} {- | 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 qualified Generics.Deriving as GD import Generics.Deriving hiding ( DecidedStrictness(..), Fixity(Infix) , SourceStrictness(..), SourceUnpackedness(..) , datatypeName ) import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- type TypeSubst = Map Name Type applySubstitutionKind :: Map Name Kind -> Type -> Type applySubstitutionKind = applySubstitution 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 SigT _ (VarT k) -> IsKindVar k _ -> 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 hasKindStar (SigT _ StarT) = True 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 makeFunKind = makeFunType -- | Remove any outer `SigT` and `ParensT` constructors, and turn -- an outermost `InfixT` constructor into plain applications. dustOff :: Type -> Type dustOff (SigT ty _) = dustOff ty dustOff (ParensT ty) = dustOff ty dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2 dustOff ty = ty -- | Checks whether a type is an unsaturated type family -- application. isUnsaturatedType :: Type -> Q Bool isUnsaturatedType = go 0 . dustOff where -- Expects its argument to be dusted go :: Int -> Type -> Q Bool go d t = case t of ConT tcName -> check d tcName AppT f _ -> go (d + 1) (dustOff f) _ -> return False check :: Int -> Name -> Q Bool check d tcName = do mbinders <- getTypeFamilyBinders tcName return $ case mbinders of Just bndrs -> length bndrs > d Nothing -> False -- | Given a name, check if that name is a type family. If -- so, return a list of its binders. getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndrVis]) getTypeFamilyBinders tcName = do info <- reify tcName return $ case info of FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ -> Just bndrs FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ -> Just bndrs _ -> Nothing -- | True if the type does not mention the Name ground :: Type -> Name -> Bool ground 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]) uncurryKind = uncurryTy 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 isKindVar = isTyVar -- | 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 && go k 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 || go k names 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 ------------------------------------------------------------------------------- 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 generic-deriving-1.14.6/src/Generics/Deriving/TH/Post4_9.hs0000644000000000000000000001163707346545000021432 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.6/src/Generics/Deriving/Traversable.hs0000644000000000000000000001245207346545000022124 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} module Generics.Deriving.Traversable ( -- * Generic Traversable class GTraversable(..) -- * Default method , gtraversedefault -- * Internal Traversable class , GTraversable'(..) ) where import Control.Applicative (Const, WrappedMonad(..), ZipList) import Data.Complex (Complex) import Data.Functor.Identity (Identity) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Monoid as Monoid (First, Last, Product, Sum) import Data.Monoid (Dual) import Data.Ord (Down) import Data.Proxy (Proxy) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, WrappedMonoid) import Generics.Deriving.Base import Generics.Deriving.Foldable import Generics.Deriving.Functor -------------------------------------------------------------------------------- -- 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 {} 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) default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) => (a -> f b) -> t a -> f (t b) gtraverse = gtraversedefault 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 instance GTraversable (Arg a) where gtraverse = gtraversedefault instance GTraversable Complex where gtraverse = gtraversedefault 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 instance GTraversable (Semigroup.First) where gtraverse = gtraversedefault instance GTraversable Identity where gtraverse = gtraversedefault instance GTraversable Monoid.Last where gtraverse = gtraversedefault instance GTraversable Semigroup.Last where gtraverse = gtraversedefault instance GTraversable Max where gtraverse = gtraversedefault instance GTraversable Maybe where gtraverse = gtraversedefault instance GTraversable Min where gtraverse = gtraversedefault instance GTraversable NonEmpty where gtraverse = gtraversedefault instance GTraversable Monoid.Product where gtraverse = gtraversedefault instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where gtraverse = gtraversedefault instance GTraversable Proxy where gtraverse = gtraversedefault instance GTraversable Monoid.Sum where gtraverse = gtraversedefault instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where gtraverse = gtraversedefault instance GTraversable WrappedMonoid where gtraverse = gtraversedefault instance GTraversable ZipList where gtraverse = gtraversedefault generic-deriving-1.14.6/src/Generics/Deriving/Uniplate.hs0000644000000000000000000002312107346545000021426 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {- | 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 {-# OVERLAPPING #-} (Uniplate a) => Uniplate' (K1 i a) a where children' (K1 a) = [a] descend' f (K1 a) = K1 (f a) descendM' f (K1 a) = liftM K1 (f a) transform' f (K1 a) = K1 (transform f a) transformM' f (K1 a) = liftM K1 (transformM f a) instance {-# OVERLAPPABLE #-} 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 {-# OVERLAPPING #-} Context' (K1 i a) a where context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" context' (K1 _) (c:_) = K1 c instance {-# OVERLAPPABLE #-} 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 {-# OVERLAPPING #-} (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs instance {-# OVERLAPPABLE #-} (Context' g b) => Context' (f :*: g) b where context' (a :*: b) cs = a :*: context' b cs class Uniplate a where children :: a -> [a] default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] children = childrendefault context :: a -> [a] -> a default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a context = contextdefault descend :: (a -> a) -> a -> a default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a descend = descenddefault descendM :: Monad m => (a -> m a) -> a -> m a default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a descendM = descendMdefault transform :: (a -> a) -> a -> a default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a transform = transformdefault transformM :: Monad m => (a -> m a) -> a -> m a default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a transformM = transformMdefault 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.6/tests/0000755000000000000000000000000007346545000014357 5ustar0000000000000000generic-deriving-1.14.6/tests/DefaultSpec.hs0000644000000000000000000001272607346545000017122 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.6/tests/EmptyCaseSpec.hs0000644000000000000000000000063707346545000017426 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} 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.6/tests/ExampleSpec.hs0000644000000000000000000003104507346545000017124 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-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 data family MyType3 (a :: v) (b :: w) (c :: x) (d :: y) (e :: z) newtype instance MyType3 (f p) (f p) f p (q :: *) = MyType3Newtype q data instance MyType3 Bool () f p q = MyType3True | MyType3False data instance MyType3 Int () f p (q :: *) = MyType3Hash q Addr# Char# Double# Float# Int# Word# $(deriveAll0And1 ''Empty) $(deriveAll0And1 ''(:/:)) $(deriveAll0And1 ''GADTSyntax) $(deriveAll0 ''MyType2) $(deriveAll0And1 ''PlainHash) $(deriveAll0 ''ExampleSpec.Lexeme) $(deriveAll0 ''Text.Read.Lex.Lexeme) $(deriveAll0And1 'MyType3Newtype) $(deriveAll0And1 'MyType3False) $(deriveAll0And1 'MyType3Hash) ------------------------------------------------------------------------------- -- 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.6/tests/Spec.hs0000644000000000000000000000005407346545000015604 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} generic-deriving-1.14.6/tests/T68Spec.hs0000644000000000000000000000052007346545000016104 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module T68Spec (main, spec) where import Generics.Deriving.TH import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = return () type family F68 :: * -> * type instance F68 = Maybe data T68 a = MkT68 (F68 a) $(deriveAll1 ''T68) generic-deriving-1.14.6/tests/T80Spec.hs0000644000000000000000000000047007346545000016102 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module T80Spec (main, spec) where import Generics.Deriving.TH import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = return () newtype T f a b = MkT (f a b) $(deriveAll1 ''T) generic-deriving-1.14.6/tests/T82Spec.hs0000644000000000000000000000076107346545000016107 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module T82Spec (main, spec) where import Test.Hspec #if MIN_VERSION_base(4,10,0) import Generics.Deriving.TH import GHC.Exts (RuntimeRep, TYPE) data Code m (a :: TYPE (r :: RuntimeRep)) = Code $(deriveAll0And1 ''Code) #endif main :: IO () main = hspec spec spec :: Spec spec = return () generic-deriving-1.14.6/tests/TypeInTypeSpec.hs0000644000000000000000000000262107346545000017601 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module TypeInTypeSpec (main, spec) where import Data.Proxy (Proxy(..)) import Generics.Deriving.TH import Test.Hspec #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 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