diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,235 @@ +# 1.14.7 [2026.01.03] +* Allow building with GHC 9.14. +* Remove unused `ghc-prim` dependency. + +# 1.14.6 [2024.12.05] +* Drop support for GHC 7.10 and earlier. + +# 1.14.5 [2023.08.06] +* Support building with `template-haskell-2.21.*` (GHC 9.8). +* The Template Haskell machinery now uses `TemplateHaskellQuotes` when + building with GHC 8.0+ instead of manually constructing each Template Haskell + `Name`. A consequence of this is that `generic-deriving` will now build with + GHC 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template + Haskell changes introduced in 9.8. + +# 1.14.4 [2023.04.30] +* Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined, + such as the WASM backend. +* Place `INLINE [1]` pragmas on `from` and `to` implementations when types + don't have too many constructors or fields, following the heuristics that GHC + 9.2+ uses for `Generic` deriving. + +# 1.14.3 [2023.02.27] +* Support `th-abstraction-0.5.*`. + +# 1.14.2 [2022.07.23] +* Fix a bug in which `deriveAll1` could generate ill kinded code when using + `kindSigOptions=False`, or when using GHC 8.0 or earlier. +* Fix a bug in which `deriveAll1` would reject data types whose last type + variable has a kind besides `Type` or `k` on GHC 8.2 or later. + +# 1.14.1 [2021.08.30] +* Backport the `Generic(1)` instances introduced for tuples (8 through 15) in + `base-4.16`. +* Make the test suite compile on GHC 9.2 or later. +* Always import `Data.List` qualified to fix the build with recent GHCs. + +# 1.14 [2020.09.30] +* Remove instances for `Data.Semigroup.Option`, which is deprecated as of + `base-4.15.0.0`. +* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). +* Fix a bug in which `deriveAll1` would needlessly reject data types whose last + type parameter appears as an oversaturated argument to a type family. + +# 1.13.1 [2019.11.26] +* Backport the `Generic(1)` instances for `Kleisli` introduced in `base-4.14`. + +# 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,28 +1,28 @@ -Copyright (c) 2010 Universiteit Utrecht -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -3. Neither the name of Universiteit Utrecht nor the names of its contributors - may be used to endorse or promote products derived from this software without - specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +Copyright (c) 2010 Universiteit Utrecht +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of Universiteit Utrecht nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,86 @@ +## `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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,6 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/examples/Examples.hs b/examples/Examples.hs deleted file mode 100644 --- a/examples/Examples.hs +++ /dev/null @@ -1,583 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DatatypeContexts #-} -{-# LANGUAGE DeriveFunctor #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DeriveGeneric #-} -#endif - -module Main ( - -- * Run all tests - main - ) where - -import Prelude hiding (Either(..)) -import Generics.Deriving -import Generics.Deriving.TH - - --------------------------------------------------------------------------------- --- Temporary tests for TH generation --------------------------------------------------------------------------------- - -data (:/:) f a = MyType1Nil - | MyType1Cons { myType1Rec :: (f :/: a), myType2Rec :: MyType2 } - | MyType1Cons2 (f :/: a) Int a (f a) - -#if __GLASGOW_HASKELL__ >= 701 - deriving Generic -#endif - -data MyType2 = MyType2 Float ([] :/: Int) - -#if __GLASGOW_HASKELL__ < 701 - -$(deriveAll ''(:/:)) -$(deriveAll ''MyType2) - -#else - --- deriving instance Generic (f :/: a) -deriving instance Generic MyType2 - -#endif - --------------------------------------------------------------------------------- --- Example: Haskell's lists and Maybe --------------------------------------------------------------------------------- - -hList1, hList2 :: [Int] -hList1 = [1..10] -hList2 = [2,4..] - -maybe1 = Nothing -maybe2 = Just (Just 'p') - -double :: [Int] -> [Int] -double [] = [] -double (x:xs) = x:x:xs - -testsStandard = [ gshow hList1 - , gshow (children maybe2) - , gshow (transform (const "abc") []) - , gshow (transform double hList1) - , gshow (geq hList1 hList1) - , gshow (geq maybe1 maybe2) - , gshow (take 5 (genum :: [Maybe Int])) - , gshow (take 15 (genum :: [[Int]])) - , gshow (range ([0], [1::Int])) - , gshow (inRange ([0], [3,5::Int]) hList1) ] - --------------------------------------------------------------------------------- --- Example: trees of integers (kind *) --------------------------------------------------------------------------------- - -data Tree = Empty | Branch Int Tree Tree - -#if __GLASGOW_HASKELL__ >= 701 - -deriving instance Generic Tree - -instance GShow Tree -instance Uniplate Tree -instance GEnum Tree - -#else - -$(deriveAll ''Tree) - -instance GShow Tree where gshowsPrec = gshowsPrecdefault -instance Uniplate Tree where - children = childrendefault - context = contextdefault - descend = descenddefault - descendM = descendMdefault - transform = transformdefault - transformM = transformdefault -instance GEnum Tree where genum = genumDefault - -#endif - -upgradeTree :: Tree -> Tree -upgradeTree Empty = Branch 0 Empty Empty -upgradeTree (Branch n l r) = Branch (succ n) l r - --- Example usage -tree = Branch 2 Empty (Branch 1 Empty Empty) -testsTree = [ gshow tree - , gshow (children tree) - , gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) - , gshow (context tree [Branch 1 Empty Empty,Empty]) - , gshow (transform upgradeTree tree) - , gshow (take 10 (genum :: [Tree])) ] - --------------------------------------------------------------------------------- --- Example: lists (kind * -> *) --------------------------------------------------------------------------------- - -data List a = Nil | Cons a (List a) - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (List a) -#else - -type Rep0List_ a = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) (Par0 a) (Rec0 (List a))))) -instance Generic (List a) where - type Rep (List a) = Rep0List_ a - from Nil = M1 (L1 (M1 U1)) - from (Cons h t) = M1 (R1 (M1 ((:*:) (K1 h) (K1 t)))) - to (M1 (L1 (M1 U1))) = Nil - to (M1 (R1 (M1 (K1 h :*: K1 t)))) = Cons h t - -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 List -#else - -data List_ -data Nil_ -data Cons_ - -instance Datatype List_ where - datatypeName _ = "List" - moduleName _ = "Examples" - -instance Constructor Nil_ where conName _ = "Nil" -instance Constructor Cons_ where conName _ = "Cons" - -type Rep1List_ = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) Par1 (Rec1 List)))) -instance Generic1 List where - type Rep1 List = Rep1List_ - from1 Nil = M1 (L1 (M1 U1)) - from1 (Cons h t) = M1 (R1 (M1 (Par1 h :*: Rec1 t))) - to1 (M1 (L1 (M1 U1))) = Nil - to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = Cons h t - -#endif - -#if __GLASGOW_HASKELL__ < 701 --- Instance for generic functions (should be automatically generated) -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 = transformdefault - -#else - -instance GFunctor List -instance (GShow a) => GShow (List a) -instance (Uniplate a) => Uniplate (List a) - -#endif - --- Example usage -list = Cons 'p' (Cons 'q' Nil) -listlist = Cons list (Cons Nil Nil) -- ["pq",""] - -testsList = [ gshow (gmap fromEnum list) - , gshow (gmap gshow listlist) - , gshow list - , gshow listlist - , gshow (children list) - , gshow (children listlist) ] - - --------------------------------------------------------------------------------- --- Example: Nested datatype, record selectors --------------------------------------------------------------------------------- - -data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] } - deriving Functor - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (Nested a) -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''Nested) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''Nested) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Nested -#else - -type RepNested = D1 Nested_ (C1 Nested_Leaf_ U1 :+: C1 Nested_Nested_ (Par1 :*: Nested :.: Rec1 [])) -instance Generic1 Nested where - type Rep1 Nested = RepNested - from1 Leaf = M1 (L1 (M1 U1)) - from1 (Nested a l) = M1 (R1 (M1 (Par1 a :*: Comp1 (gmap Rec1 l)))) - to1 (M1 (L1 (M1 U1))) = Leaf - to1 (M1 (R1 (M1 (Par1 a :*: Comp1 l)))) = Nested a (gmap unRec1 l) -#endif - -#if __GLASGOW_HASKELL__ < 701 --- Instance for gshow (should be automatically generated) -instance (GShow a) => GShow (Nested a) where - gshowsPrec = gshowsPrecdefault - -instance GFunctor Nested where - gmap = gmapdefault - -#else - -instance (GShow a) => GShow (Nested a) -instance GFunctor Nested - -#endif - --- Example usage -nested :: Nested Int -nested = Nested 1 (Nested [2] (Nested [[3],[4,5],[]] Leaf)) ---nested = Nested 1 (Nested (Nested 1 Leaf) Leaf) - - -testsNested = [ gshow nested - , gshow (gmap gshow nested) ] - --------------------------------------------------------------------------------- --- Example: Type composition --------------------------------------------------------------------------------- - -data Rose a = Rose [a] [Rose a] - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (Rose a) -#else - -type Rep0Rose a = D1 RoseD (C1 RoseC (Rec0 [a] :*: Rec0 [Rose a])) -instance Generic (Rose a) where - type Rep (Rose a) = Rep0Rose a - from (Rose a x) = M1 (M1 (K1 a :*: K1 x)) - to (M1 (M1 (K1 a :*: K1 x))) = Rose a x - -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Rose -#else - -data RoseD -data RoseC - -instance Datatype RoseD where - datatypeName _ = "Rose" - moduleName _ = "Examples" - -instance Constructor RoseC where conName _ = "Rose" - --- Generic1 instances -type RepRose = D1 RoseD (C1 RoseC (Rec1 [] :*: [] :.: Rec1 Rose)) -instance Generic1 Rose where - type Rep1 Rose = RepRose - from1 (Rose a x) = M1 (M1 (Rec1 a :*: Comp1 (gmap Rec1 x))) - to1 (M1 (M1 (Rec1 a :*: Comp1 x))) = Rose a (gmap unRec1 x) - -#endif - -#if __GLASGOW_HASKELL_ >= 701 - -instance (GShow a) => GShow (Rose a) -instance GFunctor Rose - -#else - --- Instance for gshow (should be automatically generated) -instance (GShow a) => GShow (Rose a) where - gshowsPrec = gshowsPrecdefault - -instance GFunctor Rose where - gmap = gmapdefault - -#endif - --- Example usage -rose1 :: Rose Int -rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []] - -testsRose = [ gshow rose1 - , gshow (gmap gshow rose1) ] - --------------------------------------------------------------------------------- --- 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) - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (GRose f a) -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''GRose) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''GRose) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance (Functor f) => Generic1 (GRose f) -#else - -type Rep1GRose f = D1 GRose_ (C1 GRose_GRose_ (Rec1 f :*: f :.: (Rec1 (GRose f)))) -instance (GFunctor f) => Generic1 (GRose f) where - type Rep1 (GRose f) = Rep1GRose f - from1 (GRose a x) = M1 (M1 (Rec1 a :*: Comp1 (gmap Rec1 x))) - to1 (M1 (M1 (Rec1 a :*: Comp1 x))) = GRose a (gmap unRec1 x) -#endif - -#if __GLASGOW_HASKELL__ < 701 --- Requires UndecidableInstances -instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where - gshowsPrec = gshowsPrecdefault - -instance (GFunctor f) => GFunctor (GRose f) where - gmap = gmapdefault - -#else - -instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) -instance (Functor f, GFunctor f) => GFunctor (GRose f) - -#endif - --- Example usage -grose1 :: GRose [] Int -grose1 = GRose [1,2] [GRose [3] [], GRose [] []] - -testsGRose = [ gshow grose1 - , gshow (gmap gshow grose1) ] - --------------------------------------------------------------------------------- --- Example: NGRose (minimal) --------------------------------------------------------------------------------- - --- Cannot represent because of nesting on an argument other than the parameter -{- -data NGRose f a = NGNode a (f (NGRose (Comp f f) a)) -data Comp f g a = Comp (f (g a)) - -type Rep0NGRose f a = Par0 a :*: Rec0 (f (NGRose (Comp f f) a)) -instance Generic (NGRose f a) (Rep0NGRose f a) where - from (NGNode a x) = K1 a :*: K1 x - to (K1 a :*: K1 x) = NGNode a x - -type Rep0Comp f g a = Rec0 (f (g a)) -instance Generic (Comp f g a) (Rep0Comp f g a) where - from (Comp x) = K1 x - to (K1 x) = Comp x - -type Rep1Comp f g = f :.: Rec1 g -instance (GFunctor f) => Generic1 (Comp f g) (Rep1Comp f g) where - from1 (Comp x) = Comp1 (gmap Rec1 x) - to1 (Comp1 x) = Comp (gmap unRec1 x) - -type Rep1NGRose f = Par1 :*: f :.: Rec1 (NGRose (Comp f f)) -instance (GFunctor f) => Generic1 (NGRose f) (Rep1NGRose f) where - from1 (NGNode a x) = Par1 a :*: (Comp1 (gmap Rec1 x)) - to1 (Par1 a :*: Comp1 x) = NGNode a (gmap unRec1 x) - -instance (GShow a, GShow (f (NGRose (Comp f f) a))) => GShow (NGRose f a) where - gshowsPrec = t undefined where - t :: (GShow a, GShow (f (NGRose (Comp f f) a))) => Rep0NGRose f a x -> NGRose f a -> ShowS - t = gshowsPrecdefault - -instance (GShow a) => GShow (Comp f g a) where - gshowsPrec = t undefined where - t :: (GShow a) => Rep0Comp f g a x -> Comp f g a -> ShowS - t = gshowsPrecdefault - -instance (GFunctor f, GFunctor (Comp f f)) => GFunctor (NGRose f) where - gmap = t undefined where - t :: (GFunctor f, GFunctor (Comp f f)) => Rep1NGRose f a -> (a -> b) -> NGRose f a -> NGRose f b - t = gmapdefault - -ngrose1 :: NGRose [] Int -ngrose1 = NGNode 0 [ngrose2, ngrose2] - -ngrose2 :: NGRose (Comp [] []) Int -ngrose2 = NGNode 1 (Comp []) - -testsNGRose = [ gshow ngrose1 - , gshow (gmap gshow ngrose1) ] --} - --------------------------------------------------------------------------------- --- Example: Double type composition (minimal) --------------------------------------------------------------------------------- - --- Add this to EHC -unComp (Comp1 x) = x - -data Weird a = Weird [[[a]]] deriving Show - -type Rep1Weird = [] :.: [] :.: Rec1 [] -instance Generic1 Weird where - type Rep1 Weird = Rep1Weird - from1 (Weird x) = Comp1 (gmap (Comp1 . gmap Rec1) x) - to1 (Comp1 x) = Weird (gmap (gmap unRec1 . unComp) x) - -#if __GLASGOW_HASKELL__ >= 701 - -instance GFunctor Weird - -#else - -instance GFunctor Weird where - gmap = gmapdefault - -#endif - --------------------------------------------------------------------------------- --- Example: Nested datatype Bush (minimal) --------------------------------------------------------------------------------- - -data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (Bush a) -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''Bush) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''Bush) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Bush -#else - -type Rep1Bush = U1 :+: Par1 :*: Bush :.: Rec1 Bush -instance Generic1 Bush where - type Rep1 Bush = Rep1Bush - from1 BushNil = L1 U1 - from1 (BushCons a b) = R1 (Par1 a :*: Comp1 (gmap Rec1 b)) - to1 (L1 U1) = BushNil - to1 (R1 (Par1 a :*: Comp1 b)) = BushCons a (gmap unRec1 b) - -#endif - -#if __GLASGOW_HASKELL__ < 701 - -instance GFunctor Bush where - gmap = gmapdefault - -instance (GShow a) => GShow (Bush a) where - gshowsPrec = gshowsPrecdefault - -#else - -instance GFunctor Bush -instance (GShow a) => GShow (Bush a) - -#endif - --- Example usage -bush1 :: Bush Int -bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil) - -testsBush = [ gshow bush1 - , gshow (gmap gshow bush1) ] - --------------------------------------------------------------------------------- --- Example: Two parameters, datatype constraint, nested on other parameter --------------------------------------------------------------------------------- - --- Any constraints on |b| mean we cannot generate the Generic1 instance --- Constraints on |a| are just propagated to Generic and generic --- function instances -data (Show a) => Either a b = Left (Either [a] b) | Right b - - --- Generic1 instances -type Rep0Either a b = Rec0 (Either [a] b) :+: Rec0 b -instance (Show a) => Generic (Either a b) where - type Rep (Either a b) = Rep0Either a b - from (Left a) = L1 (K1 a) - from (Right a) = R1 (K1 a) - to (L1 (K1 a)) = Left a - to (R1 (K1 a)) = Right a - -type RepEither a = Rec1 (Either [a]) :+: Par1 -instance (Show a) => Generic1 (Either a) where - type Rep1 (Either a) = RepEither a - from1 (Left a) = L1 (Rec1 a) - from1 (Right a) = R1 (Par1 a) - to1 (L1 (Rec1 a)) = Left a - to1 (R1 (Par1 a)) = Right a - - -#if __GLASGOW_HASKELL__ < 701 --- Instance for gshow (should be automatically generated) -instance (Show a, GShow a, GShow b) => GShow (Either a b) where - gshowsPrec = gshowsPrecdefault - -instance (Show a) => GFunctor (Either a) where - gmap = gmapdefault - -#else - -instance (Show a, GShow a, GShow b) => GShow (Either a b) -instance (Show a) => GFunctor (Either a) - -#endif - -either1 :: Either Int Char -either1 = Left either2 - -either2 :: Either [Int] Char -either2 = Right 'p' - -testsEither = [ gshow either1 - , gshow (gmap gshow either1) ] - --------------------------------------------------------------------------------- --- Main tests --------------------------------------------------------------------------------- - -main :: IO () -main = do - let p = putStrLn . ((++) "- ") . show - putStrLn "[] and Maybe tests:" - mapM_ p testsStandard - putStrLn "Tests for Tree:" - mapM_ p testsTree - putStrLn "\nTests for List:" - mapM_ p testsList - putStrLn "\nTests for Rose:" - mapM_ p testsRose - putStrLn "\nTests for GRose:" - mapM_ p testsGRose - putStrLn "\nTests for Either:" - mapM_ p testsEither - putStrLn "\nTests for Nested:" - mapM_ p testsNested - putStrLn "\nTests for Bush:" - mapM_ p testsBush diff --git a/generic-deriving.cabal b/generic-deriving.cabal --- a/generic-deriving.cabal +++ b/generic-deriving.cabal @@ -1,56 +1,150 @@ -name: generic-deriving -version: 1.5.0 -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 GHC before version 7.2. - -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.6 -tested-with: GHC == 7.0.3, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1 -extra-source-files: examples/Examples.hs - -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.ConNames - Generics.Deriving.Enum - Generics.Deriving.Eq - Generics.Deriving.Foldable - Generics.Deriving.Functor - Generics.Deriving.Monoid - Generics.Deriving.Show - Generics.Deriving.Traversable - Generics.Deriving.Uniplate - - Generics.Deriving.TH - - build-depends: base < 5, template-haskell >=2.4 && <2.10 - if impl(ghc > 7.0) - build-depends: ghc-prim < 1 - - extensions: CPP - ghc-options: -Wall +name: generic-deriving +version: 1.14.7 +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.3 + , GHC == 9.12.2 + , GHC == 9.14.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.9 + , template-haskell >= 2.11 && < 2.25 + -- TODO: Eventually, we should bump the lower version + -- bounds to >=0.6 so that we can remove some CPP in + -- Generics.Deriving.TH.Internal. + , th-abstraction >= 0.4 && < 0.8 + + default-language: Haskell2010 + ghc-options: -Wall + +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 + 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 diff --git a/src/Generics/Deriving.hs b/src/Generics/Deriving.hs --- a/src/Generics/Deriving.hs +++ b/src/Generics/Deriving.hs @@ -1,20 +1,24 @@ - -module Generics.Deriving ( - - module Generics.Deriving.Base, - module Generics.Deriving.ConNames, - 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.ConNames -import Generics.Deriving.Enum -import Generics.Deriving.Eq -import Generics.Deriving.Functor -import Generics.Deriving.Show -import Generics.Deriving.Uniplate + +module Generics.Deriving ( + + module Generics.Deriving.Base, + module Generics.Deriving.Copoint, + module Generics.Deriving.ConNames, + module Generics.Deriving.Default, + module Generics.Deriving.Enum, + module Generics.Deriving.Eq, + module Generics.Deriving.Functor, + module Generics.Deriving.Show, + module Generics.Deriving.Uniplate + + ) where + +import Generics.Deriving.Base +import Generics.Deriving.Copoint +import Generics.Deriving.ConNames +import Generics.Deriving.Default +import Generics.Deriving.Enum +import Generics.Deriving.Eq +import Generics.Deriving.Functor +import Generics.Deriving.Show +import Generics.Deriving.Uniplate diff --git a/src/Generics/Deriving/Base.hs b/src/Generics/Deriving/Base.hs --- a/src/Generics/Deriving/Base.hs +++ b/src/Generics/Deriving/Base.hs @@ -1,165 +1,7 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} - -module Generics.Deriving.Base ( -#if __GLASGOW_HASKELL__ < 701 - -- * Generic representation types - V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) - , (:+:)(..), (:*:)(..), (:.:)(..) - - -- ** Synonyms for convenience - , Rec0, Par0, R, P - , D1, C1, S1, D, C, S - - -- * Meta-information - , Datatype(..), Constructor(..), Selector(..), NoSelector - , Fixity(..), Associativity(..), Arity(..), prec - - -- * Generic type classes - , Generic(..), Generic1(..) - - , -#else - module GHC.Generics, -#endif - - ) where - - -#if __GLASGOW_HASKELL__ >= 701 -import GHC.Generics - -#else --------------------------------------------------------------------------------- --- Representation types --------------------------------------------------------------------------------- - --- | Void: used for datatypes without constructors -data V1 p - --- | Unit: used for constructors without arguments -data U1 p = U1 - --- | Used for marking occurrences of the parameter -newtype Par1 p = Par1 { unPar1 :: p } - - --- | Recursive calls of kind * -> * -newtype Rec1 f p = Rec1 { unRec1 :: f p } - --- | Constants, additional parameters and recursion of kind * -newtype K1 i c p = K1 { unK1 :: c } - --- | Meta-information (constructor names, etc.) -newtype M1 i c f p = M1 { unM1 :: f p } - --- | Sums: encode choice between constructors -infixr 5 :+: -data (:+:) f g p = L1 { unL1 :: f p } | R1 { unR1 :: g p } - --- | Products: encode multiple arguments to constructors -infixr 6 :*: -data (:*:) f g p = f p :*: g p - --- | Composition of functors -infixr 7 :.: -newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } - --- | Tag for K1: recursion (of kind *) -data R --- | Tag for K1: parameters (other than the last) -data P - --- | Type synonym for encoding recursion (of kind *) -type Rec0 = K1 R --- | Type synonym for encoding parameters (other than the last) -type Par0 = K1 P - --- | Tag for M1: datatype -data D --- | Tag for M1: constructor -data C --- | Tag for M1: record selector -data S - --- | Type synonym for encoding meta-information for datatypes -type D1 = M1 D - --- | Type synonym for encoding meta-information for constructors -type C1 = M1 C - --- | Type synonym for encoding meta-information for record selectors -type S1 = M1 S - --- | Class for datatypes that represent datatypes -class Datatype d where - -- | The name of the datatype, fully qualified - datatypeName :: t d (f :: * -> *) a -> String - moduleName :: t d (f :: * -> *) a -> String - --- | Class for datatypes that represent records -class Selector s where - -- | The name of the selector - selName :: t s (f :: * -> *) a -> String - --- | Used for constructor fields without a name -data NoSelector - -instance Selector NoSelector where selName _ = "" - --- | Class for datatypes that represent data constructors -class Constructor c where - -- | The name of the constructor - conName :: t c (f :: * -> *) a -> String - - -- | The fixity of the constructor - conFixity :: t c (f :: * -> *) a -> Fixity - conFixity = const Prefix - - -- | Marks if this constructor is a record - conIsRecord :: t c (f :: * -> *) a -> Bool - conIsRecord = const False - - --- | Datatype to represent the arity of a tuple. -data Arity = NoArity | Arity Int - deriving (Eq, Show, Ord, Read) - --- | Datatype to represent the fixity of a constructor. An infix --- | declaration directly corresponds to an application of 'Infix'. -data Fixity = Prefix | Infix Associativity Int - deriving (Eq, Show, Ord, Read) - --- | Get the precedence of a fixity value. -prec :: Fixity -> Int -prec Prefix = 10 -prec (Infix _ n) = n - --- | Datatype to represent the associativy of a constructor -data Associativity = LeftAssociative - | RightAssociative - | NotAssociative - deriving (Eq, Show, Ord, Read) - --- | Representable types of kind * -class Generic a where - type Rep a :: * -> * - -- | Convert from the datatype to its representation - from :: a -> Rep a x - -- | Convert from the representation to the datatype - to :: Rep a x -> a - --- | Representable types of kind * -> * -class Generic1 f where - type Rep1 f :: * -> * - -- | Convert from the datatype to its representation - from1 :: f a -> Rep1 f a - -- | Convert from the representation to the datatype - to1 :: Rep1 f a -> f a - -#endif +{-# LANGUAGE Safe #-} + +module Generics.Deriving.Base (module GHC.Generics) where + +import GHC.Generics + +import Generics.Deriving.Instances () diff --git a/src/Generics/Deriving/ConNames.hs b/src/Generics/Deriving/ConNames.hs --- a/src/Generics/Deriving/ConNames.hs +++ b/src/Generics/Deriving/ConNames.hs @@ -1,50 +1,63 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# 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 all the possible contructors - -- of a type - ConNames(..), conNames - - ) where - -import Generics.Deriving.Base - - -class ConNames f where - gconNames :: f a -> [String] - -instance (ConNames f, ConNames g) => ConNames (f :+: g) where - gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++ - gconNames (undefined :: g a) - -instance (ConNames f) => ConNames (D1 c f) where - gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a) - -instance (Constructor c) => ConNames (C1 c f) where - gconNames 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)) +{-# 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) diff --git a/src/Generics/Deriving/Copoint.hs b/src/Generics/Deriving/Copoint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Copoint.hs @@ -0,0 +1,141 @@ +{-# 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 diff --git a/src/Generics/Deriving/Default.hs b/src/Generics/Deriving/Default.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Default.hs @@ -0,0 +1,271 @@ +-- | +-- 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 diff --git a/src/Generics/Deriving/Enum.hs b/src/Generics/Deriving/Enum.hs --- a/src/Generics/Deriving/Enum.hs +++ b/src/Generics/Deriving/Enum.hs @@ -1,210 +1,1041 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Enum ( - - -- * Generic enum class - GEnum(..) - - -- * Default definitions for GEnum - , genumDefault, toEnumDefault, fromEnumDefault - - -- * Generic Ix class - , GIx(..) - - -- * Default definitions for GIx - , rangeDefault, indexDefault, inRangeDefault - - ) where - - -import Generics.Deriving.Base -import Generics.Deriving.Instances () -import Generics.Deriving.Eq - - ------------------------------------------------------------------------------ --- Utility functions for Enum' ------------------------------------------------------------------------------ - -infixr 5 ||| - --- | Interleave elements from two lists. Similar to (++), but swap left and --- right arguments on every recursive application. --- --- From Mark Jones' talk at AFP2008 -(|||) :: [a] -> [a] -> [a] -[] ||| ys = ys -(x:xs) ||| ys = x : ys ||| xs - --- | Diagonalization of nested lists. Ensure that some elements from every --- sublist will be included. Handles infinite sublists. --- --- From Mark Jones' talk at AFP2008 -diag :: [[a]] -> [a] -diag = concat . foldr skew [] . map (map (\x -> [x])) - -skew :: [[a]] -> [[a]] -> [[a]] -skew [] ys = ys -skew (x:xs) ys = x : combine (++) xs ys - -combine :: (a -> a -> a) -> [a] -> [a] -> [a] -combine _ xs [] = xs -combine _ [] ys = ys -combine f (x:xs) (y:ys) = f x y : combine f xs ys - -findIndex :: (a -> Bool) -> [a] -> Maybe Int -findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] - in if (null l) - then Nothing - else Just (head l) - --------------------------------------------------------------------------------- --- Generic enum --------------------------------------------------------------------------------- - -class Enum' f where - enum' :: [f a] - -instance Enum' U1 where - enum' = [U1] - -instance (GEnum c) => Enum' (K1 i c) where - enum' = map K1 genum - -instance (Enum' f) => Enum' (M1 i c f) where - enum' = map M1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :+: g) where - enum' = map L1 enum' ||| map R1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :*: g) where - enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] - - -#if __GLASGOW_HASKELL__ < 701 - -instance (GEnum a) => GEnum (Maybe a) where - genum = genumDefault - -instance (GEnum a) => GEnum [a] where - genum = genumDefault - -#else - -instance (GEnum a) => GEnum (Maybe a) -instance (GEnum a) => GEnum [a] - -#endif - -genumDefault :: (Generic a, Enum' (Rep a)) => [a] -genumDefault = map to enum' - -toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a -toEnumDefault i = let l = enum' - in if (length l > i) - then to (l !! i) - else error "toEnum: invalid index" - -fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a)) - => a -> Int -fromEnumDefault x = case findIndex (geq x) (map to enum') of - Nothing -> error "fromEnum: no corresponding index" - Just i -> i - - -class GEnum a where - genum :: [a] - -#if __GLASGOW_HASKELL__ >= 701 - default genum :: (Generic a, Enum' (Rep a)) => [a] - genum = genumDefault -#endif - -instance GEnum Int where - genum = [0..] ||| (neg 0) where - neg n = (n-1) : neg (n-1) - --------------------------------------------------------------------------------- --- Generic Ix --------------------------------------------------------------------------------- - --- Minimal complete instance: 'range', 'index' and 'inRange'. -class (Ord a) => GIx a where - -- | The list of values in the subrange defined by a bounding pair. - range :: (a,a) -> [a] - -- | The position of a subscript in the subrange. - index :: (a,a) -> a -> Int - -- | Returns 'True' the given subscript lies in the range defined - -- the bounding pair. - inRange :: (a,a) -> a -> Bool -#if __GLASGOW_HASKELL__ >= 701 - default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] - range = rangeDefault - - default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int - index = indexDefault - - default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool - inRange = inRangeDefault -#endif - -rangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> [a] -rangeDefault = t (map to enum') where - t l (x,y) = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "rangeDefault: no corresponding index" - (_, Nothing) -> error "rangeDefault: no corresponding index" - (Just i, Just j) -> take (j-i) (drop i l) - -indexDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Int -indexDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of - Nothing -> error "indexDefault: index out of range" - Just k -> k - -inRangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Bool -inRangeDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> maybe False (const True) - (findIndex (geq z) (take (j-i) (drop i l))) - -#if __GLASGOW_HASKELL__ < 701 - -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 [a] where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#else - -instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) -instance (GEq a, GEnum a, GIx a) => GIx [a] - -#endif - -instance GIx Int where - range (m,n) = [m..n] - index (m,_n) i = i - m - inRange (m,n) i = m <= i && i <= n +{-# 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 diff --git a/src/Generics/Deriving/Eq.hs b/src/Generics/Deriving/Eq.hs --- a/src/Generics/Deriving/Eq.hs +++ b/src/Generics/Deriving/Eq.hs @@ -1,93 +1,557 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - - -module Generics.Deriving.Eq ( - -- * Generic show class - GEq(..) - -#if __GLASGOW_HASKELL__ >= 701 --- Nothing -#else - -- * Default definition - , geqdefault -#endif - - ) where - - -import Generics.Deriving.Base -import Generics.Deriving.Instances () --- import GHC.Generics - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -class GEq' f where - geq' :: f a -> f a -> Bool - -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 - - -class GEq a where - geq :: a -> a -> Bool - - -#if __GLASGOW_HASKELL__ >= 701 - default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool - geq x y = geq' (from x) (from y) -#endif - -#if __GLASGOW_HASKELL__ >= 701 --- Nothing; the default is in the class -#else -geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool -geqdefault x y = geq' (from x) (from y) -#endif - --- Base types instances -instance GEq Char where geq = (==) -instance GEq Int where geq = (==) -instance GEq Float where geq = (==) - - -#if __GLASGOW_HASKELL__ < 701 - -instance (GEq a) => GEq (Maybe a) where - geq = geqdefault - -instance (GEq a) => GEq [a] where - geq = geqdefault - -#else - -instance (GEq a) => GEq (Maybe a) -instance (GEq a) => GEq [a] - -#endif +{-# 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 diff --git a/src/Generics/Deriving/Foldable.hs b/src/Generics/Deriving/Foldable.hs --- a/src/Generics/Deriving/Foldable.hs +++ b/src/Generics/Deriving/Foldable.hs @@ -1,175 +1,274 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Foldable ( - -- * Foldable class - GFoldable(..) - - -- * Default method - , gfoldMapdefault - - -- * Derived functions - , gtoList - , gconcat - , gconcatMap - , gand - , gor - , gany - , gall - , gsum - , gproduct - , gmaximum - , gmaximumBy - , gminimum - , gminimumBy - , gelem - , gnotElem - , gfind - ) where - -import Data.Maybe -import Data.Monoid -import Generics.Deriving.Base -import Generics.Deriving.Instances () - --------------------------------------------------------------------------------- --- Generic fold --------------------------------------------------------------------------------- - -class GFoldable' t where - gfoldMap' :: Monoid m => (a -> m) -> t a -> m - -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 - - -class GFoldable t where - gfoldMap :: Monoid m => (a -> m) -> t a -> m -#if __GLASGOW_HASKELL__ >= 701 - default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) - => (a -> m) -> t a -> m - gfoldMap = gfoldMapdefault -#endif - - gfold :: Monoid m => t m -> m - gfold = gfoldMap id - - gfoldr :: (a -> b -> b) -> b -> t a -> b - gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z - - gfoldr' :: (a -> b -> b) -> b -> t a -> b - gfoldr' f z0 xs = gfoldl f' id xs z0 - where f' k x z = k $! f x z - - gfoldl :: (a -> b -> a) -> a -> t b -> a - gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z - - gfoldl' :: (a -> b -> a) -> a -> t b -> a - gfoldl' f z0 xs = gfoldr f' id xs z0 - where f' x k z = k $! f z x - - gfoldr1 :: (a -> a -> a) -> t a -> a - gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure") - (gfoldr mf Nothing xs) - where - mf x Nothing = Just x - mf x (Just y) = Just (f x y) - - gfoldl1 :: (a -> a -> a) -> t a -> a - gfoldl1 f xs = fromMaybe (error "foldl1: empty structure") - (gfoldl mf Nothing xs) - where - mf Nothing y = Just y - mf (Just x) y = Just (f x y) - -gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) - => (a -> m) -> t a -> m -gfoldMapdefault f x = gfoldMap' f (from1 x) - --- Base types instances -instance GFoldable Maybe where - gfoldMap = gfoldMapdefault - -instance GFoldable [] 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 = getSum . gfoldMap Sum - -gproduct :: (GFoldable t, Num a) => t a -> a -gproduct = getProduct . gfoldMap Product - -gmaximum :: (GFoldable t, Ord a) => t a -> a -gmaximum = gfoldr1 max - -gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a -gmaximumBy cmp = gfoldr1 max' - where max' x y = case cmp x y of - GT -> x - _ -> y - -gminimum :: (GFoldable t, Ord a) => t a -> a -gminimum = gfoldr1 min - -gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a -gminimumBy cmp = gfoldr1 min' - where min' x y = case cmp x y of - GT -> y - _ -> x - -gelem :: (GFoldable t, Eq a) => a -> t a -> Bool -gelem = gany . (==) - -gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool -gnotElem x = not . gelem x - -gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a -gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else []) - +{-# LANGUAGE 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 []) diff --git a/src/Generics/Deriving/Functor.hs b/src/Generics/Deriving/Functor.hs --- a/src/Generics/Deriving/Functor.hs +++ b/src/Generics/Deriving/Functor.hs @@ -1,70 +1,182 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Functor ( - -- * GFunctor class - GFunctor(..) - - -- * Default method - , gmapdefault - - ) where - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - --------------------------------------------------------------------------------- --- Generic fmap --------------------------------------------------------------------------------- - -class GFunctor' f where - gmap' :: (a -> b) -> f a -> f b - -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) - - -class GFunctor f where - gmap :: (a -> b) -> f a -> f b -#if __GLASGOW_HASKELL__ >= 701 - default gmap :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b - gmap = gmapdefault -#endif - -gmapdefault :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b -gmapdefault f = to1 . gmap' f . from1 - --- Base types instances -instance GFunctor Maybe where - gmap = gmapdefault - -instance GFunctor [] where - gmap = gmapdefault +{-# 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 diff --git a/src/Generics/Deriving/Instances.hs b/src/Generics/Deriving/Instances.hs --- a/src/Generics/Deriving/Instances.hs +++ b/src/Generics/Deriving/Instances.hs @@ -1,134 +1,106 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Generics.Deriving.Instances ( --- Only instances from Generics.Deriving.Base --- and the Generic1 instances -#if __GLASGOW_HASKELL__ < 705 - Rep1Maybe, Rep1List -#endif -#if __GLASGOW_HASKELL__ < 701 - -- * Representations for base types - , Rep0Char, Rep0Int, Rep0Float - , Rep0Maybe, Rep0List -#endif - ) where - -#if __GLASGOW_HASKELL__ < 705 -import Generics.Deriving.Base -#endif - -#if __GLASGOW_HASKELL__ < 701 --------------------------------------------------------------------------------- --- Representation for base types --------------------------------------------------------------------------------- - --- Representation types -{- -type Rep1Par1 = Par1 -instance Generic1 Par1 Rep1Par1 where - from1 = id - to1 = id - -type Rep1Rec1 f = Rec1 f -instance Generic1 (Rec1 f) (Rep1Rec1 f) where - from1 = id - to1 = id --} --- Kind * - -type Rep0Char = Rec0 Char -instance Generic Char where - type Rep Char = Rep0Char - from = K1 - to = unK1 - -type Rep0Int = Rec0 Int -instance Generic Int where - type Rep Int = Rep0Int - from = K1 - to = unK1 - -type Rep0Float = Rec0 Float -instance Generic Float where - type Rep Float = Rep0Float - from = K1 - to = unK1 - --- etc... - --- Kind * -> * - -type Rep0Maybe a = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ (Par0 a)) -instance Generic (Maybe a) where - type Rep (Maybe a) = Rep0Maybe a - from Nothing = M1 (L1 (M1 U1)) - from (Just x) = M1 (R1 (M1 (K1 x))) - to (M1 (L1 (M1 U1))) = Nothing - to (M1 (R1 (M1 (K1 x)))) = Just x - -type Rep0List a = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par0 a :*: Rec0 [a]))) -instance Generic [a] where - type Rep [a] = Rep0List a - from [] = M1 (L1 (M1 U1)) - from (h:t) = M1 (R1 (M1 (K1 h :*: K1 t))) - to (M1 (L1 (M1 U1))) = [] - to (M1 (R1 (M1 (K1 h :*: K1 t)))) = h : t -#endif - -#if __GLASGOW_HASKELL__ < 705 --- GHC 7.2 and 7.4 still need these instances; 7.6 doesn't - -data Maybe_ -data Nothing_ -data Just_ - -instance Datatype Maybe_ where - datatypeName _ = "Maybe" - moduleName _ = "Representation" - -instance Constructor Nothing_ where - conName _ = "Nothing" - -instance Constructor Just_ where - conName _ = "Just" - - -type Rep1Maybe = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ Par1) -instance Generic1 Maybe where - type Rep1 Maybe = Rep1Maybe - from1 Nothing = M1 (L1 (M1 U1)) - from1 (Just x) = M1 (R1 (M1 (Par1 x))) - to1 (M1 (L1 (M1 U1))) = Nothing - to1 (M1 (R1 (M1 (Par1 x)))) = Just x - - -data List__ -data Nil__ -data Cons__ - -instance Datatype List__ where - datatypeName _ = "[]" - moduleName _ = "Data.List" - -instance Constructor Nil__ where conName _ = "[]" -instance Constructor Cons__ where - conName _ = ":" - conFixity _ = Infix RightAssociative 5 - - -type Rep1List = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par1 :*: Rec1 []))) -instance Generic1 [] where - type Rep1 [] = Rep1List - from1 [] = M1 (L1 (M1 U1)) - from1 (h:t) = M1 (R1 (M1 (Par1 h :*: Rec1 t))) - to1 (M1 (L1 (M1 U1))) = [] - to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = h : t - --- etc... - -#endif +{-# 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 diff --git a/src/Generics/Deriving/Monoid.hs b/src/Generics/Deriving/Monoid.hs --- a/src/Generics/Deriving/Monoid.hs +++ b/src/Generics/Deriving/Monoid.hs @@ -1,217 +1,17 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - --- | 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. - -module Generics.Deriving.Monoid ( - - -- * GMonoid type class - GMonoid(..), - - -- * Default definitions - -- ** GMonoid - gmemptydefault, - gmappenddefault, - - -- ** 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, - - -- * The Monoid module - -- | This is exported for convenient access to the various wrapper types. - module Data.Monoid, - - ) where - --------------------------------------------------------------------------------- - -import Generics.Deriving.Base -import Generics.Deriving.Instances () -import Data.Monoid - --------------------------------------------------------------------------------- - -class 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 GMonoid a where - - -- | Generic 'mempty' - gmempty :: a - - -- | Generic 'mappend' - gmappend :: a -> a -> a - - -- | Generic 'mconcat' - gmconcat :: [a] -> a - gmconcat = foldr gmappend gmempty - -#if __GLASGOW_HASKELL__ >= 701 - default gmempty :: (Generic a, GMonoid' (Rep a)) => a - gmempty = to gmempty' - - default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a - gmappend x y = to (gmappend' (from x) (from y)) -#endif - --------------------------------------------------------------------------------- - --- Instances that reuse Monoid -instance GMonoid Ordering where - gmempty = mempty - gmappend = mappend -instance GMonoid () where - gmempty = mempty - gmappend = mappend -instance GMonoid Any where - gmempty = mempty - gmappend = mappend -instance GMonoid All where - gmempty = mempty - gmappend = mappend -instance GMonoid (First a) where - gmempty = mempty - gmappend = mappend -instance GMonoid (Last a) where - gmempty = mempty - gmappend = mappend -instance Num a => GMonoid (Sum a) where - gmempty = mempty - gmappend = mappend -instance Num a => GMonoid (Product a) where - gmempty = mempty - gmappend = mappend -instance GMonoid [a] where - gmempty = mempty - gmappend = mappend -instance GMonoid (Endo a) where - gmempty = mempty - gmappend = mappend - --- Handwritten instances -instance GMonoid a => GMonoid (Dual a) where - gmempty = Dual gmempty - gmappend (Dual x) (Dual y) = Dual (gmappend y x) -instance GMonoid a => GMonoid (Maybe a) where - gmempty = Nothing - gmappend Nothing x = x - gmappend x Nothing = x - gmappend (Just x) (Just y) = Just (gmappend x y) -instance GMonoid b => GMonoid (a -> b) where - gmempty _ = gmempty - gmappend f g x = gmappend (f x) (g x) - --- Tuple instances -instance (GMonoid a,GMonoid b) => GMonoid (a,b) where - gmempty = (gmempty,gmempty) - gmappend (a1,b1) (a2,b2) = - (gmappend a1 a2,gmappend b1 b2) -instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where - gmempty = (gmempty,gmempty,gmempty) - gmappend (a1,b1,c1) (a2,b2,c2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where - gmempty = (gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2) - +{-# LANGUAGE 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 diff --git a/src/Generics/Deriving/Monoid/Internal.hs b/src/Generics/Deriving/Monoid/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Monoid/Internal.hs @@ -0,0 +1,239 @@ +{-# 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) diff --git a/src/Generics/Deriving/Semigroup.hs b/src/Generics/Deriving/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Semigroup.hs @@ -0,0 +1,12 @@ +{-# 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) diff --git a/src/Generics/Deriving/Semigroup/Internal.hs b/src/Generics/Deriving/Semigroup/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Semigroup/Internal.hs @@ -0,0 +1,167 @@ +{-# 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) diff --git a/src/Generics/Deriving/Show.hs b/src/Generics/Deriving/Show.hs --- a/src/Generics/Deriving/Show.hs +++ b/src/Generics/Deriving/Show.hs @@ -1,142 +1,606 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Show ( - -- * Generic show class - GShow(..) - - -- * Default definition - , gshowsPrecdefault - - ) where - - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -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' 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 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 - - -class GShow a where - gshowsPrec :: Int -> a -> ShowS - gshows :: a -> ShowS - gshows = gshowsPrec 0 - gshow :: a -> String - gshow x = gshows x "" -#if __GLASGOW_HASKELL__ >= 701 - default gshowsPrec :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS - gshowsPrec = gshowsPrecdefault - -instance (GShow a) => GShow (Maybe a) - -#else - -instance (GShow a) => GShow (Maybe a) where - gshowsPrec = gshowsPrecdefault - -#endif - -gshowsPrecdefault :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS -gshowsPrecdefault n = gshowsPrec' Pref n . from - - --- Base types instances -instance GShow Char where gshowsPrec = showsPrec -instance GShow Int where gshowsPrec = showsPrec -instance GShow Float where gshowsPrec = showsPrec -instance GShow String where gshowsPrec = showsPrec -instance GShow Bool where gshowsPrec = showsPrec - -intersperse :: a -> [a] -> [a] -intersperse _ [] = [] -intersperse _ [h] = [h] -intersperse x (h:t) = h : x : (intersperse x t) - -instance (GShow a) => GShow [a] where - gshowsPrec _ l = showChar '[' - . foldr (.) id - (intersperse (showChar ',') (map (gshowsPrec 0) l)) - . showChar ']' +{-# 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 diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs --- a/src/Generics/Deriving/TH.hs +++ b/src/Generics/Deriving/TH.hs @@ -1,415 +1,1206 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} -{-# OPTIONS_GHC -w #-} - ------------------------------------------------------------------------------ --- | --- 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. For now, it generates only the 'Generic' instance. --- Empty datatypes are not yet supported. ------------------------------------------------------------------------------ - --- Adapted from Generics.Regular.TH -module Generics.Deriving.TH ( - - deriveMeta - , deriveData - , deriveConstructors - , deriveSelectors - -#if __GLASGOW_HASKELL__ < 701 - , deriveAll - , deriveRepresentable0 - , deriveRep0 - , simplInstance -#endif - ) where - -import Generics.Deriving.Base - -import Language.Haskell.TH hiding (Fixity()) -import Language.Haskell.TH.Syntax (Lift(..)) - -import Data.List (intercalate) -import Control.Monad - --- | Given the names of a generic class, a type to instantiate, a function in --- the class and the default implementation, generates the code for a basic --- generic instance. -simplInstance :: Name -> Name -> Name -> Name -> Q [Dec] -simplInstance cl ty fn df = do - i <- reify (genRepName 0 ty) - x <- newName "x" - let typ = ForallT [PlainTV x] [] - ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 ty)) - (typeVariables i)) `AppT` (VarT x)) - fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty) - [funD fn [clause [] (normalB (varE df `appE` - (sigE (global 'undefined) (return typ)))) []]] - - --- | 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. -deriveAll :: Name -> Q [Dec] -deriveAll n = - do a <- deriveMeta n - b <- deriveRepresentable0 n - return (a ++ b) - --- | Given the type and the name (as string) for the type to derive, --- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' --- instances. -deriveMeta :: Name -> Q [Dec] -deriveMeta n = - do a <- deriveData n - b <- deriveConstructors n - c <- deriveSelectors n - return (a ++ b ++ c) - --- | Given a datatype name, derive a datatype and instance of class 'Datatype'. -deriveData :: Name -> Q [Dec] -deriveData = dataInstance - --- | Given a datatype name, derive datatypes and --- instances of class 'Constructor'. -deriveConstructors :: Name -> Q [Dec] -deriveConstructors = constrInstance - --- | Given a datatype name, derive datatypes and instances of class 'Selector'. -deriveSelectors :: Name -> Q [Dec] -deriveSelectors = selectInstance - --- | Given the type and the name (as string) for the Representable0 type --- synonym to derive, generate the 'Representable0' instance. -deriveRepresentable0 :: Name -> Q [Dec] -deriveRepresentable0 n = do - rep0 <- deriveRep0 n - inst <- deriveInst n - return $ rep0 ++ inst - --- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0' --- is used. -deriveRep0 :: Name -> Q [Dec] -deriveRep0 n = do - i <- reify n - fmap (:[]) $ tySynD (genRepName 0 n) (typeVariables i) (rep0Type n) - -deriveInst :: Name -> Q [Dec] -deriveInst t = do - i <- reify t - let typ q = foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q) - (typeVariables i) -#if __GLASGOW_HASKELL__ >= 707 - let tyIns = TySynInstD ''Rep (fmap (TySynEqn [typ (genRepName 0 t)]) [typ t]) -#else - let tyIns = TySynInstD ''Rep [typ t] (typ (genRepName 0 t)) -#endif - fcs <- mkFrom t 1 0 t - tcs <- mkTo t 1 0 t - liftM (:[]) $ - instanceD (cxt []) (conT ''Generic `appT` return (typ t)) - [return tyIns, funD 'from fcs, funD 'to tcs] - - -dataInstance :: Name -> Q [Dec] -dataInstance n = do - i <- reify n - case i of - TyConI (DataD _ n _ _ _) -> mkInstance n - TyConI (NewtypeD _ n _ _ _) -> mkInstance n - _ -> return [] - where - mkInstance n = do - ds <- mkDataData n - is <- mkDataInstance n - return $ [ds,is] - -constrInstance :: Name -> Q [Dec] -constrInstance n = do - i <- reify n - case i of - TyConI (DataD _ n _ cs _) -> mkInstance n cs - TyConI (NewtypeD _ n _ c _) -> mkInstance n [c] - _ -> return [] - where - mkInstance n cs = do - ds <- mapM (mkConstrData n) cs - is <- mapM (mkConstrInstance n) cs - return $ ds ++ is - -selectInstance :: Name -> Q [Dec] -selectInstance n = do - i <- reify n - case i of - TyConI (DataD _ n _ cs _) -> mkInstance n cs - TyConI (NewtypeD _ n _ c _) -> mkInstance n [c] - _ -> return [] - where - mkInstance n cs = do - ds <- mapM (mkSelectData n) cs - is <- mapM (mkSelectInstance n) cs - return $ concat (ds ++ is) - -typeVariables :: Info -> [TyVarBndr] -typeVariables (TyConI (DataD _ _ tv _ _)) = tv -typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv -typeVariables _ = [] - -tyVarBndrToName :: TyVarBndr -> Name -tyVarBndrToName (PlainTV name) = name -tyVarBndrToName (KindedTV name _) = name - -stripRecordNames :: Con -> Con -stripRecordNames (RecC n f) = - NormalC n (map (\(_, s, t) -> (s, t)) f) -stripRecordNames c = c - -genName :: [Name] -> Name -genName = mkName . (++"_") . intercalate "_" . map nameBase - -genRepName :: Int -> Name -> Name -genRepName n = mkName . (++"_") . (("Rep" ++ show n) ++) . nameBase - -mkDataData :: Name -> Q Dec -mkDataData n = dataD (cxt []) (genName [n]) [] [] [] - -mkConstrData :: Name -> Con -> Q Dec -mkConstrData dt (NormalC n _) = - dataD (cxt []) (genName [dt, n]) [] [] [] -mkConstrData dt r@(RecC _ _) = - mkConstrData dt (stripRecordNames r) -mkConstrData dt (InfixC t1 n t2) = - mkConstrData dt (NormalC n [t1,t2]) - -mkSelectData :: Name -> Con -> Q [Dec] -mkSelectData dt r@(RecC n fs) = return (map one fs) - where one (f, _, _) = DataD [] (genName [dt, n, f]) [] [] [] -mkSelectData dt _ = return [] - - -mkDataInstance :: Name -> Q Dec -mkDataInstance n = - instanceD (cxt []) (appT (conT ''Datatype) (conT $ genName [n])) - [funD 'datatypeName [clause [wildP] (normalB (stringE (nameBase n))) []] - ,funD 'moduleName [clause [wildP] (normalB (stringE name)) []]] - where - name = maybe (error "Cannot fetch module name!") id (nameModule n) - -instance Lift Fixity where - lift Prefix = conE 'Prefix - lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |] - -instance Lift Associativity where - lift LeftAssociative = conE 'LeftAssociative - lift RightAssociative = conE 'RightAssociative - lift NotAssociative = conE 'NotAssociative - -mkConstrInstance :: Name -> Con -> Q Dec -mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n [] -mkConstrInstance dt (RecC n _) = mkConstrInstanceWith dt n - [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]] -mkConstrInstance dt (InfixC t1 n t2) = - do - i <- reify n - let fi = case i of - DataConI _ _ _ f -> convertFixity f - _ -> Prefix - instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n])) - [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []], - funD 'conFixity [clause [wildP] (normalB [| fi |]) []]] - where - convertFixity (Fixity n d) = Infix (convertDirection d) n - convertDirection InfixL = LeftAssociative - convertDirection InfixR = RightAssociative - convertDirection InfixN = NotAssociative - -mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec -mkConstrInstanceWith dt n extra = - instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n])) - (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra) - -mkSelectInstance :: Name -> Con -> Q [Dec] -mkSelectInstance dt r@(RecC n fs) = return (map one fs) where - one (f, _, _) = - InstanceD ([]) (AppT (ConT ''Selector) (ConT $ genName [dt, n, f])) - [FunD 'selName [Clause [WildP] - (NormalB (LitE (StringL (nameBase f)))) []]] -mkSelectInstance _ _ = return [] - -rep0Type :: Name -> Q Type -rep0Type n = - do - -- runIO $ putStrLn $ "processing " ++ show n - i <- reify n - let b = case i of - TyConI (DataD _ dt vs cs _) -> - (conT ''D1) `appT` (conT $ genName [dt]) `appT` - (foldr1' sum (conT ''V1) - (map (rep0Con (dt, map tyVarBndrToName vs)) cs)) - TyConI (NewtypeD _ dt vs c _) -> - (conT ''D1) `appT` (conT $ genName [dt]) `appT` - (rep0Con (dt, map tyVarBndrToName vs) c) - TyConI (TySynD t _ _) -> error "type synonym?" - _ -> error "unknown construct" - --appT b (conT $ mkName (nameBase n)) - b where - sum :: Q Type -> Q Type -> Q Type - sum a b = conT ''(:+:) `appT` a `appT` b - - -rep0Con :: (Name, [Name]) -> Con -> Q Type -rep0Con (dt, vs) (NormalC n []) = - conT ''C1 `appT` (conT $ genName [dt, n]) `appT` - (conT ''S1 `appT` conT ''NoSelector `appT` conT ''U1) -rep0Con (dt, vs) (NormalC n fs) = - conT ''C1 `appT` (conT $ genName [dt, n]) `appT` - (foldr1 prod (map (repField (dt, vs) . snd) fs)) where - prod :: Q Type -> Q Type -> Q Type - prod a b = conT ''(:*:) `appT` a `appT` b -rep0Con (dt, vs) r@(RecC n []) = - conT ''C1 `appT` (conT $ genName [dt, n]) `appT` conT ''U1 -rep0Con (dt, vs) r@(RecC n fs) = - conT ''C1 `appT` (conT $ genName [dt, n]) `appT` - (foldr1 prod (map (repField' (dt, vs) n) fs)) where - prod :: Q Type -> Q Type -> Q Type - prod a b = conT ''(:*:) `appT` a `appT` b - -rep0Con d (InfixC t1 n t2) = rep0Con d (NormalC n [t1,t2]) - ---dataDeclToType :: (Name, [Name]) -> Type ---dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs - -repField :: (Name, [Name]) -> Type -> Q Type ---repField d t | t == dataDeclToType d = conT ''I -repField d t = conT ''S1 `appT` conT ''NoSelector `appT` - (conT ''Rec0 `appT` return t) - -repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type ---repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I -repField' (dt, vs) ns (f, _, t) = conT ''S1 `appT` conT (genName [dt, ns, f]) - `appT` (conT ''Rec0 `appT` return t) --- Note: we should generate Par0 too, at some point - - -mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause] -mkFrom ns m i n = - do - -- runIO $ putStrLn $ "processing " ++ show n - let wrapE e = lrE m i e - i <- reify n - let b = case i of - TyConI (DataD _ dt vs cs _) -> - zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs) - (length cs)) [0..] cs - TyConI (NewtypeD _ dt vs c _) -> - [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c] - TyConI (TySynD t _ _) -> error "type synonym?" - -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `appE` varE (field 0))) []] - _ -> error "unknown construct" - return b - -mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause] -mkTo ns m i n = - do - -- runIO $ putStrLn $ "processing " ++ show n - let wrapP p = lrP m i p - i <- reify n - let b = case i of - TyConI (DataD _ dt vs cs _) -> - zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs) - (length cs)) [0..] cs - TyConI (NewtypeD _ dt vs c _) -> - [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c] - TyConI (TySynD t _ _) -> error "type synonym?" - -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []] - _ -> error "unknown construct" - return b - -fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause -fromCon wrap ns (dt, vs) m i (NormalC cn []) = - clause - [conP cn []] - (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ appE (conE 'M1) $ - conE 'M1 `appE` (conE 'U1)) [] -fromCon wrap ns (dt, vs) m i (NormalC cn fs) = - -- runIO (putStrLn ("constructor " ++ show ix)) >> - clause - [conP cn (map (varP . field) [0..length fs - 1])] - (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` - foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) [] - where prod x y = conE '(:*:) `appE` x `appE` y -fromCon wrap ns (dt, vs) m i r@(RecC cn []) = - clause - [conP cn []] - (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` (conE 'U1)) [] -fromCon wrap ns (dt, vs) m i r@(RecC cn fs) = - clause - [conP cn (map (varP . field) [0..length fs - 1])] - (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` - foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) [] - where prod x y = conE '(:*:) `appE` x `appE` y -fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) = - fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2]) - -fromField :: (Name, [Name]) -> Int -> Type -> Q Exp ---fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr) -fromField (dt, vs) nr t = conE 'M1 `appE` (conE 'K1 `appE` varE (field nr)) - -toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause -toCon wrap ns (dt, vs) m i (NormalC cn []) = - clause - [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'M1 [conP 'U1 []]]]] - (normalB $ conE cn) [] -toCon wrap ns (dt, vs) m i (NormalC cn fs) = - -- runIO (putStrLn ("constructor " ++ show ix)) >> - clause - [wrap $ conP 'M1 [lrP m i $ conP 'M1 - [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]] - (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) [] - where prod x y = conP '(:*:) [x,y] -toCon wrap ns (dt, vs) m i r@(RecC cn []) = - clause - [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'U1 []]]] - (normalB $ conE cn) [] -toCon wrap ns (dt, vs) m i r@(RecC cn fs) = - clause - [wrap $ conP 'M1 [lrP m i $ conP 'M1 - [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]] - (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) [] - where prod x y = conP '(:*:) [x,y] -toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) = - toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2]) - -toField :: (Name, [Name]) -> Int -> Type -> Q Pat ---toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)] -toField (dt, vs) nr t = conP 'M1 [conP 'K1 [varP (field nr)]] - - -field :: Int -> Name -field n = mkName $ "f" ++ show n - -lrP :: Int -> Int -> (Q Pat -> Q Pat) -lrP 1 0 p = p -lrP m 0 p = conP 'L1 [p] -lrP m i p = conP 'R1 [lrP (m-1) (i-1) p] - -lrE :: Int -> Int -> (Q Exp -> Q Exp) -lrE 1 0 e = e -lrE m 0 e = conE 'L1 `appE` e -lrE m i e = conE 'R1 `appE` lrE (m-1) (i-1) e - -trd (_,_,c) = c - --- | Variant of foldr1 which returns a special element for empty lists -foldr1' f x [] = x -foldr1' _ _ [x] = x -foldr1' f x (h:t) = f h (foldr1' f x t) +{-# 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! +-} diff --git a/src/Generics/Deriving/TH/Internal.hs b/src/Generics/Deriving/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/TH/Internal.hs @@ -0,0 +1,830 @@ +{-# 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 diff --git a/src/Generics/Deriving/TH/Post4_9.hs b/src/Generics/Deriving/TH/Post4_9.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/TH/Post4_9.hs @@ -0,0 +1,137 @@ +{- | +Module : Generics.Deriving.TH.Post4_9 +Copyright : (c) 2008--2009 Universiteit Utrecht +License : BSD3 + +Maintainer : generics@haskell.org +Stability : experimental +Portability : non-portable + +Template Haskell machinery for the type-literal-based variant of GHC +generics introduced in @base-4.9@. +-} + +module Generics.Deriving.TH.Post4_9 ( + deriveMeta + , deriveData + , deriveConstructors + , deriveSelectors + , mkMetaDataType + , mkMetaConsType + , mkMetaSelType + , SelStrictInfo(..) + , reifySelStrictInfo + ) where + +import Data.Maybe (fromMaybe) + +import Generics.Deriving.TH.Internal + +import Language.Haskell.TH.Datatype as THAbs +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type +mkMetaDataType dv n = + promotedT metaDataDataName + `appT` litT (strTyLit (nameBase n)) + `appT` litT (strTyLit m) + `appT` litT (strTyLit pkg) + `appT` promoteBool (isNewtypeVariant dv) + where + m, pkg :: String + m = fromMaybe (error "Cannot fetch module name!") (nameModule n) + pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) + +mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type +mkMetaConsType _ _ n conIsRecord conIsInfix = do + mbFi <- reifyFixity n + promotedT metaConsDataName + `appT` litT (strTyLit (nameBase n)) + `appT` fixityIPromotedType mbFi conIsInfix + `appT` promoteBool conIsRecord + +promoteBool :: Bool -> Q Type +promoteBool True = promotedT trueDataName +promoteBool False = promotedT falseDataName + +fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type +fixityIPromotedType mbFi True = + promotedT infixIDataName + `appT` promoteAssociativity a + `appT` litT (numTyLit (toInteger n)) + where + Fixity n a = fromMaybe defaultFixity mbFi +fixityIPromotedType _ False = promotedT prefixIDataName + +promoteAssociativity :: FixityDirection -> Q Type +promoteAssociativity InfixL = promotedT leftAssociativeDataName +promoteAssociativity InfixR = promotedT rightAssociativeDataName +promoteAssociativity InfixN = promotedT notAssociativeDataName + +mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name + -> SelStrictInfo -> Q Type +mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) = + let mbSelNameT = case mbF of + Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f)) + Nothing -> promotedT nothingDataName + in promotedT metaSelDataName + `appT` mbSelNameT + `appT` promoteUnpackedness su + `appT` promoteStrictness ss + `appT` promoteDecidedStrictness ds + +data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness + +promoteUnpackedness :: Unpackedness -> Q Type +promoteUnpackedness UnspecifiedUnpackedness = promotedT noSourceUnpackednessDataName +promoteUnpackedness NoUnpack = promotedT sourceNoUnpackDataName +promoteUnpackedness Unpack = promotedT sourceUnpackDataName + +promoteStrictness :: Strictness -> Q Type +promoteStrictness UnspecifiedStrictness = promotedT noSourceStrictnessDataName +promoteStrictness Lazy = promotedT sourceLazyDataName +promoteStrictness THAbs.Strict = promotedT sourceStrictDataName + +promoteDecidedStrictness :: DecidedStrictness -> Q Type +promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName +promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName +promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName + +reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo] +reifySelStrictInfo conName fs = do + dcdStrs <- reifyConStrictness conName + let srcUnpks = map fieldUnpackedness fs + srcStrs = map fieldStrictness fs + return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs + +-- | Given the type and the name (as string) for the type to derive, +-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' +-- instances. +-- +-- On GHC 7.11 and up, this functionality is no longer used in GHC generics, +-- so this function generates no declarations. +deriveMeta :: Name -> Q [Dec] +deriveMeta _ = return [] + +-- | Given a datatype name, derive a datatype and instance of class 'Datatype'. +-- +-- On GHC 7.11 and up, this functionality is no longer used in GHC generics, +-- so this function generates no declarations. +deriveData :: Name -> Q [Dec] +deriveData _ = return [] + +-- | Given a datatype name, derive datatypes and +-- instances of class 'Constructor'. +-- +-- On GHC 7.11 and up, this functionality is no longer used in GHC generics, +-- so this function generates no declarations. +deriveConstructors :: Name -> Q [Dec] +deriveConstructors _ = return [] + +-- | Given a datatype name, derive datatypes and instances of class 'Selector'. +-- +-- On GHC 7.11 and up, this functionality is no longer used in GHC generics, +-- so this function generates no declarations. +deriveSelectors :: Name -> Q [Dec] +deriveSelectors _ = return [] diff --git a/src/Generics/Deriving/Traversable.hs b/src/Generics/Deriving/Traversable.hs --- a/src/Generics/Deriving/Traversable.hs +++ b/src/Generics/Deriving/Traversable.hs @@ -1,82 +1,184 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Traversable ( - -- * GTraversable class - GTraversable(..) - - -- * Default method - , gtraversedefault - - ) where - -import Control.Applicative -import Generics.Deriving.Base -import Generics.Deriving.Foldable -import Generics.Deriving.Functor -import Generics.Deriving.Instances () - --------------------------------------------------------------------------------- --- Generic traverse --------------------------------------------------------------------------------- - -class GTraversable' t where - gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b) - -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 - - -class (GFunctor t, GFoldable t) => GTraversable t where - gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b) -#if __GLASGOW_HASKELL__ >= 701 - default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) - gtraverse = gtraversedefault -#endif - - gsequenceA :: Applicative f => t (f a) -> f (t a) - gsequenceA = gtraverse id - - gmapM :: Monad m => (a -> m b) -> t a -> m (t b) - gmapM f = unwrapMonad . gtraverse (WrapMonad . f) - - gsequence :: Monad m => t (m a) -> m (t a) - gsequence = gmapM id - -gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) -gtraversedefault f x = to1 <$> gtraverse' f (from1 x) - --- Base types instances -instance GTraversable Maybe where - gtraverse = gtraversedefault - -instance GTraversable [] where - gtraverse = gtraversedefault +{-# 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 diff --git a/src/Generics/Deriving/Uniplate.hs b/src/Generics/Deriving/Uniplate.hs --- a/src/Generics/Deriving/Uniplate.hs +++ b/src/Generics/Deriving/Uniplate.hs @@ -1,355 +1,345 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : Generics.Deriving.Uniplate --- Copyright : 2011-2012 Universiteit Utrecht, University of Oxford --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Functions inspired by the Uniplate generic programming library, --- mostly implemented by Sean Leather. --------------------------------------------------------------------------------- - -module Generics.Deriving.Uniplate ( - Uniplate(..) - - -- * Derived functions - , uniplate - , universe - , rewrite - , rewriteM - , contexts - , holes - , para - - -- * Default definitions - , childrendefault - , contextdefault - , descenddefault - , descendMdefault - , transformdefault - , transformMdefault - - ) where - - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -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 (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 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 Context' (K1 i a) a where - context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context' (K1 _) (c:_) = K1 c - -instance 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 (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 (Context' g b) => Context' (f :*: g) b where - context' (a :*: b) cs = a :*: context' b cs - - -class Uniplate a where - children :: a -> [a] -#if __GLASGOW_HASKELL__ >= 701 - default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] - children = childrendefault -#endif - - context :: a -> [a] -> a -#if __GLASGOW_HASKELL__ >= 701 - default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a - context = contextdefault -#endif - - descend :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - descend = descenddefault -#endif - - descendM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - descendM = descendMdefault -#endif - - transform :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - transform = transformdefault -#endif - - transformM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - transformM = transformMdefault -#endif - -childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] -childrendefault = children' . from - -contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a -contextdefault x cs = to (context' (from x) cs) - -descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -descenddefault f = to . descend' f . from - -descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -descendMdefault f = liftM to . descendM' f . from - -transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -transformdefault f = f . to . transform' f . from - -transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -transformMdefault f = liftM to . transformM' f . from - - --- Derived functions (mostly copied from Neil Michell's code) - -uniplate :: Uniplate a => a -> ([a], [a] -> a) -uniplate a = (children a, context a) - -universe :: Uniplate a => a -> [a] -universe a = build (go a) - where - go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x - -rewrite :: Uniplate a => (a -> Maybe a) -> a -> a -rewrite f = transform g - where - g x = maybe x (rewrite f) (f x) - -rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a -rewriteM f = transformM g - where - g x = f x >>= maybe (return x) (rewriteM f) - -contexts :: Uniplate a => a -> [(a, a -> a)] -contexts a = (a, id) : f (holes a) - where - f xs = [ (ch2, ctx1 . ctx2) - | (ch1, ctx1) <- xs - , (ch2, ctx2) <- contexts ch1] - -holes :: Uniplate a => a -> [(a, a -> a)] -holes a = uncurry f (uniplate a) - where - f [] _ = [] - f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) - -para :: Uniplate a => (a -> [r] -> r) -> a -> r -para f x = f x $ map (para f) $ children x - - --- Base types instances -instance Uniplate Bool where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Char where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Double where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Float where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Int where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate () where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Tuple instances -instance Uniplate (b,c) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g,h) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Parameterized type instances -instance Uniplate (Maybe a) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (Either a b) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - -instance Uniplate [a] where - children [] = [] - children (_:t) = [t] - context _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context [] _ = [] - context (h:_) (t:_) = h:t - descend _ [] = [] - descend f (h:t) = h:f t - descendM _ [] = return [] - descendM f (h:t) = f t >>= \t' -> return (h:t') - transform f [] = f [] - transform f (h:t) = f (h:transform f t) - transformM f [] = f [] - transformM f (h:t) = transformM f t >>= \t' -> f (h:t') - +{-# LANGUAGE 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') + diff --git a/tests/DefaultSpec.hs b/tests/DefaultSpec.hs new file mode 100644 --- /dev/null +++ b/tests/DefaultSpec.hs @@ -0,0 +1,161 @@ +-- | +-- Module : DefaultSpec +-- Description : Ensure that deriving via (Default a) newtype works +-- License : BSD-3-Clause +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on +-- versions below. +-- +-- The test check a miscellany of properties of the derived type classes. +-- (Testing all the required properties is beyond the scope of this module.) +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +#endif + +module DefaultSpec where + +import Test.Hspec + +#if __GLASGOW_HASKELL__ >= 806 +import Test.Hspec.QuickCheck + +import Data.Semigroup (First(..)) +import Data.Foldable (sequenceA_) +import Generics.Deriving hiding (universe) +import Generics.Deriving.Default () +import Generics.Deriving.Foldable (GFoldable(..)) +import Generics.Deriving.Semigroup (GSemigroup(..)) +#endif + +spec :: Spec +spec = do + describe "DerivingVia Default" $ do + +#if __GLASGOW_HASKELL__ >= 806 + it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $ + let commutative :: GEq a => a -> a -> Expectation + commutative x y = x `geq` y `shouldBe` y `geq` x + + universe :: [MyType] + universe = MyType <$> [False, True] + + in commutative <$> universe <*> universe + + it "GShow for MyType is like Show for Bool with derivingVia (Default MyType) but prefixed with 'MyType '" $ do + gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False "" + gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True "" + + it "GEq is commutative for parameterized derivingVia (Default (MyType1 Bool))" . sequenceA_ $ + let commutative :: GEq a => a -> a -> Expectation + commutative x y = x `geq` y `shouldBe` y `geq` x + + universe :: [MyType1 Bool] + universe = MyType1 <$> [False, True] + + in commutative <$> universe <*> universe + + it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default (MyType1 Bool)) but prefixed with 'MyType1 '" $ do + gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0 False "" + gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True "" + + it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $ + let commutative :: GEq a => a -> a -> Expectation + commutative x y = x `geq` y `shouldBe` y `geq` x + + universe :: [TestEq] + universe = TestEq <$> [False, True] + + in commutative <$> universe <*> universe + + it "GENum is correct for derivingVia (Default Bool)" $ + genum `shouldBe` [TestEnum False, TestEnum True] + + it "GShow for TestShow is the same as Show for Bool with derivingVia (Default Bool)" $ do + gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False "" + gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True "" + + it "GSemigroup is like First when instantiated with derivingVia (First Bool)" . sequenceA_ $ + let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation + first' x y = x `gsappend` y `shouldBe` x + + universe :: [FirstSemigroup] + universe = FirstSemigroup <$> [False, True] + + in first' <$> universe <*> universe + + prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with Maybe (First Bool)" $ \(xs :: [Maybe Bool]) -> + let ys :: [Maybe (First Bool)] + -- Note that there is no Arbitrary instance for this type + ys = fmap First <$> xs + + unTestFoldable :: TestFoldable a -> Maybe a + unTestFoldable (TestFoldable x) = x + + in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys + + it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" . sequenceA_ $ + let universe :: [Maybe Bool] + universe = [Nothing, Just False, Just True] + + functor_prop :: Maybe Bool -> Expectation + functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor (not <$> x) + + in functor_prop <$> universe + +#endif + return () + +#if __GLASGOW_HASKELL__ >= 806 + +-- These types all implement instances using `DerivingVia`: most via +-- `Default` (one uses `First`). + +newtype TestEq = TestEq Bool + deriving (GEq) via (Default Bool) +newtype TestEnum = TestEnum Bool + deriving stock (Eq, Show) + deriving (GEnum) via (Default Bool) +newtype TestShow = TestShow Bool + deriving (GShow) via (Default Bool) + +newtype FirstSemigroup = FirstSemigroup Bool + deriving stock (Eq, Show) + deriving (GSemigroup) via (First Bool) + +newtype TestFoldable a = TestFoldable (Maybe a) + deriving (GFoldable) via (Default1 Maybe) + +newtype TestFunctor a = TestFunctor (Maybe a) + deriving stock (Eq, Show, Functor) + deriving (GFunctor) via (Default1 Maybe) + +newtype TestHigherEq a = TestHigherEq (Maybe a) + deriving stock (Generic) + deriving (GEq) via (Default (TestHigherEq a)) + +-- These types correspond to the hypothetical examples in the module +-- documentation. + +data MyType = MyType Bool + deriving (Generic) + deriving (GEq) via (Default MyType) + +deriving via (Default MyType) instance GShow MyType + +data MyType1 a = MyType1 a + deriving (Generic, Generic1) + deriving (GEq) via (Default (MyType1 a)) + deriving (GFunctor) via (Default1 MyType1) + +deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a) +deriving via (Default1 MyType1) instance GFoldable MyType1 +#endif diff --git a/tests/EmptyCaseSpec.hs b/tests/EmptyCaseSpec.hs new file mode 100644 --- /dev/null +++ b/tests/EmptyCaseSpec.hs @@ -0,0 +1,20 @@ +{-# 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 () diff --git a/tests/ExampleSpec.hs b/tests/ExampleSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleSpec.hs @@ -0,0 +1,393 @@ +{-# 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)" diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/T68Spec.hs b/tests/T68Spec.hs new file mode 100644 --- /dev/null +++ b/tests/T68Spec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module T68Spec (main, spec) where + +import Generics.Deriving.TH +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = return () + +type family F68 :: * -> * +type instance F68 = Maybe +data T68 a = MkT68 (F68 a) +$(deriveAll1 ''T68) diff --git a/tests/T80Spec.hs b/tests/T80Spec.hs new file mode 100644 --- /dev/null +++ b/tests/T80Spec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module T80Spec (main, spec) where + +import Generics.Deriving.TH +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = return () + +newtype T f a b = MkT (f a b) +$(deriveAll1 ''T) diff --git a/tests/T82Spec.hs b/tests/T82Spec.hs new file mode 100644 --- /dev/null +++ b/tests/T82Spec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +module T82Spec (main, spec) where + +import Test.Hspec + +#if MIN_VERSION_base(4,10,0) +import Generics.Deriving.TH +import GHC.Exts (RuntimeRep, TYPE) + +data Code m (a :: TYPE (r :: RuntimeRep)) = Code +$(deriveAll0And1 ''Code) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = return () diff --git a/tests/TypeInTypeSpec.hs b/tests/TypeInTypeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/TypeInTypeSpec.hs @@ -0,0 +1,52 @@ +{-# 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