diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,173 +1,176 @@ -### 0.6.1 [2022.05.07] -* Backport [GHC!6955](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6955), - which makes derived `Eq` instances check data constructor tags, which can - improve runtime performance for data types with nullary constructors. -* Allow building the test suite with `transformers-0.6.*`. - -## 0.6 [2021.08.29] -* Allow building with `template-haskell-2.18.0.0` (GHC 9.2). -* Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may - now require the use of the `TypeInType` extension if using GHC 8.0, 8.2, or - 8.4. (On later versions of GHC, `TypeInType`'s functionality has been folded - into `PolyKinds`.) -* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields - of type `Int32#` or `Word32#` on GHC 9.2 or later. -* `deriveVia` now instantiates "floating" `via` type variables (i.e., type - variables mentioned in the `via` type that are not mentioned in the instance - context or the first argument to `Via`) to `Any` in the generated code. As a - result, `deriveVia` no longer generates code that produces `-Wunused-foralls` - warnings. - -### 0.5.10 [2020.09.30] -* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). - -### 0.5.9 [2019.06.08] -* Have `deriveFunctor` and `deriveFoldable` derive implementations of `(<$)` - and `null`, which GHC starting doing in 8.2 and 8.4, respectively. -* Fix a bug in which `deriveOrd{,1,2}` could generate incorrect code for data - types with a combination of nullary and non-nullary constructors. -* Fix a bug in which `deriveFunctor` would fail on sufficiently complex uses - of rank-n types in constructor fields. -* Fix a bug in which `deriveFunctor` and related functions would needlessly - reject data types whose last type parameters appear as oversaturated - arguments to a type family. - -### 0.5.8 [2019.11.26] -* Allow building with GHC 8.10. - -### 0.5.7 [2019.08.27] -* Permit `deriveVia` to use "floating" `via` type variables, such as the `a` - in: - - ```hs - deriveVia [t| forall a. Show MyInt `Via` Const Int a |] - ``` - -### 0.5.6 [2019.05.02] -* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields - of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later. - -### 0.5.5 [2019.04.26] -* Support `th-abstraction-0.3` or later. - -### 0.5.4 [2019.01.21] -* Expose `Internal` modules. - -### 0.5.3 [2019.01.20] -* Fix a bug in which `deriveEnum`/`deriveIx` would generate ill-scoped code - for certain poly-kinded data types. - -### 0.5.2 [2018.09.13] -* Fix a bug (on GHC 8.7 and above) in which `deriveGND`/`deriveVia` would - generate ill-scoped code. - -### 0.5.1 [2018.07.11] -* Have `deriveGND`/`deriveVia` throw an error if an incorrect number of - arguments are supplied to the type class. - -## 0.5 [2018.07.01] -* Backport the changes to `GeneralizedNewtypeDeriving` and `DerivingVia` code - generation from - [Trac #15290](https://ghc.haskell.org/trac/ghc/ticket/15290). - - As a result, code generated by `deriveGND` or `deriveVia` now requires the - `InstanceSigs` and `ScopedTypeVariables` language extensions. On the other - hand, the generated code no longer requires the `ImpredicativeTypes` - extension (unless any class methods use higher-rank types). -* Allow building with `containers-0.6` and `template-haskell-2.14`. - -### 0.4.3 [2018.06.16] -* Fix a bug that caused debug-enabled GHC builds to panic when generating - code from this library (see - [Trac #15270](https://ghc.haskell.org/trac/ghc/ticket/15270)). - The fix only affects the library's internals, so no changes are user-facing. - -### 0.4.2 [2018.05.14] -* Backport the fixes for GHC Trac - [#14364](https://ghc.haskell.org/trac/ghc/ticket/14364) - and - [#14918](https://ghc.haskell.org/trac/ghc/ticket/14918), - which significantly improve the compliation times of derived `Read` - instances. - -### 0.4.1 [2018.02.04] -* Add `Data.Deriving.Via`, which allows emulating the behavior of the - `GeneralizedNewtypeDeriving` and `DerivingVia` extensions. -* Test suite fixes for GHC 8.4. - -## 0.4 [2017.12.07] -* Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC - as of 8.4): - * For derived `Eq` and `Ord` instances for empty data types, simply return - `True` and `EQ`, respectively, without inspecting the arguments. - * For derived `Read` instances for empty data types, simply return `pfail` - (without `parens`). - * For derived `Show` instances for empty data types, inspect the argument - (instead of `error`ing). In addition, add `showEmptyCaseBehavior` to - `ShowOptions`, which configures whether derived instances for empty data - types should use the `EmptyCase` extension (this is disabled by default). - * For derived `Functor` and `Traversable` instances for empty data - types, make `fmap` and `traverse` strict in its argument. - * For derived `Foldable` instances, do not error on empty data types. - Instead, simply return the folded state (for `foldr`) or `mempty` (for - `foldMap`), without inspecting the arguments. - * Add `FFTOptions` (`Functor`/`Foldable`/`Traversable` options) to - `Data.Functor.Deriving`, along with variants of existing functions that - take `FFTOptions` as an argument. For now, the only configurable option is - whether derived instances for empty data types should use the `EmptyCase` - extension (this is disabled by default). -* Backport the fix to #13328. That is, when deriving `Functor` or - `Traversable` instances for data types where the last type variable is at - phantom role, generated `fmap`/`traverse` implementations now use `coerce` - for efficiency. -* Rename `emptyCaseBehavior` from `Data.Functor.Deriving` to - `fftEmptyCaseBehavior`. - -### 0.3.6 [2017.04.10] -* Make `deriveTraversable` use `liftA2` in derived implementations of - `traverse` when possible, now that `liftA2` is a class method of - `Applicative` (as of GHC 8.2) -* Make `deriveShow` use `showCommaSpace`, a change introduced in GHC 8.2 - -### 0.3.5 [2016.12.12] -* Fix bug in which derived `Ord` instances for datatypes with many constructors - would fail to typecheck - -### 0.3.4 [2016.10.20] -* Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances -* Fix bug in which record selectors weren't parsed correctly in derived `Read` instances - -### 0.3.3 [2016.09.11] -* Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH. -* Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH. -* Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH. -* Fix bug in which derived `Show` instance would parenthesize the output too eagerly - -### 0.3.2 -* Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2 -* Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods -* Fix GHC HEAD build - -### 0.3.1 -* Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples -* Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show` - -## 0.3 -* Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH. -* Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH. -* Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH. -* Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules. - -### 0.2.2 -* Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types - -### 0.2.1 -* Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH. - -## 0.2 -* Added support for GHC 8.0 -* Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH. -* Added `Data.Deriving`, which reexports all other modules - -## 0.1 -* Initial commit +### 0.6.2 [2022.12.07] +* Make the test suite build with GHC 9.6 or later. + +### 0.6.1 [2022.05.07] +* Backport [GHC!6955](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6955), + which makes derived `Eq` instances check data constructor tags, which can + improve runtime performance for data types with nullary constructors. +* Allow building the test suite with `transformers-0.6.*`. + +## 0.6 [2021.08.29] +* Allow building with `template-haskell-2.18.0.0` (GHC 9.2). +* Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may + now require the use of the `TypeInType` extension if using GHC 8.0, 8.2, or + 8.4. (On later versions of GHC, `TypeInType`'s functionality has been folded + into `PolyKinds`.) +* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields + of type `Int32#` or `Word32#` on GHC 9.2 or later. +* `deriveVia` now instantiates "floating" `via` type variables (i.e., type + variables mentioned in the `via` type that are not mentioned in the instance + context or the first argument to `Via`) to `Any` in the generated code. As a + result, `deriveVia` no longer generates code that produces `-Wunused-foralls` + warnings. + +### 0.5.10 [2020.09.30] +* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). + +### 0.5.9 [2019.06.08] +* Have `deriveFunctor` and `deriveFoldable` derive implementations of `(<$)` + and `null`, which GHC starting doing in 8.2 and 8.4, respectively. +* Fix a bug in which `deriveOrd{,1,2}` could generate incorrect code for data + types with a combination of nullary and non-nullary constructors. +* Fix a bug in which `deriveFunctor` would fail on sufficiently complex uses + of rank-n types in constructor fields. +* Fix a bug in which `deriveFunctor` and related functions would needlessly + reject data types whose last type parameters appear as oversaturated + arguments to a type family. + +### 0.5.8 [2019.11.26] +* Allow building with GHC 8.10. + +### 0.5.7 [2019.08.27] +* Permit `deriveVia` to use "floating" `via` type variables, such as the `a` + in: + + ```hs + deriveVia [t| forall a. Show MyInt `Via` Const Int a |] + ``` + +### 0.5.6 [2019.05.02] +* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields + of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later. + +### 0.5.5 [2019.04.26] +* Support `th-abstraction-0.3` or later. + +### 0.5.4 [2019.01.21] +* Expose `Internal` modules. + +### 0.5.3 [2019.01.20] +* Fix a bug in which `deriveEnum`/`deriveIx` would generate ill-scoped code + for certain poly-kinded data types. + +### 0.5.2 [2018.09.13] +* Fix a bug (on GHC 8.7 and above) in which `deriveGND`/`deriveVia` would + generate ill-scoped code. + +### 0.5.1 [2018.07.11] +* Have `deriveGND`/`deriveVia` throw an error if an incorrect number of + arguments are supplied to the type class. + +## 0.5 [2018.07.01] +* Backport the changes to `GeneralizedNewtypeDeriving` and `DerivingVia` code + generation from + [Trac #15290](https://ghc.haskell.org/trac/ghc/ticket/15290). + + As a result, code generated by `deriveGND` or `deriveVia` now requires the + `InstanceSigs` and `ScopedTypeVariables` language extensions. On the other + hand, the generated code no longer requires the `ImpredicativeTypes` + extension (unless any class methods use higher-rank types). +* Allow building with `containers-0.6` and `template-haskell-2.14`. + +### 0.4.3 [2018.06.16] +* Fix a bug that caused debug-enabled GHC builds to panic when generating + code from this library (see + [Trac #15270](https://ghc.haskell.org/trac/ghc/ticket/15270)). + The fix only affects the library's internals, so no changes are user-facing. + +### 0.4.2 [2018.05.14] +* Backport the fixes for GHC Trac + [#14364](https://ghc.haskell.org/trac/ghc/ticket/14364) + and + [#14918](https://ghc.haskell.org/trac/ghc/ticket/14918), + which significantly improve the compliation times of derived `Read` + instances. + +### 0.4.1 [2018.02.04] +* Add `Data.Deriving.Via`, which allows emulating the behavior of the + `GeneralizedNewtypeDeriving` and `DerivingVia` extensions. +* Test suite fixes for GHC 8.4. + +## 0.4 [2017.12.07] +* Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC + as of 8.4): + * For derived `Eq` and `Ord` instances for empty data types, simply return + `True` and `EQ`, respectively, without inspecting the arguments. + * For derived `Read` instances for empty data types, simply return `pfail` + (without `parens`). + * For derived `Show` instances for empty data types, inspect the argument + (instead of `error`ing). In addition, add `showEmptyCaseBehavior` to + `ShowOptions`, which configures whether derived instances for empty data + types should use the `EmptyCase` extension (this is disabled by default). + * For derived `Functor` and `Traversable` instances for empty data + types, make `fmap` and `traverse` strict in its argument. + * For derived `Foldable` instances, do not error on empty data types. + Instead, simply return the folded state (for `foldr`) or `mempty` (for + `foldMap`), without inspecting the arguments. + * Add `FFTOptions` (`Functor`/`Foldable`/`Traversable` options) to + `Data.Functor.Deriving`, along with variants of existing functions that + take `FFTOptions` as an argument. For now, the only configurable option is + whether derived instances for empty data types should use the `EmptyCase` + extension (this is disabled by default). +* Backport the fix to #13328. That is, when deriving `Functor` or + `Traversable` instances for data types where the last type variable is at + phantom role, generated `fmap`/`traverse` implementations now use `coerce` + for efficiency. +* Rename `emptyCaseBehavior` from `Data.Functor.Deriving` to + `fftEmptyCaseBehavior`. + +### 0.3.6 [2017.04.10] +* Make `deriveTraversable` use `liftA2` in derived implementations of + `traverse` when possible, now that `liftA2` is a class method of + `Applicative` (as of GHC 8.2) +* Make `deriveShow` use `showCommaSpace`, a change introduced in GHC 8.2 + +### 0.3.5 [2016.12.12] +* Fix bug in which derived `Ord` instances for datatypes with many constructors + would fail to typecheck + +### 0.3.4 [2016.10.20] +* Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances +* Fix bug in which record selectors weren't parsed correctly in derived `Read` instances + +### 0.3.3 [2016.09.11] +* Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH. +* Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH. +* Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH. +* Fix bug in which derived `Show` instance would parenthesize the output too eagerly + +### 0.3.2 +* Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2 +* Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods +* Fix GHC HEAD build + +### 0.3.1 +* Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples +* Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show` + +## 0.3 +* Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH. +* Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH. +* Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH. +* Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules. + +### 0.2.2 +* Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types + +### 0.2.1 +* Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH. + +## 0.2 +* Added support for GHC 8.0 +* Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH. +* Added `Data.Deriving`, which reexports all other modules + +## 0.1 +* Initial commit diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2015-2017, Ryan Scott - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * 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. - - * Neither the name of Ryan Scott nor the names of other - 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) 2015-2017, Ryan Scott + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Ryan Scott nor the names of other + 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 --- a/README.md +++ b/README.md @@ -1,42 +1,42 @@ -# `deriving-compat` -[![Hackage](https://img.shields.io/hackage/v/deriving-compat.svg)][Hackage: deriving-compat] -[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) -[![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/haskell-compat/deriving-compat/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-compat/deriving-compat/actions?query=workflow%3AHaskell-CI) - -[Hackage: deriving-compat]: - http://hackage.haskell.org/package/deriving-compat - "deriving-compat 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)" - -`deriving-compat` provides Template Haskell functions that mimic `deriving` extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: - -* Deriving `Bounded` -* Deriving `Enum` -* Deriving `Ix` -* Deriving `Eq` -* Deriving `Ord` -* Deriving `Read` -* Deriving `Show` -* `DeriveFoldable` -* `DeriveFunctor` -* `DeriveTraversable` -* `GeneralizedNewtypeDeriving` (with GHC 8.2 or later) -* `DerivingVia` (with GHC 8.2 or later) - -See the `Data.Deriving` module for a full list of backported changes. - -In addition, `deriving-compat` also provides some additional `deriving` functionality that has not yet been merged into upstream GHC. Aside from the GHC `deriving` extensions mentioned above, `deriving-compat` also permits deriving instances of classes in the `Data.Functor.Classes` module, covering the `Eq1`, `Eq2`, `Ord1`, `Ord2`, `Read1`, `Read2`, `Show1`, and `Show2` classes. This extra functionality is outside of the main scope of `deriving-compat`, as it does not backport extensions that exist in today's GHC. Nevertheless, the underlying Template Haskell machinery needed to derive `Eq` and friends extends very naturally to `Eq1` and friends, so this extra functionality is included in `deriving-compat` as a convenience. - -Note that some recent GHC typeclasses/extensions are not covered by this package: - -* `DeriveDataTypeable` -* `DeriveGeneric`, which was introducted in GHC 7.2 for deriving `Generic` instances, and modified in GHC 7.6 to allow derivation of `Generic1` instances. Use `Generics.Deriving.TH` from [`generic-deriving`](http://hackage.haskell.org/package/generic-deriving) to derive `Generic(1)` using Template Haskell. -* `DeriveLift`, which was introduced in GHC 8.0 for deriving `Lift` instances. Use `Language.Haskell.TH.Lift` from [`th-lift`](http://hackage.haskell.org/package/th-lift) to derive `Lift` using Template Haskell. -* The `Bifunctor` typeclass, which was introduced in GHC 7.10, as well as the `Bifoldable` and `Bitraversable` typeclasses, which were introduced in GHC 8.2. Use `Data.Bifunctor.TH` from [`bifunctors`](http://hackage.haskell.org/package/bifunctors) to derive these typeclasses using Template Haskell. +# `deriving-compat` +[![Hackage](https://img.shields.io/hackage/v/deriving-compat.svg)][Hackage: deriving-compat] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) +[![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/haskell-compat/deriving-compat/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-compat/deriving-compat/actions?query=workflow%3AHaskell-CI) + +[Hackage: deriving-compat]: + http://hackage.haskell.org/package/deriving-compat + "deriving-compat 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)" + +`deriving-compat` provides Template Haskell functions that mimic `deriving` extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: + +* Deriving `Bounded` +* Deriving `Enum` +* Deriving `Ix` +* Deriving `Eq` +* Deriving `Ord` +* Deriving `Read` +* Deriving `Show` +* `DeriveFoldable` +* `DeriveFunctor` +* `DeriveTraversable` +* `GeneralizedNewtypeDeriving` (with GHC 8.2 or later) +* `DerivingVia` (with GHC 8.2 or later) + +See the `Data.Deriving` module for a full list of backported changes. + +In addition, `deriving-compat` also provides some additional `deriving` functionality that has not yet been merged into upstream GHC. Aside from the GHC `deriving` extensions mentioned above, `deriving-compat` also permits deriving instances of classes in the `Data.Functor.Classes` module, covering the `Eq1`, `Eq2`, `Ord1`, `Ord2`, `Read1`, `Read2`, `Show1`, and `Show2` classes. This extra functionality is outside of the main scope of `deriving-compat`, as it does not backport extensions that exist in today's GHC. Nevertheless, the underlying Template Haskell machinery needed to derive `Eq` and friends extends very naturally to `Eq1` and friends, so this extra functionality is included in `deriving-compat` as a convenience. + +Note that some recent GHC typeclasses/extensions are not covered by this package: + +* `DeriveDataTypeable` +* `DeriveGeneric`, which was introducted in GHC 7.2 for deriving `Generic` instances, and modified in GHC 7.6 to allow derivation of `Generic1` instances. Use `Generics.Deriving.TH` from [`generic-deriving`](http://hackage.haskell.org/package/generic-deriving) to derive `Generic(1)` using Template Haskell. +* `DeriveLift`, which was introduced in GHC 8.0 for deriving `Lift` instances. Use `Language.Haskell.TH.Lift` from [`th-lift`](http://hackage.haskell.org/package/th-lift) to derive `Lift` using Template Haskell. +* The `Bifunctor` typeclass, which was introduced in GHC 7.10, as well as the `Bifoldable` and `Bitraversable` typeclasses, which were introduced in GHC 8.2. Use `Data.Bifunctor.TH` from [`bifunctors`](http://hackage.haskell.org/package/bifunctors) to derive these typeclasses using Template Haskell. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,214 +1,214 @@ -name: deriving-compat -version: 0.6.1 -synopsis: Backports of GHC deriving extensions -description: @deriving-compat@ provides Template Haskell functions that - mimic @deriving@ extensions that were introduced or modified - in recent versions of GHC. Currently, the following - typeclasses/extensions are covered: - . - * Deriving @Bounded@ - . - * Deriving @Enum@ - . - * Deriving @Ix@ - . - * Deriving @Eq@ - . - * Deriving @Ord@ - . - * Deriving @Read@ - . - * Deriving @Show@ - . - * @DeriveFoldable@ - . - * @DeriveFunctor@ - . - * @DeriveTraversable@ - . - * @GeneralizedNewtypeDeriving@ (with GHC 8.2 or later) - . - * @DerivingVia@ (with GHC 8.2 or later) - . - See the "Data.Deriving" module for a full list of backported changes. - . - In addition, @deriving-compat@ also provides some additional - @deriving@ functionality that has not yet been merged into - upstream GHC. Aside from the GHC @deriving@ extensions - mentioned above, @deriving-compat@ also permits deriving - instances of classes in the @Data.Functor.Classes@ module, - covering the @Eq1@, @Eq2@, @Ord1@, @Ord2@, @Read1@, - @Read2@, @Show1@, and @Show2@ classes. This extra - functionality is outside of the main scope of - @deriving-compat@, as it does not backport extensions that - exist in today's GHC. Nevertheless, the underlying Template - Haskell machinery needed to derive @Eq@ and friends - extends very naturally to @Eq1@ and friends, so this extra - functionality is included in @deriving-compat@ as a - convenience. - . - Note that some recent GHC typeclasses/extensions are not covered by this package: - . - * @DeriveDataTypeable@ - . - * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving - @Generic@ instances, and modified in GHC 7.6 to allow derivation - of @Generic1@ instances. Use @Generics.Deriving.TH@ from - @@ - to derive @Generic(1)@ using Template Haskell. - . - * @DeriveLift@, which was introduced in GHC 8.0 for deriving - @Lift@ instances. Use @Language.Haskell.TH.Lift@ from - @@ - to derive @Lift@ using Template Haskell. - . - * The @Bifunctor@ typeclass, which was introduced in GHC 7.10, - as well as the @Bifoldable@ and @Bitraversable@ typeclasses, which - were introduced in GHC 8.2. Use @Data.Bifunctor.TH@ from - @@ - to derive these typeclasses using Template Haskell. -homepage: https://github.com/haskell-compat/deriving-compat -bug-reports: https://github.com/haskell-compat/deriving-compat/issues -license: BSD3 -license-file: LICENSE -author: Ryan Scott -maintainer: Ryan Scott -stability: Experimental -copyright: (C) 2015-2017 Ryan Scott -category: Compatibility -build-type: Simple -extra-source-files: CHANGELOG.md, README.md -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 - , GHC == 8.10.7 - , GHC == 9.0.2 - , GHC == 9.2.2 -cabal-version: >=1.10 - -source-repository head - type: git - location: https://github.com/haskell-compat/deriving-compat - -flag base-4-9 - description: Use base-4.9 or later. - default: True - -flag template-haskell-2-11 - description: Use template-haskell-2.11.0.0 or later. - default: True - -flag new-functor-classes - description: Use a version of transformers or transformers-compat with a - modern-style Data.Functor.Classes module. This flag cannot be - used when building with transformers-0.4, since it comes with - a different version of Data.Functor.Classes. - default: True - -library - exposed-modules: Data.Deriving - Data.Deriving.Internal - - Data.Bounded.Deriving - Data.Bounded.Deriving.Internal - Data.Deriving.Via - Data.Deriving.Via.Internal - Data.Enum.Deriving - Data.Enum.Deriving.Internal - Data.Eq.Deriving - Data.Eq.Deriving.Internal - Data.Foldable.Deriving - Data.Functor.Deriving.Internal - Data.Functor.Deriving - Data.Ix.Deriving - Data.Ix.Deriving.Internal - Data.Ord.Deriving - Data.Ord.Deriving.Internal - Data.Traversable.Deriving - Text.Read.Deriving - Text.Read.Deriving.Internal - Text.Show.Deriving - Text.Show.Deriving.Internal - other-modules: Paths_deriving_compat - build-depends: containers >= 0.1 && < 0.7 - , ghc-prim - , th-abstraction >= 0.4 && < 0.5 - - if flag(base-4-9) - build-depends: base >= 4.9 && < 5 - cpp-options: "-DNEW_FUNCTOR_CLASSES" - else - build-depends: base >= 4.3 && < 4.9 - - if flag(template-haskell-2-11) - build-depends: template-haskell >= 2.11 && < 2.19 - , ghc-boot-th - else - build-depends: template-haskell >= 2.5 && < 2.11 - - if flag(new-functor-classes) - build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7) - , transformers-compat >= 0.5 - cpp-options: "-DNEW_FUNCTOR_CLASSES" - else - build-depends: transformers == 0.4.* - - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: BoundedEnumIxSpec - DerivingViaSpec - EqSpec - FunctorSpec - OrdSpec - ReadSpec - ShowSpec - GH6Spec - GH24Spec - GH27Spec - GH31Spec - - Types.EqOrd - Types.ReadShow - build-depends: base-compat >= 0.8.1 && < 1 - , base-orphans >= 0.5 && < 1 - , deriving-compat - , hspec >= 1.8 - , QuickCheck >= 2 && < 3 - , tagged >= 0.7 && < 1 - , template-haskell >= 2.5 && < 2.19 - , void >= 0.5.10 && < 1 - build-tool-depends: hspec-discover:hspec-discover >= 1.8 - - if flag(base-4-9) - build-depends: base >= 4.9 && < 5 - cpp-options: "-DNEW_FUNCTOR_CLASSES" - else - build-depends: base >= 4.3 && < 4.9 - - if flag(new-functor-classes) - build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7) - , transformers-compat >= 0.5 - cpp-options: "-DNEW_FUNCTOR_CLASSES" - else - build-depends: transformers == 0.4.* - - hs-source-dirs: tests - default-language: Haskell2010 - ghc-options: -Wall -threaded -rtsopts - if impl(ghc >= 8.6) - ghc-options: -Wno-star-is-type - if impl(ghc >= 9.0) - ghc-options: -fenable-th-splice-warnings +name: deriving-compat +version: 0.6.2 +synopsis: Backports of GHC deriving extensions +description: @deriving-compat@ provides Template Haskell functions that + mimic @deriving@ extensions that were introduced or modified + in recent versions of GHC. Currently, the following + typeclasses/extensions are covered: + . + * Deriving @Bounded@ + . + * Deriving @Enum@ + . + * Deriving @Ix@ + . + * Deriving @Eq@ + . + * Deriving @Ord@ + . + * Deriving @Read@ + . + * Deriving @Show@ + . + * @DeriveFoldable@ + . + * @DeriveFunctor@ + . + * @DeriveTraversable@ + . + * @GeneralizedNewtypeDeriving@ (with GHC 8.2 or later) + . + * @DerivingVia@ (with GHC 8.2 or later) + . + See the "Data.Deriving" module for a full list of backported changes. + . + In addition, @deriving-compat@ also provides some additional + @deriving@ functionality that has not yet been merged into + upstream GHC. Aside from the GHC @deriving@ extensions + mentioned above, @deriving-compat@ also permits deriving + instances of classes in the @Data.Functor.Classes@ module, + covering the @Eq1@, @Eq2@, @Ord1@, @Ord2@, @Read1@, + @Read2@, @Show1@, and @Show2@ classes. This extra + functionality is outside of the main scope of + @deriving-compat@, as it does not backport extensions that + exist in today's GHC. Nevertheless, the underlying Template + Haskell machinery needed to derive @Eq@ and friends + extends very naturally to @Eq1@ and friends, so this extra + functionality is included in @deriving-compat@ as a + convenience. + . + Note that some recent GHC typeclasses/extensions are not covered by this package: + . + * @DeriveDataTypeable@ + . + * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving + @Generic@ instances, and modified in GHC 7.6 to allow derivation + of @Generic1@ instances. Use @Generics.Deriving.TH@ from + @@ + to derive @Generic(1)@ using Template Haskell. + . + * @DeriveLift@, which was introduced in GHC 8.0 for deriving + @Lift@ instances. Use @Language.Haskell.TH.Lift@ from + @@ + to derive @Lift@ using Template Haskell. + . + * The @Bifunctor@ typeclass, which was introduced in GHC 7.10, + as well as the @Bifoldable@ and @Bitraversable@ typeclasses, which + were introduced in GHC 8.2. Use @Data.Bifunctor.TH@ from + @@ + to derive these typeclasses using Template Haskell. +homepage: https://github.com/haskell-compat/deriving-compat +bug-reports: https://github.com/haskell-compat/deriving-compat/issues +license: BSD3 +license-file: LICENSE +author: Ryan Scott +maintainer: Ryan Scott +stability: Experimental +copyright: (C) 2015-2017 Ryan Scott +category: Compatibility +build-type: Simple +extra-source-files: CHANGELOG.md, README.md +tested-with: GHC == 7.0.4 + , GHC == 7.2.2 + , GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.2 +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/haskell-compat/deriving-compat + +flag base-4-9 + description: Use base-4.9 or later. + default: True + +flag template-haskell-2-11 + description: Use template-haskell-2.11.0.0 or later. + default: True + +flag new-functor-classes + description: Use a version of transformers or transformers-compat with a + modern-style Data.Functor.Classes module. This flag cannot be + used when building with transformers-0.4, since it comes with + a different version of Data.Functor.Classes. + default: True + +library + exposed-modules: Data.Deriving + Data.Deriving.Internal + + Data.Bounded.Deriving + Data.Bounded.Deriving.Internal + Data.Deriving.Via + Data.Deriving.Via.Internal + Data.Enum.Deriving + Data.Enum.Deriving.Internal + Data.Eq.Deriving + Data.Eq.Deriving.Internal + Data.Foldable.Deriving + Data.Functor.Deriving.Internal + Data.Functor.Deriving + Data.Ix.Deriving + Data.Ix.Deriving.Internal + Data.Ord.Deriving + Data.Ord.Deriving.Internal + Data.Traversable.Deriving + Text.Read.Deriving + Text.Read.Deriving.Internal + Text.Show.Deriving + Text.Show.Deriving.Internal + other-modules: Paths_deriving_compat + build-depends: containers >= 0.1 && < 0.7 + , ghc-prim + , th-abstraction >= 0.4 && < 0.5 + + if flag(base-4-9) + build-depends: base >= 4.9 && < 5 + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: base >= 4.3 && < 4.9 + + if flag(template-haskell-2-11) + build-depends: template-haskell >= 2.11 && < 2.20 + , ghc-boot-th + else + build-depends: template-haskell >= 2.5 && < 2.11 + + if flag(new-functor-classes) + build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7) + , transformers-compat >= 0.5 + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: transformers == 0.4.* + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: BoundedEnumIxSpec + DerivingViaSpec + EqSpec + FunctorSpec + OrdSpec + ReadSpec + ShowSpec + GH6Spec + GH24Spec + GH27Spec + GH31Spec + + Types.EqOrd + Types.ReadShow + build-depends: base-compat >= 0.8.1 && < 1 + , base-orphans >= 0.5 && < 1 + , deriving-compat + , hspec >= 1.8 + , QuickCheck >= 2 && < 3 + , tagged >= 0.7 && < 1 + , template-haskell >= 2.5 && < 2.20 + , void >= 0.5.10 && < 1 + build-tool-depends: hspec-discover:hspec-discover >= 1.8 + + if flag(base-4-9) + build-depends: base >= 4.9 && < 5 + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: base >= 4.3 && < 4.9 + + if flag(new-functor-classes) + build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7) + , transformers-compat >= 0.5 + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: transformers == 0.4.* + + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts + if impl(ghc >= 8.6) + ghc-options: -Wno-star-is-type + if impl(ghc >= 9.0) + ghc-options: -fenable-th-splice-warnings diff --git a/src/Data/Bounded/Deriving.hs b/src/Data/Bounded/Deriving.hs --- a/src/Data/Bounded/Deriving.hs +++ b/src/Data/Bounded/Deriving.hs @@ -1,27 +1,27 @@ -{-| -Module: Data.Bounded.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Bounded' instances. --} -module Data.Bounded.Deriving ( - -- * 'Bounded' - deriveBounded - , makeMinBound - , makeMaxBound - -- * 'deriveBounded' limitations - -- $constraints - ) where - -import Data.Bounded.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @*@ are assumed to have 'Bounded' constraints. - If this is not desirable, use 'makeMinBound' or one of its cousins. --} +{-| +Module: Data.Bounded.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Bounded' instances. +-} +module Data.Bounded.Deriving ( + -- * 'Bounded' + deriveBounded + , makeMinBound + , makeMaxBound + -- * 'deriveBounded' limitations + -- $constraints + ) where + +import Data.Bounded.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Bounded' constraints. + If this is not desirable, use 'makeMinBound' or one of its cousins. +-} diff --git a/src/Data/Bounded/Deriving/Internal.hs b/src/Data/Bounded/Deriving/Internal.hs --- a/src/Data/Bounded/Deriving/Internal.hs +++ b/src/Data/Bounded/Deriving/Internal.hs @@ -1,141 +1,141 @@ -{-# LANGUAGE CPP #-} - -{-| -Module: Data.Bounded.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Bounded' instances. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Bounded.Deriving.Internal ( - -- * 'Bounded' - deriveBounded - , makeMinBound - , makeMaxBound - ) where - -import Data.Deriving.Internal - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Generates a 'Bounded' instance declaration for the given data type or data --- family instance. -deriveBounded :: Name -> Q [Dec] -deriveBounded name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance BoundedClass parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (boundedFunDecs parentName cons) - --- | Generates a lambda expression which behaves like 'minBound' (without --- requiring a 'Bounded' instance). -makeMinBound :: Name -> Q Exp -makeMinBound = makeBoundedFun MinBound - --- | Generates a lambda expression which behaves like 'maxBound' (without --- requiring a 'Bounded' instance). -makeMaxBound :: Name -> Q Exp -makeMaxBound = makeBoundedFun MaxBound - --- | Generates 'minBound' and 'maxBound' method declarations. -boundedFunDecs :: Name -> [ConstructorInfo] -> [Q Dec] -boundedFunDecs tyName cons = [makeFunD MinBound, makeFunD MaxBound] - where - makeFunD :: BoundedFun -> Q Dec - makeFunD bf = - funD (boundedFunName bf) - [ clause [] - (normalB $ makeBoundedFunForCons bf tyName cons) - [] - ] - --- | Generates a lambda expression which behaves like the BoundedFun argument. -makeBoundedFun :: BoundedFun -> Name -> Q Exp -makeBoundedFun bf name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have minBound/maxBound - -- implemented for it, and produces errors if it can't. - buildTypeInstance BoundedClass parentName ctxt instTypes variant - >> makeBoundedFunForCons bf parentName cons - --- | Generates a lambda expression for minBound/maxBound. for the --- given constructors. All constructors must be from the same type. -makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp -makeBoundedFunForCons _ _ [] = noConstructorsError -makeBoundedFunForCons bf tyName cons - | not (isProduct || isEnumeration) - = enumerationOrProductError $ nameBase tyName - | isEnumeration - = pickCon - | otherwise -- It's a product type - = pickConApp - where - isProduct, isEnumeration :: Bool - isProduct = isProductType cons - isEnumeration = isEnumerationType cons - - con1, conN :: Q Exp - con1 = conE $ constructorName $ head cons - conN = conE $ constructorName $ last cons - - pickCon :: Q Exp - pickCon = case bf of - MinBound -> con1 - MaxBound -> conN - - pickConApp :: Q Exp - pickConApp = appsE - $ pickCon - : map varE (replicate (conArity $ head cons) (boundedFunName bf)) - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- There's only one Bounded variant! -data BoundedClass = BoundedClass - -instance ClassRep BoundedClass where - arity _ = 0 - - allowExQuant _ = True - - fullClassName _ = boundedTypeName - - classConstraint _ 0 = Just $ boundedTypeName - classConstraint _ _ = Nothing - --- | A representation of which function is being generated. -data BoundedFun = MinBound | MaxBound - -boundedFunName :: BoundedFun -> Name -boundedFunName MinBound = minBoundValName -boundedFunName MaxBound = maxBoundValName +{-# LANGUAGE CPP #-} + +{-| +Module: Data.Bounded.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Bounded' instances. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Bounded.Deriving.Internal ( + -- * 'Bounded' + deriveBounded + , makeMinBound + , makeMaxBound + ) where + +import Data.Deriving.Internal + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Generates a 'Bounded' instance declaration for the given data type or data +-- family instance. +deriveBounded :: Name -> Q [Dec] +deriveBounded name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance BoundedClass parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (boundedFunDecs parentName cons) + +-- | Generates a lambda expression which behaves like 'minBound' (without +-- requiring a 'Bounded' instance). +makeMinBound :: Name -> Q Exp +makeMinBound = makeBoundedFun MinBound + +-- | Generates a lambda expression which behaves like 'maxBound' (without +-- requiring a 'Bounded' instance). +makeMaxBound :: Name -> Q Exp +makeMaxBound = makeBoundedFun MaxBound + +-- | Generates 'minBound' and 'maxBound' method declarations. +boundedFunDecs :: Name -> [ConstructorInfo] -> [Q Dec] +boundedFunDecs tyName cons = [makeFunD MinBound, makeFunD MaxBound] + where + makeFunD :: BoundedFun -> Q Dec + makeFunD bf = + funD (boundedFunName bf) + [ clause [] + (normalB $ makeBoundedFunForCons bf tyName cons) + [] + ] + +-- | Generates a lambda expression which behaves like the BoundedFun argument. +makeBoundedFun :: BoundedFun -> Name -> Q Exp +makeBoundedFun bf name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have minBound/maxBound + -- implemented for it, and produces errors if it can't. + buildTypeInstance BoundedClass parentName ctxt instTypes variant + >> makeBoundedFunForCons bf parentName cons + +-- | Generates a lambda expression for minBound/maxBound. for the +-- given constructors. All constructors must be from the same type. +makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp +makeBoundedFunForCons _ _ [] = noConstructorsError +makeBoundedFunForCons bf tyName cons + | not (isProduct || isEnumeration) + = enumerationOrProductError $ nameBase tyName + | isEnumeration + = pickCon + | otherwise -- It's a product type + = pickConApp + where + isProduct, isEnumeration :: Bool + isProduct = isProductType cons + isEnumeration = isEnumerationType cons + + con1, conN :: Q Exp + con1 = conE $ constructorName $ head cons + conN = conE $ constructorName $ last cons + + pickCon :: Q Exp + pickCon = case bf of + MinBound -> con1 + MaxBound -> conN + + pickConApp :: Q Exp + pickConApp = appsE + $ pickCon + : map varE (replicate (conArity $ head cons) (boundedFunName bf)) + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- There's only one Bounded variant! +data BoundedClass = BoundedClass + +instance ClassRep BoundedClass where + arity _ = 0 + + allowExQuant _ = True + + fullClassName _ = boundedTypeName + + classConstraint _ 0 = Just $ boundedTypeName + classConstraint _ _ = Nothing + +-- | A representation of which function is being generated. +data BoundedFun = MinBound | MaxBound + +boundedFunName :: BoundedFun -> Name +boundedFunName MinBound = minBoundValName +boundedFunName MaxBound = maxBoundValName diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -1,300 +1,300 @@ -{-| -Module: Data.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -This module reexports all of the functionality of the other modules in this library -(with the exception of "Data.Deriving.Via", which is only available on GHC 8.2 or -later). This module also provides a high-level tutorial on @deriving-compat@'s -naming conventions and best practices. Typeclass-specific information can be found -in their respective modules. --} -module Data.Deriving ( - -- * Backported changes - -- $changes - - -- * @derive@- functions - -- $derive - - -- * @make@- functions - -- $make - module Exports - ) where - -import Data.Bounded.Deriving as Exports -import Data.Enum.Deriving as Exports -import Data.Eq.Deriving as Exports -import Data.Foldable.Deriving as Exports -import Data.Functor.Deriving as Exports -import Data.Ix.Deriving as Exports -import Data.Ord.Deriving as Exports -import Data.Traversable.Deriving as Exports -import Text.Read.Deriving as Exports -import Text.Show.Deriving as Exports - -{- $changes -The following changes have been backported: - -* In GHC 7.2, deriving 'Read' was changed so that constructors that use - @MagicHash@ now parse correctly. - -* In GHC 7.8, deriving standalone 'Read' instances was fixed to avoid crashing on - datatypes with no constructors. Derived 'Read' instances were also changed so - as to compile more quickly. - -* In GHC 7.10, deriving standalone 'Read' and 'Show' instances were fixed to ensure - that they use the correct fixity information for a particular datatype. - -* In GHC 8.0, @DeriveFoldable@ was changed to allow folding over data types with - existential constraints. - -* In GHC 8.0, @DeriveFoldable@ and @DeriveTraversable@ were changed so as not to - generate superfluous 'mempty' or 'pure' expressions in generated code. As a result, - this allows deriving 'Traversable' instances for datatypes with unlifted argument - types. - -* In GHC 8.0, deriving 'Ix' was changed to use @('&&')@ instead of @if@, as the latter - interacts poorly with @RebindableSyntax@. A bug was also fixed so that - standalone-derived 'Ix' instances for single-constructor GADTs do not crash GHC. - -* In GHC 8.0, deriving 'Show' was changed so that constructor fields with unlifted - types are no longer shown with parentheses, and the output of showing an unlifted - type is suffixed with the same number of hash signs as the corresponding primitive - literals. - -* In GHC 8.2, deriving 'Ord' was changed so that it generates concrete @if@-expressions - that are not subject to @RebindableSyntax@. It was also changed so that derived - @('<=')@, @('>')@, and @('>=')@ methods are expressed through @('<')@, which avoids - generating a substantial amount of code. - -* In GHC 8.2, deriving 'Traversable' was changed so that it uses 'liftA2' to implement - 'traverse' whenever possible. This was done since 'liftA2' was also made a class - method of 'Applicative', so sometimes using 'liftA2' produces more efficient code. - -* In GHC 8.2, deriving 'Show' was changed so that it uses an explicit @showCommaSpace@ - method, instead of repeating the code @showString \", \"@ in several places. - -* In GHC 8.2, @DeriveFunctor@ was changed so that it derives implementations of - ('<$'). - -* In GHC 8.4, @DeriveFoldable@ was changed so that it derives implementations of - 'null'. - -* In GHC 8.4, deriving 'Functor' and 'Traverable' was changed so that it uses 'coerce' - for efficiency when the last parameter of the data type is at phantom role. - -* In GHC 8.4, the @EmptyDataDeriving@ proposal brought forth a slew of changes related - to how instances for empty data types (i.e., no constructors) were derived. These - changes include: - - * For derived 'Eq' and 'Ord' instances for empty data types, simply return - 'True' and 'EQ', respectively, without inspecting the arguments. - - * For derived 'Read' instances for empty data types, simply return 'pfail' - (without 'parens'). - - * For derived 'Show' instances for empty data types, inspect the argument - (instead of 'error'ing). - - * For derived 'Functor' and 'Traversable' instances for empty data - types, make 'fmap' and 'traverse' strict in its argument. - - * For derived 'Foldable' instances, do not error on empty data types. - Instead, simply return the folded state (for 'foldr') or 'mempty' (for - 'foldMap'), without inspecting the arguments. - -* In GHC 8.6, the @DerivingVia@ language extension was introduced. - @deriving-compat@ provides an interface which attempts to mimic this - extension (as well as @GeneralizedNewtypeDeriving@, which is a special case - of @DerivingVia@) as closely as possible. - - Since the generated code requires the use of @TypeApplications@, this can - only be backported back to GHC 8.2. - -* In GHC 8.6, deriving 'Read' was changed so as to factor out certain commonly - used subexpressions, which significantly improve compliation times. - -* In GHC 8.10, @DerivingVia@ permits \"floating\" type variables in @via@ types, - such as the @a@ in @'deriveVia' [t| forall a. Show MyInt ``Via`` Const Int a |]@. - @deriving-compat@ does so by instantiating the @a@ to @GHC.Exts.Any@ in the - generated instance. - -* In GHC 9.0, @DeriveFunctor@ was changed so that it works on more - constructors with rank-n field types. - -* In GHC 9.4, deriving 'Eq' was changed so that it checks data constructor - tags, which can improve runtime performance for data types with nullary - constructors. --} - -{- $derive - -Functions with the @derive@- prefix can be used to automatically generate an instance -of a typeclass for a given datatype 'Name'. Some examples: - -@ -{-# LANGUAGE TemplateHaskell #-} -import Data.Deriving - -data Pair a = Pair a a -$('deriveFunctor' ''Pair) -- instance Functor Pair where ... - -data Product f g a = Product (f a) (g a) -$('deriveFoldable' ''Product) --- instance (Foldable f, Foldable g) => Foldable (Pair f g) where ... -@ - -If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), -then @derive@-functions can be used with data family instances (which requires the -@-XTypeFamilies@ extension). To do so, pass the 'Name' of a data or newtype instance -constructor (NOT a data family name!) to @deriveFoldable@. Note that the -generated code may require the @-XFlexibleInstances@ extension. Example: - -@ -{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} -import Data.Deriving - -class AssocClass a b where - data AssocData a b -instance AssocClass Int b where - data AssocData Int b = AssocDataInt1 Int - | AssocDataInt2 b -$('deriveFunctor' 'AssocDataInt1) -- instance Functor (AssocData Int) where ... --- Alternatively, one could use $(deriveFunctor 'AssocDataInt2) -@ - -@derive@-functions in @deriving-compat@ fall into one of three categories: - -* Category 0: Typeclasses with an argument of kind @*@. - ('deriveBounded', 'deriveEnum', 'deriveEq', 'deriveIx', 'deriveOrd', 'deriveRead', 'deriveShow') - -* Category 1: Typeclasses with an argument of kind @* -> *@, That is, a datatype - with such an instance must have at least one type variable, and the last type - variable must be of kind @*@. - ('deriveEq1', 'deriveFoldable', 'deriveFunctor', 'deriveOrd1', - 'deriveRead1', 'deriveShow1', 'deriveTraversable') - -* Category 2: Typeclasses with an argument of kind @* -> * -> *@. That is, a datatype - with such an instance must have at least two type variables, and the last two type - variables must be of kind @*@. - ('deriveEq2', 'deriveOrd2', 'deriveRead2', 'deriveShow2') - -Note that there are some limitations to @derive@-functions: - -* The 'Name' argument must not be of a type synonym. - -* Type variables (other than the last ones) are assumed to require typeclass - constraints. The constraints are different depending on the category. For example, - for Category 0 functions, other type variables of kind @*@ are assumed to be - constrained by that typeclass. As an example: - - @ - data Foo a = Foo a - $(deriveEq ''Foo) - @ - - will result in a generated instance of: - - @ - instance Eq a => Eq (Foo a) where ... - @ - - If you do not want this behavior, use a @make@- function instead. - -* For Category 1 and 2 functions, if you are using the @-XDatatypeContexts@ extension, - a constraint cannot mention the last type variables. For example, - @data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived 'Functor' - instance. - -* For Category 1 and 2 functions, if one of the last type variables is used within a - constructor field's type, it must only be used in the last type arguments. For - example, @data Legal a = Legal (Either Int a)@ can have a derived 'Functor' instance, - but @data Illegal a = Illegal (Either a Int)@ cannot. - -* For Category 1 and 2 functions, data family instances must be able to eta-reduce the - last type variables. In other words, if you have a instance of the form: - - @ - data family Family a1 ... an t1 ... tn - data instance Family e1 ... e2 v1 ... vn = ... - @ - - where @t1@, ..., @tn@ are the last type variables, then the following conditions - must hold: - - 1. @v1@, ..., @vn@ must be type variables. - 2. @v1@, ..., @vn@ must not be mentioned in any of @e1@, ..., @e2@. - --} - -{- $make - -Functions prefixed with @make@- are similar to @derive@-functions in that they also -generate code, but @make@-functions in particular generate the expression for a -particular typeclass method. For example: - -@ -{-# LANGUAGE TemplateHaskell #-} -import Data.Deriving - -data Pair a = Pair a a - -instance Functor Pair where - fmap = $('makeFmap' ''Pair) -@ - -In this example, 'makeFmap' will splice in the appropriate lambda expression which -implements 'fmap' for @Pair@. - -@make@-functions are subject to all the restrictions of @derive@-functions listed -above save for one exception: the datatype need not be an instance of a particular -typeclass. There are some scenarios where this might be preferred over using a -@derive@-function. For example, you might want to map over a @Pair@ value -without explicitly having to make it an instance of 'Functor'. - -Another use case for @make@-functions is sophisticated data types—that is, an -expression for which a @derive@-function would infer the wrong instance context. -Consider the following example: - -@ -data Proxy a = Proxy -$('deriveEq' ''Proxy) -@ - -This would result in a generated instance of: - -@ -instance Eq a => Eq (Proxy a) where ... -@ - -This compiles, but is not what we want, since the @Eq a@ constraint is completely -unnecessary. Another scenario in which @derive@-functions fail is when you -have something like this: - -@ -newtype HigherKinded f a b = HigherKinded (f a b) -$('deriveFunctor' ''HigherKinded) -@ - -Ideally, this would produce @HigherKinded (f a)@ as its instance context, but sadly, -the Template Haskell type inference machinery used in @deriving-compat@ is not smart -enough to figure that out. Nevertheless, @make@-functions provide a valuable -backdoor for these sorts of scenarios: - -@ -{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} -import Data.Foldable.Deriving - -data Proxy a = Proxy -newtype HigherKinded f a b = HigherKinded (f a b) - -instance Eq (Proxy a) where - (==) = $('makeEq' ''Proxy) - -instance Functor (f a) => Functor (HigherKinded f a) where - fmap = $('makeFmap' ''HigherKinded) -@ - --} +{-| +Module: Data.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +This module reexports all of the functionality of the other modules in this library +(with the exception of "Data.Deriving.Via", which is only available on GHC 8.2 or +later). This module also provides a high-level tutorial on @deriving-compat@'s +naming conventions and best practices. Typeclass-specific information can be found +in their respective modules. +-} +module Data.Deriving ( + -- * Backported changes + -- $changes + + -- * @derive@- functions + -- $derive + + -- * @make@- functions + -- $make + module Exports + ) where + +import Data.Bounded.Deriving as Exports +import Data.Enum.Deriving as Exports +import Data.Eq.Deriving as Exports +import Data.Foldable.Deriving as Exports +import Data.Functor.Deriving as Exports +import Data.Ix.Deriving as Exports +import Data.Ord.Deriving as Exports +import Data.Traversable.Deriving as Exports +import Text.Read.Deriving as Exports +import Text.Show.Deriving as Exports + +{- $changes +The following changes have been backported: + +* In GHC 7.2, deriving 'Read' was changed so that constructors that use + @MagicHash@ now parse correctly. + +* In GHC 7.8, deriving standalone 'Read' instances was fixed to avoid crashing on + datatypes with no constructors. Derived 'Read' instances were also changed so + as to compile more quickly. + +* In GHC 7.10, deriving standalone 'Read' and 'Show' instances were fixed to ensure + that they use the correct fixity information for a particular datatype. + +* In GHC 8.0, @DeriveFoldable@ was changed to allow folding over data types with + existential constraints. + +* In GHC 8.0, @DeriveFoldable@ and @DeriveTraversable@ were changed so as not to + generate superfluous 'mempty' or 'pure' expressions in generated code. As a result, + this allows deriving 'Traversable' instances for datatypes with unlifted argument + types. + +* In GHC 8.0, deriving 'Ix' was changed to use @('&&')@ instead of @if@, as the latter + interacts poorly with @RebindableSyntax@. A bug was also fixed so that + standalone-derived 'Ix' instances for single-constructor GADTs do not crash GHC. + +* In GHC 8.0, deriving 'Show' was changed so that constructor fields with unlifted + types are no longer shown with parentheses, and the output of showing an unlifted + type is suffixed with the same number of hash signs as the corresponding primitive + literals. + +* In GHC 8.2, deriving 'Ord' was changed so that it generates concrete @if@-expressions + that are not subject to @RebindableSyntax@. It was also changed so that derived + @('<=')@, @('>')@, and @('>=')@ methods are expressed through @('<')@, which avoids + generating a substantial amount of code. + +* In GHC 8.2, deriving 'Traversable' was changed so that it uses 'liftA2' to implement + 'traverse' whenever possible. This was done since 'liftA2' was also made a class + method of 'Applicative', so sometimes using 'liftA2' produces more efficient code. + +* In GHC 8.2, deriving 'Show' was changed so that it uses an explicit @showCommaSpace@ + method, instead of repeating the code @showString \", \"@ in several places. + +* In GHC 8.2, @DeriveFunctor@ was changed so that it derives implementations of + ('<$'). + +* In GHC 8.4, @DeriveFoldable@ was changed so that it derives implementations of + 'null'. + +* In GHC 8.4, deriving 'Functor' and 'Traverable' was changed so that it uses 'coerce' + for efficiency when the last parameter of the data type is at phantom role. + +* In GHC 8.4, the @EmptyDataDeriving@ proposal brought forth a slew of changes related + to how instances for empty data types (i.e., no constructors) were derived. These + changes include: + + * For derived 'Eq' and 'Ord' instances for empty data types, simply return + 'True' and 'EQ', respectively, without inspecting the arguments. + + * For derived 'Read' instances for empty data types, simply return 'pfail' + (without 'parens'). + + * For derived 'Show' instances for empty data types, inspect the argument + (instead of 'error'ing). + + * For derived 'Functor' and 'Traversable' instances for empty data + types, make 'fmap' and 'traverse' strict in its argument. + + * For derived 'Foldable' instances, do not error on empty data types. + Instead, simply return the folded state (for 'foldr') or 'mempty' (for + 'foldMap'), without inspecting the arguments. + +* In GHC 8.6, the @DerivingVia@ language extension was introduced. + @deriving-compat@ provides an interface which attempts to mimic this + extension (as well as @GeneralizedNewtypeDeriving@, which is a special case + of @DerivingVia@) as closely as possible. + + Since the generated code requires the use of @TypeApplications@, this can + only be backported back to GHC 8.2. + +* In GHC 8.6, deriving 'Read' was changed so as to factor out certain commonly + used subexpressions, which significantly improve compliation times. + +* In GHC 8.10, @DerivingVia@ permits \"floating\" type variables in @via@ types, + such as the @a@ in @'deriveVia' [t| forall a. Show MyInt ``Via`` Const Int a |]@. + @deriving-compat@ does so by instantiating the @a@ to @GHC.Exts.Any@ in the + generated instance. + +* In GHC 9.0, @DeriveFunctor@ was changed so that it works on more + constructors with rank-n field types. + +* In GHC 9.4, deriving 'Eq' was changed so that it checks data constructor + tags, which can improve runtime performance for data types with nullary + constructors. +-} + +{- $derive + +Functions with the @derive@- prefix can be used to automatically generate an instance +of a typeclass for a given datatype 'Name'. Some examples: + +@ +{-# LANGUAGE TemplateHaskell #-} +import Data.Deriving + +data Pair a = Pair a a +$('deriveFunctor' ''Pair) -- instance Functor Pair where ... + +data Product f g a = Product (f a) (g a) +$('deriveFoldable' ''Product) +-- instance (Foldable f, Foldable g) => Foldable (Pair f g) where ... +@ + +If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), +then @derive@-functions can be used with data family instances (which requires the +@-XTypeFamilies@ extension). To do so, pass the 'Name' of a data or newtype instance +constructor (NOT a data family name!) to @deriveFoldable@. Note that the +generated code may require the @-XFlexibleInstances@ extension. Example: + +@ +{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} +import Data.Deriving + +class AssocClass a b where + data AssocData a b +instance AssocClass Int b where + data AssocData Int b = AssocDataInt1 Int + | AssocDataInt2 b +$('deriveFunctor' 'AssocDataInt1) -- instance Functor (AssocData Int) where ... +-- Alternatively, one could use $(deriveFunctor 'AssocDataInt2) +@ + +@derive@-functions in @deriving-compat@ fall into one of three categories: + +* Category 0: Typeclasses with an argument of kind @*@. + ('deriveBounded', 'deriveEnum', 'deriveEq', 'deriveIx', 'deriveOrd', 'deriveRead', 'deriveShow') + +* Category 1: Typeclasses with an argument of kind @* -> *@, That is, a datatype + with such an instance must have at least one type variable, and the last type + variable must be of kind @*@. + ('deriveEq1', 'deriveFoldable', 'deriveFunctor', 'deriveOrd1', + 'deriveRead1', 'deriveShow1', 'deriveTraversable') + +* Category 2: Typeclasses with an argument of kind @* -> * -> *@. That is, a datatype + with such an instance must have at least two type variables, and the last two type + variables must be of kind @*@. + ('deriveEq2', 'deriveOrd2', 'deriveRead2', 'deriveShow2') + +Note that there are some limitations to @derive@-functions: + +* The 'Name' argument must not be of a type synonym. + +* Type variables (other than the last ones) are assumed to require typeclass + constraints. The constraints are different depending on the category. For example, + for Category 0 functions, other type variables of kind @*@ are assumed to be + constrained by that typeclass. As an example: + + @ + data Foo a = Foo a + $(deriveEq ''Foo) + @ + + will result in a generated instance of: + + @ + instance Eq a => Eq (Foo a) where ... + @ + + If you do not want this behavior, use a @make@- function instead. + +* For Category 1 and 2 functions, if you are using the @-XDatatypeContexts@ extension, + a constraint cannot mention the last type variables. For example, + @data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived 'Functor' + instance. + +* For Category 1 and 2 functions, if one of the last type variables is used within a + constructor field's type, it must only be used in the last type arguments. For + example, @data Legal a = Legal (Either Int a)@ can have a derived 'Functor' instance, + but @data Illegal a = Illegal (Either a Int)@ cannot. + +* For Category 1 and 2 functions, data family instances must be able to eta-reduce the + last type variables. In other words, if you have a instance of the form: + + @ + data family Family a1 ... an t1 ... tn + data instance Family e1 ... e2 v1 ... vn = ... + @ + + where @t1@, ..., @tn@ are the last type variables, then the following conditions + must hold: + + 1. @v1@, ..., @vn@ must be type variables. + 2. @v1@, ..., @vn@ must not be mentioned in any of @e1@, ..., @e2@. + +-} + +{- $make + +Functions prefixed with @make@- are similar to @derive@-functions in that they also +generate code, but @make@-functions in particular generate the expression for a +particular typeclass method. For example: + +@ +{-# LANGUAGE TemplateHaskell #-} +import Data.Deriving + +data Pair a = Pair a a + +instance Functor Pair where + fmap = $('makeFmap' ''Pair) +@ + +In this example, 'makeFmap' will splice in the appropriate lambda expression which +implements 'fmap' for @Pair@. + +@make@-functions are subject to all the restrictions of @derive@-functions listed +above save for one exception: the datatype need not be an instance of a particular +typeclass. There are some scenarios where this might be preferred over using a +@derive@-function. For example, you might want to map over a @Pair@ value +without explicitly having to make it an instance of 'Functor'. + +Another use case for @make@-functions is sophisticated data types—that is, an +expression for which a @derive@-function would infer the wrong instance context. +Consider the following example: + +@ +data Proxy a = Proxy +$('deriveEq' ''Proxy) +@ + +This would result in a generated instance of: + +@ +instance Eq a => Eq (Proxy a) where ... +@ + +This compiles, but is not what we want, since the @Eq a@ constraint is completely +unnecessary. Another scenario in which @derive@-functions fail is when you +have something like this: + +@ +newtype HigherKinded f a b = HigherKinded (f a b) +$('deriveFunctor' ''HigherKinded) +@ + +Ideally, this would produce @HigherKinded (f a)@ as its instance context, but sadly, +the Template Haskell type inference machinery used in @deriving-compat@ is not smart +enough to figure that out. Nevertheless, @make@-functions provide a valuable +backdoor for these sorts of scenarios: + +@ +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +import Data.Foldable.Deriving + +data Proxy a = Proxy +newtype HigherKinded f a b = HigherKinded (f a b) + +instance Eq (Proxy a) where + (==) = $('makeEq' ''Proxy) + +instance Functor (f a) => Functor (HigherKinded f a) where + fmap = $('makeFmap' ''HigherKinded) +@ + +-} diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -1,2304 +1,2304 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} - -#if !(MIN_VERSION_base(4,9,0)) -# if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TemplateHaskellQuotes #-} -# else -{-# LANGUAGE TemplateHaskell #-} -# endif -#endif - -{-| -Module: Data.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Template Haskell-related utilities. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Deriving.Internal where - -import Control.Applicative (liftA2) -import Control.Monad (when, unless) - -import Data.Foldable (foldr') -#if !(MIN_VERSION_base(4,9,0)) -import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) -# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) -import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..)) -# endif -#endif -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Traversable as T - -import Text.ParserCombinators.ReadPrec (ReadPrec) -import qualified Text.Read.Lex as L - -#if MIN_VERSION_base(4,7,0) -import GHC.Read (expectP) -#else -import GHC.Read (lexP) - -import Text.Read (pfail) -import Text.Read.Lex (Lexeme) -#endif - -#if MIN_VERSION_ghc_prim(0,3,1) -import GHC.Prim (Int#, tagToEnum#) -#endif - -#if defined(MIN_VERSION_ghc_boot_th) -import GHC.Lexeme (startsConSym, startsVarSym) -#else -import Data.Char (isSymbol, ord) -#endif - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Datatype.TyVarBndr -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr (pprint) -import Language.Haskell.TH.Syntax - --- Ensure, beyond a shadow of a doubt, that the instances are in-scope -import Data.Functor () -import Data.Functor.Classes () -import Data.Foldable () -import Data.Traversable () - -#ifndef CURRENT_PACKAGE_KEY -import Data.Version (showVersion) -import Paths_deriving_compat (version) -#endif - -------------------------------------------------------------------------------- --- Expanding type synonyms -------------------------------------------------------------------------------- - -applySubstitutionKind :: Map Name Kind -> Type -> Type -#if MIN_VERSION_template_haskell(2,8,0) -applySubstitutionKind = applySubstitution -#else -applySubstitutionKind _ t = t -#endif - -substNameWithKind :: Name -> Kind -> Type -> Type -substNameWithKind n k = applySubstitutionKind (Map.singleton n k) - -substNamesWithKindStar :: [Name] -> Type -> Type -substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns - -------------------------------------------------------------------------------- --- Via -------------------------------------------------------------------------------- - --- | A type-level modifier intended to be used in conjunction with 'deriveVia'. --- Refer to the documentation for 'deriveVia' for more details. -data a `Via` b -infix 0 `Via` - -------------------------------------------------------------------------------- --- Type-specialized const functions -------------------------------------------------------------------------------- - -fmapConst :: f b -> (a -> b) -> f a -> f b -fmapConst x _ _ = x -{-# INLINE fmapConst #-} - -replaceConst :: f a -> a -> f b -> f a -replaceConst x _ _ = x -{-# INLINE replaceConst #-} - -foldrConst :: b -> (a -> b -> b) -> b -> t a -> b -foldrConst x _ _ _ = x -{-# INLINE foldrConst #-} - -foldMapConst :: m -> (a -> m) -> t a -> m -foldMapConst x _ _ = x -{-# INLINE foldMapConst #-} - -nullConst :: Bool -> t a -> Bool -nullConst x _ = x -{-# INLINE nullConst #-} - -traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b) -traverseConst x _ _ = x -{-# INLINE traverseConst #-} - -eqConst :: Bool - -> a -> a -> Bool -eqConst x _ _ = x -{-# INLINE eqConst #-} - -eq1Const :: Bool - -> f a -> f a-> Bool -eq1Const x _ _ = x -{-# INLINE eq1Const #-} - -liftEqConst :: Bool - -> (a -> b -> Bool) -> f a -> f b -> Bool -liftEqConst x _ _ _ = x -{-# INLINE liftEqConst #-} - -liftEq2Const :: Bool - -> (a -> b -> Bool) -> (c -> d -> Bool) - -> f a c -> f b d -> Bool -liftEq2Const x _ _ _ _ = x -{-# INLINE liftEq2Const #-} - -compareConst :: Ordering -> a -> a -> Ordering -compareConst x _ _ = x -{-# INLINE compareConst #-} - -ltConst :: Bool -> a -> a -> Bool -ltConst x _ _ = x -{-# INLINE ltConst #-} - -compare1Const :: Ordering -> f a -> f a -> Ordering -compare1Const x _ _ = x -{-# INLINE compare1Const #-} - -liftCompareConst :: Ordering - -> (a -> b -> Ordering) -> f a -> f b -> Ordering -liftCompareConst x _ _ _ = x -{-# INLINE liftCompareConst #-} - -liftCompare2Const :: Ordering - -> (a -> b -> Ordering) -> (c -> d -> Ordering) - -> f a c -> f b d -> Ordering -liftCompare2Const x _ _ _ _ = x -{-# INLINE liftCompare2Const #-} - -readsPrecConst :: ReadS a -> Int -> ReadS a -readsPrecConst x _ = x -{-# INLINE readsPrecConst #-} - --- This isn't really necessary, but it makes for an easier implementation -readPrecConst :: ReadPrec a -> ReadPrec a -readPrecConst x = x -{-# INLINE readPrecConst #-} - -readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a) -readsPrec1Const x _ = x -{-# INLINE readsPrec1Const #-} - -liftReadsPrecConst :: ReadS (f a) - -> (Int -> ReadS a) -> ReadS [a] - -> Int -> ReadS (f a) -liftReadsPrecConst x _ _ _ = x -{-# INLINE liftReadsPrecConst #-} - -liftReadPrecConst :: ReadPrec (f a) - -> ReadPrec a -> ReadPrec [a] - -> ReadPrec (f a) -liftReadPrecConst x _ _ = x -{-# INLINE liftReadPrecConst #-} - -liftReadsPrec2Const :: ReadS (f a b) - -> (Int -> ReadS a) -> ReadS [a] - -> (Int -> ReadS b) -> ReadS [b] - -> Int -> ReadS (f a b) -liftReadsPrec2Const x _ _ _ _ _ = x -{-# INLINE liftReadsPrec2Const #-} - -liftReadPrec2Const :: ReadPrec (f a b) - -> ReadPrec a -> ReadPrec [a] - -> ReadPrec b -> ReadPrec [b] - -> ReadPrec (f a b) -liftReadPrec2Const x _ _ _ _ = x -{-# INLINE liftReadPrec2Const #-} - -showsPrecConst :: ShowS - -> Int -> a -> ShowS -showsPrecConst x _ _ = x -{-# INLINE showsPrecConst #-} - -showsPrec1Const :: ShowS - -> Int -> f a -> ShowS -showsPrec1Const x _ _ = x -{-# INLINE showsPrec1Const #-} - -liftShowsPrecConst :: ShowS - -> (Int -> a -> ShowS) -> ([a] -> ShowS) - -> Int -> f a -> ShowS -liftShowsPrecConst x _ _ _ _ = x -{-# INLINE liftShowsPrecConst #-} - -liftShowsPrec2Const :: ShowS - -> (Int -> a -> ShowS) -> ([a] -> ShowS) - -> (Int -> b -> ShowS) -> ([b] -> ShowS) - -> Int -> f a b -> ShowS -liftShowsPrec2Const x _ _ _ _ _ _ = x -{-# INLINE liftShowsPrec2Const #-} - -------------------------------------------------------------------------------- --- StarKindStatus -------------------------------------------------------------------------------- - --- | Whether a type is not of kind *, is of kind *, or is a kind variable. -data StarKindStatus = NotKindStar - | KindStar - | IsKindVar Name - deriving Eq - --- | Does a Type have kind * or k (for some kind variable k)? -canRealizeKindStar :: Type -> StarKindStatus -canRealizeKindStar t - | hasKindStar t = KindStar - | otherwise = case t of -#if MIN_VERSION_template_haskell(2,8,0) - SigT _ (VarT k) -> IsKindVar k -#endif - _ -> NotKindStar - --- | 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 - -------------------------------------------------------------------------------- --- ClassRep -------------------------------------------------------------------------------- - -class ClassRep a where - arity :: a -> Int - allowExQuant :: a -> Bool - fullClassName :: a -> Name - classConstraint :: a -> Int -> Maybe Name - -------------------------------------------------------------------------------- --- Template Haskell reifying and AST manipulation -------------------------------------------------------------------------------- - --- For the given Types, generate an instance context and head. 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 :: ClassRep a - => a - -- ^ The typeclass for which an instance should be derived - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [Type] - -- ^ The types to instantiate the instance with - -> DatatypeVariant - -- ^ Are we dealing with a data family instance or not - -> Q (Cxt, Type) -buildTypeInstance cRep tyConName dataCxt varTysOrig variant = 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 - arity cRep - - droppedTysExp :: [Type] - droppedTysExp = drop remainingLength varTysExp - - droppedStarKindStati :: [StarKindStatus] - droppedStarKindStati = map canRealizeKindStar droppedTysExp - - -- Check there are enough types to drop and that all of them are either of - -- kind * or kind k (for some kind variable k). If not, throw an error. - when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ - derivingKindError cRep tyConName - - let droppedKindVarNames :: [Name] - droppedKindVarNames = catKindVarNames droppedStarKindStati - - -- Substitute kind * for any dropped kind variables - varTysExpSubst :: [Type] - varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp - - remainingTysExpSubst, droppedTysExpSubst :: [Type] - (remainingTysExpSubst, droppedTysExpSubst) = - splitAt remainingLength varTysExpSubst - - -- All of the type variables mentioned in the dropped types - -- (post-synonym expansion) - droppedTyVarNames :: [Name] - droppedTyVarNames = freeVariables droppedTysExpSubst - - -- If any of the dropped types were polykinded, ensure that they are of kind * - -- after substituting * for the dropped kind variables. If not, throw an error. - unless (all hasKindStar droppedTysExpSubst) $ - derivingKindError cRep tyConName - - let preds :: [Maybe Pred] - kvNames :: [[Name]] - kvNames' :: [Name] - -- Derive instance constraints (and any kind variables which are specialized - -- to * in those constraints) - (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst - kvNames' = concat kvNames - - -- Substitute the kind variables specialized in the constraints with * - remainingTysExpSubst' :: [Type] - remainingTysExpSubst' = - map (substNamesWithKindStar kvNames') remainingTysExpSubst - - -- 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]) - remainingTysOrigSubst :: [Type] - remainingTysOrigSubst = - map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) - $ take remainingLength varTysOrig - - isDataFamily :: Bool - isDataFamily = case variant of - Datatype -> False - Newtype -> False - DataInstance -> True - NewtypeInstance -> True - - remainingTysOrigSubst' :: [Type] - -- See Note [Kind signatures in derived instances] for an explanation - -- of the isDataFamily check. - remainingTysOrigSubst' = - if isDataFamily - then remainingTysOrigSubst - else map unSigT remainingTysOrigSubst - - instanceCxt :: Cxt - instanceCxt = catMaybes preds - - instanceType :: Type - instanceType = AppT (ConT (fullClassName cRep)) - $ applyTyCon tyConName remainingTysOrigSubst' - - -- If the datatype context mentions any of the dropped type variables, - -- we can't derive an instance, so throw an error. - when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ - datatypeContextError tyConName instanceType - -- Also ensure the dropped types can be safely eta-reduced. Otherwise, - -- throw an error. - unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ - etaReductionError instanceType - return (instanceCxt, instanceType) - --- | Attempt to derive a constraint on a Type. If successful, return --- Just the constraint and any kind variable names constrained to *. --- Otherwise, return Nothing and the empty list. --- --- See Note [Type inference in derived instances] for the heuristics used to --- come up with constraints. -deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name]) -deriveConstraint cRep t - | not (isTyVar t) = (Nothing, []) - | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, []) - | otherwise = case hasKindVarChain 1 t of - Just ns | cRepArity >= 1 - -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns) - _ -> case hasKindVarChain 2 t of - Just ns | cRepArity == 2 - -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns) - _ -> (Nothing, []) - where - tName :: Name - tName = varTToName t - - cRepArity :: Int - cRepArity = arity cRep - -{- -Note [Kind signatures in derived instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is possible to put explicit kind signatures into the derived instances, e.g., - - instance C a => C (Data (f :: * -> *)) where ... - -But it is preferable to avoid this if possible. If we come up with an incorrect -kind signature (which is entirely possible, since our type inferencer is pretty -unsophisticated - see Note [Type inference in derived instances]), then GHC will -flat-out reject the instance, which is quite unfortunate. - -Plain old datatypes have the advantage that you can avoid using any kind signatures -at all in their instances. This is because a datatype declaration uses all type -variables, so the types that we use in a derived instance uniquely determine their -kinds. As long as we plug in the right types, the kind inferencer can do the rest -of the work. For this reason, we use unSigT to remove all kind signatures before -splicing in the instance context and head. - -Data family instances are trickier, since a data family can have two instances that -are distinguished by kind alone, e.g., - - data family Fam (a :: k) - data instance Fam (a :: * -> *) - data instance Fam (a :: *) - -If we dropped the kind signatures for C (Fam a), then GHC will have no way of -knowing which instance we are talking about. To avoid this scenario, we always -include explicit kind signatures in data family instances. There is a chance that -the inferred kind signatures will be incorrect, but if so, we can always fall back -on the make- functions. - -Note [Type inference in derived instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Type inference is can be tricky to get right, and we want to avoid recreating the -entirety of GHC's type inferencer in Template Haskell. For this reason, we will -probably never come up with derived instance contexts that are as accurate as -GHC's. But that doesn't mean we can't do anything! There are a couple of simple -things we can do to make instance contexts that work for 80% of use cases: - -1. If one of the last type parameters is polykinded, then its kind will be - specialized to * in the derived instance. We note what kind variable the type - parameter had and substitute it with * in the other types as well. For example, - imagine you had - - data Data (a :: k) (b :: k) - - Then you'd want to derived instance to be: - - instance C (Data (a :: *)) - - Not: - - instance C (Data (a :: k)) - -2. We naïvely come up with instance constraints using the following criteria, using - Show(1)(2) as the example typeclasses: - - (i) If there's a type parameter n of kind *, generate a Show n constraint. - (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind - variables), then generate a Show1 n constraint, and if k1/k2 are kind - variables, then substitute k1/k2 with * elsewhere in the types. We must - consider the case where they are kind variables because you might have a - scenario like this: - - newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) - = Compose (f (g a)) - - Which would have a derived Show1 instance of: - - instance (Show1 f, Show1 g) => Show1 (Compose f g) where ... - (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are - * or kind variables), then generate a Show2 constraint and perform - kind substitution as in the other cases. --} - -checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name - -> Q c -> Q c -checkExistentialContext cRep tvMap ctxt conName q = - if (any (`predMentionsName` Map.keys tvMap) ctxt - || Map.size tvMap < arity cRep) - && not (allowExQuant cRep) - then existentialContextError conName - else q - -{- -Note [Matching functions with GADT type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When deriving category-2 classes like Show2, there is a tricky corner case to consider: - - data Both a b where - BothCon :: x -> x -> Both x x - -Which show functions should be applied to which arguments of BothCon? We have a -choice, since both the function of type (Int -> a -> ShowS) and of type -(Int -> b -> ShowS) can be applied to either argument. In such a scenario, the -second show function takes precedence over the first show function, so the -derived Show2 instance would be: - - instance Show2 Both where - liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) = - showsParen (p > appPrec) $ - showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2 - -This is not an arbitrary choice, as this definition ensures that -liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for -Both. --} - -------------------------------------------------------------------------------- --- Error messages -------------------------------------------------------------------------------- - --- | The given datatype has no constructors, and we don't know what to do with it. -noConstructorsError :: Q a -noConstructorsError = fail "Must have at least one data constructor" - --- | 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 :: ClassRep a => a -> Name -> Q b -derivingKindError cRep tyConName = fail - . showString "Cannot derive well-kinded instance of form ‘" - . showString className - . showChar ' ' - . showParen True - ( showString (nameBase tyConName) - . showString " ..." - ) - . showString "‘\n\tClass " - . showString className - . showString " expects an argument of kind " - . showString (pprint . createKindChain $ arity cRep) - $ "" - where - className :: String - className = nameBase $ fullClassName cRep - --- | The last type variable appeared in a contravariant position --- when deriving Functor. -contravarianceError :: Name -> Q a -contravarianceError conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must not use the last type variable in a function argument" - $ "" - --- | A constructor has a function argument in a derived Foldable or Traversable --- instance. -noFunctionsError :: Name -> Q a -noFunctionsError conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must not contain function types" - $ "" - --- | 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 - --- | The data type has a DatatypeContext which mentions one of the eta-reduced --- type variables. -datatypeContextError :: Name -> Type -> Q a -datatypeContextError dataName instanceType = fail - . showString "Can't make a derived instance of ‘" - . showString (pprint instanceType) - . showString "‘:\n\tData type ‘" - . showString (nameBase dataName) - . showString "‘ must not have a class context involving the last type argument(s)" - $ "" - --- | The data type has an existential constraint which mentions one of the --- eta-reduced type variables. -existentialContextError :: Name -> Q a -existentialContextError conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must be truly polymorphic in the last argument(s) of the data type" - $ "" - --- | The data type mentions one of the n eta-reduced type variables in a place other --- than the last nth positions of a data type in a constructor's field. -outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b -outOfPlaceTyVarError cRep conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must only use its last " - . shows n - . showString " type variable(s) within the last " - . shows n - . showString " argument(s) of a data type" - $ "" - where - n :: Int - n = arity cRep - -enumerationError :: String -> Q a -enumerationError = fail . enumerationErrorStr - -enumerationOrProductError :: String -> Q a -enumerationOrProductError nb = fail $ unlines - [ enumerationErrorStr nb - , "\tor a product type (precisely one constructor)" - ] - -enumerationErrorStr :: String -> String -enumerationErrorStr nb = - '\'':nb ++ "’ must be an enumeration type" - ++ " (one or more nullary, non-GADT constructors)" - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - --- | A mapping of type variable Names to their auxiliary function Names. -type TyVarMap a = Map Name (OneOrTwoNames a) -type TyVarMap1 = TyVarMap One -type TyVarMap2 = TyVarMap Two - -data OneOrTwoNames a where - OneName :: Name -> OneOrTwoNames One - TwoNames :: Name -> Name -> OneOrTwoNames Two - -data One -data Two - -interleave :: [a] -> [a] -> [a] -interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s -interleave _ _ = [] - -#if MIN_VERSION_ghc_prim(0,3,1) -isTrue# :: Int# -> Bool -isTrue# x = tagToEnum# x -#else -isTrue# :: Bool -> Bool -isTrue# x = x -#endif -{-# INLINE isTrue# #-} - --- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) - --- | 'filterByList' takes a list of Bools and a list of some elements and --- filters out these elements for which the corresponding value in the list of --- Bools is False. This function does not check whether the lists have equal --- length. -filterByList :: [Bool] -> [a] -> [a] -filterByList (True:bs) (x:xs) = x : filterByList bs xs -filterByList (False:bs) (_:xs) = filterByList bs xs -filterByList _ _ = [] - --- | 'filterByLists' takes a list of Bools and two lists as input, and --- outputs a new list consisting of elements from the last two input lists. For --- each Bool in the list, if it is 'True', then it takes an element from the --- former list. If it is 'False', it takes an element from the latter list. --- The elements taken correspond to the index of the Bool in its list. --- For example: --- --- @ --- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" --- @ --- --- This function does not check whether the lists have equal length. -filterByLists :: [Bool] -> [a] -> [a] -> [a] -filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys -filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys -filterByLists _ _ _ = [] - --- | 'partitionByList' takes a list of Bools and a list of some elements and --- partitions the list according to the list of Bools. Elements corresponding --- to 'True' go to the left; elements corresponding to 'False' go to the right. --- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ --- This function does not check whether the lists have equal --- length. -partitionByList :: [Bool] -> [a] -> ([a], [a]) -partitionByList = go [] [] - where - go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs - go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs - go trues falses _ _ = (reverse trues, reverse falses) - -integerE :: Int -> Q Exp -integerE = litE . integerL . fromIntegral - --- | Returns True if a Type has kind *. -hasKindStar :: Type -> Bool -hasKindStar VarT{} = True -#if MIN_VERSION_template_haskell(2,8,0) -hasKindStar (SigT _ StarT) = True -#else -hasKindStar (SigT _ StarK) = True -#endif -hasKindStar _ = False - --- Returns True is a kind is equal to *, or if it is a kind variable. -isStarOrVar :: Kind -> Bool -#if MIN_VERSION_template_haskell(2,8,0) -isStarOrVar StarT = True -isStarOrVar VarT{} = True -#else -isStarOrVar StarK = True -#endif -isStarOrVar _ = False - --- | @hasKindVarChain n kind@ Checks if @kind@ is of the form --- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or --- kind variables. -hasKindVarChain :: Int -> Type -> Maybe [Name] -hasKindVarChain kindArrows t = - let uk = uncurryKind (tyKind t) - in if (length uk - 1 == kindArrows) && all isStarOrVar uk - then Just (freeVariables uk) - else Nothing - --- | If a Type is a SigT, returns its kind signature. Otherwise, return *. -tyKind :: Type -> Kind -tyKind (SigT _ k) = k -tyKind _ = starK - -zipWithAndUnzipM :: Monad m - => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) -zipWithAndUnzipM f (x:xs) (y:ys) = do - (c, d) <- f x y - (cs, ds) <- zipWithAndUnzipM f xs ys - return (c:cs, d:ds) -zipWithAndUnzipM _ _ _ = return ([], []) -{-# INLINE zipWithAndUnzipM #-} - -zipWith3AndUnzipM :: Monad m - => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] - -> m ([d], [e]) -zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do - (d, e) <- f x y z - (ds, es) <- zipWith3AndUnzipM f xs ys zs - return (d:ds, e:es) -zipWith3AndUnzipM _ _ _ _ = return ([], []) -{-# INLINE zipWith3AndUnzipM #-} - -thd3 :: (a, b, c) -> c -thd3 (_, _, c) = c - -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc (x:xs) = case unsnoc xs of - Nothing -> Just ([], x) - Just (a,b) -> Just (x:a, b) - -isNullaryCon :: ConstructorInfo -> Bool -isNullaryCon (ConstructorInfo { constructorFields = tys }) = null tys - --- | Returns the number of fields for the constructor. -conArity :: ConstructorInfo -> Int -conArity (ConstructorInfo { constructorFields = tys }) = length tys - --- | Returns 'True' if it's a datatype with exactly one, non-existential constructor. -isProductType :: [ConstructorInfo] -> Bool -isProductType [con] = null (constructorVars con) -isProductType _ = False - --- | Returns 'True' if it's a datatype with one or more nullary, non-GADT --- constructors. -isEnumerationType :: [ConstructorInfo] -> Bool -isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons -isEnumerationType _ = False - --- | Returns 'False' if we're dealing with existential quantification or GADTs. -isVanillaCon :: ConstructorInfo -> Bool -isVanillaCon (ConstructorInfo { constructorContext = ctxt, constructorVars = vars }) = - null ctxt && null vars - --- | 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] - --- | Extracts the kind from a TyVarBndr. -tvbKind :: TyVarBndr_ flag -> Kind -tvbKind = elimTV (\_ -> starK) (\_ k -> k) - --- | Convert a TyVarBndr to a Type. -tvbToType :: TyVarBndr_ flag -> Type -tvbToType = elimTV VarT (\n k -> SigT (VarT n) k) - --- | Applies a typeclass constraint to a type. -applyClass :: Name -> Name -> Pred -#if MIN_VERSION_template_haskell(2,10,0) -applyClass con t = AppT (ConT con) (VarT t) -#else -applyClass con t = ClassP con [VarT t] -#endif - -createKindChain :: Int -> Kind -createKindChain = go starK - where - go :: Kind -> Int -> Kind - go k !0 = k -#if MIN_VERSION_template_haskell(2,8,0) - go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) -#else - go k !n = go (ArrowK StarK k) (n - 1) -#endif - --- | 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 - && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type - -- didn't have an Ord instance until template-haskell-2.10.0.0 - && not (any (`mentionsName` droppedNames) remaining) - where - droppedNames :: [Name] - droppedNames = map varTToName dropped - --- | Extract the Name from a type constructor. If the argument Type is not a --- type variable, throw an error. -conTToName :: Type -> Name -conTToName (ConT n) = n -conTToName (SigT t _) = conTToName t -conTToName _ = error "Not a type constructor!" - --- | Extract Just the Name from a type variable. If the argument Type is not a --- type variable, return Nothing. -varTToName_maybe :: Type -> Maybe Name -varTToName_maybe (VarT n) = Just n -varTToName_maybe (SigT t _) = varTToName_maybe t -varTToName_maybe _ = Nothing - --- | Extract the Name from a type variable. If the argument Type is not a --- type variable, throw an error. -varTToName :: Type -> Name -varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe - --- | Peel off a kind signature from a Type (if it has one). -unSigT :: Type -> Type -unSigT (SigT t _) = t -unSigT t = t - --- | Is the given type a variable? -isTyVar :: Type -> Bool -isTyVar (VarT _) = True -isTyVar (SigT t _) = isTyVar t -isTyVar _ = False - --- | Detect if a Name in a list of provided Names occurs as an argument to some --- type family. This makes an effort to exclude /oversaturated/ arguments to --- type families. For instance, if one declared the following type family: --- --- @ --- type family F a :: Type -> Type --- @ --- --- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, --- but not @b@. -isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool -isInTypeFamilyApp names tyFun tyArgs = - case tyFun of - ConT tcName -> go tcName - _ -> return False - where - go :: Name -> Q Bool - go tcName = do - info <- reify tcName - case info of -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ - -> withinFirstArgs bndrs -#elif MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD TypeFam _ bndrs _) _ - -> withinFirstArgs bndrs -#else - TyConI (FamilyD TypeFam _ bndrs _) - -> withinFirstArgs bndrs -#endif - -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ - -> withinFirstArgs bndrs -#elif MIN_VERSION_template_haskell(2,9,0) - FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ - -> withinFirstArgs bndrs -#endif - - _ -> return False - where - withinFirstArgs :: [a] -> Q Bool - withinFirstArgs bndrs = - let firstArgs = take (length bndrs) tyArgs - argFVs = freeVariables firstArgs - in return $ any (`elem` argFVs) names - --- | 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 - --- | Does the given type mention any of the Names in the list? -mentionsName :: Type -> [Name] -> Bool -mentionsName = go - where - go :: Type -> [Name] -> Bool - go (AppT t1 t2) names = go t1 names || go t2 names - go (SigT t _k) names = go t names -#if MIN_VERSION_template_haskell(2,8,0) - || go _k names -#endif - go (VarT n) names = n `elem` names - go _ _ = False - --- | Does an instance predicate mention any of the Names in the list? -predMentionsName :: Pred -> [Name] -> Bool -#if MIN_VERSION_template_haskell(2,10,0) -predMentionsName = mentionsName -#else -predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys -predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names -#endif - --- | Construct a type via curried application. -applyTy :: Type -> [Type] -> Type -applyTy = List.foldl' AppT - --- | Fully applies a type constructor to its type variables. -applyTyCon :: Name -> [Type] -> Type -applyTyCon = applyTy . ConT - --- | Split an applied type into its individual components. For example, this: --- --- @ --- Either Int Char --- @ --- --- would split to this: --- --- @ --- [Either, Int, Char] --- @ -unapplyTy :: Type -> (Type, [Type]) -unapplyTy ty = go ty ty [] - where - go :: Type -> Type -> [Type] -> (Type, [Type]) - go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) - go origTy (SigT ty' _) args = go origTy ty' args -#if MIN_VERSION_template_haskell(2,11,0) - go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args - go origTy (ParensT ty') args = go origTy ty' args -#endif - go origTy _ args = (origTy, args) - --- | Split a type signature by the arrows on its spine. For example, this: --- --- @ --- forall a b. (a ~ b) => (a -> b) -> Char -> () --- @ --- --- would split to this: --- --- @ --- (a ~ b, [a -> b, Char, ()]) --- @ -uncurryTy :: Type -> (Cxt, [Type]) -uncurryTy (AppT (AppT ArrowT t1) t2) = - let (ctxt, tys) = uncurryTy t2 - in (ctxt, t1:tys) -uncurryTy (SigT t _) = uncurryTy t -uncurryTy (ForallT _ ctxt t) = - let (ctxt', tys) = uncurryTy t - in (ctxt ++ ctxt', tys) -uncurryTy t = ([], [t]) - - --- | Like uncurryType, except on a kind level. -uncurryKind :: Kind -> [Kind] -#if MIN_VERSION_template_haskell(2,8,0) -uncurryKind = snd . uncurryTy -#else -uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 -uncurryKind k = [k] -#endif - -untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp -untagExpr [] e = e -untagExpr ((untagThis, putTagHere) : more) e = - caseE (varE getTagValName `appE` varE untagThis) - [match (varP putTagHere) - (normalB $ untagExpr more e) - []] - -tag2ConExpr :: Type -> Q Exp -tag2ConExpr ty = do - iHash <- newName "i#" - ty' <- freshenType ty - lam1E (conP iHashDataName [varP iHash]) $ - varE tagToEnumHashValName `appE` varE iHash - `sigE` return (quantifyType ty') - -- tagToEnum# is a hack, and won't typecheck unless it's in the - -- immediate presence of a type ascription like so: - -- - -- tagToEnum# x :: Foo - -- - -- We have to be careful when dealing with datatypes with type - -- variables, since Template Haskell might reject the type variables - -- we use for being out-of-scope. To avoid this, we explicitly - -- collect the type variable binders and shove them into a ForallT - -- (using th-abstraction's quantifyType function). Also make sure - -- to freshen the bound type variables to avoid shadowed variable - -- warnings on old versions of GHC when -Wall is enabled. - -primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name) -primOrdFunTbl = Map.fromList - [ (addrHashTypeName, ( ltAddrHashValName - , leAddrHashValName - , eqAddrHashValName - , geAddrHashValName - , gtAddrHashValName - )) - , (charHashTypeName, ( ltCharHashValName - , leCharHashValName - , eqCharHashValName - , geCharHashValName - , gtCharHashValName - )) - , (doubleHashTypeName, ( ltDoubleHashValName - , leDoubleHashValName - , eqDoubleHashValName - , geDoubleHashValName - , gtDoubleHashValName - )) - , (floatHashTypeName, ( ltFloatHashValName - , leFloatHashValName - , eqFloatHashValName - , geFloatHashValName - , gtFloatHashValName - )) - , (intHashTypeName, ( ltIntHashValName - , leIntHashValName - , eqIntHashValName - , geIntHashValName - , gtIntHashValName - )) - , (wordHashTypeName, ( ltWordHashValName - , leWordHashValName - , eqWordHashValName - , geWordHashValName - , gtWordHashValName - )) -#if MIN_VERSION_base(4,13,0) - , (int8HashTypeName, ( ltInt8HashValName - , leInt8HashValName - , eqInt8HashValName - , geInt8HashValName - , gtInt8HashValName - )) - , (int16HashTypeName, ( ltInt16HashValName - , leInt16HashValName - , eqInt16HashValName - , geInt16HashValName - , gtInt16HashValName - )) - , (word8HashTypeName, ( ltWord8HashValName - , leWord8HashValName - , eqWord8HashValName - , geWord8HashValName - , gtWord8HashValName - )) - , (word16HashTypeName, ( ltWord16HashValName - , leWord16HashValName - , eqWord16HashValName - , geWord16HashValName - , gtWord16HashValName - )) -#endif -#if MIN_VERSION_base(4,16,0) - , (int32HashTypeName, ( ltInt32HashValName - , leInt32HashValName - , eqInt32HashValName - , geInt32HashValName - , gtInt32HashValName - )) - , (word32HashTypeName, ( ltWord32HashValName - , leWord32HashValName - , eqWord32HashValName - , geWord32HashValName - , gtWord32HashValName - )) -#endif - ] - -removeClassApp :: Type -> Type -removeClassApp (AppT _ t2) = t2 -removeClassApp t = t - --- This is an ugly, but unfortunately necessary hack on older versions of GHC which --- don't have a properly working newName. On those GHCs, even running newName on a --- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by --- appending an uncommonly used string to the end of the name. This isn't foolproof, --- since a user could freshen a variable named x and still have another x_' variable in --- scope, but at least it's unlikely. -freshen :: Name -> Q Name -freshen n = newName (nameBase n ++ "_'") - -freshenType :: Type -> Q Type -freshenType t = - do let xs = [(n, VarT `fmap` freshen n) | n <- freeVariables t] - subst <- T.sequence (Map.fromList xs) - return (applySubstitution subst t) - -enumFromToExpr :: Q Exp -> Q Exp -> Q Exp -enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t - -primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp -primOpAppExpr e1 op e2 = varE isTrueHashValName `appE` - infixApp e1 (varE op) e2 - --- | Checks if a 'Name' represents a tuple type constructor (other than '()') -isNonUnitTuple :: Name -> Bool -isNonUnitTuple = isNonUnitTupleString . nameBase - --- | Checks if a 'String' represents a tuple (other than '()') -isNonUnitTupleString :: String -> Bool -isNonUnitTupleString ('(':',':_) = True -isNonUnitTupleString _ = False - --- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does --- it begin with a colon?). -isInfixDataCon :: String -> Bool -isInfixDataCon (':':_) = True -isInfixDataCon _ = False - -isSym :: String -> Bool -isSym "" = False -isSym (c : _) = startsVarSym c || startsConSym c - -#if !defined(MIN_VERSION_ghc_boot_th) -startsVarSym, startsConSym :: Char -> Bool -startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids -startsConSym c = c == ':' -- Infix data constructors - -startsVarSymASCII :: Char -> Bool -startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" -#endif - -ghc7'8OrLater :: Bool -#if __GLASGOW_HASKELL__ >= 708 -ghc7'8OrLater = True -#else -ghc7'8OrLater = False -#endif - -------------------------------------------------------------------------------- --- Manually quoted names -------------------------------------------------------------------------------- - --- By manually generating these names we avoid needing to use the --- TemplateHaskell language extension when compiling the deriving-compat library. --- This allows the library to be used in stage1 cross-compilers. - -derivingCompatPackageKey :: String -#ifdef CURRENT_PACKAGE_KEY -derivingCompatPackageKey = CURRENT_PACKAGE_KEY -#else -derivingCompatPackageKey = "deriving-compat-" ++ showVersion version -#endif - -gHC_IX :: String -#if MIN_VERSION_base(4,14,0) -gHC_IX = "GHC.Ix" -#else -gHC_IX = "GHC.Arr" -#endif - -mkDerivingCompatName_v :: String -> Name -mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" - -mkDerivingCompatName_tc :: String -> Name -mkDerivingCompatName_tc = mkNameG_tc derivingCompatPackageKey "Data.Deriving.Internal" - -isTrueHashValName :: Name -isTrueHashValName = mkDerivingCompatName_v "isTrue#" - -fmapConstValName :: Name -fmapConstValName = mkDerivingCompatName_v "fmapConst" - -replaceConstValName :: Name -replaceConstValName = mkDerivingCompatName_v "replaceConst" - -foldrConstValName :: Name -foldrConstValName = mkDerivingCompatName_v "foldrConst" - -foldMapConstValName :: Name -foldMapConstValName = mkDerivingCompatName_v "foldMapConst" - -nullConstValName :: Name -nullConstValName = mkDerivingCompatName_v "nullConst" - -traverseConstValName :: Name -traverseConstValName = mkDerivingCompatName_v "traverseConst" - -eqConstValName :: Name -eqConstValName = mkDerivingCompatName_v "eqConst" - -eq1ConstValName :: Name -eq1ConstValName = mkDerivingCompatName_v "eq1Const" - -liftEqConstValName :: Name -liftEqConstValName = mkDerivingCompatName_v "liftEqConst" - -liftEq2ConstValName :: Name -liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const" - -compareConstValName :: Name -compareConstValName = mkDerivingCompatName_v "compareConst" - -ltConstValName :: Name -ltConstValName = mkDerivingCompatName_v "ltConst" - -compare1ConstValName :: Name -compare1ConstValName = mkDerivingCompatName_v "compare1Const" - -liftCompareConstValName :: Name -liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst" - -liftCompare2ConstValName :: Name -liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const" - -readsPrecConstValName :: Name -readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst" - -readPrecConstValName :: Name -readPrecConstValName = mkDerivingCompatName_v "readPrecConst" - -readsPrec1ConstValName :: Name -readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const" - -liftReadsPrecConstValName :: Name -liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst" - -liftReadPrecConstValName :: Name -liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst" - -liftReadsPrec2ConstValName :: Name -liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const" - -liftReadPrec2ConstValName :: Name -liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const" - -showsPrecConstValName :: Name -showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst" - -showsPrec1ConstValName :: Name -showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const" - -liftShowsPrecConstValName :: Name -liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst" - -liftShowsPrec2ConstValName :: Name -liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" - -viaTypeName :: Name -viaTypeName = mkDerivingCompatName_tc "Via" - -cHashDataName :: Name -cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" - -dHashDataName :: Name -dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#" - -fHashDataName :: Name -fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#" - -identDataName :: Name -identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident" - -iHashDataName :: Name -iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#" - -puncDataName :: Name -puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc" - -symbolDataName :: Name -symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol" - -wrapMonadDataName :: Name -wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" - -addrHashTypeName :: Name -addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#" - -boundedTypeName :: Name -boundedTypeName = mkNameG_tc "base" "GHC.Enum" "Bounded" - -charHashTypeName :: Name -charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#" - -doubleHashTypeName :: Name -doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#" - -enumTypeName :: Name -enumTypeName = mkNameG_tc "base" "GHC.Enum" "Enum" - -floatHashTypeName :: Name -floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#" - -foldableTypeName :: Name -foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" - -functorTypeName :: Name -functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" - -intTypeName :: Name -intTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Int" - -intHashTypeName :: Name -intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#" - -ixTypeName :: Name -ixTypeName = mkNameG_tc "base" gHC_IX "Ix" - -readTypeName :: Name -readTypeName = mkNameG_tc "base" "GHC.Read" "Read" - -showTypeName :: Name -showTypeName = mkNameG_tc "base" "GHC.Show" "Show" - -traversableTypeName :: Name -traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" - -wordHashTypeName :: Name -wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#" - -altValName :: Name -altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++" - -appendValName :: Name -appendValName = mkNameG_v "base" "GHC.Base" "++" - -chooseValName :: Name -chooseValName = mkNameG_v "base" "GHC.Read" "choose" - -coerceValName :: Name -coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" - -composeValName :: Name -composeValName = mkNameG_v "base" "GHC.Base" "." - -constValName :: Name -constValName = mkNameG_v "base" "GHC.Base" "const" - -enumFromValName :: Name -enumFromValName = mkNameG_v "base" "GHC.Enum" "enumFrom" - -enumFromThenValName :: Name -enumFromThenValName = mkNameG_v "base" "GHC.Enum" "enumFromThen" - -enumFromThenToValName :: Name -enumFromThenToValName = mkNameG_v "base" "GHC.Enum" "enumFromThenTo" - -enumFromToValName :: Name -enumFromToValName = mkNameG_v "base" "GHC.Enum" "enumFromTo" - -eqAddrHashValName :: Name -eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#" - -eqCharHashValName :: Name -eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#" - -eqDoubleHashValName :: Name -eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##" - -eqFloatHashValName :: Name -eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#" - -eqIntHashValName :: Name -eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#" - -eqWordHashValName :: Name -eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#" - -errorValName :: Name -errorValName = mkNameG_v "base" "GHC.Err" "error" - -flipValName :: Name -flipValName = mkNameG_v "base" "GHC.Base" "flip" - -fmapValName :: Name -fmapValName = mkNameG_v "base" "GHC.Base" "fmap" - -foldrValName :: Name -foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" - -foldMapValName :: Name -foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" - -fromEnumValName :: Name -fromEnumValName = mkNameG_v "base" "GHC.Enum" "fromEnum" - -geAddrHashValName :: Name -geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#" - -geCharHashValName :: Name -geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#" - -geDoubleHashValName :: Name -geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##" - -geFloatHashValName :: Name -geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#" - -geIntHashValName :: Name -geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#" - -getTagValName :: Name -getTagValName = mkNameG_v "base" "GHC.Base" "getTag" - -geWordHashValName :: Name -geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#" - -gtAddrHashValName :: Name -gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#" - -gtCharHashValName :: Name -gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#" - -gtDoubleHashValName :: Name -gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##" - -gtFloatHashValName :: Name -gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#" - -gtIntHashValName :: Name -gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#" - -gtWordHashValName :: Name -gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#" - -idValName :: Name -idValName = mkNameG_v "base" "GHC.Base" "id" - -indexValName :: Name -indexValName = mkNameG_v "base" gHC_IX "index" - -inRangeValName :: Name -inRangeValName = mkNameG_v "base" gHC_IX "inRange" - -leAddrHashValName :: Name -leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#" - -leCharHashValName :: Name -leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#" - -leDoubleHashValName :: Name -leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##" - -leFloatHashValName :: Name -leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#" - -leIntHashValName :: Name -leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#" - -leWordHashValName :: Name -leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#" - -liftReadListPrecDefaultValName :: Name -liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault" - -liftReadListPrec2DefaultValName :: Name -liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default" - -liftReadListPrecValName :: Name -liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec" - -liftReadListPrec2ValName :: Name -liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2" - -liftReadPrecValName :: Name -liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec" - -liftReadPrec2ValName :: Name -liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2" - -listValName :: Name -listValName = mkNameG_v "base" "GHC.Read" "list" - -ltAddrHashValName :: Name -ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#" - -ltCharHashValName :: Name -ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#" - -ltDoubleHashValName :: Name -ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##" - -ltFloatHashValName :: Name -ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#" - -ltIntHashValName :: Name -ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#" - -ltWordHashValName :: Name -ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#" - -minBoundValName :: Name -minBoundValName = mkNameG_v "base" "GHC.Enum" "minBound" - -mapValName :: Name -mapValName = mkNameG_v "base" "GHC.Base" "map" - -maxBoundValName :: Name -maxBoundValName = mkNameG_v "base" "GHC.Enum" "maxBound" - -minusIntHashValName :: Name -minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#" - -neqIntHashValName :: Name -neqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "/=#" - -parenValName :: Name -parenValName = mkNameG_v "base" "GHC.Read" "paren" - -parensValName :: Name -parensValName = mkNameG_v "base" "GHC.Read" "parens" - -pfailValName :: Name -pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail" - -plusValName :: Name -plusValName = mkNameG_v "base" "GHC.Num" "+" - -precValName :: Name -precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec" - -predValName :: Name -predValName = mkNameG_v "base" "GHC.Enum" "pred" - -rangeSizeValName :: Name -rangeSizeValName = mkNameG_v "base" gHC_IX "rangeSize" - -rangeValName :: Name -rangeValName = mkNameG_v "base" gHC_IX "range" - -readFieldHash :: String -> ReadPrec a -> ReadPrec a -readFieldHash fieldName readVal = do - expectP (L.Ident fieldName) - expectP (L.Symbol "#") - expectP (L.Punc "=") - readVal -{-# NOINLINE readFieldHash #-} - -readFieldHashValName :: Name -readFieldHashValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readFieldHash" - -readListValName :: Name -readListValName = mkNameG_v "base" "GHC.Read" "readList" - -readListPrecDefaultValName :: Name -readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault" - -readListPrecValName :: Name -readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec" - -readPrec_to_SValName :: Name -readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S" - -readPrecValName :: Name -readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec" - -readS_to_PrecValName :: Name -readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec" - -readsPrecValName :: Name -readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec" - -replaceValName :: Name -replaceValName = mkNameG_v "base" "GHC.Base" "<$" - -resetValName :: Name -resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset" - -returnValName :: Name -returnValName = mkNameG_v "base" "GHC.Base" "return" - -seqValName :: Name -seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" - -showCharValName :: Name -showCharValName = mkNameG_v "base" "GHC.Show" "showChar" - -showListValName :: Name -showListValName = mkNameG_v "base" "GHC.Show" "showList" - -showListWithValName :: Name -showListWithValName = mkNameG_v "base" "Text.Show" "showListWith" - -showParenValName :: Name -showParenValName = mkNameG_v "base" "GHC.Show" "showParen" - -showsPrecValName :: Name -showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec" - -showSpaceValName :: Name -showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace" - -showStringValName :: Name -showStringValName = mkNameG_v "base" "GHC.Show" "showString" - -stepValName :: Name -stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step" - -succValName :: Name -succValName = mkNameG_v "base" "GHC.Enum" "succ" - -tagToEnumHashValName :: Name -tagToEnumHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#" - -timesValName :: Name -timesValName = mkNameG_v "base" "GHC.Num" "*" - -toEnumValName :: Name -toEnumValName = mkNameG_v "base" "GHC.Enum" "toEnum" - -traverseValName :: Name -traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" - -unsafeIndexValName :: Name -unsafeIndexValName = mkNameG_v "base" gHC_IX "unsafeIndex" - -unsafeRangeSizeValName :: Name -unsafeRangeSizeValName = mkNameG_v "base" gHC_IX "unsafeRangeSize" - -unwrapMonadValName :: Name -unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" - -#if MIN_VERSION_base(4,4,0) -boolTypeName :: Name -boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool" - -falseDataName :: Name -falseDataName = mkNameG_d "ghc-prim" "GHC.Types" "False" - -trueDataName :: Name -trueDataName = mkNameG_d "ghc-prim" "GHC.Types" "True" -#else -boolTypeName :: Name -boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool" - -falseDataName :: Name -falseDataName = mkNameG_d "ghc-prim" "GHC.Bool" "False" - -trueDataName :: Name -trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True" -#endif - -#if MIN_VERSION_base(4,5,0) -eqDataName :: Name -eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ" - -gtDataName :: Name -gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT" - -ltDataName :: Name -ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT" - -eqTypeName :: Name -eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq" - -ordTypeName :: Name -ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord" - -andValName :: Name -andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&" - -compareValName :: Name -compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare" - -eqValName :: Name -eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "==" - -geValName :: Name -geValName = mkNameG_v "ghc-prim" "GHC.Classes" ">=" - -gtValName :: Name -gtValName = mkNameG_v "ghc-prim" "GHC.Classes" ">" - -leValName :: Name -leValName = mkNameG_v "ghc-prim" "GHC.Classes" "<=" - -ltValName :: Name -ltValName = mkNameG_v "ghc-prim" "GHC.Classes" "<" - -notValName :: Name -notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not" -#else -eqDataName :: Name -eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ" - -gtDataName :: Name -gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT" - -ltDataName :: Name -ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT" - -eqTypeName :: Name -eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq" - -ordTypeName :: Name -ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord" - -andValName :: Name -andValName = mkNameG_v "base" "GHC.Classes" "&&" - -compareValName :: Name -compareValName = mkNameG_v "base" "GHC.Classes" "compare" - -eqValName :: Name -eqValName = mkNameG_v "base" "GHC.Classes" "==" - -geValName :: Name -geValName = mkNameG_v "base" "GHC.Classes" ">=" - -gtValName :: Name -gtValName = mkNameG_v "base" "GHC.Classes" ">" - -leValName :: Name -leValName = mkNameG_v "base" "GHC.Classes" "<=" - -ltValName :: Name -ltValName = mkNameG_v "base" "GHC.Classes" "<" - -notValName :: Name -notValName = mkNameG_v "base" "GHC.Classes" "not" -#endif - -#if MIN_VERSION_base(4,6,0) -wHashDataName :: Name -wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#" -#else -wHashDataName :: Name -wHashDataName = mkNameG_d "base" "GHC.Word" "W#" -#endif - -#if MIN_VERSION_base(4,7,0) -expectPValName :: Name -expectPValName = mkNameG_v "base" "GHC.Read" "expectP" -#else -expectP :: Lexeme -> ReadPrec () -expectP lexeme = do - thing <- lexP - if thing == lexeme then return () else pfail - -expectPValName :: Name -expectPValName = mkDerivingCompatName_v "expectP" -#endif - -#if MIN_VERSION_base(4,8,0) -allValName :: Name -allValName = mkNameG_v "base" "Data.Foldable" "all" - -apValName :: Name -apValName = mkNameG_v "base" "GHC.Base" "<*>" - -pureValName :: Name -pureValName = mkNameG_v "base" "GHC.Base" "pure" - -liftA2ValName :: Name -liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2" - -mappendValName :: Name -mappendValName = mkNameG_v "base" "GHC.Base" "mappend" - -memptyValName :: Name -memptyValName = mkNameG_v "base" "GHC.Base" "mempty" - -nullValName :: Name -nullValName = mkNameG_v "base" "Data.Foldable" "null" -#else -allValName :: Name -allValName = mkNameG_v "base" "GHC.List" "all" - -apValName :: Name -apValName = mkNameG_v "base" "Control.Applicative" "<*>" - -pureValName :: Name -pureValName = mkNameG_v "base" "Control.Applicative" "pure" - -liftA2ValName :: Name -liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2" - -mappendValName :: Name -mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" - -memptyValName :: Name -memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" - -nullValName :: Name -nullValName = mkNameG_v "base" "GHC.List" "null" -#endif - -#if MIN_VERSION_base(4,9,0) -eq1TypeName :: Name -eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1" - -eq2TypeName :: Name -eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2" - -liftEqValName :: Name -liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq" - -liftEq2ValName :: Name -liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2" - -ord1TypeName :: Name -ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1" - -ord2TypeName :: Name -ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2" - -liftCompareValName :: Name -liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare" - -liftCompare2ValName :: Name -liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2" - -read1TypeName :: Name -read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1" - -read2TypeName :: Name -read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2" - -liftReadsPrecValName :: Name -liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec" - -liftReadListValName :: Name -liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList" - -liftReadsPrec2ValName :: Name -liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2" - -liftReadList2ValName :: Name -liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2" - -show1TypeName :: Name -show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1" - -show2TypeName :: Name -show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2" - -liftShowListValName :: Name -liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList" - -liftShowsPrecValName :: Name -liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec" - -liftShowList2ValName :: Name -liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2" - -liftShowsPrec2ValName :: Name -liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2" -#else --- If Data.Functor.Classes isn't located in base, then sadly we can't refer to --- Names from that module without using -XTemplateHaskell. -# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) -eq1TypeName :: Name -eq1TypeName = ''Eq1 - -eq2TypeName :: Name -eq2TypeName = ''Eq2 - -liftEqValName :: Name -liftEqValName = 'liftEq - -liftEq2ValName :: Name -liftEq2ValName = 'liftEq2 - -ord1TypeName :: Name -ord1TypeName = ''Ord1 - -ord2TypeName :: Name -ord2TypeName = ''Ord2 - -liftCompareValName :: Name -liftCompareValName = 'liftCompare - -liftCompare2ValName :: Name -liftCompare2ValName = 'liftCompare2 - -read1TypeName :: Name -read1TypeName = ''Read1 - -read2TypeName :: Name -read2TypeName = ''Read2 - -liftReadsPrecValName :: Name -liftReadsPrecValName = 'liftReadsPrec - -liftReadListValName :: Name -liftReadListValName = 'liftReadList - -liftReadsPrec2ValName :: Name -liftReadsPrec2ValName = 'liftReadsPrec2 - -liftReadList2ValName :: Name -liftReadList2ValName = 'liftReadList2 - -show1TypeName :: Name -show1TypeName = ''Show1 - -show2TypeName :: Name -show2TypeName = ''Show2 - -liftShowListValName :: Name -liftShowListValName = 'liftShowList - -liftShowsPrecValName :: Name -liftShowsPrecValName = 'liftShowsPrec - -liftShowList2ValName :: Name -liftShowList2ValName = 'liftShowList2 - -liftShowsPrec2ValName :: Name -liftShowsPrec2ValName = 'liftShowsPrec2 -# else -eq1TypeName :: Name -eq1TypeName = ''Eq1 - -eq1ValName :: Name -eq1ValName = 'eq1 - -ord1TypeName :: Name -ord1TypeName = ''Ord1 - -compare1ValName :: Name -compare1ValName = 'compare1 - -read1TypeName :: Name -read1TypeName = ''Read1 - -readsPrec1ValName :: Name -readsPrec1ValName = 'readsPrec1 - -show1TypeName :: Name -show1TypeName = ''Show1 - -showsPrec1ValName :: Name -showsPrec1ValName = 'showsPrec1 - -newtype Apply f a = Apply { unApply :: f a } - -instance (Eq1 f, Eq a) => Eq (Apply f a) where - Apply x == Apply y = eq1 x y - -instance (Ord1 g, Ord a) => Ord (Apply g a) where - compare (Apply x) (Apply y) = compare1 x y - -instance (Read1 f, Read a) => Read (Apply f a) where - readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s] - -instance (Show1 f, Show a) => Show (Apply f a) where - showsPrec p (Apply x) = showsPrec1 p x - -makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp -makeFmapApplyNeg = makeFmapApply False - -makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp -makeFmapApplyPos = makeFmapApply True - -makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp -makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name -makeFmapApply pos cRep conName t name = do - let tyCon :: Type - tyArgs :: [Type] - (tyCon, tyArgs) = unapplyTy t - - numLastArgs :: Int - numLastArgs = min (arity cRep) (length tyArgs) - - lhsArgs, rhsArgs :: [Type] - (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - - inspectTy :: Type -> Q Exp - inspectTy (SigT ty _) = inspectTy ty - inspectTy (VarT a) | a == name = varE idValName - inspectTy beta = varE fmapValName `appE` - infixApp (if pos then makeFmapApply pos cRep conName beta name - else conE applyDataName) - (varE composeValName) - (if pos then varE unApplyValName - else makeFmapApply pos cRep conName beta name) - - itf <- isInTypeFamilyApp [name] tyCon tyArgs - if any (`mentionsName` [name]) lhsArgs || itf - then outOfPlaceTyVarError cRep conName - else inspectTy (head rhsArgs) - -applyDataName :: Name -applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply" - -unApplyValName :: Name -unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply" -# endif -#endif - -#if MIN_VERSION_base(4,10,0) -showCommaSpaceValName :: Name -showCommaSpaceValName = mkNameG_v "base" "GHC.Show" "showCommaSpace" -#else -showCommaSpace :: ShowS -showCommaSpace = showString ", " - -showCommaSpaceValName :: Name -showCommaSpaceValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "showCommaSpace" -#endif - -#if MIN_VERSION_base(4,11,0) -appEndoValName :: Name -appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" - -dualDataName :: Name -dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" - -endoDataName :: Name -endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" - -getDualValName :: Name -getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" - -readFieldValName :: Name -readFieldValName = mkNameG_v "base" "GHC.Read" "readField" - -readSymFieldValName :: Name -readSymFieldValName = mkNameG_v "base" "GHC.Read" "readSymField" -#else -appEndoValName :: Name -appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" - -dualDataName :: Name -dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" - -endoDataName :: Name -endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" - -getDualValName :: Name -getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" - -readField :: String -> ReadPrec a -> ReadPrec a -readField fieldName readVal = do - expectP (L.Ident fieldName) - expectP (L.Punc "=") - readVal -{-# NOINLINE readField #-} - -readFieldValName :: Name -readFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readField" - -readSymField :: String -> ReadPrec a -> ReadPrec a -readSymField fieldName readVal = do - expectP (L.Punc "(") - expectP (L.Symbol fieldName) - expectP (L.Punc ")") - expectP (L.Punc "=") - readVal -{-# NOINLINE readSymField #-} - -readSymFieldValName :: Name -readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField" -#endif - -#if MIN_VERSION_base(4,13,0) -eqInt8HashValName :: Name -eqInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt8#" - -eqInt16HashValName :: Name -eqInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt16#" - -eqWord8HashValName :: Name -eqWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord8#" - -eqWord16HashValName :: Name -eqWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#" - -geInt8HashValName :: Name -geInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#" - -geInt16HashValName :: Name -geInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt16#" - -geWord8HashValName :: Name -geWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord8#" - -geWord16HashValName :: Name -geWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord16#" - -gtInt8HashValName :: Name -gtInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt8#" - -gtInt16HashValName :: Name -gtInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt16#" - -gtWord8HashValName :: Name -gtWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord8#" - -gtWord16HashValName :: Name -gtWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord16#" - -int8HashTypeName :: Name -int8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#" - -int8ToIntHashValName :: Name -int8ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "int8ToInt#" -# else - "extendInt8#" -# endif - -int16HashTypeName :: Name -int16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#" - -int16ToIntHashValName :: Name -int16ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "int16ToInt#" -# else - "extendInt16#" -# endif - -intToInt8HashValName :: Name -intToInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "intToInt8#" -# else - "narrowInt8#" -# endif - -intToInt16HashValName :: Name -intToInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "intToInt16#" -# else - "narrowInt16#" -# endif - -leInt8HashValName :: Name -leInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#" - -leInt16HashValName :: Name -leInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt16#" - -leWord8HashValName :: Name -leWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord8#" - -leWord16HashValName :: Name -leWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord16#" - -ltInt8HashValName :: Name -ltInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt8#" - -ltInt16HashValName :: Name -ltInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt16#" - -ltWord8HashValName :: Name -ltWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord8#" - -ltWord16HashValName :: Name -ltWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord16#" - -word8HashTypeName :: Name -word8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#" - -word8ToWordHashValName :: Name -word8ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "word8ToWord#" -# else - "extendWord8#" -# endif - -word16HashTypeName :: Name -word16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#" - -word16ToWordHashValName :: Name -word16ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "word16ToWord#" -# else - "extendWord16#" -# endif - -wordToWord8HashValName :: Name -wordToWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "wordToWord8#" -# else - "narrowWord8#" -# endif - -wordToWord16HashValName :: Name -wordToWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" -# if MIN_VERSION_base(4,16,0) - "wordToWord16#" -# else - "narrowWord16#" -# endif -#endif - -#if MIN_VERSION_base(4,16,0) -eqInt32HashValName :: Name -eqInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt32#" - -eqWord32HashValName :: Name -eqWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord32#" - -geInt32HashValName :: Name -geInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt32#" - -geWord32HashValName :: Name -geWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord32#" - -gtInt32HashValName :: Name -gtInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt32#" - -gtWord32HashValName :: Name -gtWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord32#" - -int32HashTypeName :: Name -int32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int32#" - -int32ToIntHashValName :: Name -int32ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "int32ToInt#" - -intToInt32HashValName :: Name -intToInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "intToInt32#" - -leInt32HashValName :: Name -leInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt32#" - -leWord32HashValName :: Name -leWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord32#" - -ltInt32HashValName :: Name -ltInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt32#" - -ltWord32HashValName :: Name -ltWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord32#" - -word32HashTypeName :: Name -word32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word32#" - -word32ToWordHashValName :: Name -word32ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "word32ToWord#" - -wordToWord32HashValName :: Name -wordToWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "wordToWord32#" -#endif +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} + +#if !(MIN_VERSION_base(4,9,0)) +# if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +# else +{-# LANGUAGE TemplateHaskell #-} +# endif +#endif + +{-| +Module: Data.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Template Haskell-related utilities. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Deriving.Internal where + +import Control.Applicative (liftA2) +import Control.Monad (when, unless) + +import Data.Foldable (foldr') +#if !(MIN_VERSION_base(4,9,0)) +import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) +# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..)) +# endif +#endif +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Traversable as T + +import Text.ParserCombinators.ReadPrec (ReadPrec) +import qualified Text.Read.Lex as L + +#if MIN_VERSION_base(4,7,0) +import GHC.Read (expectP) +#else +import GHC.Read (lexP) + +import Text.Read (pfail) +import Text.Read.Lex (Lexeme) +#endif + +#if MIN_VERSION_ghc_prim(0,3,1) +import GHC.Prim (Int#, tagToEnum#) +#endif + +#if defined(MIN_VERSION_ghc_boot_th) +import GHC.Lexeme (startsConSym, startsVarSym) +#else +import Data.Char (isSymbol, ord) +#endif + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr (pprint) +import Language.Haskell.TH.Syntax + +-- Ensure, beyond a shadow of a doubt, that the instances are in-scope +import Data.Functor () +import Data.Functor.Classes () +import Data.Foldable () +import Data.Traversable () + +#ifndef CURRENT_PACKAGE_KEY +import Data.Version (showVersion) +import Paths_deriving_compat (version) +#endif + +------------------------------------------------------------------------------- +-- Expanding type synonyms +------------------------------------------------------------------------------- + +applySubstitutionKind :: Map Name Kind -> Type -> Type +#if MIN_VERSION_template_haskell(2,8,0) +applySubstitutionKind = applySubstitution +#else +applySubstitutionKind _ t = t +#endif + +substNameWithKind :: Name -> Kind -> Type -> Type +substNameWithKind n k = applySubstitutionKind (Map.singleton n k) + +substNamesWithKindStar :: [Name] -> Type -> Type +substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns + +------------------------------------------------------------------------------- +-- Via +------------------------------------------------------------------------------- + +-- | A type-level modifier intended to be used in conjunction with 'deriveVia'. +-- Refer to the documentation for 'deriveVia' for more details. +data a `Via` b +infix 0 `Via` + +------------------------------------------------------------------------------- +-- Type-specialized const functions +------------------------------------------------------------------------------- + +fmapConst :: f b -> (a -> b) -> f a -> f b +fmapConst x _ _ = x +{-# INLINE fmapConst #-} + +replaceConst :: f a -> a -> f b -> f a +replaceConst x _ _ = x +{-# INLINE replaceConst #-} + +foldrConst :: b -> (a -> b -> b) -> b -> t a -> b +foldrConst x _ _ _ = x +{-# INLINE foldrConst #-} + +foldMapConst :: m -> (a -> m) -> t a -> m +foldMapConst x _ _ = x +{-# INLINE foldMapConst #-} + +nullConst :: Bool -> t a -> Bool +nullConst x _ = x +{-# INLINE nullConst #-} + +traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b) +traverseConst x _ _ = x +{-# INLINE traverseConst #-} + +eqConst :: Bool + -> a -> a -> Bool +eqConst x _ _ = x +{-# INLINE eqConst #-} + +eq1Const :: Bool + -> f a -> f a-> Bool +eq1Const x _ _ = x +{-# INLINE eq1Const #-} + +liftEqConst :: Bool + -> (a -> b -> Bool) -> f a -> f b -> Bool +liftEqConst x _ _ _ = x +{-# INLINE liftEqConst #-} + +liftEq2Const :: Bool + -> (a -> b -> Bool) -> (c -> d -> Bool) + -> f a c -> f b d -> Bool +liftEq2Const x _ _ _ _ = x +{-# INLINE liftEq2Const #-} + +compareConst :: Ordering -> a -> a -> Ordering +compareConst x _ _ = x +{-# INLINE compareConst #-} + +ltConst :: Bool -> a -> a -> Bool +ltConst x _ _ = x +{-# INLINE ltConst #-} + +compare1Const :: Ordering -> f a -> f a -> Ordering +compare1Const x _ _ = x +{-# INLINE compare1Const #-} + +liftCompareConst :: Ordering + -> (a -> b -> Ordering) -> f a -> f b -> Ordering +liftCompareConst x _ _ _ = x +{-# INLINE liftCompareConst #-} + +liftCompare2Const :: Ordering + -> (a -> b -> Ordering) -> (c -> d -> Ordering) + -> f a c -> f b d -> Ordering +liftCompare2Const x _ _ _ _ = x +{-# INLINE liftCompare2Const #-} + +readsPrecConst :: ReadS a -> Int -> ReadS a +readsPrecConst x _ = x +{-# INLINE readsPrecConst #-} + +-- This isn't really necessary, but it makes for an easier implementation +readPrecConst :: ReadPrec a -> ReadPrec a +readPrecConst x = x +{-# INLINE readPrecConst #-} + +readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a) +readsPrec1Const x _ = x +{-# INLINE readsPrec1Const #-} + +liftReadsPrecConst :: ReadS (f a) + -> (Int -> ReadS a) -> ReadS [a] + -> Int -> ReadS (f a) +liftReadsPrecConst x _ _ _ = x +{-# INLINE liftReadsPrecConst #-} + +liftReadPrecConst :: ReadPrec (f a) + -> ReadPrec a -> ReadPrec [a] + -> ReadPrec (f a) +liftReadPrecConst x _ _ = x +{-# INLINE liftReadPrecConst #-} + +liftReadsPrec2Const :: ReadS (f a b) + -> (Int -> ReadS a) -> ReadS [a] + -> (Int -> ReadS b) -> ReadS [b] + -> Int -> ReadS (f a b) +liftReadsPrec2Const x _ _ _ _ _ = x +{-# INLINE liftReadsPrec2Const #-} + +liftReadPrec2Const :: ReadPrec (f a b) + -> ReadPrec a -> ReadPrec [a] + -> ReadPrec b -> ReadPrec [b] + -> ReadPrec (f a b) +liftReadPrec2Const x _ _ _ _ = x +{-# INLINE liftReadPrec2Const #-} + +showsPrecConst :: ShowS + -> Int -> a -> ShowS +showsPrecConst x _ _ = x +{-# INLINE showsPrecConst #-} + +showsPrec1Const :: ShowS + -> Int -> f a -> ShowS +showsPrec1Const x _ _ = x +{-# INLINE showsPrec1Const #-} + +liftShowsPrecConst :: ShowS + -> (Int -> a -> ShowS) -> ([a] -> ShowS) + -> Int -> f a -> ShowS +liftShowsPrecConst x _ _ _ _ = x +{-# INLINE liftShowsPrecConst #-} + +liftShowsPrec2Const :: ShowS + -> (Int -> a -> ShowS) -> ([a] -> ShowS) + -> (Int -> b -> ShowS) -> ([b] -> ShowS) + -> Int -> f a b -> ShowS +liftShowsPrec2Const x _ _ _ _ _ _ = x +{-# INLINE liftShowsPrec2Const #-} + +------------------------------------------------------------------------------- +-- StarKindStatus +------------------------------------------------------------------------------- + +-- | Whether a type is not of kind *, is of kind *, or is a kind variable. +data StarKindStatus = NotKindStar + | KindStar + | IsKindVar Name + deriving Eq + +-- | Does a Type have kind * or k (for some kind variable k)? +canRealizeKindStar :: Type -> StarKindStatus +canRealizeKindStar t + | hasKindStar t = KindStar + | otherwise = case t of +#if MIN_VERSION_template_haskell(2,8,0) + SigT _ (VarT k) -> IsKindVar k +#endif + _ -> NotKindStar + +-- | 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 + +------------------------------------------------------------------------------- +-- ClassRep +------------------------------------------------------------------------------- + +class ClassRep a where + arity :: a -> Int + allowExQuant :: a -> Bool + fullClassName :: a -> Name + classConstraint :: a -> Int -> Maybe Name + +------------------------------------------------------------------------------- +-- Template Haskell reifying and AST manipulation +------------------------------------------------------------------------------- + +-- For the given Types, generate an instance context and head. 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 :: ClassRep a + => a + -- ^ The typeclass for which an instance should be derived + -> Name + -- ^ The type constructor or data family name + -> Cxt + -- ^ The datatype context + -> [Type] + -- ^ The types to instantiate the instance with + -> DatatypeVariant + -- ^ Are we dealing with a data family instance or not + -> Q (Cxt, Type) +buildTypeInstance cRep tyConName dataCxt varTysOrig variant = 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 - arity cRep + + droppedTysExp :: [Type] + droppedTysExp = drop remainingLength varTysExp + + droppedStarKindStati :: [StarKindStatus] + droppedStarKindStati = map canRealizeKindStar droppedTysExp + + -- Check there are enough types to drop and that all of them are either of + -- kind * or kind k (for some kind variable k). If not, throw an error. + when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ + derivingKindError cRep tyConName + + let droppedKindVarNames :: [Name] + droppedKindVarNames = catKindVarNames droppedStarKindStati + + -- Substitute kind * for any dropped kind variables + varTysExpSubst :: [Type] + varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp + + remainingTysExpSubst, droppedTysExpSubst :: [Type] + (remainingTysExpSubst, droppedTysExpSubst) = + splitAt remainingLength varTysExpSubst + + -- All of the type variables mentioned in the dropped types + -- (post-synonym expansion) + droppedTyVarNames :: [Name] + droppedTyVarNames = freeVariables droppedTysExpSubst + + -- If any of the dropped types were polykinded, ensure that they are of kind * + -- after substituting * for the dropped kind variables. If not, throw an error. + unless (all hasKindStar droppedTysExpSubst) $ + derivingKindError cRep tyConName + + let preds :: [Maybe Pred] + kvNames :: [[Name]] + kvNames' :: [Name] + -- Derive instance constraints (and any kind variables which are specialized + -- to * in those constraints) + (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst + kvNames' = concat kvNames + + -- Substitute the kind variables specialized in the constraints with * + remainingTysExpSubst' :: [Type] + remainingTysExpSubst' = + map (substNamesWithKindStar kvNames') remainingTysExpSubst + + -- 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]) + remainingTysOrigSubst :: [Type] + remainingTysOrigSubst = + map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) + $ take remainingLength varTysOrig + + isDataFamily :: Bool + isDataFamily = case variant of + Datatype -> False + Newtype -> False + DataInstance -> True + NewtypeInstance -> True + + remainingTysOrigSubst' :: [Type] + -- See Note [Kind signatures in derived instances] for an explanation + -- of the isDataFamily check. + remainingTysOrigSubst' = + if isDataFamily + then remainingTysOrigSubst + else map unSigT remainingTysOrigSubst + + instanceCxt :: Cxt + instanceCxt = catMaybes preds + + instanceType :: Type + instanceType = AppT (ConT (fullClassName cRep)) + $ applyTyCon tyConName remainingTysOrigSubst' + + -- If the datatype context mentions any of the dropped type variables, + -- we can't derive an instance, so throw an error. + when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ + datatypeContextError tyConName instanceType + -- Also ensure the dropped types can be safely eta-reduced. Otherwise, + -- throw an error. + unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ + etaReductionError instanceType + return (instanceCxt, instanceType) + +-- | Attempt to derive a constraint on a Type. If successful, return +-- Just the constraint and any kind variable names constrained to *. +-- Otherwise, return Nothing and the empty list. +-- +-- See Note [Type inference in derived instances] for the heuristics used to +-- come up with constraints. +deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name]) +deriveConstraint cRep t + | not (isTyVar t) = (Nothing, []) + | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, []) + | otherwise = case hasKindVarChain 1 t of + Just ns | cRepArity >= 1 + -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns) + _ -> case hasKindVarChain 2 t of + Just ns | cRepArity == 2 + -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns) + _ -> (Nothing, []) + where + tName :: Name + tName = varTToName t + + cRepArity :: Int + cRepArity = arity cRep + +{- +Note [Kind signatures in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to put explicit kind signatures into the derived instances, e.g., + + instance C a => C (Data (f :: * -> *)) where ... + +But it is preferable to avoid this if possible. If we come up with an incorrect +kind signature (which is entirely possible, since our type inferencer is pretty +unsophisticated - see Note [Type inference in derived instances]), then GHC will +flat-out reject the instance, which is quite unfortunate. + +Plain old datatypes have the advantage that you can avoid using any kind signatures +at all in their instances. This is because a datatype declaration uses all type +variables, so the types that we use in a derived instance uniquely determine their +kinds. As long as we plug in the right types, the kind inferencer can do the rest +of the work. For this reason, we use unSigT to remove all kind signatures before +splicing in the instance context and head. + +Data family instances are trickier, since a data family can have two instances that +are distinguished by kind alone, e.g., + + data family Fam (a :: k) + data instance Fam (a :: * -> *) + data instance Fam (a :: *) + +If we dropped the kind signatures for C (Fam a), then GHC will have no way of +knowing which instance we are talking about. To avoid this scenario, we always +include explicit kind signatures in data family instances. There is a chance that +the inferred kind signatures will be incorrect, but if so, we can always fall back +on the make- functions. + +Note [Type inference in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Type inference is can be tricky to get right, and we want to avoid recreating the +entirety of GHC's type inferencer in Template Haskell. For this reason, we will +probably never come up with derived instance contexts that are as accurate as +GHC's. But that doesn't mean we can't do anything! There are a couple of simple +things we can do to make instance contexts that work for 80% of use cases: + +1. If one of the last type parameters is polykinded, then its kind will be + specialized to * in the derived instance. We note what kind variable the type + parameter had and substitute it with * in the other types as well. For example, + imagine you had + + data Data (a :: k) (b :: k) + + Then you'd want to derived instance to be: + + instance C (Data (a :: *)) + + Not: + + instance C (Data (a :: k)) + +2. We naïvely come up with instance constraints using the following criteria, using + Show(1)(2) as the example typeclasses: + + (i) If there's a type parameter n of kind *, generate a Show n constraint. + (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind + variables), then generate a Show1 n constraint, and if k1/k2 are kind + variables, then substitute k1/k2 with * elsewhere in the types. We must + consider the case where they are kind variables because you might have a + scenario like this: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) + = Compose (f (g a)) + + Which would have a derived Show1 instance of: + + instance (Show1 f, Show1 g) => Show1 (Compose f g) where ... + (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are + * or kind variables), then generate a Show2 constraint and perform + kind substitution as in the other cases. +-} + +checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name + -> Q c -> Q c +checkExistentialContext cRep tvMap ctxt conName q = + if (any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < arity cRep) + && not (allowExQuant cRep) + then existentialContextError conName + else q + +{- +Note [Matching functions with GADT type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When deriving category-2 classes like Show2, there is a tricky corner case to consider: + + data Both a b where + BothCon :: x -> x -> Both x x + +Which show functions should be applied to which arguments of BothCon? We have a +choice, since both the function of type (Int -> a -> ShowS) and of type +(Int -> b -> ShowS) can be applied to either argument. In such a scenario, the +second show function takes precedence over the first show function, so the +derived Show2 instance would be: + + instance Show2 Both where + liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) = + showsParen (p > appPrec) $ + showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2 + +This is not an arbitrary choice, as this definition ensures that +liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for +Both. +-} + +------------------------------------------------------------------------------- +-- Error messages +------------------------------------------------------------------------------- + +-- | The given datatype has no constructors, and we don't know what to do with it. +noConstructorsError :: Q a +noConstructorsError = fail "Must have at least one data constructor" + +-- | 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 :: ClassRep a => a -> Name -> Q b +derivingKindError cRep tyConName = fail + . showString "Cannot derive well-kinded instance of form ‘" + . showString className + . showChar ' ' + . showParen True + ( showString (nameBase tyConName) + . showString " ..." + ) + . showString "‘\n\tClass " + . showString className + . showString " expects an argument of kind " + . showString (pprint . createKindChain $ arity cRep) + $ "" + where + className :: String + className = nameBase $ fullClassName cRep + +-- | The last type variable appeared in a contravariant position +-- when deriving Functor. +contravarianceError :: Name -> Q a +contravarianceError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not use the last type variable in a function argument" + $ "" + +-- | A constructor has a function argument in a derived Foldable or Traversable +-- instance. +noFunctionsError :: Name -> Q a +noFunctionsError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not contain function types" + $ "" + +-- | 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 + +-- | The data type has a DatatypeContext which mentions one of the eta-reduced +-- type variables. +datatypeContextError :: Name -> Type -> Q a +datatypeContextError dataName instanceType = fail + . showString "Can't make a derived instance of ‘" + . showString (pprint instanceType) + . showString "‘:\n\tData type ‘" + . showString (nameBase dataName) + . showString "‘ must not have a class context involving the last type argument(s)" + $ "" + +-- | The data type has an existential constraint which mentions one of the +-- eta-reduced type variables. +existentialContextError :: Name -> Q a +existentialContextError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must be truly polymorphic in the last argument(s) of the data type" + $ "" + +-- | The data type mentions one of the n eta-reduced type variables in a place other +-- than the last nth positions of a data type in a constructor's field. +outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b +outOfPlaceTyVarError cRep conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must only use its last " + . shows n + . showString " type variable(s) within the last " + . shows n + . showString " argument(s) of a data type" + $ "" + where + n :: Int + n = arity cRep + +enumerationError :: String -> Q a +enumerationError = fail . enumerationErrorStr + +enumerationOrProductError :: String -> Q a +enumerationOrProductError nb = fail $ unlines + [ enumerationErrorStr nb + , "\tor a product type (precisely one constructor)" + ] + +enumerationErrorStr :: String -> String +enumerationErrorStr nb = + '\'':nb ++ "’ must be an enumeration type" + ++ " (one or more nullary, non-GADT constructors)" + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +-- | A mapping of type variable Names to their auxiliary function Names. +type TyVarMap a = Map Name (OneOrTwoNames a) +type TyVarMap1 = TyVarMap One +type TyVarMap2 = TyVarMap Two + +data OneOrTwoNames a where + OneName :: Name -> OneOrTwoNames One + TwoNames :: Name -> Name -> OneOrTwoNames Two + +data One +data Two + +interleave :: [a] -> [a] -> [a] +interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s +interleave _ _ = [] + +#if MIN_VERSION_ghc_prim(0,3,1) +isTrue# :: Int# -> Bool +isTrue# x = tagToEnum# x +#else +isTrue# :: Bool -> Bool +isTrue# x = x +#endif +{-# INLINE isTrue# #-} + +-- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +-- | 'filterByLists' takes a list of Bools and two lists as input, and +-- outputs a new list consisting of elements from the last two input lists. For +-- each Bool in the list, if it is 'True', then it takes an element from the +-- former list. If it is 'False', it takes an element from the latter list. +-- The elements taken correspond to the index of the Bool in its list. +-- For example: +-- +-- @ +-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" +-- @ +-- +-- This function does not check whether the lists have equal length. +filterByLists :: [Bool] -> [a] -> [a] -> [a] +filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys +filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys +filterByLists _ _ _ = [] + +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + +integerE :: Int -> Q Exp +integerE = litE . integerL . fromIntegral + +-- | Returns True if a Type has kind *. +hasKindStar :: Type -> Bool +hasKindStar VarT{} = True +#if MIN_VERSION_template_haskell(2,8,0) +hasKindStar (SigT _ StarT) = True +#else +hasKindStar (SigT _ StarK) = True +#endif +hasKindStar _ = False + +-- Returns True is a kind is equal to *, or if it is a kind variable. +isStarOrVar :: Kind -> Bool +#if MIN_VERSION_template_haskell(2,8,0) +isStarOrVar StarT = True +isStarOrVar VarT{} = True +#else +isStarOrVar StarK = True +#endif +isStarOrVar _ = False + +-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form +-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or +-- kind variables. +hasKindVarChain :: Int -> Type -> Maybe [Name] +hasKindVarChain kindArrows t = + let uk = uncurryKind (tyKind t) + in if (length uk - 1 == kindArrows) && all isStarOrVar uk + then Just (freeVariables uk) + else Nothing + +-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. +tyKind :: Type -> Kind +tyKind (SigT _ k) = k +tyKind _ = starK + +zipWithAndUnzipM :: Monad m + => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +zipWithAndUnzipM f (x:xs) (y:ys) = do + (c, d) <- f x y + (cs, ds) <- zipWithAndUnzipM f xs ys + return (c:cs, d:ds) +zipWithAndUnzipM _ _ _ = return ([], []) +{-# INLINE zipWithAndUnzipM #-} + +zipWith3AndUnzipM :: Monad m + => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] + -> m ([d], [e]) +zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do + (d, e) <- f x y z + (ds, es) <- zipWith3AndUnzipM f xs ys zs + return (d:ds, e:es) +zipWith3AndUnzipM _ _ _ _ = return ([], []) +{-# INLINE zipWith3AndUnzipM #-} + +thd3 :: (a, b, c) -> c +thd3 (_, _, c) = c + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = case unsnoc xs of + Nothing -> Just ([], x) + Just (a,b) -> Just (x:a, b) + +isNullaryCon :: ConstructorInfo -> Bool +isNullaryCon (ConstructorInfo { constructorFields = tys }) = null tys + +-- | Returns the number of fields for the constructor. +conArity :: ConstructorInfo -> Int +conArity (ConstructorInfo { constructorFields = tys }) = length tys + +-- | Returns 'True' if it's a datatype with exactly one, non-existential constructor. +isProductType :: [ConstructorInfo] -> Bool +isProductType [con] = null (constructorVars con) +isProductType _ = False + +-- | Returns 'True' if it's a datatype with one or more nullary, non-GADT +-- constructors. +isEnumerationType :: [ConstructorInfo] -> Bool +isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons +isEnumerationType _ = False + +-- | Returns 'False' if we're dealing with existential quantification or GADTs. +isVanillaCon :: ConstructorInfo -> Bool +isVanillaCon (ConstructorInfo { constructorContext = ctxt, constructorVars = vars }) = + null ctxt && null vars + +-- | 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] + +-- | Extracts the kind from a TyVarBndr. +tvbKind :: TyVarBndr_ flag -> Kind +tvbKind = elimTV (\_ -> starK) (\_ k -> k) + +-- | Convert a TyVarBndr to a Type. +tvbToType :: TyVarBndr_ flag -> Type +tvbToType = elimTV VarT (\n k -> SigT (VarT n) k) + +-- | Applies a typeclass constraint to a type. +applyClass :: Name -> Name -> Pred +#if MIN_VERSION_template_haskell(2,10,0) +applyClass con t = AppT (ConT con) (VarT t) +#else +applyClass con t = ClassP con [VarT t] +#endif + +createKindChain :: Int -> Kind +createKindChain = go starK + where + go :: Kind -> Int -> Kind + go k !0 = k +#if MIN_VERSION_template_haskell(2,8,0) + go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) +#else + go k !n = go (ArrowK StarK k) (n - 1) +#endif + +-- | 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 + && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type + -- didn't have an Ord instance until template-haskell-2.10.0.0 + && not (any (`mentionsName` droppedNames) remaining) + where + droppedNames :: [Name] + droppedNames = map varTToName dropped + +-- | Extract the Name from a type constructor. If the argument Type is not a +-- type variable, throw an error. +conTToName :: Type -> Name +conTToName (ConT n) = n +conTToName (SigT t _) = conTToName t +conTToName _ = error "Not a type constructor!" + +-- | Extract Just the Name from a type variable. If the argument Type is not a +-- type variable, return Nothing. +varTToName_maybe :: Type -> Maybe Name +varTToName_maybe (VarT n) = Just n +varTToName_maybe (SigT t _) = varTToName_maybe t +varTToName_maybe _ = Nothing + +-- | Extract the Name from a type variable. If the argument Type is not a +-- type variable, throw an error. +varTToName :: Type -> Name +varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe + +-- | Peel off a kind signature from a Type (if it has one). +unSigT :: Type -> Type +unSigT (SigT t _) = t +unSigT t = t + +-- | Is the given type a variable? +isTyVar :: Type -> Bool +isTyVar (VarT _) = True +isTyVar (SigT t _) = isTyVar t +isTyVar _ = False + +-- | Detect if a Name in a list of provided Names occurs as an argument to some +-- type family. This makes an effort to exclude /oversaturated/ arguments to +-- type families. For instance, if one declared the following type family: +-- +-- @ +-- type family F a :: Type -> Type +-- @ +-- +-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, +-- but not @b@. +isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool +isInTypeFamilyApp names tyFun tyArgs = + case tyFun of + ConT tcName -> go tcName + _ -> return False + where + go :: Name -> Q Bool + go tcName = do + info <- reify tcName + case info of +#if MIN_VERSION_template_haskell(2,11,0) + FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ + -> withinFirstArgs bndrs +#elif MIN_VERSION_template_haskell(2,7,0) + FamilyI (FamilyD TypeFam _ bndrs _) _ + -> withinFirstArgs bndrs +#else + TyConI (FamilyD TypeFam _ bndrs _) + -> withinFirstArgs bndrs +#endif + +#if MIN_VERSION_template_haskell(2,11,0) + FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ + -> withinFirstArgs bndrs +#elif MIN_VERSION_template_haskell(2,9,0) + FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ + -> withinFirstArgs bndrs +#endif + + _ -> return False + where + withinFirstArgs :: [a] -> Q Bool + withinFirstArgs bndrs = + let firstArgs = take (length bndrs) tyArgs + argFVs = freeVariables firstArgs + in return $ any (`elem` argFVs) names + +-- | 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 + +-- | Does the given type mention any of the Names in the list? +mentionsName :: Type -> [Name] -> Bool +mentionsName = go + where + go :: Type -> [Name] -> Bool + go (AppT t1 t2) names = go t1 names || go t2 names + go (SigT t _k) names = go t names +#if MIN_VERSION_template_haskell(2,8,0) + || go _k names +#endif + go (VarT n) names = n `elem` names + go _ _ = False + +-- | Does an instance predicate mention any of the Names in the list? +predMentionsName :: Pred -> [Name] -> Bool +#if MIN_VERSION_template_haskell(2,10,0) +predMentionsName = mentionsName +#else +predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys +predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names +#endif + +-- | Construct a type via curried application. +applyTy :: Type -> [Type] -> Type +applyTy = List.foldl' AppT + +-- | Fully applies a type constructor to its type variables. +applyTyCon :: Name -> [Type] -> Type +applyTyCon = applyTy . ConT + +-- | Split an applied type into its individual components. For example, this: +-- +-- @ +-- Either Int Char +-- @ +-- +-- would split to this: +-- +-- @ +-- [Either, Int, Char] +-- @ +unapplyTy :: Type -> (Type, [Type]) +unapplyTy ty = go ty ty [] + where + go :: Type -> Type -> [Type] -> (Type, [Type]) + go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) + go origTy (SigT ty' _) args = go origTy ty' args +#if MIN_VERSION_template_haskell(2,11,0) + go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args + go origTy (ParensT ty') args = go origTy ty' args +#endif + go origTy _ args = (origTy, args) + +-- | Split a type signature by the arrows on its spine. For example, this: +-- +-- @ +-- forall a b. (a ~ b) => (a -> b) -> Char -> () +-- @ +-- +-- would split to this: +-- +-- @ +-- (a ~ b, [a -> b, Char, ()]) +-- @ +uncurryTy :: Type -> (Cxt, [Type]) +uncurryTy (AppT (AppT ArrowT t1) t2) = + let (ctxt, tys) = uncurryTy t2 + in (ctxt, t1:tys) +uncurryTy (SigT t _) = uncurryTy t +uncurryTy (ForallT _ ctxt t) = + let (ctxt', tys) = uncurryTy t + in (ctxt ++ ctxt', tys) +uncurryTy t = ([], [t]) + + +-- | Like uncurryType, except on a kind level. +uncurryKind :: Kind -> [Kind] +#if MIN_VERSION_template_haskell(2,8,0) +uncurryKind = snd . uncurryTy +#else +uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 +uncurryKind k = [k] +#endif + +untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp +untagExpr [] e = e +untagExpr ((untagThis, putTagHere) : more) e = + caseE (varE getTagValName `appE` varE untagThis) + [match (varP putTagHere) + (normalB $ untagExpr more e) + []] + +tag2ConExpr :: Type -> Q Exp +tag2ConExpr ty = do + iHash <- newName "i#" + ty' <- freshenType ty + lam1E (conP iHashDataName [varP iHash]) $ + varE tagToEnumHashValName `appE` varE iHash + `sigE` return (quantifyType ty') + -- tagToEnum# is a hack, and won't typecheck unless it's in the + -- immediate presence of a type ascription like so: + -- + -- tagToEnum# x :: Foo + -- + -- We have to be careful when dealing with datatypes with type + -- variables, since Template Haskell might reject the type variables + -- we use for being out-of-scope. To avoid this, we explicitly + -- collect the type variable binders and shove them into a ForallT + -- (using th-abstraction's quantifyType function). Also make sure + -- to freshen the bound type variables to avoid shadowed variable + -- warnings on old versions of GHC when -Wall is enabled. + +primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name) +primOrdFunTbl = Map.fromList + [ (addrHashTypeName, ( ltAddrHashValName + , leAddrHashValName + , eqAddrHashValName + , geAddrHashValName + , gtAddrHashValName + )) + , (charHashTypeName, ( ltCharHashValName + , leCharHashValName + , eqCharHashValName + , geCharHashValName + , gtCharHashValName + )) + , (doubleHashTypeName, ( ltDoubleHashValName + , leDoubleHashValName + , eqDoubleHashValName + , geDoubleHashValName + , gtDoubleHashValName + )) + , (floatHashTypeName, ( ltFloatHashValName + , leFloatHashValName + , eqFloatHashValName + , geFloatHashValName + , gtFloatHashValName + )) + , (intHashTypeName, ( ltIntHashValName + , leIntHashValName + , eqIntHashValName + , geIntHashValName + , gtIntHashValName + )) + , (wordHashTypeName, ( ltWordHashValName + , leWordHashValName + , eqWordHashValName + , geWordHashValName + , gtWordHashValName + )) +#if MIN_VERSION_base(4,13,0) + , (int8HashTypeName, ( ltInt8HashValName + , leInt8HashValName + , eqInt8HashValName + , geInt8HashValName + , gtInt8HashValName + )) + , (int16HashTypeName, ( ltInt16HashValName + , leInt16HashValName + , eqInt16HashValName + , geInt16HashValName + , gtInt16HashValName + )) + , (word8HashTypeName, ( ltWord8HashValName + , leWord8HashValName + , eqWord8HashValName + , geWord8HashValName + , gtWord8HashValName + )) + , (word16HashTypeName, ( ltWord16HashValName + , leWord16HashValName + , eqWord16HashValName + , geWord16HashValName + , gtWord16HashValName + )) +#endif +#if MIN_VERSION_base(4,16,0) + , (int32HashTypeName, ( ltInt32HashValName + , leInt32HashValName + , eqInt32HashValName + , geInt32HashValName + , gtInt32HashValName + )) + , (word32HashTypeName, ( ltWord32HashValName + , leWord32HashValName + , eqWord32HashValName + , geWord32HashValName + , gtWord32HashValName + )) +#endif + ] + +removeClassApp :: Type -> Type +removeClassApp (AppT _ t2) = t2 +removeClassApp t = t + +-- This is an ugly, but unfortunately necessary hack on older versions of GHC which +-- don't have a properly working newName. On those GHCs, even running newName on a +-- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by +-- appending an uncommonly used string to the end of the name. This isn't foolproof, +-- since a user could freshen a variable named x and still have another x_' variable in +-- scope, but at least it's unlikely. +freshen :: Name -> Q Name +freshen n = newName (nameBase n ++ "_'") + +freshenType :: Type -> Q Type +freshenType t = + do let xs = [(n, VarT `fmap` freshen n) | n <- freeVariables t] + subst <- T.sequence (Map.fromList xs) + return (applySubstitution subst t) + +enumFromToExpr :: Q Exp -> Q Exp -> Q Exp +enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t + +primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp +primOpAppExpr e1 op e2 = varE isTrueHashValName `appE` + infixApp e1 (varE op) e2 + +-- | Checks if a 'Name' represents a tuple type constructor (other than '()') +isNonUnitTuple :: Name -> Bool +isNonUnitTuple = isNonUnitTupleString . nameBase + +-- | Checks if a 'String' represents a tuple (other than '()') +isNonUnitTupleString :: String -> Bool +isNonUnitTupleString ('(':',':_) = True +isNonUnitTupleString _ = False + +-- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does +-- it begin with a colon?). +isInfixDataCon :: String -> Bool +isInfixDataCon (':':_) = True +isInfixDataCon _ = False + +isSym :: String -> Bool +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c + +#if !defined(MIN_VERSION_ghc_boot_th) +startsVarSym, startsConSym :: Char -> Bool +startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids +startsConSym c = c == ':' -- Infix data constructors + +startsVarSymASCII :: Char -> Bool +startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" +#endif + +ghc7'8OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 708 +ghc7'8OrLater = True +#else +ghc7'8OrLater = False +#endif + +------------------------------------------------------------------------------- +-- Manually quoted names +------------------------------------------------------------------------------- + +-- By manually generating these names we avoid needing to use the +-- TemplateHaskell language extension when compiling the deriving-compat library. +-- This allows the library to be used in stage1 cross-compilers. + +derivingCompatPackageKey :: String +#ifdef CURRENT_PACKAGE_KEY +derivingCompatPackageKey = CURRENT_PACKAGE_KEY +#else +derivingCompatPackageKey = "deriving-compat-" ++ showVersion version +#endif + +gHC_IX :: String +#if MIN_VERSION_base(4,14,0) +gHC_IX = "GHC.Ix" +#else +gHC_IX = "GHC.Arr" +#endif + +mkDerivingCompatName_v :: String -> Name +mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" + +mkDerivingCompatName_tc :: String -> Name +mkDerivingCompatName_tc = mkNameG_tc derivingCompatPackageKey "Data.Deriving.Internal" + +isTrueHashValName :: Name +isTrueHashValName = mkDerivingCompatName_v "isTrue#" + +fmapConstValName :: Name +fmapConstValName = mkDerivingCompatName_v "fmapConst" + +replaceConstValName :: Name +replaceConstValName = mkDerivingCompatName_v "replaceConst" + +foldrConstValName :: Name +foldrConstValName = mkDerivingCompatName_v "foldrConst" + +foldMapConstValName :: Name +foldMapConstValName = mkDerivingCompatName_v "foldMapConst" + +nullConstValName :: Name +nullConstValName = mkDerivingCompatName_v "nullConst" + +traverseConstValName :: Name +traverseConstValName = mkDerivingCompatName_v "traverseConst" + +eqConstValName :: Name +eqConstValName = mkDerivingCompatName_v "eqConst" + +eq1ConstValName :: Name +eq1ConstValName = mkDerivingCompatName_v "eq1Const" + +liftEqConstValName :: Name +liftEqConstValName = mkDerivingCompatName_v "liftEqConst" + +liftEq2ConstValName :: Name +liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const" + +compareConstValName :: Name +compareConstValName = mkDerivingCompatName_v "compareConst" + +ltConstValName :: Name +ltConstValName = mkDerivingCompatName_v "ltConst" + +compare1ConstValName :: Name +compare1ConstValName = mkDerivingCompatName_v "compare1Const" + +liftCompareConstValName :: Name +liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst" + +liftCompare2ConstValName :: Name +liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const" + +readsPrecConstValName :: Name +readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst" + +readPrecConstValName :: Name +readPrecConstValName = mkDerivingCompatName_v "readPrecConst" + +readsPrec1ConstValName :: Name +readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const" + +liftReadsPrecConstValName :: Name +liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst" + +liftReadPrecConstValName :: Name +liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst" + +liftReadsPrec2ConstValName :: Name +liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const" + +liftReadPrec2ConstValName :: Name +liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const" + +showsPrecConstValName :: Name +showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst" + +showsPrec1ConstValName :: Name +showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const" + +liftShowsPrecConstValName :: Name +liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst" + +liftShowsPrec2ConstValName :: Name +liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" + +viaTypeName :: Name +viaTypeName = mkDerivingCompatName_tc "Via" + +cHashDataName :: Name +cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" + +dHashDataName :: Name +dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#" + +fHashDataName :: Name +fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#" + +identDataName :: Name +identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident" + +iHashDataName :: Name +iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#" + +puncDataName :: Name +puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc" + +symbolDataName :: Name +symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol" + +wrapMonadDataName :: Name +wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" + +addrHashTypeName :: Name +addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#" + +boundedTypeName :: Name +boundedTypeName = mkNameG_tc "base" "GHC.Enum" "Bounded" + +charHashTypeName :: Name +charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#" + +doubleHashTypeName :: Name +doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#" + +enumTypeName :: Name +enumTypeName = mkNameG_tc "base" "GHC.Enum" "Enum" + +floatHashTypeName :: Name +floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#" + +foldableTypeName :: Name +foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" + +functorTypeName :: Name +functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" + +intTypeName :: Name +intTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Int" + +intHashTypeName :: Name +intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#" + +ixTypeName :: Name +ixTypeName = mkNameG_tc "base" gHC_IX "Ix" + +readTypeName :: Name +readTypeName = mkNameG_tc "base" "GHC.Read" "Read" + +showTypeName :: Name +showTypeName = mkNameG_tc "base" "GHC.Show" "Show" + +traversableTypeName :: Name +traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" + +wordHashTypeName :: Name +wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#" + +altValName :: Name +altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++" + +appendValName :: Name +appendValName = mkNameG_v "base" "GHC.Base" "++" + +chooseValName :: Name +chooseValName = mkNameG_v "base" "GHC.Read" "choose" + +coerceValName :: Name +coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" + +composeValName :: Name +composeValName = mkNameG_v "base" "GHC.Base" "." + +constValName :: Name +constValName = mkNameG_v "base" "GHC.Base" "const" + +enumFromValName :: Name +enumFromValName = mkNameG_v "base" "GHC.Enum" "enumFrom" + +enumFromThenValName :: Name +enumFromThenValName = mkNameG_v "base" "GHC.Enum" "enumFromThen" + +enumFromThenToValName :: Name +enumFromThenToValName = mkNameG_v "base" "GHC.Enum" "enumFromThenTo" + +enumFromToValName :: Name +enumFromToValName = mkNameG_v "base" "GHC.Enum" "enumFromTo" + +eqAddrHashValName :: Name +eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#" + +eqCharHashValName :: Name +eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#" + +eqDoubleHashValName :: Name +eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##" + +eqFloatHashValName :: Name +eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#" + +eqIntHashValName :: Name +eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#" + +eqWordHashValName :: Name +eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#" + +errorValName :: Name +errorValName = mkNameG_v "base" "GHC.Err" "error" + +flipValName :: Name +flipValName = mkNameG_v "base" "GHC.Base" "flip" + +fmapValName :: Name +fmapValName = mkNameG_v "base" "GHC.Base" "fmap" + +foldrValName :: Name +foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" + +foldMapValName :: Name +foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" + +fromEnumValName :: Name +fromEnumValName = mkNameG_v "base" "GHC.Enum" "fromEnum" + +geAddrHashValName :: Name +geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#" + +geCharHashValName :: Name +geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#" + +geDoubleHashValName :: Name +geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##" + +geFloatHashValName :: Name +geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#" + +geIntHashValName :: Name +geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#" + +getTagValName :: Name +getTagValName = mkNameG_v "base" "GHC.Base" "getTag" + +geWordHashValName :: Name +geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#" + +gtAddrHashValName :: Name +gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#" + +gtCharHashValName :: Name +gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#" + +gtDoubleHashValName :: Name +gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##" + +gtFloatHashValName :: Name +gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#" + +gtIntHashValName :: Name +gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#" + +gtWordHashValName :: Name +gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#" + +idValName :: Name +idValName = mkNameG_v "base" "GHC.Base" "id" + +indexValName :: Name +indexValName = mkNameG_v "base" gHC_IX "index" + +inRangeValName :: Name +inRangeValName = mkNameG_v "base" gHC_IX "inRange" + +leAddrHashValName :: Name +leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#" + +leCharHashValName :: Name +leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#" + +leDoubleHashValName :: Name +leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##" + +leFloatHashValName :: Name +leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#" + +leIntHashValName :: Name +leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#" + +leWordHashValName :: Name +leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#" + +liftReadListPrecDefaultValName :: Name +liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault" + +liftReadListPrec2DefaultValName :: Name +liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default" + +liftReadListPrecValName :: Name +liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec" + +liftReadListPrec2ValName :: Name +liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2" + +liftReadPrecValName :: Name +liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec" + +liftReadPrec2ValName :: Name +liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2" + +listValName :: Name +listValName = mkNameG_v "base" "GHC.Read" "list" + +ltAddrHashValName :: Name +ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#" + +ltCharHashValName :: Name +ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#" + +ltDoubleHashValName :: Name +ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##" + +ltFloatHashValName :: Name +ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#" + +ltIntHashValName :: Name +ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#" + +ltWordHashValName :: Name +ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#" + +minBoundValName :: Name +minBoundValName = mkNameG_v "base" "GHC.Enum" "minBound" + +mapValName :: Name +mapValName = mkNameG_v "base" "GHC.Base" "map" + +maxBoundValName :: Name +maxBoundValName = mkNameG_v "base" "GHC.Enum" "maxBound" + +minusIntHashValName :: Name +minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#" + +neqIntHashValName :: Name +neqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "/=#" + +parenValName :: Name +parenValName = mkNameG_v "base" "GHC.Read" "paren" + +parensValName :: Name +parensValName = mkNameG_v "base" "GHC.Read" "parens" + +pfailValName :: Name +pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail" + +plusValName :: Name +plusValName = mkNameG_v "base" "GHC.Num" "+" + +precValName :: Name +precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec" + +predValName :: Name +predValName = mkNameG_v "base" "GHC.Enum" "pred" + +rangeSizeValName :: Name +rangeSizeValName = mkNameG_v "base" gHC_IX "rangeSize" + +rangeValName :: Name +rangeValName = mkNameG_v "base" gHC_IX "range" + +readFieldHash :: String -> ReadPrec a -> ReadPrec a +readFieldHash fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Symbol "#") + expectP (L.Punc "=") + readVal +{-# NOINLINE readFieldHash #-} + +readFieldHashValName :: Name +readFieldHashValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readFieldHash" + +readListValName :: Name +readListValName = mkNameG_v "base" "GHC.Read" "readList" + +readListPrecDefaultValName :: Name +readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault" + +readListPrecValName :: Name +readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec" + +readPrec_to_SValName :: Name +readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S" + +readPrecValName :: Name +readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec" + +readS_to_PrecValName :: Name +readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec" + +readsPrecValName :: Name +readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec" + +replaceValName :: Name +replaceValName = mkNameG_v "base" "GHC.Base" "<$" + +resetValName :: Name +resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset" + +returnValName :: Name +returnValName = mkNameG_v "base" "GHC.Base" "return" + +seqValName :: Name +seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" + +showCharValName :: Name +showCharValName = mkNameG_v "base" "GHC.Show" "showChar" + +showListValName :: Name +showListValName = mkNameG_v "base" "GHC.Show" "showList" + +showListWithValName :: Name +showListWithValName = mkNameG_v "base" "Text.Show" "showListWith" + +showParenValName :: Name +showParenValName = mkNameG_v "base" "GHC.Show" "showParen" + +showsPrecValName :: Name +showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec" + +showSpaceValName :: Name +showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace" + +showStringValName :: Name +showStringValName = mkNameG_v "base" "GHC.Show" "showString" + +stepValName :: Name +stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step" + +succValName :: Name +succValName = mkNameG_v "base" "GHC.Enum" "succ" + +tagToEnumHashValName :: Name +tagToEnumHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#" + +timesValName :: Name +timesValName = mkNameG_v "base" "GHC.Num" "*" + +toEnumValName :: Name +toEnumValName = mkNameG_v "base" "GHC.Enum" "toEnum" + +traverseValName :: Name +traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" + +unsafeIndexValName :: Name +unsafeIndexValName = mkNameG_v "base" gHC_IX "unsafeIndex" + +unsafeRangeSizeValName :: Name +unsafeRangeSizeValName = mkNameG_v "base" gHC_IX "unsafeRangeSize" + +unwrapMonadValName :: Name +unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" + +#if MIN_VERSION_base(4,4,0) +boolTypeName :: Name +boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool" + +falseDataName :: Name +falseDataName = mkNameG_d "ghc-prim" "GHC.Types" "False" + +trueDataName :: Name +trueDataName = mkNameG_d "ghc-prim" "GHC.Types" "True" +#else +boolTypeName :: Name +boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool" + +falseDataName :: Name +falseDataName = mkNameG_d "ghc-prim" "GHC.Bool" "False" + +trueDataName :: Name +trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True" +#endif + +#if MIN_VERSION_base(4,5,0) +eqDataName :: Name +eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ" + +gtDataName :: Name +gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT" + +ltDataName :: Name +ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT" + +eqTypeName :: Name +eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq" + +ordTypeName :: Name +ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord" + +andValName :: Name +andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&" + +compareValName :: Name +compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare" + +eqValName :: Name +eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "==" + +geValName :: Name +geValName = mkNameG_v "ghc-prim" "GHC.Classes" ">=" + +gtValName :: Name +gtValName = mkNameG_v "ghc-prim" "GHC.Classes" ">" + +leValName :: Name +leValName = mkNameG_v "ghc-prim" "GHC.Classes" "<=" + +ltValName :: Name +ltValName = mkNameG_v "ghc-prim" "GHC.Classes" "<" + +notValName :: Name +notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not" +#else +eqDataName :: Name +eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ" + +gtDataName :: Name +gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT" + +ltDataName :: Name +ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT" + +eqTypeName :: Name +eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq" + +ordTypeName :: Name +ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord" + +andValName :: Name +andValName = mkNameG_v "base" "GHC.Classes" "&&" + +compareValName :: Name +compareValName = mkNameG_v "base" "GHC.Classes" "compare" + +eqValName :: Name +eqValName = mkNameG_v "base" "GHC.Classes" "==" + +geValName :: Name +geValName = mkNameG_v "base" "GHC.Classes" ">=" + +gtValName :: Name +gtValName = mkNameG_v "base" "GHC.Classes" ">" + +leValName :: Name +leValName = mkNameG_v "base" "GHC.Classes" "<=" + +ltValName :: Name +ltValName = mkNameG_v "base" "GHC.Classes" "<" + +notValName :: Name +notValName = mkNameG_v "base" "GHC.Classes" "not" +#endif + +#if MIN_VERSION_base(4,6,0) +wHashDataName :: Name +wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#" +#else +wHashDataName :: Name +wHashDataName = mkNameG_d "base" "GHC.Word" "W#" +#endif + +#if MIN_VERSION_base(4,7,0) +expectPValName :: Name +expectPValName = mkNameG_v "base" "GHC.Read" "expectP" +#else +expectP :: Lexeme -> ReadPrec () +expectP lexeme = do + thing <- lexP + if thing == lexeme then return () else pfail + +expectPValName :: Name +expectPValName = mkDerivingCompatName_v "expectP" +#endif + +#if MIN_VERSION_base(4,8,0) +allValName :: Name +allValName = mkNameG_v "base" "Data.Foldable" "all" + +apValName :: Name +apValName = mkNameG_v "base" "GHC.Base" "<*>" + +pureValName :: Name +pureValName = mkNameG_v "base" "GHC.Base" "pure" + +liftA2ValName :: Name +liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2" + +mappendValName :: Name +mappendValName = mkNameG_v "base" "GHC.Base" "mappend" + +memptyValName :: Name +memptyValName = mkNameG_v "base" "GHC.Base" "mempty" + +nullValName :: Name +nullValName = mkNameG_v "base" "Data.Foldable" "null" +#else +allValName :: Name +allValName = mkNameG_v "base" "GHC.List" "all" + +apValName :: Name +apValName = mkNameG_v "base" "Control.Applicative" "<*>" + +pureValName :: Name +pureValName = mkNameG_v "base" "Control.Applicative" "pure" + +liftA2ValName :: Name +liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2" + +mappendValName :: Name +mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" + +memptyValName :: Name +memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" + +nullValName :: Name +nullValName = mkNameG_v "base" "GHC.List" "null" +#endif + +#if MIN_VERSION_base(4,9,0) +eq1TypeName :: Name +eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1" + +eq2TypeName :: Name +eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2" + +liftEqValName :: Name +liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq" + +liftEq2ValName :: Name +liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2" + +ord1TypeName :: Name +ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1" + +ord2TypeName :: Name +ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2" + +liftCompareValName :: Name +liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare" + +liftCompare2ValName :: Name +liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2" + +read1TypeName :: Name +read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1" + +read2TypeName :: Name +read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2" + +liftReadsPrecValName :: Name +liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec" + +liftReadListValName :: Name +liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList" + +liftReadsPrec2ValName :: Name +liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2" + +liftReadList2ValName :: Name +liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2" + +show1TypeName :: Name +show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1" + +show2TypeName :: Name +show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2" + +liftShowListValName :: Name +liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList" + +liftShowsPrecValName :: Name +liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec" + +liftShowList2ValName :: Name +liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2" + +liftShowsPrec2ValName :: Name +liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2" +#else +-- If Data.Functor.Classes isn't located in base, then sadly we can't refer to +-- Names from that module without using -XTemplateHaskell. +# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +eq1TypeName :: Name +eq1TypeName = ''Eq1 + +eq2TypeName :: Name +eq2TypeName = ''Eq2 + +liftEqValName :: Name +liftEqValName = 'liftEq + +liftEq2ValName :: Name +liftEq2ValName = 'liftEq2 + +ord1TypeName :: Name +ord1TypeName = ''Ord1 + +ord2TypeName :: Name +ord2TypeName = ''Ord2 + +liftCompareValName :: Name +liftCompareValName = 'liftCompare + +liftCompare2ValName :: Name +liftCompare2ValName = 'liftCompare2 + +read1TypeName :: Name +read1TypeName = ''Read1 + +read2TypeName :: Name +read2TypeName = ''Read2 + +liftReadsPrecValName :: Name +liftReadsPrecValName = 'liftReadsPrec + +liftReadListValName :: Name +liftReadListValName = 'liftReadList + +liftReadsPrec2ValName :: Name +liftReadsPrec2ValName = 'liftReadsPrec2 + +liftReadList2ValName :: Name +liftReadList2ValName = 'liftReadList2 + +show1TypeName :: Name +show1TypeName = ''Show1 + +show2TypeName :: Name +show2TypeName = ''Show2 + +liftShowListValName :: Name +liftShowListValName = 'liftShowList + +liftShowsPrecValName :: Name +liftShowsPrecValName = 'liftShowsPrec + +liftShowList2ValName :: Name +liftShowList2ValName = 'liftShowList2 + +liftShowsPrec2ValName :: Name +liftShowsPrec2ValName = 'liftShowsPrec2 +# else +eq1TypeName :: Name +eq1TypeName = ''Eq1 + +eq1ValName :: Name +eq1ValName = 'eq1 + +ord1TypeName :: Name +ord1TypeName = ''Ord1 + +compare1ValName :: Name +compare1ValName = 'compare1 + +read1TypeName :: Name +read1TypeName = ''Read1 + +readsPrec1ValName :: Name +readsPrec1ValName = 'readsPrec1 + +show1TypeName :: Name +show1TypeName = ''Show1 + +showsPrec1ValName :: Name +showsPrec1ValName = 'showsPrec1 + +newtype Apply f a = Apply { unApply :: f a } + +instance (Eq1 f, Eq a) => Eq (Apply f a) where + Apply x == Apply y = eq1 x y + +instance (Ord1 g, Ord a) => Ord (Apply g a) where + compare (Apply x) (Apply y) = compare1 x y + +instance (Read1 f, Read a) => Read (Apply f a) where + readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s] + +instance (Show1 f, Show a) => Show (Apply f a) where + showsPrec p (Apply x) = showsPrec1 p x + +makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp +makeFmapApplyNeg = makeFmapApply False + +makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp +makeFmapApplyPos = makeFmapApply True + +makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp +makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name +makeFmapApply pos cRep conName t name = do + let tyCon :: Type + tyArgs :: [Type] + (tyCon, tyArgs) = unapplyTy t + + numLastArgs :: Int + numLastArgs = min (arity cRep) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + inspectTy :: Type -> Q Exp + inspectTy (SigT ty _) = inspectTy ty + inspectTy (VarT a) | a == name = varE idValName + inspectTy beta = varE fmapValName `appE` + infixApp (if pos then makeFmapApply pos cRep conName beta name + else conE applyDataName) + (varE composeValName) + (if pos then varE unApplyValName + else makeFmapApply pos cRep conName beta name) + + itf <- isInTypeFamilyApp [name] tyCon tyArgs + if any (`mentionsName` [name]) lhsArgs || itf + then outOfPlaceTyVarError cRep conName + else inspectTy (head rhsArgs) + +applyDataName :: Name +applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply" + +unApplyValName :: Name +unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply" +# endif +#endif + +#if MIN_VERSION_base(4,10,0) +showCommaSpaceValName :: Name +showCommaSpaceValName = mkNameG_v "base" "GHC.Show" "showCommaSpace" +#else +showCommaSpace :: ShowS +showCommaSpace = showString ", " + +showCommaSpaceValName :: Name +showCommaSpaceValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "showCommaSpace" +#endif + +#if MIN_VERSION_base(4,11,0) +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" + +readFieldValName :: Name +readFieldValName = mkNameG_v "base" "GHC.Read" "readField" + +readSymFieldValName :: Name +readSymFieldValName = mkNameG_v "base" "GHC.Read" "readSymField" +#else +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" + +readField :: String -> ReadPrec a -> ReadPrec a +readField fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Punc "=") + readVal +{-# NOINLINE readField #-} + +readFieldValName :: Name +readFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readField" + +readSymField :: String -> ReadPrec a -> ReadPrec a +readSymField fieldName readVal = do + expectP (L.Punc "(") + expectP (L.Symbol fieldName) + expectP (L.Punc ")") + expectP (L.Punc "=") + readVal +{-# NOINLINE readSymField #-} + +readSymFieldValName :: Name +readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField" +#endif + +#if MIN_VERSION_base(4,13,0) +eqInt8HashValName :: Name +eqInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt8#" + +eqInt16HashValName :: Name +eqInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt16#" + +eqWord8HashValName :: Name +eqWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord8#" + +eqWord16HashValName :: Name +eqWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#" + +geInt8HashValName :: Name +geInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#" + +geInt16HashValName :: Name +geInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt16#" + +geWord8HashValName :: Name +geWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord8#" + +geWord16HashValName :: Name +geWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord16#" + +gtInt8HashValName :: Name +gtInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt8#" + +gtInt16HashValName :: Name +gtInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt16#" + +gtWord8HashValName :: Name +gtWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord8#" + +gtWord16HashValName :: Name +gtWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord16#" + +int8HashTypeName :: Name +int8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#" + +int8ToIntHashValName :: Name +int8ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "int8ToInt#" +# else + "extendInt8#" +# endif + +int16HashTypeName :: Name +int16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#" + +int16ToIntHashValName :: Name +int16ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "int16ToInt#" +# else + "extendInt16#" +# endif + +intToInt8HashValName :: Name +intToInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "intToInt8#" +# else + "narrowInt8#" +# endif + +intToInt16HashValName :: Name +intToInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "intToInt16#" +# else + "narrowInt16#" +# endif + +leInt8HashValName :: Name +leInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#" + +leInt16HashValName :: Name +leInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt16#" + +leWord8HashValName :: Name +leWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord8#" + +leWord16HashValName :: Name +leWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord16#" + +ltInt8HashValName :: Name +ltInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt8#" + +ltInt16HashValName :: Name +ltInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt16#" + +ltWord8HashValName :: Name +ltWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord8#" + +ltWord16HashValName :: Name +ltWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord16#" + +word8HashTypeName :: Name +word8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#" + +word8ToWordHashValName :: Name +word8ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "word8ToWord#" +# else + "extendWord8#" +# endif + +word16HashTypeName :: Name +word16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#" + +word16ToWordHashValName :: Name +word16ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "word16ToWord#" +# else + "extendWord16#" +# endif + +wordToWord8HashValName :: Name +wordToWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "wordToWord8#" +# else + "narrowWord8#" +# endif + +wordToWord16HashValName :: Name +wordToWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "wordToWord16#" +# else + "narrowWord16#" +# endif +#endif + +#if MIN_VERSION_base(4,16,0) +eqInt32HashValName :: Name +eqInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt32#" + +eqWord32HashValName :: Name +eqWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord32#" + +geInt32HashValName :: Name +geInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt32#" + +geWord32HashValName :: Name +geWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord32#" + +gtInt32HashValName :: Name +gtInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt32#" + +gtWord32HashValName :: Name +gtWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord32#" + +int32HashTypeName :: Name +int32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int32#" + +int32ToIntHashValName :: Name +int32ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "int32ToInt#" + +intToInt32HashValName :: Name +intToInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "intToInt32#" + +leInt32HashValName :: Name +leInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt32#" + +leWord32HashValName :: Name +leWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord32#" + +ltInt32HashValName :: Name +ltInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt32#" + +ltWord32HashValName :: Name +ltWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord32#" + +word32HashTypeName :: Name +word32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word32#" + +word32ToWordHashValName :: Name +word32ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "word32ToWord#" + +wordToWord32HashValName :: Name +wordToWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "wordToWord32#" +#endif diff --git a/src/Data/Deriving/Via.hs b/src/Data/Deriving/Via.hs --- a/src/Data/Deriving/Via.hs +++ b/src/Data/Deriving/Via.hs @@ -1,71 +1,71 @@ -{-# LANGUAGE CPP #-} - -{-| -Module: Data.Deriving.Via -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module -exports functionality which emulates the @GeneralizedNewtypeDeriving@ and -@DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6). - -On older versions of @template-haskell@/GHC, this module does not export -anything. --} -module Data.Deriving.Via ( -#if !(MIN_VERSION_template_haskell(2,12,0)) - ) where -#else - -- * @GeneralizedNewtypeDeriving@ - deriveGND - -- * @DerivingVia@ - , deriveVia - , Via - -- * Limitations - -- $constraints - ) where - -import Data.Deriving.Internal (Via) -import Data.Deriving.Via.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Unlike every other module in this library, the functions exported by - "Data.Deriving.Via" only support GHC 8.2 and later, as they require - Template Haskell functionality not present in earlier GHCs. - -* Additionally, using the functions in "Data.Deriving.Via" will likely - require you to enable some language extensions (besides @TemplateHaskell@). - These may include: - - * @ImpredicativeTypes@ (if any class methods contain higher-rank types) - - * @InstanceSigs@ - - * @KindSignatures@ - - * @RankNTypes@ - - * @ScopedTypeVariables@ - - * @TypeApplications@ - - * @TypeOperators@ - - * @UndecidableInstances@ (if deriving an instance of a type class with - associated type families) - -* The functions in "Data.Deriving.Via" are not terribly robust in the presence - of @PolyKinds@. Alas, Template Haskell does not make this easy to fix. - -* The functions in "Data.Deriving.Via" make a best-effort attempt to derive - instances for classes with associated type families. This is known not to - work in all scenarios, however, especially when the last parameter to a type - class appears as a kind variable in an associated type family. (See - .) --} -#endif +{-# LANGUAGE CPP #-} + +{-| +Module: Data.Deriving.Via +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module +exports functionality which emulates the @GeneralizedNewtypeDeriving@ and +@DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6). + +On older versions of @template-haskell@/GHC, this module does not export +anything. +-} +module Data.Deriving.Via ( +#if !(MIN_VERSION_template_haskell(2,12,0)) + ) where +#else + -- * @GeneralizedNewtypeDeriving@ + deriveGND + -- * @DerivingVia@ + , deriveVia + , Via + -- * Limitations + -- $constraints + ) where + +import Data.Deriving.Internal (Via) +import Data.Deriving.Via.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Unlike every other module in this library, the functions exported by + "Data.Deriving.Via" only support GHC 8.2 and later, as they require + Template Haskell functionality not present in earlier GHCs. + +* Additionally, using the functions in "Data.Deriving.Via" will likely + require you to enable some language extensions (besides @TemplateHaskell@). + These may include: + + * @ImpredicativeTypes@ (if any class methods contain higher-rank types) + + * @InstanceSigs@ + + * @KindSignatures@ + + * @RankNTypes@ + + * @ScopedTypeVariables@ + + * @TypeApplications@ + + * @TypeOperators@ + + * @UndecidableInstances@ (if deriving an instance of a type class with + associated type families) + +* The functions in "Data.Deriving.Via" are not terribly robust in the presence + of @PolyKinds@. Alas, Template Haskell does not make this easy to fix. + +* The functions in "Data.Deriving.Via" make a best-effort attempt to derive + instances for classes with associated type families. This is known not to + work in all scenarios, however, especially when the last parameter to a type + class appears as a kind variable in an associated type family. (See + .) +-} +#endif diff --git a/src/Data/Deriving/Via/Internal.hs b/src/Data/Deriving/Via/Internal.hs --- a/src/Data/Deriving/Via/Internal.hs +++ b/src/Data/Deriving/Via/Internal.hs @@ -1,244 +1,244 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TemplateHaskellQuotes #-} -#endif - -{-| -Module: Data.Deriving.Via.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module -exports functionality which emulates the @GeneralizedNewtypeDeriving@ and -@DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6). - -On older versions of @template-haskell@/GHC, this module does not export -anything. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Deriving.Via.Internal where - -#if MIN_VERSION_template_haskell(2,12,0) -import Control.Monad ((<=<), unless) - -import Data.Deriving.Internal -import qualified Data.List as L -import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe (catMaybes) - -import GHC.Exts (Any) - -import Language.Haskell.TH -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Datatype.TyVarBndr - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - -{- | Generates an instance for a type class at a newtype by emulating the -behavior of the @GeneralizedNewtypeDeriving@ extension. For example: - -@ -newtype Foo a = MkFoo a -$('deriveGND' [t| forall a. 'Eq' a => 'Eq' (Foo a) |]) -@ --} -deriveGND :: Q Type -> Q [Dec] -deriveGND qty = do - ty <- qty - let (_instanceTvbs, instanceCxt, instanceTy) = decomposeType ty - instanceTy' <- (resolveTypeSynonyms <=< resolveInfixT) instanceTy - decs <- deriveViaDecs instanceTy' Nothing - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceTy) - (map return decs) - -{- | Generates an instance for a type class by emulating the behavior of the -@DerivingVia@ extension. For example: - -@ -newtype Foo a = MkFoo a -$('deriveVia' [t| forall a. 'Ord' a => 'Ord' (Foo a) ``Via`` Down a |]) -@ - -As shown in the example above, the syntax is a tad strange. One must specify -the type by which to derive the instance using the 'Via' type. This -requirement is in place to ensure that the type variables are scoped -correctly across all the types being used (e.g., to make sure that the same -@a@ is used in @'Ord' a@, @'Ord' (Foo a)@, and @Down a@). --} -deriveVia :: Q Type -> Q [Dec] -deriveVia qty = do - ty <- qty - let (_instanceTvbs, instanceCxt, viaApp) = decomposeType ty - viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp - (instanceTy, viaTy) - <- case unapplyTy viaApp' of - (via, [instanceTy,viaTy]) - | via == ConT viaTypeName - -> return (instanceTy, viaTy) - _ -> fail $ unlines - [ "Failure to meet ‘deriveVia‘ specification" - , "\tThe ‘Via‘ type must be used, e.g." - , "\t[t| forall a. C (T a) `Via` V a |]" - ] - -- This is a stronger requirement than what GHC's implementation of - -- DerivingVia imposes, but due to Template Haskell restrictions, we - -- currently can't do better. See #27. - let viaTyFVs = freeVariables viaTy - otherFVs = concat [freeVariables instanceCxt, freeVariables instanceTy] - floatingViaTyFVs = viaTyFVs L.\\ otherFVs - floatingViaTySubst = M.fromList $ map (, ConT ''Any) floatingViaTyFVs - viaTy' = applySubstitution floatingViaTySubst viaTy - decs <- deriveViaDecs instanceTy (Just viaTy') - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceTy) - (map return decs) - -deriveViaDecs :: Type -- ^ The instance head (e.g., @Eq (Foo a)@) - -> Maybe Type -- ^ If using 'deriveGND', this is 'Nothing. - -- If using 'deriveVia', this is 'Just' the @via@ type. - -> Q [Dec] -deriveViaDecs instanceTy mbViaTy = do - let (clsTy, clsArgs) = unapplyTy instanceTy - case clsTy of - ConT clsName -> do - clsInfo <- reify clsName - case clsInfo of - ClassI (ClassD _ _ clsTvbs _ clsDecs) _ -> - case (unsnoc clsArgs, unsnoc clsTvbs) of - (Just (_, dataApp), Just (_, clsLastTvb)) -> do - let (dataTy, dataArgs) = unapplyTy dataApp - clsLastTvbKind = tvbKind clsLastTvb - (_, kindList) = uncurryTy clsLastTvbKind - numArgsToEtaReduce = length kindList - 1 - repTy <- - case mbViaTy of - Just viaTy -> return viaTy - Nothing -> - case dataTy of - ConT dataName -> do - DatatypeInfo { - datatypeInstTypes = dataInstTypes - , datatypeVariant = dv - , datatypeCons = cons - } <- reifyDatatype dataName - case newtypeRepType dv cons of - Just newtypeRepTy -> - case etaReduce numArgsToEtaReduce newtypeRepTy of - Just etaRepTy -> - let repTySubst = - M.fromList $ - zipWith (\var arg -> (varTToName var, arg)) - dataInstTypes dataArgs - in return $ applySubstitution repTySubst etaRepTy - Nothing -> etaReductionError instanceTy - Nothing -> fail $ "Not a newtype: " ++ nameBase dataName - _ -> fail $ "Not a data type: " ++ pprint dataTy - concat . catMaybes <$> traverse (deriveViaDecs' clsName clsTvbs clsArgs repTy) clsDecs - (_, _) -> fail $ "Cannot derive instance for nullary class " ++ pprint clsTy - _ -> fail $ "Not a type class: " ++ pprint clsTy - _ -> fail $ "Malformed instance: " ++ pprint instanceTy - -deriveViaDecs' :: Name -> [TyVarBndrUnit] -> [Type] -> Type -> Dec -> Q (Maybe [Dec]) -deriveViaDecs' clsName clsTvbs clsArgs repTy dec = do - let numExpectedArgs = length clsTvbs - numActualArgs = length clsArgs - unless (numExpectedArgs == numActualArgs) $ - fail $ "Mismatched number of class arguments" - ++ "\n\tThe class " ++ nameBase clsName ++ " expects " ++ show numExpectedArgs ++ " argument(s)," - ++ "\n\tbut was provided " ++ show numActualArgs ++ " argument(s)." - go dec - where - go :: Dec -> Q (Maybe [Dec]) - - go (OpenTypeFamilyD (TypeFamilyHead tfName tfTvbs _ _)) = do - let lhsSubst = zipTvbSubst clsTvbs clsArgs - rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy - tfTvbTys = map tvbToType tfTvbs - tfLHSTys = map (applySubstitution lhsSubst) tfTvbTys - tfRHSTys = map (applySubstitution rhsSubst) tfTvbTys - tfRHSTy = applyTy (ConT tfName) tfRHSTys - tfInst <- tySynInstDCompat tfName Nothing - (map pure tfLHSTys) (pure tfRHSTy) - pure (Just [tfInst]) - - go (SigD methName methTy) = - let (fromTy, toTy) = mkCoerceClassMethEqn clsTvbs clsArgs repTy $ - stripOuterForallT methTy - fromTau = stripOuterForallT fromTy - toTau = stripOuterForallT toTy - rhsExpr = VarE coerceValName `AppTypeE` fromTau - `AppTypeE` toTau - `AppE` VarE methName - sig = SigD methName toTy - meth = ValD (VarP methName) - (NormalB rhsExpr) - [] - in return (Just [sig, meth]) - - go _ = return Nothing - -mkCoerceClassMethEqn :: [TyVarBndrUnit] -> [Type] -> Type -> Type -> (Type, Type) -mkCoerceClassMethEqn clsTvbs clsArgs repTy methTy - = ( applySubstitution rhsSubst methTy - , applySubstitution lhsSubst methTy - ) - where - lhsSubst = zipTvbSubst clsTvbs clsArgs - rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy - -zipTvbSubst :: [TyVarBndr_ flag] -> [Type] -> Map Name Type -zipTvbSubst tvbs = M.fromList . zipWith (\tvb ty -> (tvName tvb, ty)) tvbs - --- | Replace the last element of a list with another element. -changeLast :: [a] -> a -> [a] -changeLast [] _ = error "changeLast" -changeLast [_] x = [x] -changeLast (x:xs) x' = x : changeLast xs x' - -stripOuterForallT :: Type -> Type -#if __GLASGOW_HASKELL__ < 807 --- Before GHC 8.7, TH-reified classes would put a redundant forall/class --- context in front of each method's type signature, so we have to strip them --- off here. -stripOuterForallT (ForallT _ _ ty) = ty -#endif -stripOuterForallT ty = ty - -decomposeType :: Type -> ([TyVarBndrSpec], Cxt, Type) -decomposeType (ForallT tvbs ctxt ty) = (tvbs, ctxt, ty) -decomposeType ty = ([], [], ty) - -newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type -newtypeRepType dv cons = do - checkIfNewtype - case cons of - [ConstructorInfo { constructorVars = [] - , constructorContext = [] - , constructorFields = [repTy] - }] -> Just repTy - _ -> Nothing - where - checkIfNewtype :: Maybe () - checkIfNewtype - | Newtype <- dv = Just () - | NewtypeInstance <- dv = Just () - | otherwise = Nothing - -etaReduce :: Int -> Type -> Maybe Type -etaReduce num ty = - let (tyHead, tyArgs) = unapplyTy ty - (tyArgsRemaining, tyArgsDropped) = splitAt (length tyArgs - num) tyArgs - in if canEtaReduce tyArgsRemaining tyArgsDropped - then Just $ applyTy tyHead tyArgsRemaining - else Nothing -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +#endif + +{-| +Module: Data.Deriving.Via.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module +exports functionality which emulates the @GeneralizedNewtypeDeriving@ and +@DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6). + +On older versions of @template-haskell@/GHC, this module does not export +anything. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Deriving.Via.Internal where + +#if MIN_VERSION_template_haskell(2,12,0) +import Control.Monad ((<=<), unless) + +import Data.Deriving.Internal +import qualified Data.List as L +import qualified Data.Map as M +import Data.Map (Map) +import Data.Maybe (catMaybes) + +import GHC.Exts (Any) + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype.TyVarBndr + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +{- | Generates an instance for a type class at a newtype by emulating the +behavior of the @GeneralizedNewtypeDeriving@ extension. For example: + +@ +newtype Foo a = MkFoo a +$('deriveGND' [t| forall a. 'Eq' a => 'Eq' (Foo a) |]) +@ +-} +deriveGND :: Q Type -> Q [Dec] +deriveGND qty = do + ty <- qty + let (_instanceTvbs, instanceCxt, instanceTy) = decomposeType ty + instanceTy' <- (resolveTypeSynonyms <=< resolveInfixT) instanceTy + decs <- deriveViaDecs instanceTy' Nothing + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceTy) + (map return decs) + +{- | Generates an instance for a type class by emulating the behavior of the +@DerivingVia@ extension. For example: + +@ +newtype Foo a = MkFoo a +$('deriveVia' [t| forall a. 'Ord' a => 'Ord' (Foo a) ``Via`` Down a |]) +@ + +As shown in the example above, the syntax is a tad strange. One must specify +the type by which to derive the instance using the 'Via' type. This +requirement is in place to ensure that the type variables are scoped +correctly across all the types being used (e.g., to make sure that the same +@a@ is used in @'Ord' a@, @'Ord' (Foo a)@, and @Down a@). +-} +deriveVia :: Q Type -> Q [Dec] +deriveVia qty = do + ty <- qty + let (_instanceTvbs, instanceCxt, viaApp) = decomposeType ty + viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp + (instanceTy, viaTy) + <- case unapplyTy viaApp' of + (via, [instanceTy,viaTy]) + | via == ConT viaTypeName + -> return (instanceTy, viaTy) + _ -> fail $ unlines + [ "Failure to meet ‘deriveVia‘ specification" + , "\tThe ‘Via‘ type must be used, e.g." + , "\t[t| forall a. C (T a) `Via` V a |]" + ] + -- This is a stronger requirement than what GHC's implementation of + -- DerivingVia imposes, but due to Template Haskell restrictions, we + -- currently can't do better. See #27. + let viaTyFVs = freeVariables viaTy + otherFVs = concat [freeVariables instanceCxt, freeVariables instanceTy] + floatingViaTyFVs = viaTyFVs L.\\ otherFVs + floatingViaTySubst = M.fromList $ map (, ConT ''Any) floatingViaTyFVs + viaTy' = applySubstitution floatingViaTySubst viaTy + decs <- deriveViaDecs instanceTy (Just viaTy') + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceTy) + (map return decs) + +deriveViaDecs :: Type -- ^ The instance head (e.g., @Eq (Foo a)@) + -> Maybe Type -- ^ If using 'deriveGND', this is 'Nothing. + -- If using 'deriveVia', this is 'Just' the @via@ type. + -> Q [Dec] +deriveViaDecs instanceTy mbViaTy = do + let (clsTy, clsArgs) = unapplyTy instanceTy + case clsTy of + ConT clsName -> do + clsInfo <- reify clsName + case clsInfo of + ClassI (ClassD _ _ clsTvbs _ clsDecs) _ -> + case (unsnoc clsArgs, unsnoc clsTvbs) of + (Just (_, dataApp), Just (_, clsLastTvb)) -> do + let (dataTy, dataArgs) = unapplyTy dataApp + clsLastTvbKind = tvbKind clsLastTvb + (_, kindList) = uncurryTy clsLastTvbKind + numArgsToEtaReduce = length kindList - 1 + repTy <- + case mbViaTy of + Just viaTy -> return viaTy + Nothing -> + case dataTy of + ConT dataName -> do + DatatypeInfo { + datatypeInstTypes = dataInstTypes + , datatypeVariant = dv + , datatypeCons = cons + } <- reifyDatatype dataName + case newtypeRepType dv cons of + Just newtypeRepTy -> + case etaReduce numArgsToEtaReduce newtypeRepTy of + Just etaRepTy -> + let repTySubst = + M.fromList $ + zipWith (\var arg -> (varTToName var, arg)) + dataInstTypes dataArgs + in return $ applySubstitution repTySubst etaRepTy + Nothing -> etaReductionError instanceTy + Nothing -> fail $ "Not a newtype: " ++ nameBase dataName + _ -> fail $ "Not a data type: " ++ pprint dataTy + concat . catMaybes <$> traverse (deriveViaDecs' clsName clsTvbs clsArgs repTy) clsDecs + (_, _) -> fail $ "Cannot derive instance for nullary class " ++ pprint clsTy + _ -> fail $ "Not a type class: " ++ pprint clsTy + _ -> fail $ "Malformed instance: " ++ pprint instanceTy + +deriveViaDecs' :: Name -> [TyVarBndrUnit] -> [Type] -> Type -> Dec -> Q (Maybe [Dec]) +deriveViaDecs' clsName clsTvbs clsArgs repTy dec = do + let numExpectedArgs = length clsTvbs + numActualArgs = length clsArgs + unless (numExpectedArgs == numActualArgs) $ + fail $ "Mismatched number of class arguments" + ++ "\n\tThe class " ++ nameBase clsName ++ " expects " ++ show numExpectedArgs ++ " argument(s)," + ++ "\n\tbut was provided " ++ show numActualArgs ++ " argument(s)." + go dec + where + go :: Dec -> Q (Maybe [Dec]) + + go (OpenTypeFamilyD (TypeFamilyHead tfName tfTvbs _ _)) = do + let lhsSubst = zipTvbSubst clsTvbs clsArgs + rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy + tfTvbTys = map tvbToType tfTvbs + tfLHSTys = map (applySubstitution lhsSubst) tfTvbTys + tfRHSTys = map (applySubstitution rhsSubst) tfTvbTys + tfRHSTy = applyTy (ConT tfName) tfRHSTys + tfInst <- tySynInstDCompat tfName Nothing + (map pure tfLHSTys) (pure tfRHSTy) + pure (Just [tfInst]) + + go (SigD methName methTy) = + let (fromTy, toTy) = mkCoerceClassMethEqn clsTvbs clsArgs repTy $ + stripOuterForallT methTy + fromTau = stripOuterForallT fromTy + toTau = stripOuterForallT toTy + rhsExpr = VarE coerceValName `AppTypeE` fromTau + `AppTypeE` toTau + `AppE` VarE methName + sig = SigD methName toTy + meth = ValD (VarP methName) + (NormalB rhsExpr) + [] + in return (Just [sig, meth]) + + go _ = return Nothing + +mkCoerceClassMethEqn :: [TyVarBndrUnit] -> [Type] -> Type -> Type -> (Type, Type) +mkCoerceClassMethEqn clsTvbs clsArgs repTy methTy + = ( applySubstitution rhsSubst methTy + , applySubstitution lhsSubst methTy + ) + where + lhsSubst = zipTvbSubst clsTvbs clsArgs + rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy + +zipTvbSubst :: [TyVarBndr_ flag] -> [Type] -> Map Name Type +zipTvbSubst tvbs = M.fromList . zipWith (\tvb ty -> (tvName tvb, ty)) tvbs + +-- | Replace the last element of a list with another element. +changeLast :: [a] -> a -> [a] +changeLast [] _ = error "changeLast" +changeLast [_] x = [x] +changeLast (x:xs) x' = x : changeLast xs x' + +stripOuterForallT :: Type -> Type +#if __GLASGOW_HASKELL__ < 807 +-- Before GHC 8.7, TH-reified classes would put a redundant forall/class +-- context in front of each method's type signature, so we have to strip them +-- off here. +stripOuterForallT (ForallT _ _ ty) = ty +#endif +stripOuterForallT ty = ty + +decomposeType :: Type -> ([TyVarBndrSpec], Cxt, Type) +decomposeType (ForallT tvbs ctxt ty) = (tvbs, ctxt, ty) +decomposeType ty = ([], [], ty) + +newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type +newtypeRepType dv cons = do + checkIfNewtype + case cons of + [ConstructorInfo { constructorVars = [] + , constructorContext = [] + , constructorFields = [repTy] + }] -> Just repTy + _ -> Nothing + where + checkIfNewtype :: Maybe () + checkIfNewtype + | Newtype <- dv = Just () + | NewtypeInstance <- dv = Just () + | otherwise = Nothing + +etaReduce :: Int -> Type -> Maybe Type +etaReduce num ty = + let (tyHead, tyArgs) = unapplyTy ty + (tyArgsRemaining, tyArgsDropped) = splitAt (length tyArgs - num) tyArgs + in if canEtaReduce tyArgsRemaining tyArgsDropped + then Just $ applyTy tyHead tyArgsRemaining + else Nothing +#endif diff --git a/src/Data/Enum/Deriving.hs b/src/Data/Enum/Deriving.hs --- a/src/Data/Enum/Deriving.hs +++ b/src/Data/Enum/Deriving.hs @@ -1,34 +1,34 @@ -{-| -Module: Data.Enum.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Enum' instances. --} -module Data.Enum.Deriving ( - -- * 'Enum' - deriveEnum - , makeSucc - , makePred - , makeToEnum - , makeFromEnum - , makeEnumFrom - , makeEnumFromThen - -- * 'deriveEnum' limitations - -- $constraints - ) where - -import Data.Enum.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @*@ are assumed to have 'Enum' constraints. - If this is not desirable, use 'makeToEnum' or one of its cousins. - -* Generated 'Enum' instances for poly-kinded data family instances are likely - to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. --} +{-| +Module: Data.Enum.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Enum' instances. +-} +module Data.Enum.Deriving ( + -- * 'Enum' + deriveEnum + , makeSucc + , makePred + , makeToEnum + , makeFromEnum + , makeEnumFrom + , makeEnumFromThen + -- * 'deriveEnum' limitations + -- $constraints + ) where + +import Data.Enum.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Enum' constraints. + If this is not desirable, use 'makeToEnum' or one of its cousins. + +* Generated 'Enum' instances for poly-kinded data family instances are likely + to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. +-} diff --git a/src/Data/Enum/Deriving/Internal.hs b/src/Data/Enum/Deriving/Internal.hs --- a/src/Data/Enum/Deriving/Internal.hs +++ b/src/Data/Enum/Deriving/Internal.hs @@ -1,253 +1,253 @@ -{-| -Module: Data.Enum.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Enum' instances. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Enum.Deriving.Internal ( - -- * 'Enum' - deriveEnum - , makeSucc - , makePred - , makeToEnum - , makeFromEnum - , makeEnumFrom - , makeEnumFromThen - ) where - -import Data.Deriving.Internal - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Generates an 'Enum' instance declaration for the given data type or data --- family instance. -deriveEnum :: Name -> Q [Dec] -deriveEnum name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance EnumClass parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (enumFunDecs parentName instanceType cons) - --- | Generates a lambda expression which behaves like 'succ' (without --- requiring an 'Enum' instance). -makeSucc :: Name -> Q Exp -makeSucc = makeEnumFun Succ - --- | Generates a lambda expression which behaves like 'pred' (without --- requiring an 'Enum' instance). -makePred :: Name -> Q Exp -makePred = makeEnumFun Pred - --- | Generates a lambda expression which behaves like 'toEnum' (without --- requiring an 'Enum' instance). -makeToEnum :: Name -> Q Exp -makeToEnum = makeEnumFun ToEnum - --- | Generates a lambda expression which behaves like 'fromEnum' (without --- requiring an 'Enum' instance). -makeFromEnum :: Name -> Q Exp -makeFromEnum = makeEnumFun FromEnum - --- | Generates a lambda expression which behaves like 'enumFrom' (without --- requiring an 'Enum' instance). -makeEnumFrom :: Name -> Q Exp -makeEnumFrom = makeEnumFun EnumFrom - --- | Generates a lambda expression which behaves like 'enumFromThen' (without --- requiring an 'Enum' instance). -makeEnumFromThen :: Name -> Q Exp -makeEnumFromThen = makeEnumFun EnumFromThen - --- | Generates method declarations for an 'Enum' instance. -enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] -enumFunDecs tyName ty cons = - map makeFunD [ Succ - , Pred - , ToEnum - , EnumFrom - , EnumFromThen - , FromEnum - ] - where - makeFunD :: EnumFun -> Q Dec - makeFunD ef = - funD (enumFunName ef) - [ clause [] - (normalB $ makeEnumFunForCons ef tyName ty cons) - [] - ] - --- | Generates a lambda expression which behaves like the EnumFun argument. -makeEnumFun :: EnumFun -> Name -> Q Exp -makeEnumFun ef name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (_, instanceType) <- buildTypeInstance EnumClass parentName ctxt instTypes variant - makeEnumFunForCons ef parentName instanceType cons - --- | Generates a lambda expression for fromEnum/toEnum/etc. for the --- given constructors. All constructors must be from the same type. -makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp -makeEnumFunForCons _ _ _ [] = noConstructorsError -makeEnumFunForCons ef tyName ty cons - | not $ isEnumerationType cons - = enumerationError tyNameBase - | otherwise = case ef of - Succ -> lamOneHash $ \aHash -> - condE (varE eqValName `appE` maxTagExpr `appE` - (conE iHashDataName `appE` varE aHash)) - (illegalExpr "succ" tyNameBase - "tried to take `succ' of last tag in enumeration") - (tag2Con `appE` (varE plusValName `appE` - (conE iHashDataName `appE` varE aHash) `appE` integerE 1)) - - Pred -> lamOneHash $ \aHash -> - condE (varE eqValName `appE` integerE 0 `appE` - (conE iHashDataName `appE` varE aHash)) - (illegalExpr "pred" tyNameBase - "tried to take `pred' of first tag in enumeration") - (tag2Con `appE` (varE plusValName `appE` - (conE iHashDataName `appE` varE aHash) `appE` integerE (-1))) - - ToEnum -> lamOne $ \a -> - condE (appsE [ varE andValName - , varE geValName `appE` varE a `appE` integerE 0 - , varE leValName `appE` varE a `appE` maxTagExpr - ]) - (tag2Con `appE` varE a) - (illegalToEnumTag tyNameBase maxTagExpr a) - - EnumFrom -> lamOneHash $ \aHash -> - appsE [ varE mapValName - , tag2Con - , enumFromToExpr (conE iHashDataName `appE` varE aHash) maxTagExpr - ] - - EnumFromThen -> do - a <- newName "a" - aHash <- newName "a#" - b <- newName "b" - bHash <- newName "b#" - lamE [varP a, varP b] $ untagExpr [(a, aHash), (b, bHash)] $ - appE (varE mapValName `appE` tag2Con) $ - enumFromThenToExpr - (conE iHashDataName `appE` varE aHash) - (conE iHashDataName `appE` varE bHash) - (condE (appsE [ varE gtValName - , conE iHashDataName `appE` varE aHash - , conE iHashDataName `appE` varE bHash - ]) - (integerE 0) maxTagExpr) - - FromEnum -> lamOneHash $ \aHash -> - conE iHashDataName `appE` varE aHash - - where - tyNameBase :: String - tyNameBase = nameBase tyName - - maxTagExpr :: Q Exp - maxTagExpr = integerE (length cons - 1) `sigE` conT intTypeName - - lamOne :: (Name -> Q Exp) -> Q Exp - lamOne f = do - a <- newName "a" - lam1E (varP a) $ f a - - lamOneHash :: (Name -> Q Exp) -> Q Exp - lamOneHash f = lamOne $ \a -> do - aHash <- newName "a#" - untagExpr [(a, aHash)] $ f aHash - - tag2Con :: Q Exp - tag2Con = tag2ConExpr $ removeClassApp ty - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- There's only one Enum variant! -data EnumClass = EnumClass - -instance ClassRep EnumClass where - arity _ = 0 - - allowExQuant _ = True - - fullClassName _ = enumTypeName - - classConstraint _ 0 = Just $ enumTypeName - classConstraint _ _ = Nothing - --- | A representation of which function is being generated. -data EnumFun = Succ - | Pred - | ToEnum - | FromEnum - | EnumFrom - | EnumFromThen - deriving Show - -enumFunName :: EnumFun -> Name -enumFunName Succ = succValName -enumFunName Pred = predValName -enumFunName ToEnum = toEnumValName -enumFunName FromEnum = fromEnumValName -enumFunName EnumFrom = enumFromValName -enumFunName EnumFromThen = enumFromThenValName - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - -enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp -enumFromThenToExpr f t1 t2 = varE enumFromThenToValName `appE` f `appE` t1 `appE` t2 - -illegalExpr :: String -> String -> String -> Q Exp -illegalExpr meth tp msg = - varE errorValName `appE` stringE (meth ++ '{':tp ++ "}: " ++ msg) - -illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp -illegalToEnumTag tp maxtag a = - appE (varE errorValName) - (appE (appE (varE appendValName) - (stringE ("toEnum{" ++ tp ++ "}: tag("))) - (appE (appE (appE - (varE showsPrecValName) - (integerE 0)) - (varE a)) - (appE (appE - (varE appendValName) - (stringE ") is outside of enumeration's range (0,")) - (appE (appE (appE - (varE showsPrecValName) - (integerE 0)) - maxtag) - (stringE ")"))))) +{-| +Module: Data.Enum.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Enum' instances. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Enum.Deriving.Internal ( + -- * 'Enum' + deriveEnum + , makeSucc + , makePred + , makeToEnum + , makeFromEnum + , makeEnumFrom + , makeEnumFromThen + ) where + +import Data.Deriving.Internal + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Generates an 'Enum' instance declaration for the given data type or data +-- family instance. +deriveEnum :: Name -> Q [Dec] +deriveEnum name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance EnumClass parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (enumFunDecs parentName instanceType cons) + +-- | Generates a lambda expression which behaves like 'succ' (without +-- requiring an 'Enum' instance). +makeSucc :: Name -> Q Exp +makeSucc = makeEnumFun Succ + +-- | Generates a lambda expression which behaves like 'pred' (without +-- requiring an 'Enum' instance). +makePred :: Name -> Q Exp +makePred = makeEnumFun Pred + +-- | Generates a lambda expression which behaves like 'toEnum' (without +-- requiring an 'Enum' instance). +makeToEnum :: Name -> Q Exp +makeToEnum = makeEnumFun ToEnum + +-- | Generates a lambda expression which behaves like 'fromEnum' (without +-- requiring an 'Enum' instance). +makeFromEnum :: Name -> Q Exp +makeFromEnum = makeEnumFun FromEnum + +-- | Generates a lambda expression which behaves like 'enumFrom' (without +-- requiring an 'Enum' instance). +makeEnumFrom :: Name -> Q Exp +makeEnumFrom = makeEnumFun EnumFrom + +-- | Generates a lambda expression which behaves like 'enumFromThen' (without +-- requiring an 'Enum' instance). +makeEnumFromThen :: Name -> Q Exp +makeEnumFromThen = makeEnumFun EnumFromThen + +-- | Generates method declarations for an 'Enum' instance. +enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] +enumFunDecs tyName ty cons = + map makeFunD [ Succ + , Pred + , ToEnum + , EnumFrom + , EnumFromThen + , FromEnum + ] + where + makeFunD :: EnumFun -> Q Dec + makeFunD ef = + funD (enumFunName ef) + [ clause [] + (normalB $ makeEnumFunForCons ef tyName ty cons) + [] + ] + +-- | Generates a lambda expression which behaves like the EnumFun argument. +makeEnumFun :: EnumFun -> Name -> Q Exp +makeEnumFun ef name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (_, instanceType) <- buildTypeInstance EnumClass parentName ctxt instTypes variant + makeEnumFunForCons ef parentName instanceType cons + +-- | Generates a lambda expression for fromEnum/toEnum/etc. for the +-- given constructors. All constructors must be from the same type. +makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp +makeEnumFunForCons _ _ _ [] = noConstructorsError +makeEnumFunForCons ef tyName ty cons + | not $ isEnumerationType cons + = enumerationError tyNameBase + | otherwise = case ef of + Succ -> lamOneHash $ \aHash -> + condE (varE eqValName `appE` maxTagExpr `appE` + (conE iHashDataName `appE` varE aHash)) + (illegalExpr "succ" tyNameBase + "tried to take `succ' of last tag in enumeration") + (tag2Con `appE` (varE plusValName `appE` + (conE iHashDataName `appE` varE aHash) `appE` integerE 1)) + + Pred -> lamOneHash $ \aHash -> + condE (varE eqValName `appE` integerE 0 `appE` + (conE iHashDataName `appE` varE aHash)) + (illegalExpr "pred" tyNameBase + "tried to take `pred' of first tag in enumeration") + (tag2Con `appE` (varE plusValName `appE` + (conE iHashDataName `appE` varE aHash) `appE` integerE (-1))) + + ToEnum -> lamOne $ \a -> + condE (appsE [ varE andValName + , varE geValName `appE` varE a `appE` integerE 0 + , varE leValName `appE` varE a `appE` maxTagExpr + ]) + (tag2Con `appE` varE a) + (illegalToEnumTag tyNameBase maxTagExpr a) + + EnumFrom -> lamOneHash $ \aHash -> + appsE [ varE mapValName + , tag2Con + , enumFromToExpr (conE iHashDataName `appE` varE aHash) maxTagExpr + ] + + EnumFromThen -> do + a <- newName "a" + aHash <- newName "a#" + b <- newName "b" + bHash <- newName "b#" + lamE [varP a, varP b] $ untagExpr [(a, aHash), (b, bHash)] $ + appE (varE mapValName `appE` tag2Con) $ + enumFromThenToExpr + (conE iHashDataName `appE` varE aHash) + (conE iHashDataName `appE` varE bHash) + (condE (appsE [ varE gtValName + , conE iHashDataName `appE` varE aHash + , conE iHashDataName `appE` varE bHash + ]) + (integerE 0) maxTagExpr) + + FromEnum -> lamOneHash $ \aHash -> + conE iHashDataName `appE` varE aHash + + where + tyNameBase :: String + tyNameBase = nameBase tyName + + maxTagExpr :: Q Exp + maxTagExpr = integerE (length cons - 1) `sigE` conT intTypeName + + lamOne :: (Name -> Q Exp) -> Q Exp + lamOne f = do + a <- newName "a" + lam1E (varP a) $ f a + + lamOneHash :: (Name -> Q Exp) -> Q Exp + lamOneHash f = lamOne $ \a -> do + aHash <- newName "a#" + untagExpr [(a, aHash)] $ f aHash + + tag2Con :: Q Exp + tag2Con = tag2ConExpr $ removeClassApp ty + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- There's only one Enum variant! +data EnumClass = EnumClass + +instance ClassRep EnumClass where + arity _ = 0 + + allowExQuant _ = True + + fullClassName _ = enumTypeName + + classConstraint _ 0 = Just $ enumTypeName + classConstraint _ _ = Nothing + +-- | A representation of which function is being generated. +data EnumFun = Succ + | Pred + | ToEnum + | FromEnum + | EnumFrom + | EnumFromThen + deriving Show + +enumFunName :: EnumFun -> Name +enumFunName Succ = succValName +enumFunName Pred = predValName +enumFunName ToEnum = toEnumValName +enumFunName FromEnum = fromEnumValName +enumFunName EnumFrom = enumFromValName +enumFunName EnumFromThen = enumFromThenValName + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp +enumFromThenToExpr f t1 t2 = varE enumFromThenToValName `appE` f `appE` t1 `appE` t2 + +illegalExpr :: String -> String -> String -> Q Exp +illegalExpr meth tp msg = + varE errorValName `appE` stringE (meth ++ '{':tp ++ "}: " ++ msg) + +illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp +illegalToEnumTag tp maxtag a = + appE (varE errorValName) + (appE (appE (varE appendValName) + (stringE ("toEnum{" ++ tp ++ "}: tag("))) + (appE (appE (appE + (varE showsPrecValName) + (integerE 0)) + (varE a)) + (appE (appE + (varE appendValName) + (stringE ") is outside of enumeration's range (0,")) + (appE (appE (appE + (varE showsPrecValName) + (integerE 0)) + maxtag) + (stringE ")"))))) diff --git a/src/Data/Eq/Deriving.hs b/src/Data/Eq/Deriving.hs --- a/src/Data/Eq/Deriving.hs +++ b/src/Data/Eq/Deriving.hs @@ -1,55 +1,55 @@ -{-# LANGUAGE CPP #-} -{-| -Module: Data.Eq.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. -Note that upstream GHC does not have the ability to derive 'Eq1' or 'Eq2' -instances, but since the functionality to derive 'Eq' extends very naturally -'Eq1' and 'Eq2', the ability to derive the latter two classes is provided as a -convenience. --} -module Data.Eq.Deriving ( - -- * 'Eq' - deriveEq - , makeEq - , makeNotEq - -- * 'Eq1' - , deriveEq1 -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftEq -#endif - , makeEq1 -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Eq2' - , deriveEq2 - , makeLiftEq2 - , makeEq2 -#endif - -- * 'deriveEq' limitations - -- $constraints - ) where - -import Data.Eq.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @*@ are assumed to have 'Eq' constraints. - Type variables of kind @* -> *@ are assumed to have 'Eq1' constraints. - Type variables of kind @* -> * -> *@ are assumed to have 'Eq2' constraints. - If this is not desirable, use 'makeEq' or one of its cousins. - -* The 'Eq1' class had a different definition in @transformers-0.4@, and as a result, - 'deriveEq1' implements different instances for the @transformers-0.4@ 'Eq1' than - it otherwise does. Also, 'makeLiftEq' is not available - when this library is built against @transformers-0.4@, only 'makeEq1. - -* The 'Eq2' class is not available in @transformers-0.4@, and as a - result, neither are Template Haskell functions that deal with 'Eq2' when this - library is built against @transformers-0.4@. --} +{-# LANGUAGE CPP #-} +{-| +Module: Data.Eq.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. +Note that upstream GHC does not have the ability to derive 'Eq1' or 'Eq2' +instances, but since the functionality to derive 'Eq' extends very naturally +'Eq1' and 'Eq2', the ability to derive the latter two classes is provided as a +convenience. +-} +module Data.Eq.Deriving ( + -- * 'Eq' + deriveEq + , makeEq + , makeNotEq + -- * 'Eq1' + , deriveEq1 +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftEq +#endif + , makeEq1 +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Eq2' + , deriveEq2 + , makeLiftEq2 + , makeEq2 +#endif + -- * 'deriveEq' limitations + -- $constraints + ) where + +import Data.Eq.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Eq' constraints. + Type variables of kind @* -> *@ are assumed to have 'Eq1' constraints. + Type variables of kind @* -> * -> *@ are assumed to have 'Eq2' constraints. + If this is not desirable, use 'makeEq' or one of its cousins. + +* The 'Eq1' class had a different definition in @transformers-0.4@, and as a result, + 'deriveEq1' implements different instances for the @transformers-0.4@ 'Eq1' than + it otherwise does. Also, 'makeLiftEq' is not available + when this library is built against @transformers-0.4@, only 'makeEq1. + +* The 'Eq2' class is not available in @transformers-0.4@, and as a + result, neither are Template Haskell functions that deal with 'Eq2' when this + library is built against @transformers-0.4@. +-} diff --git a/src/Data/Eq/Deriving/Internal.hs b/src/Data/Eq/Deriving/Internal.hs --- a/src/Data/Eq/Deriving/Internal.hs +++ b/src/Data/Eq/Deriving/Internal.hs @@ -1,410 +1,410 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} - -{-| -Module: Data.Eq.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Eq.Deriving.Internal ( - -- * 'Eq' - deriveEq - , makeEq - , makeNotEq - -- * 'Eq1' - , deriveEq1 -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftEq -#endif - , makeEq1 -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Eq2' - , deriveEq2 - , makeLiftEq2 - , makeEq2 -#endif - ) where - -import Data.Deriving.Internal -import Data.List (foldl1') -import qualified Data.Map as Map - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- | Generates an 'Eq' instance declaration for the given data type or data --- family instance. -deriveEq :: Name -> Q [Dec] -deriveEq = deriveEqClass Eq - --- | Generates a lambda expression which behaves like '(==)' (without --- requiring an 'Eq' instance). -makeEq :: Name -> Q Exp -makeEq = makeEqClass Eq - --- | Generates a lambda expression which behaves like '(/=)' (without --- requiring an 'Eq' instance). -makeNotEq :: Name -> Q Exp -makeNotEq name = do - x1 <- newName "x1" - x2 <- newName "x2" - lamE [varP x1, varP x2] $ varE notValName `appE` - (makeEq name `appE` varE x1 `appE` varE x2) - --- | Generates an 'Eq1' instance declaration for the given data type or data --- family instance. -deriveEq1 :: Name -> Q [Dec] -deriveEq1 = deriveEqClass Eq1 - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates a lambda expression which behaves like 'liftEq' (without --- requiring an 'Eq1' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftEq :: Name -> Q Exp -makeLiftEq = makeEqClass Eq1 - --- | Generates a lambda expression which behaves like 'eq1' (without --- requiring an 'Eq1' instance). -makeEq1 :: Name -> Q Exp -makeEq1 name = makeLiftEq name `appE` varE eqValName -#else --- | Generates a lambda expression which behaves like 'eq1' (without --- requiring an 'Eq1' instance). -makeEq1 :: Name -> Q Exp -makeEq1 = makeEqClass Eq1 -#endif - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates an 'Eq2' instance declaration for the given data type or data --- family instance. --- --- This function is not available with @transformers-0.4@. -deriveEq2 :: Name -> Q [Dec] -deriveEq2 = deriveEqClass Eq2 - --- | Generates a lambda expression which behaves like 'liftEq2' (without --- requiring an 'Eq2' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftEq2 :: Name -> Q Exp -makeLiftEq2 = makeEqClass Eq2 - --- | Generates a lambda expression which behaves like 'eq2' (without --- requiring an 'Eq2' instance). --- --- This function is not available with @transformers-0.4@. -makeEq2 :: Name -> Q Exp -makeEq2 name = makeLiftEq name `appE` varE eqValName `appE` varE eqValName -#endif - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Derive an Eq(1)(2) instance declaration (depending on the EqClass --- argument's value). -deriveEqClass :: EqClass -> Name -> Q [Dec] -deriveEqClass eClass name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance eClass parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (eqDecs eClass instTypes cons) - --- | Generates a declaration defining the primary function corresponding to a --- particular class ((==) for Eq, liftEq for Eq1, and --- liftEq2 for Eq2). -eqDecs :: EqClass -> [Type] -> [ConstructorInfo] -> [Q Dec] -eqDecs eClass instTypes cons = - [ funD (eqName eClass) - [ clause [] - (normalB $ makeEqForCons eClass instTypes cons) - [] - ] - ] - --- | Generates a lambda expression which behaves like (==) (for Eq), --- liftEq (for Eq1), or liftEq2 (for Eq2). -makeEqClass :: EqClass -> Name -> Q Exp -makeEqClass eClass name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have (==)/liftEq/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance eClass parentName ctxt instTypes variant - >> makeEqForCons eClass instTypes cons - --- | Generates a lambda expression for (==)/liftEq/etc. for the --- given constructors. All constructors must be from the same type. -makeEqForCons :: EqClass -> [Type] -> [ConstructorInfo] -> Q Exp -makeEqForCons eClass instTypes cons = do - value1 <- newName "value1" - value2 <- newName "value2" - eqDefn <- newName "eqDefn" - eqs <- newNameList "eq" $ arity eClass - - let lastTyVars = map varTToName $ drop (length instTypes - fromEnum eClass) instTypes - tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars eqs - - lamE (map varP $ -#if defined(NEW_FUNCTOR_CLASSES) - eqs ++ -#endif - [value1, value2] - ) . appsE - $ [ varE $ eqConstName eClass - , letE [ funD eqDefn [eqClause tvMap] - ] $ varE eqDefn `appE` varE value1 `appE` varE value2 - ] -#if defined(NEW_FUNCTOR_CLASSES) - ++ map varE eqs -#endif - ++ [varE value1, varE value2] - where - nonNullaryCons :: [ConstructorInfo] - nonNullaryCons = filter (not . isNullaryCon) cons - - numNonNullaryCons :: Int - numNonNullaryCons = length nonNullaryCons - - eqClause :: TyVarMap1 -> Q Clause - eqClause tvMap - | null cons - = makeFallThroughCaseTrue - -- Tag checking is redundant when there is only one data constructor - | [con] <- cons - = makeCaseForCon eClass tvMap con - -- This is an enum (all constructors are nullary) - just do a simple tag check - | all isNullaryCon cons - = makeTagCase - | otherwise - = do abNames@(a, _, b, _) <- newABNames - clause (map varP [a,b]) - (normalB $ eqExprWithTagCheck tvMap abNames) - [] - - eqExprWithTagCheck :: TyVarMap1 -> (Name, Name, Name, Name) -> Q Exp - eqExprWithTagCheck tvMap (a, aHash, b, bHash) = - condE (untagExpr [(a, aHash), (b, bHash)] - (primOpAppExpr (varE aHash) neqIntHashValName (varE bHash))) - (conE falseDataName) - (caseE (varE a) - (map (mkNestedMatchesForCon eClass tvMap b) nonNullaryCons - ++ [ makeFallThroughMatchTrue - | 0 < numNonNullaryCons && numNonNullaryCons < length cons - ])) - -newABNames :: Q (Name, Name, Name, Name) -newABNames = do - a <- newName "a" - aHash <- newName "a#" - b <- newName "b" - bHash <- newName "b#" - return (a, aHash, b, bHash) - -makeTagCase :: Q Clause -makeTagCase = do - (a, aHash, b, bHash) <- newABNames - clause (map varP [a,b]) - (normalB $ untagExpr [(a, aHash), (b, bHash)] $ - primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) [] - -makeFallThroughCaseTrue :: Q Clause -makeFallThroughCaseTrue = clause [wildP, wildP] (normalB $ conE trueDataName) [] - -makeFallThroughMatchFalse, makeFallThroughMatchTrue :: Q Match -makeFallThroughMatchFalse = makeFallThroughMatch falseDataName -makeFallThroughMatchTrue = makeFallThroughMatch trueDataName - -makeFallThroughMatch :: Name -> Q Match -makeFallThroughMatch dataName = match wildP (normalB $ conE dataName) [] - -makeCaseForCon :: EqClass -> TyVarMap1 -> ConstructorInfo -> Q Clause -makeCaseForCon eClass tvMap - (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do - ts' <- mapM resolveTypeSynonyms ts - let tsLen = length ts' - as <- newNameList "a" tsLen - bs <- newNameList "b" tsLen - clause [conP conName (map varP as), conP conName (map varP bs)] - (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) - [] - -mkNestedMatchesForCon :: EqClass -> TyVarMap1 -> Name -> ConstructorInfo -> Q Match -mkNestedMatchesForCon eClass tvMap b - (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do - ts' <- mapM resolveTypeSynonyms ts - let tsLen = length ts' - as <- newNameList "a" tsLen - bs <- newNameList "b" tsLen - match (conP conName (map varP as)) - (normalB $ caseE (varE b) - [ match (conP conName (map varP bs)) - (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) - [] - , makeFallThroughMatchFalse - ]) - [] - -makeCaseForArgs :: EqClass - -> TyVarMap1 - -> Name - -> [Type] - -> [Name] - -> [Name] - -> Q Exp -makeCaseForArgs _ _ _ [] [] [] = conE trueDataName -makeCaseForArgs eClass tvMap conName tys as bs = - foldl1' (\q e -> infixApp q (varE andValName) e) - (zipWith3 (makeCaseForArg eClass tvMap conName) tys as bs) - -makeCaseForArg :: EqClass - -> TyVarMap1 - -> Name - -> Type - -> Name - -> Name - -> Q Exp -makeCaseForArg _ _ _ (ConT tyName) a b = primEqExpr - where - aExpr, bExpr :: Q Exp - aExpr = varE a - bExpr = varE b - - makePrimEqExpr :: Name -> Q Exp - makePrimEqExpr n = primOpAppExpr aExpr n bExpr - - primEqExpr :: Q Exp - primEqExpr = - case Map.lookup tyName primOrdFunTbl of - Just (_, _, eq, _, _) -> makePrimEqExpr eq - Nothing -> infixApp aExpr (varE eqValName) bExpr -makeCaseForArg eClass tvMap conName ty a b = - makeCaseForType eClass tvMap conName ty `appE` varE a `appE` varE b - -makeCaseForType :: EqClass - -> TyVarMap1 - -> Name - -> Type - -> Q Exp -#if defined(NEW_FUNCTOR_CLASSES) -makeCaseForType _ tvMap _ (VarT tyName) = - varE $ case Map.lookup tyName tvMap of - Just (OneName eq) -> eq - Nothing -> eqValName -#else -makeCaseForType _ _ _ VarT{} = varE eqValName -#endif -makeCaseForType eClass tvMap conName (SigT ty _) = makeCaseForType eClass tvMap conName ty -makeCaseForType eClass tvMap conName (ForallT _ _ ty) = makeCaseForType eClass tvMap conName ty -#if defined(NEW_FUNCTOR_CLASSES) -makeCaseForType eClass tvMap conName ty = do - let tyCon :: Type - tyArgs :: [Type] - (tyCon, tyArgs) = unapplyTy ty - - numLastArgs :: Int - numLastArgs = min (arity eClass) (length tyArgs) - - lhsArgs, rhsArgs :: [Type] - (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - - tyVarNames :: [Name] - tyVarNames = Map.keys tvMap - - itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs - if any (`mentionsName` tyVarNames) lhsArgs - || itf && any (`mentionsName` tyVarNames) tyArgs - then outOfPlaceTyVarError eClass conName - else if any (`mentionsName` tyVarNames) rhsArgs - then appsE $ [ varE . eqName $ toEnum numLastArgs] - ++ map (makeCaseForType eClass tvMap conName) rhsArgs - else varE eqValName -#else -makeCaseForType eClass tvMap conName ty = do - let varNames = Map.keys tvMap - - a' <- newName "a'" - b' <- newName "b'" - case varNames of - [] -> varE eqValName - varName:_ -> - if mentionsName ty varNames - then lamE (map varP [a',b']) $ varE eq1ValName - `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE a') - `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE b') - else varE eqValName -#endif - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- | A representation of which @Eq@ variant is being derived. -data EqClass = Eq - | Eq1 -#if defined(NEW_FUNCTOR_CLASSES) - | Eq2 -#endif - deriving (Bounded, Enum) - -instance ClassRep EqClass where - arity = fromEnum - - allowExQuant _ = True - - fullClassName Eq = eqTypeName - fullClassName Eq1 = eq1TypeName -#if defined(NEW_FUNCTOR_CLASSES) - fullClassName Eq2 = eq2TypeName -#endif - - classConstraint eClass i - | eMin <= i && i <= eMax = Just $ fullClassName (toEnum i :: EqClass) - | otherwise = Nothing - where - eMin, eMax :: Int - eMin = fromEnum (minBound :: EqClass) - eMax = fromEnum eClass - -eqConstName :: EqClass -> Name -eqConstName Eq = eqConstValName -#if defined(NEW_FUNCTOR_CLASSES) -eqConstName Eq1 = liftEqConstValName -eqConstName Eq2 = liftEq2ConstValName -#else -eqConstName Eq1 = eq1ConstValName -#endif - -eqName :: EqClass -> Name -eqName Eq = eqValName -#if defined(NEW_FUNCTOR_CLASSES) -eqName Eq1 = liftEqValName -eqName Eq2 = liftEq2ValName -#else -eqName Eq1 = eq1ValName -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} + +{-| +Module: Data.Eq.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Eq.Deriving.Internal ( + -- * 'Eq' + deriveEq + , makeEq + , makeNotEq + -- * 'Eq1' + , deriveEq1 +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftEq +#endif + , makeEq1 +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Eq2' + , deriveEq2 + , makeLiftEq2 + , makeEq2 +#endif + ) where + +import Data.Deriving.Internal +import Data.List (foldl1') +import qualified Data.Map as Map + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +-- | Generates an 'Eq' instance declaration for the given data type or data +-- family instance. +deriveEq :: Name -> Q [Dec] +deriveEq = deriveEqClass Eq + +-- | Generates a lambda expression which behaves like '(==)' (without +-- requiring an 'Eq' instance). +makeEq :: Name -> Q Exp +makeEq = makeEqClass Eq + +-- | Generates a lambda expression which behaves like '(/=)' (without +-- requiring an 'Eq' instance). +makeNotEq :: Name -> Q Exp +makeNotEq name = do + x1 <- newName "x1" + x2 <- newName "x2" + lamE [varP x1, varP x2] $ varE notValName `appE` + (makeEq name `appE` varE x1 `appE` varE x2) + +-- | Generates an 'Eq1' instance declaration for the given data type or data +-- family instance. +deriveEq1 :: Name -> Q [Dec] +deriveEq1 = deriveEqClass Eq1 + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a lambda expression which behaves like 'liftEq' (without +-- requiring an 'Eq1' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftEq :: Name -> Q Exp +makeLiftEq = makeEqClass Eq1 + +-- | Generates a lambda expression which behaves like 'eq1' (without +-- requiring an 'Eq1' instance). +makeEq1 :: Name -> Q Exp +makeEq1 name = makeLiftEq name `appE` varE eqValName +#else +-- | Generates a lambda expression which behaves like 'eq1' (without +-- requiring an 'Eq1' instance). +makeEq1 :: Name -> Q Exp +makeEq1 = makeEqClass Eq1 +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates an 'Eq2' instance declaration for the given data type or data +-- family instance. +-- +-- This function is not available with @transformers-0.4@. +deriveEq2 :: Name -> Q [Dec] +deriveEq2 = deriveEqClass Eq2 + +-- | Generates a lambda expression which behaves like 'liftEq2' (without +-- requiring an 'Eq2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftEq2 :: Name -> Q Exp +makeLiftEq2 = makeEqClass Eq2 + +-- | Generates a lambda expression which behaves like 'eq2' (without +-- requiring an 'Eq2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeEq2 :: Name -> Q Exp +makeEq2 name = makeLiftEq name `appE` varE eqValName `appE` varE eqValName +#endif + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Derive an Eq(1)(2) instance declaration (depending on the EqClass +-- argument's value). +deriveEqClass :: EqClass -> Name -> Q [Dec] +deriveEqClass eClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance eClass parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (eqDecs eClass instTypes cons) + +-- | Generates a declaration defining the primary function corresponding to a +-- particular class ((==) for Eq, liftEq for Eq1, and +-- liftEq2 for Eq2). +eqDecs :: EqClass -> [Type] -> [ConstructorInfo] -> [Q Dec] +eqDecs eClass instTypes cons = + [ funD (eqName eClass) + [ clause [] + (normalB $ makeEqForCons eClass instTypes cons) + [] + ] + ] + +-- | Generates a lambda expression which behaves like (==) (for Eq), +-- liftEq (for Eq1), or liftEq2 (for Eq2). +makeEqClass :: EqClass -> Name -> Q Exp +makeEqClass eClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have (==)/liftEq/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance eClass parentName ctxt instTypes variant + >> makeEqForCons eClass instTypes cons + +-- | Generates a lambda expression for (==)/liftEq/etc. for the +-- given constructors. All constructors must be from the same type. +makeEqForCons :: EqClass -> [Type] -> [ConstructorInfo] -> Q Exp +makeEqForCons eClass instTypes cons = do + value1 <- newName "value1" + value2 <- newName "value2" + eqDefn <- newName "eqDefn" + eqs <- newNameList "eq" $ arity eClass + + let lastTyVars = map varTToName $ drop (length instTypes - fromEnum eClass) instTypes + tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars eqs + + lamE (map varP $ +#if defined(NEW_FUNCTOR_CLASSES) + eqs ++ +#endif + [value1, value2] + ) . appsE + $ [ varE $ eqConstName eClass + , letE [ funD eqDefn [eqClause tvMap] + ] $ varE eqDefn `appE` varE value1 `appE` varE value2 + ] +#if defined(NEW_FUNCTOR_CLASSES) + ++ map varE eqs +#endif + ++ [varE value1, varE value2] + where + nonNullaryCons :: [ConstructorInfo] + nonNullaryCons = filter (not . isNullaryCon) cons + + numNonNullaryCons :: Int + numNonNullaryCons = length nonNullaryCons + + eqClause :: TyVarMap1 -> Q Clause + eqClause tvMap + | null cons + = makeFallThroughCaseTrue + -- Tag checking is redundant when there is only one data constructor + | [con] <- cons + = makeCaseForCon eClass tvMap con + -- This is an enum (all constructors are nullary) - just do a simple tag check + | all isNullaryCon cons + = makeTagCase + | otherwise + = do abNames@(a, _, b, _) <- newABNames + clause (map varP [a,b]) + (normalB $ eqExprWithTagCheck tvMap abNames) + [] + + eqExprWithTagCheck :: TyVarMap1 -> (Name, Name, Name, Name) -> Q Exp + eqExprWithTagCheck tvMap (a, aHash, b, bHash) = + condE (untagExpr [(a, aHash), (b, bHash)] + (primOpAppExpr (varE aHash) neqIntHashValName (varE bHash))) + (conE falseDataName) + (caseE (varE a) + (map (mkNestedMatchesForCon eClass tvMap b) nonNullaryCons + ++ [ makeFallThroughMatchTrue + | 0 < numNonNullaryCons && numNonNullaryCons < length cons + ])) + +newABNames :: Q (Name, Name, Name, Name) +newABNames = do + a <- newName "a" + aHash <- newName "a#" + b <- newName "b" + bHash <- newName "b#" + return (a, aHash, b, bHash) + +makeTagCase :: Q Clause +makeTagCase = do + (a, aHash, b, bHash) <- newABNames + clause (map varP [a,b]) + (normalB $ untagExpr [(a, aHash), (b, bHash)] $ + primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) [] + +makeFallThroughCaseTrue :: Q Clause +makeFallThroughCaseTrue = clause [wildP, wildP] (normalB $ conE trueDataName) [] + +makeFallThroughMatchFalse, makeFallThroughMatchTrue :: Q Match +makeFallThroughMatchFalse = makeFallThroughMatch falseDataName +makeFallThroughMatchTrue = makeFallThroughMatch trueDataName + +makeFallThroughMatch :: Name -> Q Match +makeFallThroughMatch dataName = match wildP (normalB $ conE dataName) [] + +makeCaseForCon :: EqClass -> TyVarMap1 -> ConstructorInfo -> Q Clause +makeCaseForCon eClass tvMap + (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + let tsLen = length ts' + as <- newNameList "a" tsLen + bs <- newNameList "b" tsLen + clause [conP conName (map varP as), conP conName (map varP bs)] + (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) + [] + +mkNestedMatchesForCon :: EqClass -> TyVarMap1 -> Name -> ConstructorInfo -> Q Match +mkNestedMatchesForCon eClass tvMap b + (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + let tsLen = length ts' + as <- newNameList "a" tsLen + bs <- newNameList "b" tsLen + match (conP conName (map varP as)) + (normalB $ caseE (varE b) + [ match (conP conName (map varP bs)) + (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) + [] + , makeFallThroughMatchFalse + ]) + [] + +makeCaseForArgs :: EqClass + -> TyVarMap1 + -> Name + -> [Type] + -> [Name] + -> [Name] + -> Q Exp +makeCaseForArgs _ _ _ [] [] [] = conE trueDataName +makeCaseForArgs eClass tvMap conName tys as bs = + foldl1' (\q e -> infixApp q (varE andValName) e) + (zipWith3 (makeCaseForArg eClass tvMap conName) tys as bs) + +makeCaseForArg :: EqClass + -> TyVarMap1 + -> Name + -> Type + -> Name + -> Name + -> Q Exp +makeCaseForArg _ _ _ (ConT tyName) a b = primEqExpr + where + aExpr, bExpr :: Q Exp + aExpr = varE a + bExpr = varE b + + makePrimEqExpr :: Name -> Q Exp + makePrimEqExpr n = primOpAppExpr aExpr n bExpr + + primEqExpr :: Q Exp + primEqExpr = + case Map.lookup tyName primOrdFunTbl of + Just (_, _, eq, _, _) -> makePrimEqExpr eq + Nothing -> infixApp aExpr (varE eqValName) bExpr +makeCaseForArg eClass tvMap conName ty a b = + makeCaseForType eClass tvMap conName ty `appE` varE a `appE` varE b + +makeCaseForType :: EqClass + -> TyVarMap1 + -> Name + -> Type + -> Q Exp +#if defined(NEW_FUNCTOR_CLASSES) +makeCaseForType _ tvMap _ (VarT tyName) = + varE $ case Map.lookup tyName tvMap of + Just (OneName eq) -> eq + Nothing -> eqValName +#else +makeCaseForType _ _ _ VarT{} = varE eqValName +#endif +makeCaseForType eClass tvMap conName (SigT ty _) = makeCaseForType eClass tvMap conName ty +makeCaseForType eClass tvMap conName (ForallT _ _ ty) = makeCaseForType eClass tvMap conName ty +#if defined(NEW_FUNCTOR_CLASSES) +makeCaseForType eClass tvMap conName ty = do + let tyCon :: Type + tyArgs :: [Type] + (tyCon, tyArgs) = unapplyTy ty + + numLastArgs :: Int + numLastArgs = min (arity eClass) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + + itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs + if any (`mentionsName` tyVarNames) lhsArgs + || itf && any (`mentionsName` tyVarNames) tyArgs + then outOfPlaceTyVarError eClass conName + else if any (`mentionsName` tyVarNames) rhsArgs + then appsE $ [ varE . eqName $ toEnum numLastArgs] + ++ map (makeCaseForType eClass tvMap conName) rhsArgs + else varE eqValName +#else +makeCaseForType eClass tvMap conName ty = do + let varNames = Map.keys tvMap + + a' <- newName "a'" + b' <- newName "b'" + case varNames of + [] -> varE eqValName + varName:_ -> + if mentionsName ty varNames + then lamE (map varP [a',b']) $ varE eq1ValName + `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE a') + `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE b') + else varE eqValName +#endif + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which @Eq@ variant is being derived. +data EqClass = Eq + | Eq1 +#if defined(NEW_FUNCTOR_CLASSES) + | Eq2 +#endif + deriving (Bounded, Enum) + +instance ClassRep EqClass where + arity = fromEnum + + allowExQuant _ = True + + fullClassName Eq = eqTypeName + fullClassName Eq1 = eq1TypeName +#if defined(NEW_FUNCTOR_CLASSES) + fullClassName Eq2 = eq2TypeName +#endif + + classConstraint eClass i + | eMin <= i && i <= eMax = Just $ fullClassName (toEnum i :: EqClass) + | otherwise = Nothing + where + eMin, eMax :: Int + eMin = fromEnum (minBound :: EqClass) + eMax = fromEnum eClass + +eqConstName :: EqClass -> Name +eqConstName Eq = eqConstValName +#if defined(NEW_FUNCTOR_CLASSES) +eqConstName Eq1 = liftEqConstValName +eqConstName Eq2 = liftEq2ConstValName +#else +eqConstName Eq1 = eq1ConstValName +#endif + +eqName :: EqClass -> Name +eqName Eq = eqValName +#if defined(NEW_FUNCTOR_CLASSES) +eqName Eq1 = liftEqValName +eqName Eq2 = liftEq2ValName +#else +eqName Eq1 = eq1ValName +#endif diff --git a/src/Data/Foldable/Deriving.hs b/src/Data/Foldable/Deriving.hs --- a/src/Data/Foldable/Deriving.hs +++ b/src/Data/Foldable/Deriving.hs @@ -1,64 +1,64 @@ -{-| -Module: Data.Foldable.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Foldable' instances in a way that mimics -how the @-XDeriveFoldable@ extension works since GHC 8.0. - -These changes make it possible to derive @Foldable@ instances for data types with -existential constraints, e.g., - -@ -data WrappedSet a where - WrapSet :: Ord a => a -> WrappedSet a - -deriving instance Foldable WrappedSet -- On GHC 8.0 on later -$(deriveFoldable ''WrappedSet) -- On GHC 7.10 and earlier -@ - -In addition, derived 'Foldable' instances from this module do not generate -superfluous 'mempty' expressions in its implementation of 'foldMap'. One can -verify this by compiling a module that uses 'deriveFoldable' with the -@-ddump-splices@ GHC flag. - -For more info on these changes, see -. --} -module Data.Foldable.Deriving ( - -- * 'Foldable' - deriveFoldable - , deriveFoldableOptions - , makeFoldMap - , makeFoldMapOptions - , makeFoldr - , makeFoldrOptions - , makeFold - , makeFoldOptions - , makeFoldl - , makeFoldlOptions - , makeNull - , makeNullOptions - -- * 'FFTOptions' - , FFTOptions(..) - , defaultFFTOptions - -- * 'deriveFoldable' limitations - -- $constraints - ) where - -import Data.Functor.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an - existential constraint cannot mention the last type variable. For example, - @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived - 'Functor' instance. - -* Type variables of kind @* -> *@ are assumed to have 'Foldable' constraints. - If this is not desirable, use 'makeFoldr' or 'makeFoldMap'. --} +{-| +Module: Data.Foldable.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Foldable' instances in a way that mimics +how the @-XDeriveFoldable@ extension works since GHC 8.0. + +These changes make it possible to derive @Foldable@ instances for data types with +existential constraints, e.g., + +@ +data WrappedSet a where + WrapSet :: Ord a => a -> WrappedSet a + +deriving instance Foldable WrappedSet -- On GHC 8.0 on later +$(deriveFoldable ''WrappedSet) -- On GHC 7.10 and earlier +@ + +In addition, derived 'Foldable' instances from this module do not generate +superfluous 'mempty' expressions in its implementation of 'foldMap'. One can +verify this by compiling a module that uses 'deriveFoldable' with the +@-ddump-splices@ GHC flag. + +For more info on these changes, see +. +-} +module Data.Foldable.Deriving ( + -- * 'Foldable' + deriveFoldable + , deriveFoldableOptions + , makeFoldMap + , makeFoldMapOptions + , makeFoldr + , makeFoldrOptions + , makeFold + , makeFoldOptions + , makeFoldl + , makeFoldlOptions + , makeNull + , makeNullOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions + -- * 'deriveFoldable' limitations + -- $constraints + ) where + +import Data.Functor.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an + existential constraint cannot mention the last type variable. For example, + @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived + 'Functor' instance. + +* Type variables of kind @* -> *@ are assumed to have 'Foldable' constraints. + If this is not desirable, use 'makeFoldr' or 'makeFoldMap'. +-} diff --git a/src/Data/Functor/Deriving.hs b/src/Data/Functor/Deriving.hs --- a/src/Data/Functor/Deriving.hs +++ b/src/Data/Functor/Deriving.hs @@ -1,36 +1,36 @@ -{-| -Module: Data.Functor.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Functor' instances. - -For more info on how deriving @Functor@ works, see -. --} -module Data.Functor.Deriving ( - -- * 'Functor' - deriveFunctor - , deriveFunctorOptions - , makeFmap - , makeFmapOptions - , makeReplace - , makeReplaceOptions - -- * 'FFTOptions' - , FFTOptions(..) - , defaultFFTOptions - -- * 'deriveFunctor' limitations - -- $constraints - ) where - -import Data.Functor.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @* -> *@ are assumed to have 'Functor' constraints. - If this is not desirable, use 'makeFmap'. --} +{-| +Module: Data.Functor.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Functor' instances. + +For more info on how deriving @Functor@ works, see +. +-} +module Data.Functor.Deriving ( + -- * 'Functor' + deriveFunctor + , deriveFunctorOptions + , makeFmap + , makeFmapOptions + , makeReplace + , makeReplaceOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions + -- * 'deriveFunctor' limitations + -- $constraints + ) where + +import Data.Functor.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @* -> *@ are assumed to have 'Functor' constraints. + If this is not desirable, use 'makeFmap'. +-} diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -1,943 +1,943 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-| -Module: Data.Functor.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances. - -For more info on how deriving @Functor@ works, see -. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Functor.Deriving.Internal ( - -- * 'Foldable' - deriveFoldable - , deriveFoldableOptions - , makeFoldMap - , makeFoldMapOptions - , makeFoldr - , makeFoldrOptions - , makeFold - , makeFoldOptions - , makeFoldl - , makeFoldlOptions - , makeNull - , makeNullOptions - -- * 'Functor' - , deriveFunctor - , deriveFunctorOptions - , makeFmap - , makeFmapOptions - , makeReplace - , makeReplaceOptions - -- * 'Traversable' - , deriveTraversable - , deriveTraversableOptions - , makeTraverse - , makeTraverseOptions - , makeSequenceA - , makeSequenceAOptions - , makeMapM - , makeMapMOptions - , makeSequence - , makeSequenceOptions - -- * 'FFTOptions' - , FFTOptions(..) - , defaultFFTOptions - ) where - -import Control.Monad (guard) - -import Data.Deriving.Internal -import qualified Data.List as List -import qualified Data.Map as Map ((!), keys, lookup, member, singleton) -import Data.Maybe - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Datatype.TyVarBndr -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- | Options that further configure how the functions in "Data.Functor.Deriving" --- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.) -newtype FFTOptions = FFTOptions - { fftEmptyCaseBehavior :: Bool - -- ^ If 'True', derived instances for empty data types (i.e., ones with - -- no data constructors) will use the @EmptyCase@ language extension. - -- If 'False', derived instances will simply use 'seq' instead. - -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only - -- available in 7.8 or later.) - } deriving (Eq, Ord, Read, Show) - --- | Conservative 'FFTOptions' that doesn't attempt to use @EmptyCase@ (to --- prevent users from having to enable that extension at use sites.) -defaultFFTOptions :: FFTOptions -defaultFFTOptions = FFTOptions { fftEmptyCaseBehavior = False } - --- | Generates a 'Foldable' instance declaration for the given data type or data --- family instance. -deriveFoldable :: Name -> Q [Dec] -deriveFoldable = deriveFoldableOptions defaultFFTOptions - --- | Like 'deriveFoldable', but takes an 'FFTOptions' argument. -deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec] -deriveFoldableOptions = deriveFunctorClass Foldable - --- | Generates a lambda expression which behaves like 'foldMap' (without requiring a --- 'Foldable' instance). -makeFoldMap :: Name -> Q Exp -makeFoldMap = makeFoldMapOptions defaultFFTOptions - --- | Like 'makeFoldMap', but takes an 'FFTOptions' argument. -makeFoldMapOptions :: FFTOptions -> Name -> Q Exp -makeFoldMapOptions = makeFunctorFun FoldMap - --- | Generates a lambda expression which behaves like 'null' (without requiring a --- 'Foldable' instance). -makeNull :: Name -> Q Exp -makeNull = makeNullOptions defaultFFTOptions - --- | Like 'makeNull', but takes an 'FFTOptions' argument. -makeNullOptions :: FFTOptions -> Name -> Q Exp -makeNullOptions = makeFunctorFun Null - --- | Generates a lambda expression which behaves like 'foldr' (without requiring a --- 'Foldable' instance). -makeFoldr :: Name -> Q Exp -makeFoldr = makeFoldrOptions defaultFFTOptions - --- | Like 'makeFoldr', but takes an 'FFTOptions' argument. -makeFoldrOptions :: FFTOptions -> Name -> Q Exp -makeFoldrOptions = makeFunctorFun Foldr - --- | Generates a lambda expression which behaves like 'fold' (without requiring a --- 'Foldable' instance). -makeFold :: Name -> Q Exp -makeFold = makeFoldOptions defaultFFTOptions - --- | Like 'makeFold', but takes an 'FFTOptions' argument. -makeFoldOptions :: FFTOptions -> Name -> Q Exp -makeFoldOptions opts name = makeFoldMapOptions opts name `appE` varE idValName - --- | Generates a lambda expression which behaves like 'foldl' (without requiring a --- 'Foldable' instance). -makeFoldl :: Name -> Q Exp -makeFoldl = makeFoldlOptions defaultFFTOptions - --- | Like 'makeFoldl', but takes an 'FFTOptions' argument. -makeFoldlOptions :: FFTOptions -> Name -> Q Exp -makeFoldlOptions opts name = do - f <- newName "f" - z <- newName "z" - t <- newName "t" - lamE [varP f, varP z, varP t] $ - appsE [ varE appEndoValName - , appsE [ varE getDualValName - , appsE [ makeFoldMapOptions opts name, foldFun f, varE t] - ] - , varE z - ] - where - foldFun :: Name -> Q Exp - foldFun n = infixApp (conE dualDataName) - (varE composeValName) - (infixApp (conE endoDataName) - (varE composeValName) - (varE flipValName `appE` varE n) - ) - --- | Generates a 'Functor' instance declaration for the given data type or data --- family instance. -deriveFunctor :: Name -> Q [Dec] -deriveFunctor = deriveFunctorOptions defaultFFTOptions - --- | Like 'deriveFunctor', but takes an 'FFTOptions' argument. -deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec] -deriveFunctorOptions = deriveFunctorClass Functor - --- | Generates a lambda expression which behaves like 'fmap' (without requiring a --- 'Functor' instance). -makeFmap :: Name -> Q Exp -makeFmap = makeFmapOptions defaultFFTOptions - --- | Like 'makeFmap', but takes an 'FFTOptions' argument. -makeFmapOptions :: FFTOptions -> Name -> Q Exp -makeFmapOptions = makeFunctorFun Fmap - --- | Generates a lambda expression which behaves like ('<$') (without requiring a --- 'Functor' instance). -makeReplace :: Name -> Q Exp -makeReplace = makeReplaceOptions defaultFFTOptions - --- | Like 'makeReplace', but takes an 'FFTOptions' argument. -makeReplaceOptions :: FFTOptions -> Name -> Q Exp -makeReplaceOptions = makeFunctorFun Replace - --- | Generates a 'Traversable' instance declaration for the given data type or data --- family instance. -deriveTraversable :: Name -> Q [Dec] -deriveTraversable = deriveTraversableOptions defaultFFTOptions - --- | Like 'deriveTraverse', but takes an 'FFTOptions' argument. -deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec] -deriveTraversableOptions = deriveFunctorClass Traversable - --- | Generates a lambda expression which behaves like 'traverse' (without requiring a --- 'Traversable' instance). -makeTraverse :: Name -> Q Exp -makeTraverse = makeTraverseOptions defaultFFTOptions - --- | Like 'makeTraverse', but takes an 'FFTOptions' argument. -makeTraverseOptions :: FFTOptions -> Name -> Q Exp -makeTraverseOptions = makeFunctorFun Traverse - --- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a --- 'Traversable' instance). -makeSequenceA :: Name -> Q Exp -makeSequenceA = makeSequenceAOptions defaultFFTOptions - --- | Like 'makeSequenceA', but takes an 'FFTOptions' argument. -makeSequenceAOptions :: FFTOptions -> Name -> Q Exp -makeSequenceAOptions opts name = makeTraverseOptions opts name `appE` varE idValName - --- | Generates a lambda expression which behaves like 'mapM' (without requiring a --- 'Traversable' instance). -makeMapM :: Name -> Q Exp -makeMapM = makeMapMOptions defaultFFTOptions - --- | Like 'makeMapM', but takes an 'FFTOptions' argument. -makeMapMOptions :: FFTOptions -> Name -> Q Exp -makeMapMOptions opts name = do - f <- newName "f" - lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $ - makeTraverseOptions opts name `appE` wrapMonadExp f - where - wrapMonadExp :: Name -> Q Exp - wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) - --- | Generates a lambda expression which behaves like 'sequence' (without requiring a --- 'Traversable' instance). -makeSequence :: Name -> Q Exp -makeSequence = makeSequenceOptions defaultFFTOptions - --- | Like 'makeSequence', but takes an 'FFTOptions' argument. -makeSequenceOptions :: FFTOptions -> Name -> Q Exp -makeSequenceOptions opts name = makeMapMOptions opts name `appE` varE idValName - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Derive a class instance declaration (depending on the FunctorClass argument's value). -deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec] -deriveFunctorClass fc opts name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance fc parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (functorFunDecs fc opts parentName instTypes cons) - --- | Generates a declaration defining the primary function(s) corresponding to a --- particular class (fmap for Functor, foldr and foldMap for Foldable, and --- traverse for Traversable). --- --- For why both foldr and foldMap are derived for Foldable, see Trac #7436. -functorFunDecs - :: FunctorClass -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] - -> [Q Dec] -functorFunDecs fc opts parentName instTypes cons = - map makeFunD $ functorClassToFuns fc - where - makeFunD :: FunctorFun -> Q Dec - makeFunD ff = - funD (functorFunName ff) - [ clause [] - (normalB $ makeFunctorFunForCons ff opts parentName instTypes cons) - [] - ] - --- | Generates a lambda expression which behaves like the FunctorFun argument. -makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp -makeFunctorFun ff opts name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have fmap/foldr/traverse/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance (functorFunToClass ff) parentName ctxt instTypes variant - >> makeFunctorFunForCons ff opts parentName instTypes cons - --- | Generates a lambda expression for the given constructors. --- All constructors must be from the same type. -makeFunctorFunForCons - :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] - -> Q Exp -makeFunctorFunForCons ff opts _parentName instTypes cons = do - mapFun <- newName "f" - z <- newName "z" -- Only used for deriving foldr - value <- newName "value" - let argNames = catMaybes [ guard (ff /= Null) >> Just mapFun - , guard (ff == Foldr) >> Just z - , Just value - ] - lastTyVar = varTToName $ last instTypes - tvMap = Map.singleton lastTyVar $ OneName mapFun - lamE (map varP argNames) - . appsE - $ [ varE $ functorFunConstName ff - , makeFun z value tvMap - ] ++ map varE argNames - where - makeFun :: Name -> Name -> TyVarMap1 -> Q Exp - makeFun z value tvMap = do -#if MIN_VERSION_template_haskell(2,9,0) - roles <- reifyRoles _parentName -#endif - case () of - _ - -#if MIN_VERSION_template_haskell(2,9,0) - | Just (_, PhantomR) <- unsnoc roles - -> functorFunPhantom z value -#endif - - | null cons && fftEmptyCaseBehavior opts && ghc7'8OrLater - -> functorFunEmptyCase ff z value - - | null cons - -> functorFunNoCons ff z value - - | otherwise - -> caseE (varE value) - (map (makeFunctorFunForCon ff z tvMap) cons) - -#if MIN_VERSION_template_haskell(2,9,0) - functorFunPhantom :: Name -> Name -> Q Exp - functorFunPhantom z value = - functorFunTrivial coerce - (varE pureValName `appE` coerce) - ff z - where - coerce :: Q Exp - coerce = varE coerceValName `appE` varE value -#endif - --- | Generates a match for a single constructor. -makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match -makeFunctorFunForCon ff z tvMap - con@(ConstructorInfo { constructorName = conName - , constructorContext = ctxt }) = do - checkExistentialContext (functorFunToClass ff) tvMap ctxt conName $ - case ff of - Fmap -> makeFmapMatch tvMap con - Replace -> makeReplaceMatch tvMap con - Foldr -> makeFoldrMatch z tvMap con - FoldMap -> makeFoldMapMatch tvMap con - Null -> makeNullMatch tvMap con - Traverse -> makeTraverseMatch tvMap con - --- | Generates a match whose right-hand side implements @fmap@. -makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match -makeFmapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do - parts <- foldDataConArgs tvMap ft_fmap con - match_for_con_functor conName parts - where - ft_fmap :: FFoldType (Exp -> Q Exp) - ft_fmap = FT { ft_triv = return - , ft_var = \v x -> case tvMap Map.! v of - OneName f -> return $ VarE f `AppE` x - , ft_fun = \g h x -> mkSimpleLam $ \b -> do - gg <- g b - h $ x `AppE` gg - , ft_tup = mkSimpleTupleCase match_for_con_functor - , ft_ty_app = \argTy g x -> do - case varTToName_maybe argTy of - -- If the argument type is a bare occurrence of the - -- data type's last type variable, then we can - -- generate more efficient code. - -- This was inspired by GHC#17880. - Just argVar - | Just (OneName f) <- Map.lookup argVar tvMap - -> return $ VarE fmapValName `AppE` VarE f `AppE` x - _ -> do gg <- mkSimpleLam g - return $ VarE fmapValName `AppE` gg `AppE` x - , ft_forall = \_ g x -> g x - , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName - , ft_co_var = \_ _ -> contravarianceError conName - } - --- | Generates a match whose right-hand side implements @(<$)@. -makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match -makeReplaceMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do - parts <- foldDataConArgs tvMap ft_replace con - match_for_con_functor conName parts - where - ft_replace :: FFoldType (Exp -> Q Exp) - ft_replace = FT { ft_triv = return - , ft_var = \v _ -> case tvMap Map.! v of - OneName z -> return $ VarE z - , ft_fun = \g h x -> mkSimpleLam $ \b -> do - gg <- g b - h $ x `AppE` gg - , ft_tup = mkSimpleTupleCase match_for_con_functor - , ft_ty_app = \argTy g x -> do - case varTToName_maybe argTy of - -- If the argument type is a bare occurrence of the - -- data type's last type variable, then we can - -- generate more efficient code. - -- This was inspired by GHC#17880. - Just argVar - | Just (OneName z) <- Map.lookup argVar tvMap - -> return $ VarE replaceValName `AppE` VarE z `AppE` x - _ -> do gg <- mkSimpleLam g - return $ VarE fmapValName `AppE` gg `AppE` x - , ft_forall = \_ g x -> g x - , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName - , ft_co_var = \_ _ -> contravarianceError conName - } - -match_for_con_functor :: Name -> [Exp -> Q Exp] -> Q Match -match_for_con_functor = mkSimpleConMatch $ \conName' xs -> - appsE (conE conName':xs) -- Con x1 x2 .. - --- | Generates a match whose right-hand side implements @foldr@. -makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match -makeFoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do - parts <- foldDataConArgs tvMap ft_foldr con - parts' <- sequence parts - match_for_con (VarE z) conName parts' - where - -- The Bool is True if the type mentions the last type parameter, False - -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out - -- expressions that do not mention the last parameter by checking for False. - ft_foldr :: FFoldType (Q (Bool, Exp)) - ft_foldr = FT { ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z' - return (False, lam) - , ft_var = \v -> case tvMap Map.! v of - OneName f -> return (True, VarE f) - , ft_tup = \t gs -> do - gg <- sequence gs - lam <- mkSimpleLam2 $ \x z' -> - mkSimpleTupleCase (match_for_con z') t gg x - return (True, lam) - , ft_ty_app = \_ g -> do - (b, gg) <- g - e <- mkSimpleLam2 $ \x z' -> return $ - VarE foldrValName `AppE` gg `AppE` z' `AppE` x - return (b, e) - , ft_forall = \_ g -> g - , ft_co_var = \_ -> contravarianceError conName - , ft_fun = \_ _ -> noFunctionsError conName - , ft_bad_app = outOfPlaceTyVarError Foldable conName - } - - match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match - match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldr xs - where - -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [Exp] -> Exp - mkFoldr = foldr AppE zExp - --- | Generates a match whose right-hand side implements @foldMap@. -makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match -makeFoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do - parts <- foldDataConArgs tvMap ft_foldMap con - parts' <- sequence parts - match_for_con conName parts' - where - -- The Bool is True if the type mentions the last type parameter, False - -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out - -- expressions that do not mention the last parameter by checking for False. - ft_foldMap :: FFoldType (Q (Bool, Exp)) - ft_foldMap = FT { ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName - return (False, lam) - , ft_var = \v -> case tvMap Map.! v of - OneName f -> return (True, VarE f) - , ft_tup = \t gs -> do - gg <- sequence gs - lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg - return (True, lam) - , ft_ty_app = \_ g -> do - fmap (\(b, e) -> (b, VarE foldMapValName `AppE` e)) g - , ft_forall = \_ g -> g - , ft_co_var = \_ -> contravarianceError conName - , ft_fun = \_ _ -> noFunctionsError conName - , ft_bad_app = outOfPlaceTyVarError Foldable conName - } - - match_for_con :: Name -> [(Bool, Exp)] -> Q Match - match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldMap xs - where - -- mappend v1 (mappend v2 ..) - mkFoldMap :: [Exp] -> Exp - mkFoldMap [] = VarE memptyValName - mkFoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es - --- | Generates a match whose right-hand side implements @null@. -makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match -makeNullMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do - parts <- foldDataConArgs tvMap ft_null con - parts' <- sequence parts - case convert parts' of - Nothing -> return $ Match (conWildPat con) (NormalB $ ConE falseDataName) [] - Just cp -> match_for_con conName cp - where - ft_null :: FFoldType (Q (NullM Exp)) - ft_null = FT { ft_triv = return $ IsNull $ ConE trueDataName - , ft_var = \_ -> return NotNull - , ft_tup = \t g -> do - gg <- sequence g - case convert gg of - Nothing -> return NotNull - Just ggg -> - fmap NullM $ mkSimpleLam - $ mkSimpleTupleCase match_for_con t ggg - , ft_ty_app = \_ g -> flip fmap g $ \nestedResult -> - case nestedResult of - -- If e definitely contains the parameter, then we can - -- test if (G e) contains it by simply checking if (G e) - -- is null - NotNull -> NullM $ VarE nullValName - -- This case is unreachable--it will actually be caught - -- by ft_triv - r@IsNull{} -> r - -- The general case uses (all null), (all (all null)), - -- etc. - NullM nestedTest -> NullM $ - VarE allValName `AppE` nestedTest - , ft_forall = \_ g -> g - , ft_co_var = \_ -> contravarianceError conName - , ft_fun = \_ _ -> noFunctionsError conName - , ft_bad_app = outOfPlaceTyVarError Foldable conName - } - - match_for_con :: Name -> [(Bool, Exp)] -> Q Match - match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkNull xs - where - -- v1 && v2 && .. - mkNull :: [Exp] -> Exp - mkNull [] = ConE trueDataName - mkNull xs = foldr1 (\x y -> VarE andValName `AppE` x `AppE` y) xs - --- Given a list of NullM results, produce Nothing if any of them is NotNull, --- and otherwise produce a list of (Bool, a) with True entries representing --- unknowns and False entries representing things that are definitely null. -convert :: [NullM a] -> Maybe [(Bool, a)] -convert = mapM go where - go (IsNull a) = Just (False, a) - go NotNull = Nothing - go (NullM a) = Just (True, a) - -data NullM a = - IsNull a -- Definitely null - | NotNull -- Definitely not null - | NullM a -- Unknown - --- | Generates a match whose right-hand side implements @traverse@. -makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match -makeTraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do - parts <- foldDataConArgs tvMap ft_trav con - parts' <- sequence parts - match_for_con conName parts' - where - -- The Bool is True if the type mentions the last type parameter, False - -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out - -- expressions that do not mention the last parameter by checking for False. - ft_trav :: FFoldType (Q (Bool, Exp)) - ft_trav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] - ft_triv = return (False, VarE pureValName) - , ft_var = \v -> case tvMap Map.! v of - OneName f -> return (True, VarE f) - , ft_tup = \t gs -> do - gg <- sequence gs - lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg - return (True, lam) - , ft_ty_app = \_ g -> - fmap (\(b, e) -> (b, VarE traverseValName `AppE` e)) g - , ft_forall = \_ g -> g - , ft_co_var = \_ -> contravarianceError conName - , ft_fun = \_ _ -> noFunctionsError conName - , ft_bad_app = outOfPlaceTyVarError Traversable conName - } - - -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) - -- (g2 a2) <*> ... - match_for_con :: Name -> [(Bool, Exp)] -> Q Match - match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs - where - -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. - mkApCon :: Exp -> [Exp] -> Exp - mkApCon conExp [] = VarE pureValName `AppE` conExp - mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e - mkApCon conExp (e1:e2:es) = List.foldl' appAp - (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es - where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- | A representation of which class is being derived. -data FunctorClass = Functor | Foldable | Traversable - -instance ClassRep FunctorClass where - arity _ = 1 - - allowExQuant Foldable = True - allowExQuant _ = False - - fullClassName Functor = functorTypeName - fullClassName Foldable = foldableTypeName - fullClassName Traversable = traversableTypeName - - classConstraint fClass 1 = Just $ fullClassName fClass - classConstraint _ _ = Nothing - --- | A representation of which function is being generated. -data FunctorFun - = Fmap - | Replace -- (<$) - | Foldr - | FoldMap - | Null - | Traverse - deriving Eq - -instance Show FunctorFun where - showsPrec _ Fmap = showString "fmap" - showsPrec _ Replace = showString "(<$)" - showsPrec _ Foldr = showString "foldr" - showsPrec _ FoldMap = showString "foldMap" - showsPrec _ Null = showString "null" - showsPrec _ Traverse = showString "traverse" - -functorFunConstName :: FunctorFun -> Name -functorFunConstName Fmap = fmapConstValName -functorFunConstName Replace = replaceConstValName -functorFunConstName Foldr = foldrConstValName -functorFunConstName FoldMap = foldMapConstValName -functorFunConstName Null = nullConstValName -functorFunConstName Traverse = traverseConstValName - -functorFunName :: FunctorFun -> Name -functorFunName Fmap = fmapValName -functorFunName Replace = replaceValName -functorFunName Foldr = foldrValName -functorFunName FoldMap = foldMapValName -functorFunName Null = nullValName -functorFunName Traverse = traverseValName - -functorClassToFuns :: FunctorClass -> [FunctorFun] -functorClassToFuns Functor = [ Fmap, Replace ] -functorClassToFuns Foldable = [ Foldr, FoldMap -#if MIN_VERSION_base(4,8,0) - , Null -#endif - ] -functorClassToFuns Traversable = [ Traverse ] - -functorFunToClass :: FunctorFun -> FunctorClass -functorFunToClass Fmap = Functor -functorFunToClass Replace = Functor -functorFunToClass Foldr = Foldable -functorFunToClass FoldMap = Foldable -functorFunToClass Null = Foldable -functorFunToClass Traverse = Traversable - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - -functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp -functorFunEmptyCase ff z value = - functorFunTrivial emptyCase - (varE pureValName `appE` emptyCase) - ff z - where - emptyCase :: Q Exp - emptyCase = caseE (varE value) [] - -functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp -functorFunNoCons ff z value = - functorFunTrivial seqAndError - (varE pureValName `appE` seqAndError) - ff z - where - seqAndError :: Q Exp - seqAndError = appE (varE seqValName) (varE value) `appE` - appE (varE errorValName) - (stringE $ "Void " ++ nameBase (functorFunName ff)) - -functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp -functorFunTrivial fmapE traverseE ff z = go ff - where - go :: FunctorFun -> Q Exp - go Fmap = fmapE - go Replace = fmapE - go Foldr = varE z - go FoldMap = varE memptyValName - go Null = conE trueDataName - go Traverse = traverseE - -conWildPat :: ConstructorInfo -> Pat -conWildPat (ConstructorInfo { constructorName = conName - , constructorFields = ts }) = - conPCompat conName $ replicate (length ts) WildP - -------------------------------------------------------------------------------- --- Generic traversal for functor-like deriving -------------------------------------------------------------------------------- - --- Much of the code below is cargo-culted from the TcGenFunctor module in GHC. - -data FFoldType a -- Describes how to fold over a Type in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: Name -> a - -- ^ The variable itself - , ft_co_var :: Name -> a - -- ^ The variable itself, contravariantly - , ft_fun :: a -> a -> a - -- ^ Function type - , ft_tup :: TupleSort -> [a] -> a - -- ^ Tuple type. The @[a]@ is the result of folding over the - -- arguments of the tuple. - , ft_ty_app :: Type -> a -> a - -- ^ Type app, variable only in last argument. The 'Type' is the - -- @arg_ty@ in @fun_ty arg_ty@. - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: [TyVarBndrSpec] -> a -> a - -- ^ Forall type - } - --- Note that in GHC, this function is pure. It must be monadic here since we: --- --- (1) Expand type synonyms --- (2) Detect type family applications --- --- Which require reification in Template Haskell, but are pure in Core. -functorLikeTraverse :: forall a. - TyVarMap1 -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> Type -- ^ Type to process - -> Q a -functorLikeTraverse tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_co_var = caseCoVar, ft_fun = caseFun - , ft_tup = caseTuple, ft_ty_app = caseTyApp - , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) - ty - = do ty' <- resolveTypeSynonyms ty - (res, _) <- go False ty' - return res - where - go :: Bool -- Covariant or contravariant context - -> Type - -> Q (a, Bool) -- (result of type a, does type contain var) - go co t@AppT{} - | (ArrowT, [funArg, funRes]) <- unapplyTy t - = do (funArgR, funArgC) <- go (not co) funArg - (funResR, funResC) <- go co funRes - if funArgC || funResC - then return (caseFun funArgR funResR, True) - else trivial - go co t@AppT{} = do - let (f, args) = unapplyTy t - (_, fc) <- go co f - (xrs, xcs) <- fmap unzip $ mapM (go co) args - let tuple :: TupleSort -> Q (a, Bool) - tuple tupSort = return (caseTuple tupSort xrs, True) - - wrongArg :: Q (a, Bool) - wrongArg = return (caseWrongArg, True) - - case () of - _ | not (or xcs) - -> trivial -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | TupleT len <- f - -> tuple $ Boxed len -#if MIN_VERSION_template_haskell(2,6,0) - | UnboxedTupleT len <- f - -> tuple $ Unboxed len -#endif - | fc || or (init xcs) - -> wrongArg -- T (..var..) ty - | otherwise -- T (..no var..) ty - -> do itf <- isInTypeFamilyApp tyVarNames f args - if itf -- We can't decompose type families, so - -- error if we encounter one here. - then wrongArg - else return (caseTyApp (last args) (last xrs), True) - go co (SigT t k) = do - (_, kc) <- go_kind co k - if kc - then return (caseWrongArg, True) - else go co t - go co (VarT v) - | Map.member v tvMap - = return (if co then caseCoVar v else caseVar v, True) - | otherwise - = trivial - go co (ForallT tvbs _ t) = do - (tr, tc) <- go co t - let tvbNames = map tvName tvbs - if not tc || any (`elem` tvbNames) tyVarNames - then trivial - else return (caseForAll tvbs tr, True) - go _ _ = trivial - - go_kind :: Bool - -> Kind - -> Q (a, Bool) -#if MIN_VERSION_template_haskell(2,9,0) - go_kind = go -#else - go_kind _ _ = trivial -#endif - - trivial :: Q (a, Bool) - trivial = return (caseTrivial, False) - - tyVarNames :: [Name] - tyVarNames = Map.keys tvMap - --- Fold over the arguments of a data constructor in a Functor-like way. -foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a] -foldDataConArgs tvMap ft con = do - fieldTys <- mapM resolveTypeSynonyms $ constructorFields con - mapM foldArg fieldTys - where - foldArg :: Type -> Q a - foldArg = functorLikeTraverse tvMap ft - --- Make a 'LamE' using a fresh variable. -mkSimpleLam :: (Exp -> Q Exp) -> Q Exp -mkSimpleLam lam = do - n <- newName "n" - body <- lam (VarE n) - return $ LamE [VarP n] body - --- Make a 'LamE' using two fresh variables. -mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp -mkSimpleLam2 lam = do - n1 <- newName "n1" - n2 <- newName "n2" - body <- lam (VarE n1) (VarE n2) - return $ LamE [VarP n1, VarP n2] body - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConMatch fold conName insides@ produces a match clause in --- which the LHS pattern-matches on @extraPats@, followed by a match on the --- constructor @conName@ and its arguments. The RHS folds (with @fold@) over --- @conName@ and its arguments, applying an expression (from @insides@) to each --- of the respective arguments of @conName@. -mkSimpleConMatch :: (Name -> [a] -> Q Exp) - -> Name - -> [Exp -> a] - -> Q Match -mkSimpleConMatch fold conName insides = do - varsNeeded <- newNameList "_arg" $ length insides - let pat = conPCompat conName (map VarP varsNeeded) - rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) - return $ Match pat (NormalB rhs) [] - --- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" --- --- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to --- 'mkSimpleConMatch', with two key differences: --- --- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it --- filters out the expressions corresponding to arguments whose types do not --- mention the last type variable in a derived 'Foldable' or 'Traversable' --- instance (i.e., those elements of @insides@ containing @False@). --- --- 2. @fold@ takes an expression as its first argument instead of a --- constructor name. This is because it uses a specialized --- constructor function expression that only takes as many parameters as --- there are argument types that mention the last type variable. -mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) - -> Name - -> [(Bool, Exp)] - -> Q Match -mkSimpleConMatch2 fold conName insides = do - varsNeeded <- newNameList "_arg" lengthInsides - let pat = conPCompat conName (map VarP varsNeeded) - -- Make sure to zip BEFORE invoking catMaybes. We want the variable - -- indicies in each expression to match up with the argument indices - -- in conExpr (defined below). - exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v) - else Nothing) - insides varsNeeded - -- An element of argTysTyVarInfo is True if the constructor argument - -- with the same index has a type which mentions the last type - -- variable. - argTysTyVarInfo = map (\(m, _) -> m) insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded - - conExpQ - | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar) - | otherwise = do - bs <- newNameList "b" lengthInsides - let bs' = filterByList argTysTyVarInfo bs - vars = filterByLists argTysTyVarInfo - (map varE bs) (map varE varsNeeded) - lamE (map varP bs') (appsE (conE conName:vars)) - - conExp <- conExpQ - rhs <- fold conExp exps - return $ Match pat (NormalB rhs) [] - where - lengthInsides = length insides - --- Indicates whether a tuple is boxed or unboxed, as well as its number of --- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #) --- corresponds to @Unboxed 3@. -data TupleSort - = Boxed Int -#if MIN_VERSION_template_haskell(2,6,0) - | Unboxed Int -#endif - --- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: (Name -> [a] -> Q Match) - -> TupleSort -> [a] -> Exp -> Q Exp -mkSimpleTupleCase matchForCon tupSort insides x = do - let tupDataName = case tupSort of - Boxed len -> tupleDataName len -#if MIN_VERSION_template_haskell(2,6,0) - Unboxed len -> unboxedTupleDataName len -#endif - m <- matchForCon tupDataName insides - return $ CaseE x [m] - --- Adapt to the type of ConP changing in template-haskell-2.18.0.0. -conPCompat :: Name -> [Pat] -> Pat -conPCompat n pats = ConP n -#if MIN_VERSION_template_haskell(2,18,0) - [] -#endif - pats +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module: Data.Functor.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances. + +For more info on how deriving @Functor@ works, see +. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Functor.Deriving.Internal ( + -- * 'Foldable' + deriveFoldable + , deriveFoldableOptions + , makeFoldMap + , makeFoldMapOptions + , makeFoldr + , makeFoldrOptions + , makeFold + , makeFoldOptions + , makeFoldl + , makeFoldlOptions + , makeNull + , makeNullOptions + -- * 'Functor' + , deriveFunctor + , deriveFunctorOptions + , makeFmap + , makeFmapOptions + , makeReplace + , makeReplaceOptions + -- * 'Traversable' + , deriveTraversable + , deriveTraversableOptions + , makeTraverse + , makeTraverseOptions + , makeSequenceA + , makeSequenceAOptions + , makeMapM + , makeMapMOptions + , makeSequence + , makeSequenceOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions + ) where + +import Control.Monad (guard) + +import Data.Deriving.Internal +import qualified Data.List as List +import qualified Data.Map as Map ((!), keys, lookup, member, singleton) +import Data.Maybe + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +-- | Options that further configure how the functions in "Data.Functor.Deriving" +-- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.) +newtype FFTOptions = FFTOptions + { fftEmptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) + } deriving (Eq, Ord, Read, Show) + +-- | Conservative 'FFTOptions' that doesn't attempt to use @EmptyCase@ (to +-- prevent users from having to enable that extension at use sites.) +defaultFFTOptions :: FFTOptions +defaultFFTOptions = FFTOptions { fftEmptyCaseBehavior = False } + +-- | Generates a 'Foldable' instance declaration for the given data type or data +-- family instance. +deriveFoldable :: Name -> Q [Dec] +deriveFoldable = deriveFoldableOptions defaultFFTOptions + +-- | Like 'deriveFoldable', but takes an 'FFTOptions' argument. +deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec] +deriveFoldableOptions = deriveFunctorClass Foldable + +-- | Generates a lambda expression which behaves like 'foldMap' (without requiring a +-- 'Foldable' instance). +makeFoldMap :: Name -> Q Exp +makeFoldMap = makeFoldMapOptions defaultFFTOptions + +-- | Like 'makeFoldMap', but takes an 'FFTOptions' argument. +makeFoldMapOptions :: FFTOptions -> Name -> Q Exp +makeFoldMapOptions = makeFunctorFun FoldMap + +-- | Generates a lambda expression which behaves like 'null' (without requiring a +-- 'Foldable' instance). +makeNull :: Name -> Q Exp +makeNull = makeNullOptions defaultFFTOptions + +-- | Like 'makeNull', but takes an 'FFTOptions' argument. +makeNullOptions :: FFTOptions -> Name -> Q Exp +makeNullOptions = makeFunctorFun Null + +-- | Generates a lambda expression which behaves like 'foldr' (without requiring a +-- 'Foldable' instance). +makeFoldr :: Name -> Q Exp +makeFoldr = makeFoldrOptions defaultFFTOptions + +-- | Like 'makeFoldr', but takes an 'FFTOptions' argument. +makeFoldrOptions :: FFTOptions -> Name -> Q Exp +makeFoldrOptions = makeFunctorFun Foldr + +-- | Generates a lambda expression which behaves like 'fold' (without requiring a +-- 'Foldable' instance). +makeFold :: Name -> Q Exp +makeFold = makeFoldOptions defaultFFTOptions + +-- | Like 'makeFold', but takes an 'FFTOptions' argument. +makeFoldOptions :: FFTOptions -> Name -> Q Exp +makeFoldOptions opts name = makeFoldMapOptions opts name `appE` varE idValName + +-- | Generates a lambda expression which behaves like 'foldl' (without requiring a +-- 'Foldable' instance). +makeFoldl :: Name -> Q Exp +makeFoldl = makeFoldlOptions defaultFFTOptions + +-- | Like 'makeFoldl', but takes an 'FFTOptions' argument. +makeFoldlOptions :: FFTOptions -> Name -> Q Exp +makeFoldlOptions opts name = do + f <- newName "f" + z <- newName "z" + t <- newName "t" + lamE [varP f, varP z, varP t] $ + appsE [ varE appEndoValName + , appsE [ varE getDualValName + , appsE [ makeFoldMapOptions opts name, foldFun f, varE t] + ] + , varE z + ] + where + foldFun :: Name -> Q Exp + foldFun n = infixApp (conE dualDataName) + (varE composeValName) + (infixApp (conE endoDataName) + (varE composeValName) + (varE flipValName `appE` varE n) + ) + +-- | Generates a 'Functor' instance declaration for the given data type or data +-- family instance. +deriveFunctor :: Name -> Q [Dec] +deriveFunctor = deriveFunctorOptions defaultFFTOptions + +-- | Like 'deriveFunctor', but takes an 'FFTOptions' argument. +deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec] +deriveFunctorOptions = deriveFunctorClass Functor + +-- | Generates a lambda expression which behaves like 'fmap' (without requiring a +-- 'Functor' instance). +makeFmap :: Name -> Q Exp +makeFmap = makeFmapOptions defaultFFTOptions + +-- | Like 'makeFmap', but takes an 'FFTOptions' argument. +makeFmapOptions :: FFTOptions -> Name -> Q Exp +makeFmapOptions = makeFunctorFun Fmap + +-- | Generates a lambda expression which behaves like ('<$') (without requiring a +-- 'Functor' instance). +makeReplace :: Name -> Q Exp +makeReplace = makeReplaceOptions defaultFFTOptions + +-- | Like 'makeReplace', but takes an 'FFTOptions' argument. +makeReplaceOptions :: FFTOptions -> Name -> Q Exp +makeReplaceOptions = makeFunctorFun Replace + +-- | Generates a 'Traversable' instance declaration for the given data type or data +-- family instance. +deriveTraversable :: Name -> Q [Dec] +deriveTraversable = deriveTraversableOptions defaultFFTOptions + +-- | Like 'deriveTraverse', but takes an 'FFTOptions' argument. +deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec] +deriveTraversableOptions = deriveFunctorClass Traversable + +-- | Generates a lambda expression which behaves like 'traverse' (without requiring a +-- 'Traversable' instance). +makeTraverse :: Name -> Q Exp +makeTraverse = makeTraverseOptions defaultFFTOptions + +-- | Like 'makeTraverse', but takes an 'FFTOptions' argument. +makeTraverseOptions :: FFTOptions -> Name -> Q Exp +makeTraverseOptions = makeFunctorFun Traverse + +-- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a +-- 'Traversable' instance). +makeSequenceA :: Name -> Q Exp +makeSequenceA = makeSequenceAOptions defaultFFTOptions + +-- | Like 'makeSequenceA', but takes an 'FFTOptions' argument. +makeSequenceAOptions :: FFTOptions -> Name -> Q Exp +makeSequenceAOptions opts name = makeTraverseOptions opts name `appE` varE idValName + +-- | Generates a lambda expression which behaves like 'mapM' (without requiring a +-- 'Traversable' instance). +makeMapM :: Name -> Q Exp +makeMapM = makeMapMOptions defaultFFTOptions + +-- | Like 'makeMapM', but takes an 'FFTOptions' argument. +makeMapMOptions :: FFTOptions -> Name -> Q Exp +makeMapMOptions opts name = do + f <- newName "f" + lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $ + makeTraverseOptions opts name `appE` wrapMonadExp f + where + wrapMonadExp :: Name -> Q Exp + wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) + +-- | Generates a lambda expression which behaves like 'sequence' (without requiring a +-- 'Traversable' instance). +makeSequence :: Name -> Q Exp +makeSequence = makeSequenceOptions defaultFFTOptions + +-- | Like 'makeSequence', but takes an 'FFTOptions' argument. +makeSequenceOptions :: FFTOptions -> Name -> Q Exp +makeSequenceOptions opts name = makeMapMOptions opts name `appE` varE idValName + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Derive a class instance declaration (depending on the FunctorClass argument's value). +deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec] +deriveFunctorClass fc opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance fc parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (functorFunDecs fc opts parentName instTypes cons) + +-- | Generates a declaration defining the primary function(s) corresponding to a +-- particular class (fmap for Functor, foldr and foldMap for Foldable, and +-- traverse for Traversable). +-- +-- For why both foldr and foldMap are derived for Foldable, see Trac #7436. +functorFunDecs + :: FunctorClass -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] + -> [Q Dec] +functorFunDecs fc opts parentName instTypes cons = + map makeFunD $ functorClassToFuns fc + where + makeFunD :: FunctorFun -> Q Dec + makeFunD ff = + funD (functorFunName ff) + [ clause [] + (normalB $ makeFunctorFunForCons ff opts parentName instTypes cons) + [] + ] + +-- | Generates a lambda expression which behaves like the FunctorFun argument. +makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp +makeFunctorFun ff opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have fmap/foldr/traverse/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance (functorFunToClass ff) parentName ctxt instTypes variant + >> makeFunctorFunForCons ff opts parentName instTypes cons + +-- | Generates a lambda expression for the given constructors. +-- All constructors must be from the same type. +makeFunctorFunForCons + :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] + -> Q Exp +makeFunctorFunForCons ff opts _parentName instTypes cons = do + mapFun <- newName "f" + z <- newName "z" -- Only used for deriving foldr + value <- newName "value" + let argNames = catMaybes [ guard (ff /= Null) >> Just mapFun + , guard (ff == Foldr) >> Just z + , Just value + ] + lastTyVar = varTToName $ last instTypes + tvMap = Map.singleton lastTyVar $ OneName mapFun + lamE (map varP argNames) + . appsE + $ [ varE $ functorFunConstName ff + , makeFun z value tvMap + ] ++ map varE argNames + where + makeFun :: Name -> Name -> TyVarMap1 -> Q Exp + makeFun z value tvMap = do +#if MIN_VERSION_template_haskell(2,9,0) + roles <- reifyRoles _parentName +#endif + case () of + _ + +#if MIN_VERSION_template_haskell(2,9,0) + | Just (_, PhantomR) <- unsnoc roles + -> functorFunPhantom z value +#endif + + | null cons && fftEmptyCaseBehavior opts && ghc7'8OrLater + -> functorFunEmptyCase ff z value + + | null cons + -> functorFunNoCons ff z value + + | otherwise + -> caseE (varE value) + (map (makeFunctorFunForCon ff z tvMap) cons) + +#if MIN_VERSION_template_haskell(2,9,0) + functorFunPhantom :: Name -> Name -> Q Exp + functorFunPhantom z value = + functorFunTrivial coerce + (varE pureValName `appE` coerce) + ff z + where + coerce :: Q Exp + coerce = varE coerceValName `appE` varE value +#endif + +-- | Generates a match for a single constructor. +makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match +makeFunctorFunForCon ff z tvMap + con@(ConstructorInfo { constructorName = conName + , constructorContext = ctxt }) = do + checkExistentialContext (functorFunToClass ff) tvMap ctxt conName $ + case ff of + Fmap -> makeFmapMatch tvMap con + Replace -> makeReplaceMatch tvMap con + Foldr -> makeFoldrMatch z tvMap con + FoldMap -> makeFoldMapMatch tvMap con + Null -> makeNullMatch tvMap con + Traverse -> makeTraverseMatch tvMap con + +-- | Generates a match whose right-hand side implements @fmap@. +makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match +makeFmapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_fmap con + match_for_con_functor conName parts + where + ft_fmap :: FFoldType (Exp -> Q Exp) + ft_fmap = FT { ft_triv = return + , ft_var = \v x -> case tvMap Map.! v of + OneName f -> return $ VarE f `AppE` x + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ x `AppE` gg + , ft_tup = mkSimpleTupleCase match_for_con_functor + , ft_ty_app = \argTy g x -> do + case varTToName_maybe argTy of + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can + -- generate more efficient code. + -- This was inspired by GHC#17880. + Just argVar + | Just (OneName f) <- Map.lookup argVar tvMap + -> return $ VarE fmapValName `AppE` VarE f `AppE` x + _ -> do gg <- mkSimpleLam g + return $ VarE fmapValName `AppE` gg `AppE` x + , ft_forall = \_ g x -> g x + , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName + , ft_co_var = \_ _ -> contravarianceError conName + } + +-- | Generates a match whose right-hand side implements @(<$)@. +makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match +makeReplaceMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_replace con + match_for_con_functor conName parts + where + ft_replace :: FFoldType (Exp -> Q Exp) + ft_replace = FT { ft_triv = return + , ft_var = \v _ -> case tvMap Map.! v of + OneName z -> return $ VarE z + , ft_fun = \g h x -> mkSimpleLam $ \b -> do + gg <- g b + h $ x `AppE` gg + , ft_tup = mkSimpleTupleCase match_for_con_functor + , ft_ty_app = \argTy g x -> do + case varTToName_maybe argTy of + -- If the argument type is a bare occurrence of the + -- data type's last type variable, then we can + -- generate more efficient code. + -- This was inspired by GHC#17880. + Just argVar + | Just (OneName z) <- Map.lookup argVar tvMap + -> return $ VarE replaceValName `AppE` VarE z `AppE` x + _ -> do gg <- mkSimpleLam g + return $ VarE fmapValName `AppE` gg `AppE` x + , ft_forall = \_ g x -> g x + , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName + , ft_co_var = \_ _ -> contravarianceError conName + } + +match_for_con_functor :: Name -> [Exp -> Q Exp] -> Q Match +match_for_con_functor = mkSimpleConMatch $ \conName' xs -> + appsE (conE conName':xs) -- Con x1 x2 .. + +-- | Generates a match whose right-hand side implements @foldr@. +makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match +makeFoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_foldr con + parts' <- sequence parts + match_for_con (VarE z) conName parts' + where + -- The Bool is True if the type mentions the last type parameter, False + -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out + -- expressions that do not mention the last parameter by checking for False. + ft_foldr :: FFoldType (Q (Bool, Exp)) + ft_foldr = FT { ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z' + return (False, lam) + , ft_var = \v -> case tvMap Map.! v of + OneName f -> return (True, VarE f) + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam2 $ \x z' -> + mkSimpleTupleCase (match_for_con z') t gg x + return (True, lam) + , ft_ty_app = \_ g -> do + (b, gg) <- g + e <- mkSimpleLam2 $ \x z' -> return $ + VarE foldrValName `AppE` gg `AppE` z' `AppE` x + return (b, e) + , ft_forall = \_ g -> g + , ft_co_var = \_ -> contravarianceError conName + , ft_fun = \_ _ -> noFunctionsError conName + , ft_bad_app = outOfPlaceTyVarError Foldable conName + } + + match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match + match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldr xs + where + -- g1 v1 (g2 v2 (.. z)) + mkFoldr :: [Exp] -> Exp + mkFoldr = foldr AppE zExp + +-- | Generates a match whose right-hand side implements @foldMap@. +makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match +makeFoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_foldMap con + parts' <- sequence parts + match_for_con conName parts' + where + -- The Bool is True if the type mentions the last type parameter, False + -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out + -- expressions that do not mention the last parameter by checking for False. + ft_foldMap :: FFoldType (Q (Bool, Exp)) + ft_foldMap = FT { ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName + return (False, lam) + , ft_var = \v -> case tvMap Map.! v of + OneName f -> return (True, VarE f) + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + return (True, lam) + , ft_ty_app = \_ g -> do + fmap (\(b, e) -> (b, VarE foldMapValName `AppE` e)) g + , ft_forall = \_ g -> g + , ft_co_var = \_ -> contravarianceError conName + , ft_fun = \_ _ -> noFunctionsError conName + , ft_bad_app = outOfPlaceTyVarError Foldable conName + } + + match_for_con :: Name -> [(Bool, Exp)] -> Q Match + match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldMap xs + where + -- mappend v1 (mappend v2 ..) + mkFoldMap :: [Exp] -> Exp + mkFoldMap [] = VarE memptyValName + mkFoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es + +-- | Generates a match whose right-hand side implements @null@. +makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match +makeNullMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_null con + parts' <- sequence parts + case convert parts' of + Nothing -> return $ Match (conWildPat con) (NormalB $ ConE falseDataName) [] + Just cp -> match_for_con conName cp + where + ft_null :: FFoldType (Q (NullM Exp)) + ft_null = FT { ft_triv = return $ IsNull $ ConE trueDataName + , ft_var = \_ -> return NotNull + , ft_tup = \t g -> do + gg <- sequence g + case convert gg of + Nothing -> return NotNull + Just ggg -> + fmap NullM $ mkSimpleLam + $ mkSimpleTupleCase match_for_con t ggg + , ft_ty_app = \_ g -> flip fmap g $ \nestedResult -> + case nestedResult of + -- If e definitely contains the parameter, then we can + -- test if (G e) contains it by simply checking if (G e) + -- is null + NotNull -> NullM $ VarE nullValName + -- This case is unreachable--it will actually be caught + -- by ft_triv + r@IsNull{} -> r + -- The general case uses (all null), (all (all null)), + -- etc. + NullM nestedTest -> NullM $ + VarE allValName `AppE` nestedTest + , ft_forall = \_ g -> g + , ft_co_var = \_ -> contravarianceError conName + , ft_fun = \_ _ -> noFunctionsError conName + , ft_bad_app = outOfPlaceTyVarError Foldable conName + } + + match_for_con :: Name -> [(Bool, Exp)] -> Q Match + match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkNull xs + where + -- v1 && v2 && .. + mkNull :: [Exp] -> Exp + mkNull [] = ConE trueDataName + mkNull xs = foldr1 (\x y -> VarE andValName `AppE` x `AppE` y) xs + +-- Given a list of NullM results, produce Nothing if any of them is NotNull, +-- and otherwise produce a list of (Bool, a) with True entries representing +-- unknowns and False entries representing things that are definitely null. +convert :: [NullM a] -> Maybe [(Bool, a)] +convert = mapM go where + go (IsNull a) = Just (False, a) + go NotNull = Nothing + go (NullM a) = Just (True, a) + +data NullM a = + IsNull a -- Definitely null + | NotNull -- Definitely not null + | NullM a -- Unknown + +-- | Generates a match whose right-hand side implements @traverse@. +makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match +makeTraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do + parts <- foldDataConArgs tvMap ft_trav con + parts' <- sequence parts + match_for_con conName parts' + where + -- The Bool is True if the type mentions the last type parameter, False + -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out + -- expressions that do not mention the last parameter by checking for False. + ft_trav :: FFoldType (Q (Bool, Exp)) + ft_trav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] + ft_triv = return (False, VarE pureValName) + , ft_var = \v -> case tvMap Map.! v of + OneName f -> return (True, VarE f) + , ft_tup = \t gs -> do + gg <- sequence gs + lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg + return (True, lam) + , ft_ty_app = \_ g -> + fmap (\(b, e) -> (b, VarE traverseValName `AppE` e)) g + , ft_forall = \_ g -> g + , ft_co_var = \_ -> contravarianceError conName + , ft_fun = \_ _ -> noFunctionsError conName + , ft_bad_app = outOfPlaceTyVarError Traversable conName + } + + -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) + -- (g2 a2) <*> ... + match_for_con :: Name -> [(Bool, Exp)] -> Q Match + match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs + where + -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. + mkApCon :: Exp -> [Exp] -> Exp + mkApCon conExp [] = VarE pureValName `AppE` conExp + mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e + mkApCon conExp (e1:e2:es) = List.foldl' appAp + (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es + where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which class is being derived. +data FunctorClass = Functor | Foldable | Traversable + +instance ClassRep FunctorClass where + arity _ = 1 + + allowExQuant Foldable = True + allowExQuant _ = False + + fullClassName Functor = functorTypeName + fullClassName Foldable = foldableTypeName + fullClassName Traversable = traversableTypeName + + classConstraint fClass 1 = Just $ fullClassName fClass + classConstraint _ _ = Nothing + +-- | A representation of which function is being generated. +data FunctorFun + = Fmap + | Replace -- (<$) + | Foldr + | FoldMap + | Null + | Traverse + deriving Eq + +instance Show FunctorFun where + showsPrec _ Fmap = showString "fmap" + showsPrec _ Replace = showString "(<$)" + showsPrec _ Foldr = showString "foldr" + showsPrec _ FoldMap = showString "foldMap" + showsPrec _ Null = showString "null" + showsPrec _ Traverse = showString "traverse" + +functorFunConstName :: FunctorFun -> Name +functorFunConstName Fmap = fmapConstValName +functorFunConstName Replace = replaceConstValName +functorFunConstName Foldr = foldrConstValName +functorFunConstName FoldMap = foldMapConstValName +functorFunConstName Null = nullConstValName +functorFunConstName Traverse = traverseConstValName + +functorFunName :: FunctorFun -> Name +functorFunName Fmap = fmapValName +functorFunName Replace = replaceValName +functorFunName Foldr = foldrValName +functorFunName FoldMap = foldMapValName +functorFunName Null = nullValName +functorFunName Traverse = traverseValName + +functorClassToFuns :: FunctorClass -> [FunctorFun] +functorClassToFuns Functor = [ Fmap, Replace ] +functorClassToFuns Foldable = [ Foldr, FoldMap +#if MIN_VERSION_base(4,8,0) + , Null +#endif + ] +functorClassToFuns Traversable = [ Traverse ] + +functorFunToClass :: FunctorFun -> FunctorClass +functorFunToClass Fmap = Functor +functorFunToClass Replace = Functor +functorFunToClass Foldr = Foldable +functorFunToClass FoldMap = Foldable +functorFunToClass Null = Foldable +functorFunToClass Traverse = Traversable + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp +functorFunEmptyCase ff z value = + functorFunTrivial emptyCase + (varE pureValName `appE` emptyCase) + ff z + where + emptyCase :: Q Exp + emptyCase = caseE (varE value) [] + +functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp +functorFunNoCons ff z value = + functorFunTrivial seqAndError + (varE pureValName `appE` seqAndError) + ff z + where + seqAndError :: Q Exp + seqAndError = appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (functorFunName ff)) + +functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp +functorFunTrivial fmapE traverseE ff z = go ff + where + go :: FunctorFun -> Q Exp + go Fmap = fmapE + go Replace = fmapE + go Foldr = varE z + go FoldMap = varE memptyValName + go Null = conE trueDataName + go Traverse = traverseE + +conWildPat :: ConstructorInfo -> Pat +conWildPat (ConstructorInfo { constructorName = conName + , constructorFields = ts }) = + conPCompat conName $ replicate (length ts) WildP + +------------------------------------------------------------------------------- +-- Generic traversal for functor-like deriving +------------------------------------------------------------------------------- + +-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC. + +data FFoldType a -- Describes how to fold over a Type in a functor like way + = FT { ft_triv :: a + -- ^ Does not contain variable + , ft_var :: Name -> a + -- ^ The variable itself + , ft_co_var :: Name -> a + -- ^ The variable itself, contravariantly + , ft_fun :: a -> a -> a + -- ^ Function type + , ft_tup :: TupleSort -> [a] -> a + -- ^ Tuple type. The @[a]@ is the result of folding over the + -- arguments of the tuple. + , ft_ty_app :: Type -> a -> a + -- ^ Type app, variable only in last argument. The 'Type' is the + -- @arg_ty@ in @fun_ty arg_ty@. + , ft_bad_app :: a + -- ^ Type app, variable other than in last argument + , ft_forall :: [TyVarBndrSpec] -> a -> a + -- ^ Forall type + } + +-- Note that in GHC, this function is pure. It must be monadic here since we: +-- +-- (1) Expand type synonyms +-- (2) Detect type family applications +-- +-- Which require reification in Template Haskell, but are pure in Core. +functorLikeTraverse :: forall a. + TyVarMap1 -- ^ Variable to look for + -> FFoldType a -- ^ How to fold + -> Type -- ^ Type to process + -> Q a +functorLikeTraverse tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar + , ft_co_var = caseCoVar, ft_fun = caseFun + , ft_tup = caseTuple, ft_ty_app = caseTyApp + , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) + ty + = do ty' <- resolveTypeSynonyms ty + (res, _) <- go False ty' + return res + where + go :: Bool -- Covariant or contravariant context + -> Type + -> Q (a, Bool) -- (result of type a, does type contain var) + go co t@AppT{} + | (ArrowT, [funArg, funRes]) <- unapplyTy t + = do (funArgR, funArgC) <- go (not co) funArg + (funResR, funResC) <- go co funRes + if funArgC || funResC + then return (caseFun funArgR funResR, True) + else trivial + go co t@AppT{} = do + let (f, args) = unapplyTy t + (_, fc) <- go co f + (xrs, xcs) <- fmap unzip $ mapM (go co) args + let tuple :: TupleSort -> Q (a, Bool) + tuple tupSort = return (caseTuple tupSort xrs, True) + + wrongArg :: Q (a, Bool) + wrongArg = return (caseWrongArg, True) + + case () of + _ | not (or xcs) + -> trivial -- Variable does not occur + -- At this point we know that xrs, xcs is not empty, + -- and at least one xr is True + | TupleT len <- f + -> tuple $ Boxed len +#if MIN_VERSION_template_haskell(2,6,0) + | UnboxedTupleT len <- f + -> tuple $ Unboxed len +#endif + | fc || or (init xcs) + -> wrongArg -- T (..var..) ty + | otherwise -- T (..no var..) ty + -> do itf <- isInTypeFamilyApp tyVarNames f args + if itf -- We can't decompose type families, so + -- error if we encounter one here. + then wrongArg + else return (caseTyApp (last args) (last xrs), True) + go co (SigT t k) = do + (_, kc) <- go_kind co k + if kc + then return (caseWrongArg, True) + else go co t + go co (VarT v) + | Map.member v tvMap + = return (if co then caseCoVar v else caseVar v, True) + | otherwise + = trivial + go co (ForallT tvbs _ t) = do + (tr, tc) <- go co t + let tvbNames = map tvName tvbs + if not tc || any (`elem` tvbNames) tyVarNames + then trivial + else return (caseForAll tvbs tr, True) + go _ _ = trivial + + go_kind :: Bool + -> Kind + -> Q (a, Bool) +#if MIN_VERSION_template_haskell(2,9,0) + go_kind = go +#else + go_kind _ _ = trivial +#endif + + trivial :: Q (a, Bool) + trivial = return (caseTrivial, False) + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + +-- Fold over the arguments of a data constructor in a Functor-like way. +foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a] +foldDataConArgs tvMap ft con = do + fieldTys <- mapM resolveTypeSynonyms $ constructorFields con + mapM foldArg fieldTys + where + foldArg :: Type -> Q a + foldArg = functorLikeTraverse tvMap ft + +-- Make a 'LamE' using a fresh variable. +mkSimpleLam :: (Exp -> Q Exp) -> Q Exp +mkSimpleLam lam = do + n <- newName "n" + body <- lam (VarE n) + return $ LamE [VarP n] body + +-- Make a 'LamE' using two fresh variables. +mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp +mkSimpleLam2 lam = do + n1 <- newName "n1" + n2 <- newName "n2" + body <- lam (VarE n1) (VarE n2) + return $ LamE [VarP n1, VarP n2] body + +-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" +-- +-- @mkSimpleConMatch fold conName insides@ produces a match clause in +-- which the LHS pattern-matches on @extraPats@, followed by a match on the +-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over +-- @conName@ and its arguments, applying an expression (from @insides@) to each +-- of the respective arguments of @conName@. +mkSimpleConMatch :: (Name -> [a] -> Q Exp) + -> Name + -> [Exp -> a] + -> Q Match +mkSimpleConMatch fold conName insides = do + varsNeeded <- newNameList "_arg" $ length insides + let pat = conPCompat conName (map VarP varsNeeded) + rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) + return $ Match pat (NormalB rhs) [] + +-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" +-- +-- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to +-- 'mkSimpleConMatch', with two key differences: +-- +-- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it +-- filters out the expressions corresponding to arguments whose types do not +-- mention the last type variable in a derived 'Foldable' or 'Traversable' +-- instance (i.e., those elements of @insides@ containing @False@). +-- +-- 2. @fold@ takes an expression as its first argument instead of a +-- constructor name. This is because it uses a specialized +-- constructor function expression that only takes as many parameters as +-- there are argument types that mention the last type variable. +mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) + -> Name + -> [(Bool, Exp)] + -> Q Match +mkSimpleConMatch2 fold conName insides = do + varsNeeded <- newNameList "_arg" lengthInsides + let pat = conPCompat conName (map VarP varsNeeded) + -- Make sure to zip BEFORE invoking catMaybes. We want the variable + -- indicies in each expression to match up with the argument indices + -- in conExpr (defined below). + exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v) + else Nothing) + insides varsNeeded + -- An element of argTysTyVarInfo is True if the constructor argument + -- with the same index has a type which mentions the last type + -- variable. + argTysTyVarInfo = map (\(m, _) -> m) insides + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded + + conExpQ + | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar) + | otherwise = do + bs <- newNameList "b" lengthInsides + let bs' = filterByList argTysTyVarInfo bs + vars = filterByLists argTysTyVarInfo + (map varE bs) (map varE varsNeeded) + lamE (map varP bs') (appsE (conE conName:vars)) + + conExp <- conExpQ + rhs <- fold conExp exps + return $ Match pat (NormalB rhs) [] + where + lengthInsides = length insides + +-- Indicates whether a tuple is boxed or unboxed, as well as its number of +-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #) +-- corresponds to @Unboxed 3@. +data TupleSort + = Boxed Int +#if MIN_VERSION_template_haskell(2,6,0) + | Unboxed Int +#endif + +-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" +mkSimpleTupleCase :: (Name -> [a] -> Q Match) + -> TupleSort -> [a] -> Exp -> Q Exp +mkSimpleTupleCase matchForCon tupSort insides x = do + let tupDataName = case tupSort of + Boxed len -> tupleDataName len +#if MIN_VERSION_template_haskell(2,6,0) + Unboxed len -> unboxedTupleDataName len +#endif + m <- matchForCon tupDataName insides + return $ CaseE x [m] + +-- Adapt to the type of ConP changing in template-haskell-2.18.0.0. +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/src/Data/Ix/Deriving.hs b/src/Data/Ix/Deriving.hs --- a/src/Data/Ix/Deriving.hs +++ b/src/Data/Ix/Deriving.hs @@ -1,31 +1,31 @@ -{-| -Module: Data.Ix.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Ix' instances. --} -module Data.Ix.Deriving ( - -- * 'Ix' - deriveIx - , makeRange - , makeUnsafeIndex - , makeInRange - -- * 'deriveIx' limitations - -- $constraints - ) where - -import Data.Ix.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @*@ are assumed to have 'Ix' constraints. - If this is not desirable, use 'makeRange' or one of its cousins. - -* Generated 'Ix' instances for poly-kinded data family instances are likely - to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. --} +{-| +Module: Data.Ix.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Ix' instances. +-} +module Data.Ix.Deriving ( + -- * 'Ix' + deriveIx + , makeRange + , makeUnsafeIndex + , makeInRange + -- * 'deriveIx' limitations + -- $constraints + ) where + +import Data.Ix.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Ix' constraints. + If this is not desirable, use 'makeRange' or one of its cousins. + +* Generated 'Ix' instances for poly-kinded data family instances are likely + to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. +-} diff --git a/src/Data/Ix/Deriving/Internal.hs b/src/Data/Ix/Deriving/Internal.hs --- a/src/Data/Ix/Deriving/Internal.hs +++ b/src/Data/Ix/Deriving/Internal.hs @@ -1,240 +1,240 @@ -{-| -Module: Data.Ix.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Ix' instances. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Ix.Deriving.Internal ( - -- * 'Ix' - deriveIx - , makeRange - , makeUnsafeIndex - , makeInRange - ) where - -import Data.Deriving.Internal - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Generates a 'Ix' instance declaration for the given data type or data --- family instance. -deriveIx :: Name -> Q [Dec] -deriveIx name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance IxClass parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (ixFunDecs parentName instanceType cons) - --- | Generates a lambda expression which behaves like 'range' (without --- requiring an 'Ix' instance). -makeRange :: Name -> Q Exp -makeRange = makeIxFun Range - --- | Generates a lambda expression which behaves like 'unsafeIndex' (without --- requiring an 'Ix' instance). -makeUnsafeIndex :: Name -> Q Exp -makeUnsafeIndex = makeIxFun UnsafeIndex - --- | Generates a lambda expression which behaves like 'inRange' (without --- requiring an 'Ix' instance). -makeInRange :: Name -> Q Exp -makeInRange = makeIxFun InRange - --- | Generates method declarations for an 'Ix' instance. -ixFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] -ixFunDecs tyName ty cons = - [ makeFunD Range - , makeFunD UnsafeIndex - , makeFunD InRange - ] - where - makeFunD :: IxFun -> Q Dec - makeFunD ixf = - funD (ixFunName ixf) - [ clause [] - (normalB $ makeIxFunForCons ixf tyName ty cons) - [] - ] - --- | Generates a lambda expression which behaves like the IxFun argument. -makeIxFun :: IxFun -> Name -> Q Exp -makeIxFun ixf name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (_, instanceType) <- buildTypeInstance IxClass parentName ctxt instTypes variant - makeIxFunForCons ixf parentName instanceType cons - --- | Generates a lambda expression for an 'Ix' method for the --- given constructors. All constructors must be from the same type. -makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp -makeIxFunForCons _ _ _ [] = noConstructorsError -makeIxFunForCons ixf tyName ty cons - | not (isProduct || isEnumeration) - = enumerationOrProductError $ nameBase tyName - | isEnumeration - = case ixf of - Range -> do - a <- newName "a" - aHash <- newName "a#" - b <- newName "b" - bHash <- newName "b#" - lamE [tupP [varP a, varP b]] $ - untagExpr [(a, aHash)] $ - untagExpr [(b, bHash)] $ - appE (varE mapValName `appE` tag2Con) $ - enumFromToExpr (conE iHashDataName `appE` varE aHash) - (conE iHashDataName `appE` varE bHash) - - UnsafeIndex -> do - a <- newName "a" - aHash <- newName "a#" - c <- newName "c" - cHash <- newName "c#" - dHash <- newName "d#" - lamE [tupP [varP a, wildP], varP c] $ - untagExpr [(a, aHash)] $ - untagExpr [(c, cHash)] $ - caseE (infixApp (varE cHash) (varE minusIntHashValName) (varE aHash)) - [ match (varP dHash) - (normalB $ conE iHashDataName `appE` varE dHash) - [] - ] - - InRange -> do - a <- newName "a" - aHash <- newName "a#" - b <- newName "b" - bHash <- newName "b#" - c <- newName "c" - cHash <- newName "c#" - lamE [tupP [varP a, varP b], varP c] $ - untagExpr [(a, aHash)] $ - untagExpr [(b, bHash)] $ - untagExpr [(c, cHash)] $ - appsE [ varE andValName - , primOpAppExpr (varE cHash) geIntHashValName (varE aHash) - , primOpAppExpr (varE cHash) leIntHashValName (varE bHash) - ] - - | otherwise -- It's a product type - = do let con :: ConstructorInfo - con = head cons - - conName :: Name - conName = constructorName con - - conFields :: Int - conFields = conArity con - - as <- newNameList "a" conFields - bs <- newNameList "b" conFields - cs <- newNameList "c" conFields - - let conPat :: [Name] -> Q Pat - conPat = conP conName . map varP - - conExpr :: Q Exp - conExpr = appsE $ conE conName : map varE cs - - case ixf of - Range -> lamE [tupP [conPat as, conPat bs]] $ - compE $ stmts ++ [noBindS conExpr] - where - stmts :: [Q Stmt] - stmts = zipWith3 mkQual as bs cs - - mkQual :: Name -> Name -> Name -> Q Stmt - mkQual a b c = bindS (varP c) $ - varE rangeValName `appE` tupE [varE a, varE b] - - UnsafeIndex -> lamE [tupP [conPat as, conPat bs], conPat cs] $ - mkUnsafeIndex $ reverse $ zip3 as bs cs - where - mkUnsafeIndex :: [(Name, Name, Name)] -> Q Exp - mkUnsafeIndex [] = integerE 0 - mkUnsafeIndex [(l, u, i)] = mkOne l u i - mkUnsafeIndex ((l, u, i):rest) = - infixApp (mkOne l u i) - (varE plusValName) - (infixApp (varE unsafeRangeSizeValName - `appE` tupE [varE l, varE u]) - (varE timesValName) - (mkUnsafeIndex rest)) - - mkOne :: Name -> Name -> Name -> Q Exp - mkOne l u i = varE unsafeIndexValName `appE` tupE [varE l, varE u] - `appE` varE i - - InRange -> lamE [tupP [conPat as, conPat bs], conPat cs] $ - if conFields == 0 - then conE trueDataName - else foldl1 andExpr $ zipWith3 mkInRange as bs cs - where - andExpr :: Q Exp -> Q Exp -> Q Exp - andExpr a b = infixApp a (varE andValName) b - - mkInRange :: Name -> Name -> Name -> Q Exp - mkInRange a b c = varE inRangeValName `appE` tupE [varE a, varE b] - `appE` varE c - where - isProduct, isEnumeration :: Bool - isProduct = isProductType cons - isEnumeration = isEnumerationType cons - - tag2Con :: Q Exp - tag2Con = tag2ConExpr $ removeClassApp ty - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- There's only one Ix variant! -data IxClass = IxClass - -instance ClassRep IxClass where - arity _ = 0 - - allowExQuant _ = True - - fullClassName _ = ixTypeName - - classConstraint _ 0 = Just ixTypeName - classConstraint _ _ = Nothing - --- | A representation of which function is being generated. -data IxFun = Range - | UnsafeIndex - | InRange - deriving Show - -ixFunName :: IxFun -> Name -ixFunName Range = rangeValName -ixFunName UnsafeIndex = unsafeIndexValName -ixFunName InRange = inRangeValName +{-| +Module: Data.Ix.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Ix' instances. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Ix.Deriving.Internal ( + -- * 'Ix' + deriveIx + , makeRange + , makeUnsafeIndex + , makeInRange + ) where + +import Data.Deriving.Internal + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Generates a 'Ix' instance declaration for the given data type or data +-- family instance. +deriveIx :: Name -> Q [Dec] +deriveIx name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance IxClass parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (ixFunDecs parentName instanceType cons) + +-- | Generates a lambda expression which behaves like 'range' (without +-- requiring an 'Ix' instance). +makeRange :: Name -> Q Exp +makeRange = makeIxFun Range + +-- | Generates a lambda expression which behaves like 'unsafeIndex' (without +-- requiring an 'Ix' instance). +makeUnsafeIndex :: Name -> Q Exp +makeUnsafeIndex = makeIxFun UnsafeIndex + +-- | Generates a lambda expression which behaves like 'inRange' (without +-- requiring an 'Ix' instance). +makeInRange :: Name -> Q Exp +makeInRange = makeIxFun InRange + +-- | Generates method declarations for an 'Ix' instance. +ixFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] +ixFunDecs tyName ty cons = + [ makeFunD Range + , makeFunD UnsafeIndex + , makeFunD InRange + ] + where + makeFunD :: IxFun -> Q Dec + makeFunD ixf = + funD (ixFunName ixf) + [ clause [] + (normalB $ makeIxFunForCons ixf tyName ty cons) + [] + ] + +-- | Generates a lambda expression which behaves like the IxFun argument. +makeIxFun :: IxFun -> Name -> Q Exp +makeIxFun ixf name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (_, instanceType) <- buildTypeInstance IxClass parentName ctxt instTypes variant + makeIxFunForCons ixf parentName instanceType cons + +-- | Generates a lambda expression for an 'Ix' method for the +-- given constructors. All constructors must be from the same type. +makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp +makeIxFunForCons _ _ _ [] = noConstructorsError +makeIxFunForCons ixf tyName ty cons + | not (isProduct || isEnumeration) + = enumerationOrProductError $ nameBase tyName + | isEnumeration + = case ixf of + Range -> do + a <- newName "a" + aHash <- newName "a#" + b <- newName "b" + bHash <- newName "b#" + lamE [tupP [varP a, varP b]] $ + untagExpr [(a, aHash)] $ + untagExpr [(b, bHash)] $ + appE (varE mapValName `appE` tag2Con) $ + enumFromToExpr (conE iHashDataName `appE` varE aHash) + (conE iHashDataName `appE` varE bHash) + + UnsafeIndex -> do + a <- newName "a" + aHash <- newName "a#" + c <- newName "c" + cHash <- newName "c#" + dHash <- newName "d#" + lamE [tupP [varP a, wildP], varP c] $ + untagExpr [(a, aHash)] $ + untagExpr [(c, cHash)] $ + caseE (infixApp (varE cHash) (varE minusIntHashValName) (varE aHash)) + [ match (varP dHash) + (normalB $ conE iHashDataName `appE` varE dHash) + [] + ] + + InRange -> do + a <- newName "a" + aHash <- newName "a#" + b <- newName "b" + bHash <- newName "b#" + c <- newName "c" + cHash <- newName "c#" + lamE [tupP [varP a, varP b], varP c] $ + untagExpr [(a, aHash)] $ + untagExpr [(b, bHash)] $ + untagExpr [(c, cHash)] $ + appsE [ varE andValName + , primOpAppExpr (varE cHash) geIntHashValName (varE aHash) + , primOpAppExpr (varE cHash) leIntHashValName (varE bHash) + ] + + | otherwise -- It's a product type + = do let con :: ConstructorInfo + con = head cons + + conName :: Name + conName = constructorName con + + conFields :: Int + conFields = conArity con + + as <- newNameList "a" conFields + bs <- newNameList "b" conFields + cs <- newNameList "c" conFields + + let conPat :: [Name] -> Q Pat + conPat = conP conName . map varP + + conExpr :: Q Exp + conExpr = appsE $ conE conName : map varE cs + + case ixf of + Range -> lamE [tupP [conPat as, conPat bs]] $ + compE $ stmts ++ [noBindS conExpr] + where + stmts :: [Q Stmt] + stmts = zipWith3 mkQual as bs cs + + mkQual :: Name -> Name -> Name -> Q Stmt + mkQual a b c = bindS (varP c) $ + varE rangeValName `appE` tupE [varE a, varE b] + + UnsafeIndex -> lamE [tupP [conPat as, conPat bs], conPat cs] $ + mkUnsafeIndex $ reverse $ zip3 as bs cs + where + mkUnsafeIndex :: [(Name, Name, Name)] -> Q Exp + mkUnsafeIndex [] = integerE 0 + mkUnsafeIndex [(l, u, i)] = mkOne l u i + mkUnsafeIndex ((l, u, i):rest) = + infixApp (mkOne l u i) + (varE plusValName) + (infixApp (varE unsafeRangeSizeValName + `appE` tupE [varE l, varE u]) + (varE timesValName) + (mkUnsafeIndex rest)) + + mkOne :: Name -> Name -> Name -> Q Exp + mkOne l u i = varE unsafeIndexValName `appE` tupE [varE l, varE u] + `appE` varE i + + InRange -> lamE [tupP [conPat as, conPat bs], conPat cs] $ + if conFields == 0 + then conE trueDataName + else foldl1 andExpr $ zipWith3 mkInRange as bs cs + where + andExpr :: Q Exp -> Q Exp -> Q Exp + andExpr a b = infixApp a (varE andValName) b + + mkInRange :: Name -> Name -> Name -> Q Exp + mkInRange a b c = varE inRangeValName `appE` tupE [varE a, varE b] + `appE` varE c + where + isProduct, isEnumeration :: Bool + isProduct = isProductType cons + isEnumeration = isEnumerationType cons + + tag2Con :: Q Exp + tag2Con = tag2ConExpr $ removeClassApp ty + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- There's only one Ix variant! +data IxClass = IxClass + +instance ClassRep IxClass where + arity _ = 0 + + allowExQuant _ = True + + fullClassName _ = ixTypeName + + classConstraint _ 0 = Just ixTypeName + classConstraint _ _ = Nothing + +-- | A representation of which function is being generated. +data IxFun = Range + | UnsafeIndex + | InRange + deriving Show + +ixFunName :: IxFun -> Name +ixFunName Range = rangeValName +ixFunName UnsafeIndex = unsafeIndexValName +ixFunName InRange = inRangeValName diff --git a/src/Data/Ord/Deriving.hs b/src/Data/Ord/Deriving.hs --- a/src/Data/Ord/Deriving.hs +++ b/src/Data/Ord/Deriving.hs @@ -1,60 +1,60 @@ -{-# LANGUAGE CPP #-} -{-| -Module: Data.Ord.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. -Note that upstream GHC does not have the ability to derive 'Ord1' or 'Ord2' -instances, but since the functionality to derive 'Ord' extends very naturally -'Ord1' and 'Ord2', the ability to derive the latter two classes is provided as a -convenience. --} -module Data.Ord.Deriving ( - -- * 'Ord' - deriveOrd - , makeCompare - , makeLT - , makeLE - , makeGT - , makeGE - , makeMax - , makeMin - -- * 'Ord1' - , deriveOrd1 -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftCompare -#endif - , makeCompare1 -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Ord2' - , deriveOrd2 - , makeLiftCompare2 - , makeCompare2 -#endif - -- * 'deriveOrd' limitations - -- $constraints - ) where - -import Data.Ord.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @*@ are assumed to have 'Ord' constraints. - Type variables of kind @* -> *@ are assumed to have 'Ord1' constraints. - Type variables of kind @* -> * -> *@ are assumed to have 'Ord2' constraints. - If this is not desirable, use 'makeCompare' or one of its cousins. - -* The 'Ord1' class had a different definition in @transformers-0.4@, and as a result, - 'deriveOrd1' implements different instances for the @transformers-0.4@ 'Ord1' than - it otherwise does. Also, 'makeLiftCompare' is not available - when this library is built against @transformers-0.4@, only 'makeCompare1. - -* The 'Ord2' class is not available in @transformers-0.4@, and as a - result, neither are Template Haskell functions that deal with 'Ord2' when this - library is built against @transformers-0.4@. --} +{-# LANGUAGE CPP #-} +{-| +Module: Data.Ord.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. +Note that upstream GHC does not have the ability to derive 'Ord1' or 'Ord2' +instances, but since the functionality to derive 'Ord' extends very naturally +'Ord1' and 'Ord2', the ability to derive the latter two classes is provided as a +convenience. +-} +module Data.Ord.Deriving ( + -- * 'Ord' + deriveOrd + , makeCompare + , makeLT + , makeLE + , makeGT + , makeGE + , makeMax + , makeMin + -- * 'Ord1' + , deriveOrd1 +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftCompare +#endif + , makeCompare1 +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Ord2' + , deriveOrd2 + , makeLiftCompare2 + , makeCompare2 +#endif + -- * 'deriveOrd' limitations + -- $constraints + ) where + +import Data.Ord.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Ord' constraints. + Type variables of kind @* -> *@ are assumed to have 'Ord1' constraints. + Type variables of kind @* -> * -> *@ are assumed to have 'Ord2' constraints. + If this is not desirable, use 'makeCompare' or one of its cousins. + +* The 'Ord1' class had a different definition in @transformers-0.4@, and as a result, + 'deriveOrd1' implements different instances for the @transformers-0.4@ 'Ord1' than + it otherwise does. Also, 'makeLiftCompare' is not available + when this library is built against @transformers-0.4@, only 'makeCompare1. + +* The 'Ord2' class is not available in @transformers-0.4@, and as a + result, neither are Template Haskell functions that deal with 'Ord2' when this + library is built against @transformers-0.4@. +-} diff --git a/src/Data/Ord/Deriving/Internal.hs b/src/Data/Ord/Deriving/Internal.hs --- a/src/Data/Ord/Deriving/Internal.hs +++ b/src/Data/Ord/Deriving/Internal.hs @@ -1,707 +1,707 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} - -{-| -Module: Data.Ord.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Data.Ord.Deriving.Internal ( - -- * 'Ord' - deriveOrd - , makeCompare - , makeLE - , makeLT - , makeGT - , makeGE - , makeMax - , makeMin - -- * 'Ord1' - , deriveOrd1 -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftCompare -#endif - , makeCompare1 -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Ord2' - , deriveOrd2 - , makeLiftCompare2 - , makeCompare2 -#endif - ) where - -import Data.Deriving.Internal -import Data.List (partition) -import qualified Data.Map as Map -import Data.Map (Map) - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- | Generates an 'Ord' instance declaration for the given data type or data --- family instance. -deriveOrd :: Name -> Q [Dec] -deriveOrd = deriveOrdClass Ord - --- | Generates a lambda expression which behaves like 'compare' (without --- requiring an 'Ord' instance). -makeCompare :: Name -> Q Exp -makeCompare = makeOrdFun OrdCompare (error "This shouldn't happen") - --- | Generates a lambda expression which behaves like '(<)' (without --- requiring an 'Ord' instance). -makeLT :: Name -> Q Exp -makeLT = makeOrdFun OrdLT [ match (conP ltDataName []) (normalB $ conE trueDataName) [] - , match wildP (normalB $ conE falseDataName) [] - ] - --- | Generates a lambda expression which behaves like '(<=)' (without --- requiring an 'Ord' instance). -makeLE :: Name -> Q Exp -makeLE = makeOrdFun OrdLE [ match (conP gtDataName []) (normalB $ conE falseDataName) [] - , match wildP (normalB $ conE trueDataName) [] - ] - --- | Generates a lambda expression which behaves like '(>)' (without --- requiring an 'Ord' instance). -makeGT :: Name -> Q Exp -makeGT = makeOrdFun OrdGT [ match (conP gtDataName []) (normalB $ conE trueDataName) [] - , match wildP (normalB $ conE falseDataName) [] - ] - --- | Generates a lambda expression which behaves like '(>=)' (without --- requiring an 'Ord' instance). -makeGE :: Name -> Q Exp -makeGE = makeOrdFun OrdGE [ match (conP ltDataName []) (normalB $ conE falseDataName) [] - , match wildP (normalB $ conE trueDataName) [] - ] - --- | Generates a lambda expression which behaves like 'max' (without --- requiring an 'Ord' instance). -makeMax :: Name -> Q Exp -makeMax = makeMinMax flip - --- | Generates a lambda expression which behaves like 'min' (without --- requiring an 'Ord' instance). -makeMin :: Name -> Q Exp -makeMin = makeMinMax id - -makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp) - -> Name -> Q Exp -makeMinMax f name = do - x <- newName "x" - y <- newName "y" - let xExpr = varE x - yExpr = varE y - lamE [varP x, varP y] $ - f (condE $ makeLE name `appE` xExpr `appE` yExpr) xExpr yExpr - --- | Generates an 'Ord1' instance declaration for the given data type or data --- family instance. -deriveOrd1 :: Name -> Q [Dec] -deriveOrd1 = deriveOrdClass Ord1 - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates a lambda expression which behaves like 'liftCompare' (without --- requiring an 'Ord1' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftCompare :: Name -> Q Exp -makeLiftCompare = makeOrdFun Ord1LiftCompare (error "This shouldn't happen") - --- | Generates a lambda expression which behaves like 'compare1' (without --- requiring an 'Ord1' instance). -makeCompare1 :: Name -> Q Exp -makeCompare1 name = makeLiftCompare name `appE` varE compareValName -#else --- | Generates a lambda expression which behaves like 'compare1' (without --- requiring an 'Ord1' instance). -makeCompare1 :: Name -> Q Exp -makeCompare1 = makeOrdFun Ord1Compare1 (error "This shouldn't happen") -#endif - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates an 'Ord2' instance declaration for the given data type or data --- family instance. --- --- This function is not available with @transformers-0.4@. -deriveOrd2 :: Name -> Q [Dec] -deriveOrd2 = deriveOrdClass Ord2 - --- | Generates a lambda expression which behaves like 'liftCompare2' (without --- requiring an 'Ord2' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftCompare2 :: Name -> Q Exp -makeLiftCompare2 = makeOrdFun Ord2LiftCompare2 (error "This shouldn't happen") - --- | Generates a lambda expression which behaves like 'compare2' (without --- requiring an 'Ord2' instance). --- --- This function is not available with @transformers-0.4@. -makeCompare2 :: Name -> Q Exp -makeCompare2 name = makeLiftCompare name - `appE` varE compareValName - `appE` varE compareValName -#endif - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass --- argument's value). -deriveOrdClass :: OrdClass -> Name -> Q [Dec] -deriveOrdClass oClass name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance oClass parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (ordFunDecs oClass instTypes cons) - --- | Generates a declaration defining the primary function(s) corresponding to a --- particular class (compare for Ord, liftCompare for Ord1, and --- liftCompare2 for Ord2). -ordFunDecs :: OrdClass -> [Type] -> [ConstructorInfo] -> [Q Dec] -ordFunDecs oClass instTypes cons = - map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons - where - makeFunD :: OrdFun -> Q Dec - makeFunD oFun = - funD (ordFunName oFun $ arity oClass) - [ clause [] - (normalB $ dispatchFun oFun) - [] - ] - - negateExpr :: Q Exp -> Q Exp - negateExpr = appE (varE notValName) - - dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp - dispatchLT f = do - x <- newName "x" - y <- newName "y" - lamE [varP x, varP y] $ f (varE ltValName) (varE x) (varE y) - - dispatchFun :: OrdFun -> Q Exp - dispatchFun oFun | oFun `elem` [ OrdCompare, OrdLT - -- OrdLT is included to mirror the fix to - -- GHC Trac #10858. -#if defined(NEW_FUNCTOR_CLASSES) - , Ord1LiftCompare, Ord2LiftCompare2 -#else - , Ord1Compare1 -#endif - ] - = makeOrdFunForCons oFun instTypes cons - dispatchFun OrdLE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` y `appE` x - dispatchFun OrdGT = dispatchLT $ \lt x y -> lt `appE` y `appE` x - dispatchFun OrdGE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` x `appE` y - dispatchFun _ = fail "ordFunDecs" - --- | Generates a lambda expression which behaves like the OrdFun value. This --- function uses heuristics to determine whether to implement the OrdFun from --- scratch or define it in terms of compare. -makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp -makeOrdFun oFun matches name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - let oClass = ordFunToClass oFun - others = otherFuns oClass cons - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have compare/liftCompare/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance oClass parentName ctxt instTypes variant >> - if oFun `elem` compareFuns || oFun `elem` others - then makeOrdFunForCons oFun instTypes cons - else do - x <- newName "x" - y <- newName "y" - lamE [varP x, varP y] $ - caseE (makeOrdFunForCons (ordClassToCompare oClass) instTypes cons - `appE` varE x `appE` varE y) - matches - where - compareFuns :: [OrdFun] - compareFuns = [ OrdCompare -#if defined(NEW_FUNCTOR_CLASSES) - , Ord1LiftCompare - , Ord2LiftCompare2 -#else - , Ord1Compare1 -#endif - ] - --- | Generates a lambda expression for the given constructors. --- All constructors must be from the same type. -makeOrdFunForCons :: OrdFun -> [Type] -> [ConstructorInfo] -> Q Exp -makeOrdFunForCons oFun instTypes cons = do - let oClass = ordFunToClass oFun - v1 <- newName "v1" - v2 <- newName "v2" - v1Hash <- newName "v1#" - v2Hash <- newName "v2#" - ords <- newNameList "ord" $ arity oClass - - let lastTyVars :: [Name] - lastTyVars = map varTToName $ drop (length instTypes - fromEnum oClass) instTypes - - tvMap :: TyVarMap1 - tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars ords - - nullaryCons, nonNullaryCons :: [ConstructorInfo] - (nullaryCons, nonNullaryCons) = partition isNullaryCon cons - - singleConType :: Bool - singleConType = isSingleton cons - - firstConName, lastConName :: Name - firstConName = constructorName $ head cons - lastConName = constructorName $ last cons - - -- Alternatively, we could look these up from dataConTagMap, but this - -- is slightly faster due to the lack of Map lookups. - firstTag, lastTag :: Int - firstTag = 0 - lastTag = length cons - 1 - - dataConTagMap :: Map Name Int - dataConTagMap = Map.fromList $ zip (map constructorName cons) [0..] - - ordMatches :: ConstructorInfo -> Q Match - ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType - firstTag firstConName lastTag lastConName - dataConTagMap - - ordFunRhs :: Q Exp - ordFunRhs - | null cons - = conE eqDataName - | length nullaryCons <= 2 - = caseE (varE v1) $ map ordMatches cons - | null nonNullaryCons - = mkTagCmp - | otherwise - = caseE (varE v1) $ map ordMatches nonNullaryCons - ++ [match wildP (normalB mkTagCmp) []] - - mkTagCmp :: Q Exp - mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $ - unliftedOrdFun intHashTypeName oFun v1Hash v2Hash - - lamE (map varP $ -#if defined(NEW_FUNCTOR_CLASSES) - ords ++ -#endif - [v1, v2]) - . appsE - $ [ varE $ compareConstName oFun - , ordFunRhs - ] -#if defined(NEW_FUNCTOR_CLASSES) - ++ map varE ords -#endif - ++ [varE v1, varE v2] - -makeOrdFunForCon :: OrdFun - -> Name - -> Name - -> TyVarMap1 - -> Bool - -> Int -> Name - -> Int -> Name - -> Map Name Int - -> ConstructorInfo -> Q Match -makeOrdFunForCon oFun v2 v2Hash tvMap singleConType - firstTag firstConName lastTag lastConName dataConTagMap - (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do - ts' <- mapM resolveTypeSynonyms ts - let tsLen = length ts' - as <- newNameList "a" tsLen - bs <- newNameList "b" tsLen - - let innerRhs :: Q Exp - innerRhs - | singleConType - = caseE (varE v2) [innerEqAlt] - - | tag == firstTag - = caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] - - | tag == lastTag - = caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] - - | tag == firstTag + 1 - = caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) [] - , innerEqAlt - , match wildP (normalB $ ltResult oFun) [] - ] - - | tag == lastTag - 1 - = caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) [] - , innerEqAlt - , match wildP (normalB $ gtResult oFun) [] - ] - - | tag > lastTag `div` 2 - = untagExpr [(v2, v2Hash)] $ - condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit) - (gtResult oFun) $ - caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] - - | otherwise - = untagExpr [(v2, v2Hash)] $ - condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit) - (ltResult oFun) $ - caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] - - innerEqAlt :: Q Match - innerEqAlt = match (conP conName $ map varP bs) - (normalB $ makeOrdFunForFields oFun tvMap conName ts' as bs) - [] - - tagLit :: Q Exp - tagLit = litE . intPrimL $ fromIntegral tag - - match (conP conName $ map varP as) - (normalB innerRhs) - [] - where - tag = dataConTagMap Map.! conName - -makeOrdFunForFields :: OrdFun - -> TyVarMap1 - -> Name - -> [Type] - -> [Name] - -> [Name] - -> Q Exp -makeOrdFunForFields oFun tvMap conName = go - where - go :: [Type] -> [Name] -> [Name] -> Q Exp - go [] _ _ = eqResult oFun - go [ty] [a] [b] - | isSupportedUnliftedType ty = unliftedOrdFun (conTToName ty) oFun a b - | otherwise = makeOrdFunForType oFun tvMap conName ty - `appE` varE a `appE` varE b - go (ty:tys) (a:as) (b:bs) = - mkCompare ty a b (ltResult oFun) (go tys as bs) (gtResult oFun) - go _ _ _ = fail "Data.Ord.Deriving.Internal.makeOrdFunForFields" - - mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp - mkCompare ty a b lt eq gt - | isSupportedUnliftedType ty = - let (ltFun, _, eqFun, _, _) = primOrdFuns $ conTToName ty - in unliftedCompare ltFun eqFun aExpr bExpr lt eq gt - | otherwise - = caseE (makeOrdFunForType (ordClassToCompare $ ordFunToClass oFun) - tvMap conName ty `appE` aExpr `appE` bExpr) - [ match (conP ltDataName []) (normalB lt) [] - , match (conP eqDataName []) (normalB eq) [] - , match (conP gtDataName []) (normalB gt) [] - ] - where - aExpr, bExpr :: Q Exp - aExpr = varE a - bExpr = varE b - -makeOrdFunForType :: OrdFun - -> TyVarMap1 - -> Name - -> Type - -> Q Exp -#if defined(NEW_FUNCTOR_CLASSES) -makeOrdFunForType oFun tvMap _ (VarT tyName) = - varE $ case Map.lookup tyName tvMap of - Just (OneName ord) -> ord - Nothing -> ordFunName oFun 0 -#else -makeOrdFunForType oFun _ _ VarT{} = varE $ ordFunName oFun 0 -#endif -makeOrdFunForType oFun tvMap conName (SigT ty _) = makeOrdFunForType oFun tvMap conName ty -makeOrdFunForType oFun tvMap conName (ForallT _ _ ty) = makeOrdFunForType oFun tvMap conName ty -#if defined(NEW_FUNCTOR_CLASSES) -makeOrdFunForType oFun tvMap conName ty = do - let oClass :: OrdClass - oClass = ordFunToClass oFun - - tyCon :: Type - tyArgs :: [Type] - (tyCon, tyArgs) = unapplyTy ty - - numLastArgs :: Int - numLastArgs = min (arity oClass) (length tyArgs) - - lhsArgs, rhsArgs :: [Type] - (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - - tyVarNames :: [Name] - tyVarNames = Map.keys tvMap - - itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs - if any (`mentionsName` tyVarNames) lhsArgs - || itf && any (`mentionsName` tyVarNames) tyArgs - then outOfPlaceTyVarError oClass conName - else if any (`mentionsName` tyVarNames) rhsArgs - then appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs] - ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs - else varE $ ordFunName oFun 0 -#else -makeOrdFunForType oFun tvMap conName ty = do - let varNames = Map.keys tvMap - oClass = ordFunToClass oFun - - a' <- newName "a'" - b' <- newName "b'" - case varNames of - [] -> varE $ ordFunName oFun 0 - varName:_ -> - if mentionsName ty varNames - then lamE (map varP [a',b']) $ varE (ordFunName oFun 1) - `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE a') - `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE b') - else varE $ ordFunName oFun 0 -#endif - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- | A representation of which @Ord@ variant is being derived. -data OrdClass = Ord - | Ord1 -#if defined(NEW_FUNCTOR_CLASSES) - | Ord2 -#endif - deriving (Bounded, Enum) - -instance ClassRep OrdClass where - arity = fromEnum - - allowExQuant _ = True - - fullClassName Ord = ordTypeName - fullClassName Ord1 = ord1TypeName -#if defined(NEW_FUNCTOR_CLASSES) - fullClassName Ord2 = ord2TypeName -#endif - - classConstraint oClass i - | oMin <= i && i <= oMax = Just $ fullClassName (toEnum i :: OrdClass) - | otherwise = Nothing - where - oMin, oMax :: Int - oMin = fromEnum (minBound :: OrdClass) - oMax = fromEnum oClass - -compareConstName :: OrdFun -> Name -compareConstName OrdCompare = compareConstValName -compareConstName OrdLT = ltConstValName -compareConstName OrdLE = ltConstValName -compareConstName OrdGT = ltConstValName -compareConstName OrdGE = ltConstValName -#if defined(NEW_FUNCTOR_CLASSES) -compareConstName Ord1LiftCompare = liftCompareConstValName -compareConstName Ord2LiftCompare2 = liftCompare2ConstValName -#else -compareConstName Ord1Compare1 = compare1ConstValName -#endif - -ordClassToCompare :: OrdClass -> OrdFun -ordClassToCompare Ord = OrdCompare -#if defined(NEW_FUNCTOR_CLASSES) -ordClassToCompare Ord1 = Ord1LiftCompare -ordClassToCompare Ord2 = Ord2LiftCompare2 -#else -ordClassToCompare Ord1 = Ord1Compare1 -#endif - -data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT -#if defined(NEW_FUNCTOR_CLASSES) - | Ord1LiftCompare | Ord2LiftCompare2 -#else - | Ord1Compare1 -#endif - deriving Eq - -ordFunName :: OrdFun -> Int -> Name -ordFunName OrdCompare 0 = compareValName -ordFunName OrdLT 0 = ltValName -ordFunName OrdLE 0 = leValName -ordFunName OrdGE 0 = geValName -ordFunName OrdGT 0 = gtValName -#if defined(NEW_FUNCTOR_CLASSES) -ordFunName Ord1LiftCompare 0 = ordFunName OrdCompare 0 -ordFunName Ord1LiftCompare 1 = liftCompareValName -ordFunName Ord2LiftCompare2 0 = ordFunName OrdCompare 0 -ordFunName Ord2LiftCompare2 1 = ordFunName Ord1LiftCompare 1 -ordFunName Ord2LiftCompare2 2 = liftCompare2ValName -#else -ordFunName Ord1Compare1 0 = ordFunName OrdCompare 0 -ordFunName Ord1Compare1 1 = compare1ValName -#endif -ordFunName _ _ = error "Data.Ord.Deriving.Internal.ordFunName" - -ordFunToClass :: OrdFun -> OrdClass -ordFunToClass OrdCompare = Ord -ordFunToClass OrdLT = Ord -ordFunToClass OrdLE = Ord -ordFunToClass OrdGE = Ord -ordFunToClass OrdGT = Ord -#if defined(NEW_FUNCTOR_CLASSES) -ordFunToClass Ord1LiftCompare = Ord1 -ordFunToClass Ord2LiftCompare2 = Ord2 -#else -ordFunToClass Ord1Compare1 = Ord1 -#endif - -eqResult :: OrdFun -> Q Exp -eqResult OrdCompare = eqTagExpr -eqResult OrdLT = falseExpr -eqResult OrdLE = trueExpr -eqResult OrdGE = trueExpr -eqResult OrdGT = falseExpr -#if defined(NEW_FUNCTOR_CLASSES) -eqResult Ord1LiftCompare = eqTagExpr -eqResult Ord2LiftCompare2 = eqTagExpr -#else -eqResult Ord1Compare1 = eqTagExpr -#endif - -gtResult :: OrdFun -> Q Exp -gtResult OrdCompare = gtTagExpr -gtResult OrdLT = falseExpr -gtResult OrdLE = falseExpr -gtResult OrdGE = trueExpr -gtResult OrdGT = trueExpr -#if defined(NEW_FUNCTOR_CLASSES) -gtResult Ord1LiftCompare = gtTagExpr -gtResult Ord2LiftCompare2 = gtTagExpr -#else -gtResult Ord1Compare1 = gtTagExpr -#endif - -ltResult :: OrdFun -> Q Exp -ltResult OrdCompare = ltTagExpr -ltResult OrdLT = trueExpr -ltResult OrdLE = trueExpr -ltResult OrdGE = falseExpr -ltResult OrdGT = falseExpr -#if defined(NEW_FUNCTOR_CLASSES) -ltResult Ord1LiftCompare = ltTagExpr -ltResult Ord2LiftCompare2 = ltTagExpr -#else -ltResult Ord1Compare1 = ltTagExpr -#endif - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - -ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp -ltTagExpr = conE ltDataName -eqTagExpr = conE eqDataName -gtTagExpr = conE gtDataName -falseExpr = conE falseDataName -trueExpr = conE trueDataName - --- Besides compare, that is -otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun] -otherFuns _ [] = [] -- We only need compare for empty data types. -otherFuns oClass cons = case oClass of - Ord1 -> [] -#if defined(NEW_FUNCTOR_CLASSES) - Ord2 -> [] -#endif - Ord | (lastTag - firstTag) <= 2 || null nonNullaryCons - -> [OrdLT, OrdLE, OrdGE, OrdGT] - | otherwise - -> [] - where - firstTag, lastTag :: Int - firstTag = 0 - lastTag = length cons - 1 - - nonNullaryCons :: [ConstructorInfo] - nonNullaryCons = filterOut isNullaryCon cons - -unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp -unliftedOrdFun tyName oFun a b = case oFun of - OrdCompare -> unliftedCompareExpr - OrdLT -> wrap ltFun - OrdLE -> wrap leFun - OrdGE -> wrap geFun - OrdGT -> wrap gtFun -#if defined(NEW_FUNCTOR_CLASSES) - Ord1LiftCompare -> unliftedCompareExpr - Ord2LiftCompare2 -> unliftedCompareExpr -#else - Ord1Compare1 -> unliftedCompareExpr -#endif - where - unliftedCompareExpr :: Q Exp - unliftedCompareExpr = unliftedCompare ltFun eqFun aExpr bExpr - ltTagExpr eqTagExpr gtTagExpr - - ltFun, leFun, eqFun, geFun, gtFun :: Name - (ltFun, leFun, eqFun, geFun, gtFun) = primOrdFuns tyName - - wrap :: Name -> Q Exp - wrap primFun = primOpAppExpr aExpr primFun bExpr - - aExpr, bExpr :: Q Exp - aExpr = varE a - bExpr = varE b - -unliftedCompare :: Name -> Name - -> Q Exp -> Q Exp -- What to compare - -> Q Exp -> Q Exp -> Q Exp -- Three results - -> Q Exp -unliftedCompare ltFun eqFun aExpr bExpr lt eq gt = - condE (ascribeBool $ primOpAppExpr aExpr ltFun bExpr) lt $ - condE (ascribeBool $ primOpAppExpr aExpr eqFun bExpr) eq gt - where - ascribeBool :: Q Exp -> Q Exp - ascribeBool e = sigE e $ conT boolTypeName - -primOrdFuns :: Name -> (Name, Name, Name, Name, Name) -primOrdFuns tyName = - case Map.lookup tyName primOrdFunTbl of - Just names -> names - Nothing -> error $ nameBase tyName ++ " is not supported." - -isSupportedUnliftedType :: Type -> Bool -isSupportedUnliftedType (ConT tyName) = Map.member tyName primOrdFunTbl -isSupportedUnliftedType _ = False - -isSingleton :: [a] -> Bool -isSingleton [_] = True -isSingleton _ = False - --- | Like 'filter', only it reverses the sense of the test -filterOut :: (a -> Bool) -> [a] -> [a] -filterOut _ [] = [] -filterOut p (x:xs) | p x = filterOut p xs - | otherwise = x : filterOut p xs +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} + +{-| +Module: Data.Ord.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Ord.Deriving.Internal ( + -- * 'Ord' + deriveOrd + , makeCompare + , makeLE + , makeLT + , makeGT + , makeGE + , makeMax + , makeMin + -- * 'Ord1' + , deriveOrd1 +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftCompare +#endif + , makeCompare1 +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Ord2' + , deriveOrd2 + , makeLiftCompare2 + , makeCompare2 +#endif + ) where + +import Data.Deriving.Internal +import Data.List (partition) +import qualified Data.Map as Map +import Data.Map (Map) + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +-- | Generates an 'Ord' instance declaration for the given data type or data +-- family instance. +deriveOrd :: Name -> Q [Dec] +deriveOrd = deriveOrdClass Ord + +-- | Generates a lambda expression which behaves like 'compare' (without +-- requiring an 'Ord' instance). +makeCompare :: Name -> Q Exp +makeCompare = makeOrdFun OrdCompare (error "This shouldn't happen") + +-- | Generates a lambda expression which behaves like '(<)' (without +-- requiring an 'Ord' instance). +makeLT :: Name -> Q Exp +makeLT = makeOrdFun OrdLT [ match (conP ltDataName []) (normalB $ conE trueDataName) [] + , match wildP (normalB $ conE falseDataName) [] + ] + +-- | Generates a lambda expression which behaves like '(<=)' (without +-- requiring an 'Ord' instance). +makeLE :: Name -> Q Exp +makeLE = makeOrdFun OrdLE [ match (conP gtDataName []) (normalB $ conE falseDataName) [] + , match wildP (normalB $ conE trueDataName) [] + ] + +-- | Generates a lambda expression which behaves like '(>)' (without +-- requiring an 'Ord' instance). +makeGT :: Name -> Q Exp +makeGT = makeOrdFun OrdGT [ match (conP gtDataName []) (normalB $ conE trueDataName) [] + , match wildP (normalB $ conE falseDataName) [] + ] + +-- | Generates a lambda expression which behaves like '(>=)' (without +-- requiring an 'Ord' instance). +makeGE :: Name -> Q Exp +makeGE = makeOrdFun OrdGE [ match (conP ltDataName []) (normalB $ conE falseDataName) [] + , match wildP (normalB $ conE trueDataName) [] + ] + +-- | Generates a lambda expression which behaves like 'max' (without +-- requiring an 'Ord' instance). +makeMax :: Name -> Q Exp +makeMax = makeMinMax flip + +-- | Generates a lambda expression which behaves like 'min' (without +-- requiring an 'Ord' instance). +makeMin :: Name -> Q Exp +makeMin = makeMinMax id + +makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp) + -> Name -> Q Exp +makeMinMax f name = do + x <- newName "x" + y <- newName "y" + let xExpr = varE x + yExpr = varE y + lamE [varP x, varP y] $ + f (condE $ makeLE name `appE` xExpr `appE` yExpr) xExpr yExpr + +-- | Generates an 'Ord1' instance declaration for the given data type or data +-- family instance. +deriveOrd1 :: Name -> Q [Dec] +deriveOrd1 = deriveOrdClass Ord1 + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a lambda expression which behaves like 'liftCompare' (without +-- requiring an 'Ord1' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftCompare :: Name -> Q Exp +makeLiftCompare = makeOrdFun Ord1LiftCompare (error "This shouldn't happen") + +-- | Generates a lambda expression which behaves like 'compare1' (without +-- requiring an 'Ord1' instance). +makeCompare1 :: Name -> Q Exp +makeCompare1 name = makeLiftCompare name `appE` varE compareValName +#else +-- | Generates a lambda expression which behaves like 'compare1' (without +-- requiring an 'Ord1' instance). +makeCompare1 :: Name -> Q Exp +makeCompare1 = makeOrdFun Ord1Compare1 (error "This shouldn't happen") +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates an 'Ord2' instance declaration for the given data type or data +-- family instance. +-- +-- This function is not available with @transformers-0.4@. +deriveOrd2 :: Name -> Q [Dec] +deriveOrd2 = deriveOrdClass Ord2 + +-- | Generates a lambda expression which behaves like 'liftCompare2' (without +-- requiring an 'Ord2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftCompare2 :: Name -> Q Exp +makeLiftCompare2 = makeOrdFun Ord2LiftCompare2 (error "This shouldn't happen") + +-- | Generates a lambda expression which behaves like 'compare2' (without +-- requiring an 'Ord2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeCompare2 :: Name -> Q Exp +makeCompare2 name = makeLiftCompare name + `appE` varE compareValName + `appE` varE compareValName +#endif + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass +-- argument's value). +deriveOrdClass :: OrdClass -> Name -> Q [Dec] +deriveOrdClass oClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance oClass parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (ordFunDecs oClass instTypes cons) + +-- | Generates a declaration defining the primary function(s) corresponding to a +-- particular class (compare for Ord, liftCompare for Ord1, and +-- liftCompare2 for Ord2). +ordFunDecs :: OrdClass -> [Type] -> [ConstructorInfo] -> [Q Dec] +ordFunDecs oClass instTypes cons = + map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons + where + makeFunD :: OrdFun -> Q Dec + makeFunD oFun = + funD (ordFunName oFun $ arity oClass) + [ clause [] + (normalB $ dispatchFun oFun) + [] + ] + + negateExpr :: Q Exp -> Q Exp + negateExpr = appE (varE notValName) + + dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp + dispatchLT f = do + x <- newName "x" + y <- newName "y" + lamE [varP x, varP y] $ f (varE ltValName) (varE x) (varE y) + + dispatchFun :: OrdFun -> Q Exp + dispatchFun oFun | oFun `elem` [ OrdCompare, OrdLT + -- OrdLT is included to mirror the fix to + -- GHC Trac #10858. +#if defined(NEW_FUNCTOR_CLASSES) + , Ord1LiftCompare, Ord2LiftCompare2 +#else + , Ord1Compare1 +#endif + ] + = makeOrdFunForCons oFun instTypes cons + dispatchFun OrdLE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` y `appE` x + dispatchFun OrdGT = dispatchLT $ \lt x y -> lt `appE` y `appE` x + dispatchFun OrdGE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` x `appE` y + dispatchFun _ = fail "ordFunDecs" + +-- | Generates a lambda expression which behaves like the OrdFun value. This +-- function uses heuristics to determine whether to implement the OrdFun from +-- scratch or define it in terms of compare. +makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp +makeOrdFun oFun matches name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + let oClass = ordFunToClass oFun + others = otherFuns oClass cons + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have compare/liftCompare/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance oClass parentName ctxt instTypes variant >> + if oFun `elem` compareFuns || oFun `elem` others + then makeOrdFunForCons oFun instTypes cons + else do + x <- newName "x" + y <- newName "y" + lamE [varP x, varP y] $ + caseE (makeOrdFunForCons (ordClassToCompare oClass) instTypes cons + `appE` varE x `appE` varE y) + matches + where + compareFuns :: [OrdFun] + compareFuns = [ OrdCompare +#if defined(NEW_FUNCTOR_CLASSES) + , Ord1LiftCompare + , Ord2LiftCompare2 +#else + , Ord1Compare1 +#endif + ] + +-- | Generates a lambda expression for the given constructors. +-- All constructors must be from the same type. +makeOrdFunForCons :: OrdFun -> [Type] -> [ConstructorInfo] -> Q Exp +makeOrdFunForCons oFun instTypes cons = do + let oClass = ordFunToClass oFun + v1 <- newName "v1" + v2 <- newName "v2" + v1Hash <- newName "v1#" + v2Hash <- newName "v2#" + ords <- newNameList "ord" $ arity oClass + + let lastTyVars :: [Name] + lastTyVars = map varTToName $ drop (length instTypes - fromEnum oClass) instTypes + + tvMap :: TyVarMap1 + tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars ords + + nullaryCons, nonNullaryCons :: [ConstructorInfo] + (nullaryCons, nonNullaryCons) = partition isNullaryCon cons + + singleConType :: Bool + singleConType = isSingleton cons + + firstConName, lastConName :: Name + firstConName = constructorName $ head cons + lastConName = constructorName $ last cons + + -- Alternatively, we could look these up from dataConTagMap, but this + -- is slightly faster due to the lack of Map lookups. + firstTag, lastTag :: Int + firstTag = 0 + lastTag = length cons - 1 + + dataConTagMap :: Map Name Int + dataConTagMap = Map.fromList $ zip (map constructorName cons) [0..] + + ordMatches :: ConstructorInfo -> Q Match + ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType + firstTag firstConName lastTag lastConName + dataConTagMap + + ordFunRhs :: Q Exp + ordFunRhs + | null cons + = conE eqDataName + | length nullaryCons <= 2 + = caseE (varE v1) $ map ordMatches cons + | null nonNullaryCons + = mkTagCmp + | otherwise + = caseE (varE v1) $ map ordMatches nonNullaryCons + ++ [match wildP (normalB mkTagCmp) []] + + mkTagCmp :: Q Exp + mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $ + unliftedOrdFun intHashTypeName oFun v1Hash v2Hash + + lamE (map varP $ +#if defined(NEW_FUNCTOR_CLASSES) + ords ++ +#endif + [v1, v2]) + . appsE + $ [ varE $ compareConstName oFun + , ordFunRhs + ] +#if defined(NEW_FUNCTOR_CLASSES) + ++ map varE ords +#endif + ++ [varE v1, varE v2] + +makeOrdFunForCon :: OrdFun + -> Name + -> Name + -> TyVarMap1 + -> Bool + -> Int -> Name + -> Int -> Name + -> Map Name Int + -> ConstructorInfo -> Q Match +makeOrdFunForCon oFun v2 v2Hash tvMap singleConType + firstTag firstConName lastTag lastConName dataConTagMap + (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + let tsLen = length ts' + as <- newNameList "a" tsLen + bs <- newNameList "b" tsLen + + let innerRhs :: Q Exp + innerRhs + | singleConType + = caseE (varE v2) [innerEqAlt] + + | tag == firstTag + = caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] + + | tag == lastTag + = caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] + + | tag == firstTag + 1 + = caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) [] + , innerEqAlt + , match wildP (normalB $ ltResult oFun) [] + ] + + | tag == lastTag - 1 + = caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) [] + , innerEqAlt + , match wildP (normalB $ gtResult oFun) [] + ] + + | tag > lastTag `div` 2 + = untagExpr [(v2, v2Hash)] $ + condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit) + (gtResult oFun) $ + caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] + + | otherwise + = untagExpr [(v2, v2Hash)] $ + condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit) + (ltResult oFun) $ + caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] + + innerEqAlt :: Q Match + innerEqAlt = match (conP conName $ map varP bs) + (normalB $ makeOrdFunForFields oFun tvMap conName ts' as bs) + [] + + tagLit :: Q Exp + tagLit = litE . intPrimL $ fromIntegral tag + + match (conP conName $ map varP as) + (normalB innerRhs) + [] + where + tag = dataConTagMap Map.! conName + +makeOrdFunForFields :: OrdFun + -> TyVarMap1 + -> Name + -> [Type] + -> [Name] + -> [Name] + -> Q Exp +makeOrdFunForFields oFun tvMap conName = go + where + go :: [Type] -> [Name] -> [Name] -> Q Exp + go [] _ _ = eqResult oFun + go [ty] [a] [b] + | isSupportedUnliftedType ty = unliftedOrdFun (conTToName ty) oFun a b + | otherwise = makeOrdFunForType oFun tvMap conName ty + `appE` varE a `appE` varE b + go (ty:tys) (a:as) (b:bs) = + mkCompare ty a b (ltResult oFun) (go tys as bs) (gtResult oFun) + go _ _ _ = fail "Data.Ord.Deriving.Internal.makeOrdFunForFields" + + mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp + mkCompare ty a b lt eq gt + | isSupportedUnliftedType ty = + let (ltFun, _, eqFun, _, _) = primOrdFuns $ conTToName ty + in unliftedCompare ltFun eqFun aExpr bExpr lt eq gt + | otherwise + = caseE (makeOrdFunForType (ordClassToCompare $ ordFunToClass oFun) + tvMap conName ty `appE` aExpr `appE` bExpr) + [ match (conP ltDataName []) (normalB lt) [] + , match (conP eqDataName []) (normalB eq) [] + , match (conP gtDataName []) (normalB gt) [] + ] + where + aExpr, bExpr :: Q Exp + aExpr = varE a + bExpr = varE b + +makeOrdFunForType :: OrdFun + -> TyVarMap1 + -> Name + -> Type + -> Q Exp +#if defined(NEW_FUNCTOR_CLASSES) +makeOrdFunForType oFun tvMap _ (VarT tyName) = + varE $ case Map.lookup tyName tvMap of + Just (OneName ord) -> ord + Nothing -> ordFunName oFun 0 +#else +makeOrdFunForType oFun _ _ VarT{} = varE $ ordFunName oFun 0 +#endif +makeOrdFunForType oFun tvMap conName (SigT ty _) = makeOrdFunForType oFun tvMap conName ty +makeOrdFunForType oFun tvMap conName (ForallT _ _ ty) = makeOrdFunForType oFun tvMap conName ty +#if defined(NEW_FUNCTOR_CLASSES) +makeOrdFunForType oFun tvMap conName ty = do + let oClass :: OrdClass + oClass = ordFunToClass oFun + + tyCon :: Type + tyArgs :: [Type] + (tyCon, tyArgs) = unapplyTy ty + + numLastArgs :: Int + numLastArgs = min (arity oClass) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + + itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs + if any (`mentionsName` tyVarNames) lhsArgs + || itf && any (`mentionsName` tyVarNames) tyArgs + then outOfPlaceTyVarError oClass conName + else if any (`mentionsName` tyVarNames) rhsArgs + then appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs] + ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs + else varE $ ordFunName oFun 0 +#else +makeOrdFunForType oFun tvMap conName ty = do + let varNames = Map.keys tvMap + oClass = ordFunToClass oFun + + a' <- newName "a'" + b' <- newName "b'" + case varNames of + [] -> varE $ ordFunName oFun 0 + varName:_ -> + if mentionsName ty varNames + then lamE (map varP [a',b']) $ varE (ordFunName oFun 1) + `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE a') + `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE b') + else varE $ ordFunName oFun 0 +#endif + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which @Ord@ variant is being derived. +data OrdClass = Ord + | Ord1 +#if defined(NEW_FUNCTOR_CLASSES) + | Ord2 +#endif + deriving (Bounded, Enum) + +instance ClassRep OrdClass where + arity = fromEnum + + allowExQuant _ = True + + fullClassName Ord = ordTypeName + fullClassName Ord1 = ord1TypeName +#if defined(NEW_FUNCTOR_CLASSES) + fullClassName Ord2 = ord2TypeName +#endif + + classConstraint oClass i + | oMin <= i && i <= oMax = Just $ fullClassName (toEnum i :: OrdClass) + | otherwise = Nothing + where + oMin, oMax :: Int + oMin = fromEnum (minBound :: OrdClass) + oMax = fromEnum oClass + +compareConstName :: OrdFun -> Name +compareConstName OrdCompare = compareConstValName +compareConstName OrdLT = ltConstValName +compareConstName OrdLE = ltConstValName +compareConstName OrdGT = ltConstValName +compareConstName OrdGE = ltConstValName +#if defined(NEW_FUNCTOR_CLASSES) +compareConstName Ord1LiftCompare = liftCompareConstValName +compareConstName Ord2LiftCompare2 = liftCompare2ConstValName +#else +compareConstName Ord1Compare1 = compare1ConstValName +#endif + +ordClassToCompare :: OrdClass -> OrdFun +ordClassToCompare Ord = OrdCompare +#if defined(NEW_FUNCTOR_CLASSES) +ordClassToCompare Ord1 = Ord1LiftCompare +ordClassToCompare Ord2 = Ord2LiftCompare2 +#else +ordClassToCompare Ord1 = Ord1Compare1 +#endif + +data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT +#if defined(NEW_FUNCTOR_CLASSES) + | Ord1LiftCompare | Ord2LiftCompare2 +#else + | Ord1Compare1 +#endif + deriving Eq + +ordFunName :: OrdFun -> Int -> Name +ordFunName OrdCompare 0 = compareValName +ordFunName OrdLT 0 = ltValName +ordFunName OrdLE 0 = leValName +ordFunName OrdGE 0 = geValName +ordFunName OrdGT 0 = gtValName +#if defined(NEW_FUNCTOR_CLASSES) +ordFunName Ord1LiftCompare 0 = ordFunName OrdCompare 0 +ordFunName Ord1LiftCompare 1 = liftCompareValName +ordFunName Ord2LiftCompare2 0 = ordFunName OrdCompare 0 +ordFunName Ord2LiftCompare2 1 = ordFunName Ord1LiftCompare 1 +ordFunName Ord2LiftCompare2 2 = liftCompare2ValName +#else +ordFunName Ord1Compare1 0 = ordFunName OrdCompare 0 +ordFunName Ord1Compare1 1 = compare1ValName +#endif +ordFunName _ _ = error "Data.Ord.Deriving.Internal.ordFunName" + +ordFunToClass :: OrdFun -> OrdClass +ordFunToClass OrdCompare = Ord +ordFunToClass OrdLT = Ord +ordFunToClass OrdLE = Ord +ordFunToClass OrdGE = Ord +ordFunToClass OrdGT = Ord +#if defined(NEW_FUNCTOR_CLASSES) +ordFunToClass Ord1LiftCompare = Ord1 +ordFunToClass Ord2LiftCompare2 = Ord2 +#else +ordFunToClass Ord1Compare1 = Ord1 +#endif + +eqResult :: OrdFun -> Q Exp +eqResult OrdCompare = eqTagExpr +eqResult OrdLT = falseExpr +eqResult OrdLE = trueExpr +eqResult OrdGE = trueExpr +eqResult OrdGT = falseExpr +#if defined(NEW_FUNCTOR_CLASSES) +eqResult Ord1LiftCompare = eqTagExpr +eqResult Ord2LiftCompare2 = eqTagExpr +#else +eqResult Ord1Compare1 = eqTagExpr +#endif + +gtResult :: OrdFun -> Q Exp +gtResult OrdCompare = gtTagExpr +gtResult OrdLT = falseExpr +gtResult OrdLE = falseExpr +gtResult OrdGE = trueExpr +gtResult OrdGT = trueExpr +#if defined(NEW_FUNCTOR_CLASSES) +gtResult Ord1LiftCompare = gtTagExpr +gtResult Ord2LiftCompare2 = gtTagExpr +#else +gtResult Ord1Compare1 = gtTagExpr +#endif + +ltResult :: OrdFun -> Q Exp +ltResult OrdCompare = ltTagExpr +ltResult OrdLT = trueExpr +ltResult OrdLE = trueExpr +ltResult OrdGE = falseExpr +ltResult OrdGT = falseExpr +#if defined(NEW_FUNCTOR_CLASSES) +ltResult Ord1LiftCompare = ltTagExpr +ltResult Ord2LiftCompare2 = ltTagExpr +#else +ltResult Ord1Compare1 = ltTagExpr +#endif + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp +ltTagExpr = conE ltDataName +eqTagExpr = conE eqDataName +gtTagExpr = conE gtDataName +falseExpr = conE falseDataName +trueExpr = conE trueDataName + +-- Besides compare, that is +otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun] +otherFuns _ [] = [] -- We only need compare for empty data types. +otherFuns oClass cons = case oClass of + Ord1 -> [] +#if defined(NEW_FUNCTOR_CLASSES) + Ord2 -> [] +#endif + Ord | (lastTag - firstTag) <= 2 || null nonNullaryCons + -> [OrdLT, OrdLE, OrdGE, OrdGT] + | otherwise + -> [] + where + firstTag, lastTag :: Int + firstTag = 0 + lastTag = length cons - 1 + + nonNullaryCons :: [ConstructorInfo] + nonNullaryCons = filterOut isNullaryCon cons + +unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp +unliftedOrdFun tyName oFun a b = case oFun of + OrdCompare -> unliftedCompareExpr + OrdLT -> wrap ltFun + OrdLE -> wrap leFun + OrdGE -> wrap geFun + OrdGT -> wrap gtFun +#if defined(NEW_FUNCTOR_CLASSES) + Ord1LiftCompare -> unliftedCompareExpr + Ord2LiftCompare2 -> unliftedCompareExpr +#else + Ord1Compare1 -> unliftedCompareExpr +#endif + where + unliftedCompareExpr :: Q Exp + unliftedCompareExpr = unliftedCompare ltFun eqFun aExpr bExpr + ltTagExpr eqTagExpr gtTagExpr + + ltFun, leFun, eqFun, geFun, gtFun :: Name + (ltFun, leFun, eqFun, geFun, gtFun) = primOrdFuns tyName + + wrap :: Name -> Q Exp + wrap primFun = primOpAppExpr aExpr primFun bExpr + + aExpr, bExpr :: Q Exp + aExpr = varE a + bExpr = varE b + +unliftedCompare :: Name -> Name + -> Q Exp -> Q Exp -- What to compare + -> Q Exp -> Q Exp -> Q Exp -- Three results + -> Q Exp +unliftedCompare ltFun eqFun aExpr bExpr lt eq gt = + condE (ascribeBool $ primOpAppExpr aExpr ltFun bExpr) lt $ + condE (ascribeBool $ primOpAppExpr aExpr eqFun bExpr) eq gt + where + ascribeBool :: Q Exp -> Q Exp + ascribeBool e = sigE e $ conT boolTypeName + +primOrdFuns :: Name -> (Name, Name, Name, Name, Name) +primOrdFuns tyName = + case Map.lookup tyName primOrdFunTbl of + Just names -> names + Nothing -> error $ nameBase tyName ++ " is not supported." + +isSupportedUnliftedType :: Type -> Bool +isSupportedUnliftedType (ConT tyName) = Map.member tyName primOrdFunTbl +isSupportedUnliftedType _ = False + +isSingleton :: [a] -> Bool +isSingleton [_] = True +isSingleton _ = False + +-- | Like 'filter', only it reverses the sense of the test +filterOut :: (a -> Bool) -> [a] -> [a] +filterOut _ [] = [] +filterOut p (x:xs) | p x = filterOut p xs + | otherwise = x : filterOut p xs diff --git a/src/Data/Traversable/Deriving.hs b/src/Data/Traversable/Deriving.hs --- a/src/Data/Traversable/Deriving.hs +++ b/src/Data/Traversable/Deriving.hs @@ -1,61 +1,61 @@ -{-| -Module: Data.Traversable.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Traversable' instances in a way that mimics -how the @-XDeriveTraversable@ extension works since GHC 8.0. - -Derived 'Traversable' instances from this module do not generate -superfluous 'pure' expressions in its implementation of 'traverse'. One can -verify this by compiling a module that uses 'deriveTraversable' with the -@-ddump-splices@ GHC flag. - -These changes make it possible to derive @Traversable@ instances for data types with -unlifted argument types, e.g., - -@ -data IntHash a = IntHash Int# a - -deriving instance Traversable IntHash -- On GHC 8.0 on later -$(deriveTraversable ''IntHash) -- On GHC 7.10 and earlier -@ - -For more info on these changes, see -. --} -module Data.Traversable.Deriving ( - -- * 'Traversable' - deriveTraversable - , deriveTraversableOptions - , makeTraverse - , makeTraverseOptions - , makeSequenceA - , makeSequenceAOptions - , makeMapM - , makeMapMOptions - , makeSequence - , makeSequenceOptions - -- * 'FFTOptions' - , FFTOptions(..) - , defaultFFTOptions - -- * 'deriveTraversable' limitations - -- $constraints - ) where - -import Data.Functor.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an - existential constraint cannot mention the last type variable. For example, - @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived - 'Traversable' instance. - -* Type variables of kind @* -> *@ are assumed to have 'Traversable' constraints. - If this is not desirable, use 'makeTraverse'. --} +{-| +Module: Data.Traversable.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Traversable' instances in a way that mimics +how the @-XDeriveTraversable@ extension works since GHC 8.0. + +Derived 'Traversable' instances from this module do not generate +superfluous 'pure' expressions in its implementation of 'traverse'. One can +verify this by compiling a module that uses 'deriveTraversable' with the +@-ddump-splices@ GHC flag. + +These changes make it possible to derive @Traversable@ instances for data types with +unlifted argument types, e.g., + +@ +data IntHash a = IntHash Int# a + +deriving instance Traversable IntHash -- On GHC 8.0 on later +$(deriveTraversable ''IntHash) -- On GHC 7.10 and earlier +@ + +For more info on these changes, see +. +-} +module Data.Traversable.Deriving ( + -- * 'Traversable' + deriveTraversable + , deriveTraversableOptions + , makeTraverse + , makeTraverseOptions + , makeSequenceA + , makeSequenceAOptions + , makeMapM + , makeMapMOptions + , makeSequence + , makeSequenceOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions + -- * 'deriveTraversable' limitations + -- $constraints + ) where + +import Data.Functor.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an + existential constraint cannot mention the last type variable. For example, + @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived + 'Traversable' instance. + +* Type variables of kind @* -> *@ are assumed to have 'Traversable' constraints. + If this is not desirable, use 'makeTraverse'. +-} diff --git a/src/Text/Read/Deriving.hs b/src/Text/Read/Deriving.hs --- a/src/Text/Read/Deriving.hs +++ b/src/Text/Read/Deriving.hs @@ -1,98 +1,98 @@ -{-# LANGUAGE CPP #-} -{-| -Module: Text.Read.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. -Note that upstream GHC does not have the ability to derive 'Read1' or 'Read2' -instances, but since the functionality to derive 'Read' extends very naturally -'Read1' and 'Read2', the ability to derive the latter two classes is provided as a -convenience. --} -module Text.Read.Deriving ( - -- * 'Read' - deriveRead - , deriveReadOptions - , makeReadsPrec --- , makeReadsPrecOptions --- , makeReadList --- , makeReadListOptions - , makeReadPrec --- , makeReadPrecOptions --- , makeReadListPrec --- , makeReadListPrecOptions - -- * 'Read1' - , deriveRead1 - , deriveRead1Options -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftReadsPrec --- , makeLiftReadsPrecOptions --- , makeLiftReadList --- , makeLiftReadListOptions -# if __GLASGOW_HASKELL__ >= 801 - , makeLiftReadPrec --- , makeLiftReadPrecOptions --- , makeLiftReadListPrec --- , makeLiftReadListPrecOptions - , makeReadPrec1 --- , makeReadPrec1Options -# endif -#endif - , makeReadsPrec1 --- , makeReadsPrec1Options -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Read2' - , deriveRead2 - , deriveRead2Options - , makeLiftReadsPrec2 --- , makeLiftReadsPrec2Options --- , makeLiftReadList2 --- , makeLiftReadList2Options -# if __GLASGOW_HASKELL__ >= 801 - , makeLiftReadPrec2 --- , makeLiftReadPrec2Options --- , makeLiftReadListPrec2 --- , makeLiftReadListPrec2Options - , makeReadPrec2 --- , makeReadPrec2Options -# endif - , makeReadsPrec2 --- , makeReadsPrec2Options -#endif - -- * 'ReadOptions' - , ReadOptions(..) - , defaultReadOptions - -- * 'deriveRead' limitations - -- $constraints - ) where - -import Text.Read.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @*@ are assumed to have 'Read' constraints. - Type variables of kind @* -> *@ are assumed to have 'Read1' constraints. - Type variables of kind @* -> * -> *@ are assumed to have 'Read2' constraints. - If this is not desirable, use 'makeReadsPrec' or one of its cousins. - -* The 'Read1' class had a different definition in @transformers-0.4@, and as a result, - 'deriveRead1' implements different instances for the @transformers-0.4@ 'Read1' than - it otherwise does. Also, 'makeLiftReadsPrec' and 'makeLiftReadList' are not available - when this library is built against @transformers-0.4@, only 'makeReadsPrec1. - -* The 'Read2' class is not available in @transformers-0.4@, and as a - result, neither are Template Haskell functions that deal with 'Read2' when this - library is built against @transformers-0.4@. - -* The 'Read1' and 'Read2' classes have new methods ('liftReadPrec'/'liftReadListPrec' - and 'liftReadPrec2'/'liftReadListPrec2', respectively) that were introduced in - @base-4.10@. For now, these methods are only defined when deriving 'Read1'/'Read2' - if built against @base-4.10@ (until @transformers-compat@ catches up), and - the corresponding @make-@ functions are also only available when built against - @base-4.10@. --} +{-# LANGUAGE CPP #-} +{-| +Module: Text.Read.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. +Note that upstream GHC does not have the ability to derive 'Read1' or 'Read2' +instances, but since the functionality to derive 'Read' extends very naturally +'Read1' and 'Read2', the ability to derive the latter two classes is provided as a +convenience. +-} +module Text.Read.Deriving ( + -- * 'Read' + deriveRead + , deriveReadOptions + , makeReadsPrec +-- , makeReadsPrecOptions +-- , makeReadList +-- , makeReadListOptions + , makeReadPrec +-- , makeReadPrecOptions +-- , makeReadListPrec +-- , makeReadListPrecOptions + -- * 'Read1' + , deriveRead1 + , deriveRead1Options +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftReadsPrec +-- , makeLiftReadsPrecOptions +-- , makeLiftReadList +-- , makeLiftReadListOptions +# if __GLASGOW_HASKELL__ >= 801 + , makeLiftReadPrec +-- , makeLiftReadPrecOptions +-- , makeLiftReadListPrec +-- , makeLiftReadListPrecOptions + , makeReadPrec1 +-- , makeReadPrec1Options +# endif +#endif + , makeReadsPrec1 +-- , makeReadsPrec1Options +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Read2' + , deriveRead2 + , deriveRead2Options + , makeLiftReadsPrec2 +-- , makeLiftReadsPrec2Options +-- , makeLiftReadList2 +-- , makeLiftReadList2Options +# if __GLASGOW_HASKELL__ >= 801 + , makeLiftReadPrec2 +-- , makeLiftReadPrec2Options +-- , makeLiftReadListPrec2 +-- , makeLiftReadListPrec2Options + , makeReadPrec2 +-- , makeReadPrec2Options +# endif + , makeReadsPrec2 +-- , makeReadsPrec2Options +#endif + -- * 'ReadOptions' + , ReadOptions(..) + , defaultReadOptions + -- * 'deriveRead' limitations + -- $constraints + ) where + +import Text.Read.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Read' constraints. + Type variables of kind @* -> *@ are assumed to have 'Read1' constraints. + Type variables of kind @* -> * -> *@ are assumed to have 'Read2' constraints. + If this is not desirable, use 'makeReadsPrec' or one of its cousins. + +* The 'Read1' class had a different definition in @transformers-0.4@, and as a result, + 'deriveRead1' implements different instances for the @transformers-0.4@ 'Read1' than + it otherwise does. Also, 'makeLiftReadsPrec' and 'makeLiftReadList' are not available + when this library is built against @transformers-0.4@, only 'makeReadsPrec1. + +* The 'Read2' class is not available in @transformers-0.4@, and as a + result, neither are Template Haskell functions that deal with 'Read2' when this + library is built against @transformers-0.4@. + +* The 'Read1' and 'Read2' classes have new methods ('liftReadPrec'/'liftReadListPrec' + and 'liftReadPrec2'/'liftReadListPrec2', respectively) that were introduced in + @base-4.10@. For now, these methods are only defined when deriving 'Read1'/'Read2' + if built against @base-4.10@ (until @transformers-compat@ catches up), and + the corresponding @make-@ functions are also only available when built against + @base-4.10@. +-} diff --git a/src/Text/Read/Deriving/Internal.hs b/src/Text/Read/Deriving/Internal.hs --- a/src/Text/Read/Deriving/Internal.hs +++ b/src/Text/Read/Deriving/Internal.hs @@ -1,896 +1,896 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-| -Module: Text.Read.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Text.Read.Deriving.Internal ( - -- * 'Read' - deriveRead - , deriveReadOptions - , makeReadsPrec --- , makeReadsPrecOptions --- , makeReadList --- , makeReadListOptions - , makeReadPrec --- , makeReadPrecOptions --- , makeReadListPrec --- , makeReadListPrecOptions - -- * 'Read1' - , deriveRead1 - , deriveRead1Options -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftReadsPrec --- , makeLiftReadsPrecOptions --- , makeLiftReadList --- , makeLiftReadListOptions -# if __GLASGOW_HASKELL__ >= 801 - , makeLiftReadPrec --- , makeLiftReadPrecOptions --- , makeLiftReadListPrec --- , makeLiftReadListPrecOptions - , makeReadPrec1 --- , makeReadPrec1Options -# endif -#endif - , makeReadsPrec1 --- , makeReadsPrec1Options -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Read2' - , deriveRead2 - , deriveRead2Options - , makeLiftReadsPrec2 --- , makeLiftReadsPrec2Options --- , makeLiftReadList2 --- , makeLiftReadList2Options -# if __GLASGOW_HASKELL__ >= 801 - , makeLiftReadPrec2 --- , makeLiftReadPrec2Options --- , makeLiftReadListPrec2 --- , makeLiftReadListPrec2Options - , makeReadPrec2 --- , makeReadPrec2Options -# endif - , makeReadsPrec2 --- , makeReadsPrec2Options -#endif - -- * 'ReadOptions' - , ReadOptions(..) - , defaultReadOptions - ) where - -import Data.Deriving.Internal -import Data.List (intersperse, partition) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) - -import GHC.Show (appPrec, appPrec1) - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- | Options that further configure how the functions in "Text.Read.Deriving" --- should behave. -newtype ReadOptions = ReadOptions - { useReadPrec :: Bool - -- ^ If 'True': - -- - -- * Derived 'Read' instances will implement 'readPrec', not 'readsPrec', and - -- will provide a default implementation of 'readListPrec' in terms of - -- 'readPrec'. - -- - -- * If built against @base-4.10@ or later, derived 'Read1'/'Read2' - -- instances will implement 'liftReadPrec'/'liftReadPrec2', not - -- 'liftReadsPrec'/'liftReadsPrec2', and will provide default implementations - -- of 'liftReadListPrec'/'liftReadListPrec2' in terms of - -- 'liftReadPrec'/'liftReadPrec2'. If built against an earlier version of - -- @base@, derived 'Read1'/'Read2' instances are not affected, so they will - -- act as if this flag were 'False'. - -- - -- If 'False': - -- - -- * Derived 'Read' instances will implement 'readsPrec'. - -- - -- * Derived 'Read1' instances will implement 'readsPrec1' (if built against - -- @transformers-0.4@) or 'liftReadsPrec' (otherwise). If not built against - -- @transformers-0.4@, derived 'Read2' instances will implement - -- 'liftReadsPrec2'. - -- - -- It's generally a good idea to enable this option, since 'readPrec' and - -- friends are more efficient than 'readsPrec' and friends, since the former - -- use the efficient 'ReadPrec' parser datatype while the latter use the - -- slower, list-based 'ReadS' type. - } deriving (Eq, Ord, Read, Show) - --- | 'ReadOptions' that favor 'readPrec' over 'readsPrec'. -defaultReadOptions :: ReadOptions -defaultReadOptions = ReadOptions { useReadPrec = True } - --- | Generates a 'Read' instance declaration for the given data type or data --- family instance. -deriveRead :: Name -> Q [Dec] -deriveRead = deriveReadOptions defaultReadOptions - --- | Like 'deriveRead', but takes a 'ReadOptions' argument. -deriveReadOptions :: ReadOptions -> Name -> Q [Dec] -deriveReadOptions = deriveReadClass Read - --- | Generates a lambda expression which behaves like 'readsPrec' (without --- requiring a 'Read' instance). -makeReadsPrec :: Name -> Q Exp -makeReadsPrec = makeReadPrecClass Read False - --- -- | Like 'readsPrec', but takes a 'ReadOptions' argument. --- makeReadsPrecOptions :: ReadOptions -> Name -> Q Exp --- makeReadsPrecOptions _ = makeReadPrecClass Read False --- --- -- | Generates a lambda expression which behaves like 'readList' (without --- -- requiring a 'Read' instance). --- makeReadList :: Name -> Q Exp --- makeReadList = makeReadListOptions defaultReadOptions --- --- -- | Like 'readList', but takes a 'ReadOptions' argument. --- makeReadListOptions :: ReadOptions -> Name -> Q Exp --- makeReadListOptions opts name = --- if shouldDefineReadPrec Read opts --- then varE readPrec_to_SValName --- `appE` makeReadListPrecOptions opts name --- `appE` integerE 0 --- else varE readPrec_to_SValName --- `appE` (varE listValName `appE` makeReadPrecOptions opts name) --- `appE` integerE 0 - --- | Generates a lambda expression which behaves like 'readPrec' (without --- requiring a 'Read' instance). -makeReadPrec :: Name -> Q Exp -makeReadPrec = makeReadPrecClass Read True - --- -- | Like 'readPrec', but takes a 'ReadOptions' argument. --- makeReadPrecOptions :: ReadOptions -> Name -> Q Exp --- makeReadPrecOptions _ = makeReadPrecClass Read True --- --- -- | Generates a lambda expression which behaves like 'readListPrec' (without --- -- requiring a 'Read' instance). --- makeReadListPrec :: Name -> Q Exp --- makeReadListPrec = makeReadListPrecOptions defaultReadOptions --- --- -- | Like 'readListPrec', but takes a 'ReadOptions' argument. --- makeReadListPrecOptions :: ReadOptions -> Name -> Q Exp --- makeReadListPrecOptions opts name = --- if shouldDefineReadPrec Read opts --- then varE listValName `appE` makeReadPrecOptions opts name --- else varE readS_to_PrecValName --- `appE` (varE constValName `appE` makeReadListOptions opts name) - --- | Generates a 'Read1' instance declaration for the given data type or data --- family instance. -deriveRead1 :: Name -> Q [Dec] -deriveRead1 = deriveRead1Options defaultReadOptions - --- | Like 'deriveRead1', but takes a 'ReadOptions' argument. -deriveRead1Options :: ReadOptions -> Name -> Q [Dec] -deriveRead1Options = deriveReadClass Read1 - --- -- | Generates a lambda expression which behaves like 'readsPrec1' (without --- -- requiring a 'Read1' instance). --- makeReadsPrec1 :: Name -> Q Exp --- makeReadsPrec1 = makeReadsPrec1Options defaultReadOptions - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates a lambda expression which behaves like 'liftReadsPrec' (without --- requiring a 'Read1' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftReadsPrec :: Name -> Q Exp -makeLiftReadsPrec = makeReadPrecClass Read1 False - --- -- | Like 'makeLiftReadsPrec', but takes a 'ReadOptions' argument. --- -- --- -- This function is not available with @transformers-0.4@. --- makeLiftReadsPrecOptions :: ReadOptions -> Name -> Q Exp --- makeLiftReadsPrecOptions _ = makeReadPrecClass Read1 False --- --- -- | Generates a lambda expression which behaves like 'liftReadList' (without --- -- requiring a 'Read1' instance). --- -- --- -- This function is not available with @transformers-0.4@. --- makeLiftReadList :: Name -> Q Exp --- makeLiftReadList = makeLiftReadListOptions defaultReadOptions --- --- -- | Like 'makeLiftReadList', but takes a 'ReadOptions' argument. --- -- --- -- This function is not available with @transformers-0.4@. --- makeLiftReadListOptions :: ReadOptions -> Name -> Q Exp --- makeLiftReadListOptions = undefined - -# if __GLASGOW_HASKELL__ >= 801 --- | Generates a lambda expression which behaves like 'liftReadPrec' (without --- requiring a 'Read1' instance). --- --- This function is only available with @base-4.10@ or later. -makeLiftReadPrec :: Name -> Q Exp -makeLiftReadPrec = makeReadPrecClass Read1 True - --- -- | Like 'makeLiftReadPrec', but takes a 'ReadOptions' argument. --- -- --- -- This function is only available with @base-4.10@ or later. --- makeLiftReadPrecOptions :: ReadOptions -> Name -> Q Exp --- makeLiftReadPrecOptions _ = makeReadPrecClass Read1 True --- --- -- | Generates a lambda expression which behaves like 'liftReadListPrec' (without --- -- requiring a 'Read1' instance). --- -- --- -- This function is only available with @base-4.10@ or later. --- makeLiftReadListPrec :: Name -> Q Exp --- makeLiftReadListPrec = makeLiftReadListPrecOptions defaultReadOptions --- --- -- | Like 'makeLiftReadListPrec', but takes a 'ReadOptions' argument. --- -- --- -- This function is only available with @base-4.10@ or later. --- makeLiftReadListPrecOptions :: ReadOptions -> Name -> Q Exp --- makeLiftReadListPrecOptions = undefined - --- | Generates a lambda expression which behaves like 'readPrec1' (without --- requiring a 'Read1' instance). --- --- This function is only available with @base-4.10@ or later. -makeReadPrec1 :: Name -> Q Exp -makeReadPrec1 name = makeLiftReadPrec name - `appE` varE readPrecValName - `appE` varE readListPrecValName - --- -- | Like 'makeReadPrec1', but takes a 'ReadOptions' argument. --- -- --- -- This function is only available with @base-4.10@ or later. --- makeReadPrec1Options :: ReadOptions -> Name -> Q Exp --- makeReadPrec1Options opts name = makeLiftReadPrecOptions opts name --- `appE` varE readPrecValName --- `appE` varE readListPrecValName -# endif --- | Generates a lambda expression which behaves like 'readsPrec1' (without --- requiring a 'Read1' instance). -makeReadsPrec1 :: Name -> Q Exp -makeReadsPrec1 name = makeLiftReadsPrec name - `appE` varE readsPrecValName - `appE` varE readListValName - --- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument. --- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp --- makeReadsPrec1Options opts name = makeLiftReadsPrecOptions opts name --- `appE` varE readsPrecValName --- `appE` varE readListValName -#else --- | Generates a lambda expression which behaves like 'readsPrec1' (without --- requiring a 'Read1' instance). -makeReadsPrec1 :: Name -> Q Exp -makeReadsPrec1 = makeReadPrecClass Read1 False - --- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument. --- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp --- makeReadsPrec1Options _ = makeReadPrecClass Read1 False -#endif - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates a 'Read2' instance declaration for the given data type or data --- family instance. --- --- This function is not available with @transformers-0.4@. -deriveRead2 :: Name -> Q [Dec] -deriveRead2 = deriveRead2Options defaultReadOptions - --- | Like 'deriveRead2', but takes a 'ReadOptions' argument. --- --- This function is not available with @transformers-0.4@. -deriveRead2Options :: ReadOptions -> Name -> Q [Dec] -deriveRead2Options = deriveReadClass Read2 - --- | Generates a lambda expression which behaves like 'liftReadsPrec2' (without --- requiring a 'Read2' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftReadsPrec2 :: Name -> Q Exp -makeLiftReadsPrec2 = makeReadPrecClass Read2 False - --- -- | Like 'makeLiftReadsPrec2', but takes a 'ReadOptions' argument. --- -- --- -- This function is not available with @transformers-0.4@. --- makeLiftReadsPrec2Options :: ReadOptions -> Name -> Q Exp --- makeLiftReadsPrec2Options _ = makeReadPrecClass Read2 False --- --- -- | Generates a lambda expression which behaves like 'liftReadList2' (without --- -- requiring a 'Read2' instance). --- -- --- -- This function is not available with @transformers-0.4@. --- makeLiftReadList2 :: Name -> Q Exp --- makeLiftReadList2 = makeLiftReadList2Options defaultReadOptions --- --- -- | Like 'makeLiftReadList2', but takes a 'ReadOptions' argument. --- -- --- -- This function is not available with @transformers-0.4@. --- makeLiftReadList2Options :: ReadOptions -> Name -> Q Exp --- makeLiftReadList2Options opts name = do --- let rp1Expr = VarE `fmap` newName "rp1'" --- rl1Expr = VarE `fmap` newName "rl1'" --- rp2Expr = VarE `fmap` newName "rp2'" --- rl2Expr = VarE `fmap` newName "rl2'" --- let rp2sExpr = varE readPrec_to_SValName --- rs2pExpr = varE readS_to_PrecValName --- constExpr = varE constValName --- if shouldDefineReadPrec Read2 opts --- then rp2sExpr --- `appE` (makeLiftReadListPrec2Options opts name --- `appE` (rs2pExpr `appE` rp1Expr) --- `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr)) --- `appE` (rs2pExpr `appE` rp2Expr) --- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr))) --- `appE` integerE 0 --- else rp2sExpr `appE` (varE listValName --- `appE` (makeLiftReadPrec2Options opts name --- `appE` (rs2pExpr `appE` rp1Expr) --- `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr)) --- `appE` (rs2pExpr `appE` rp2Expr) --- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr)))) --- `appE` integerE 0 - -# if __GLASGOW_HASKELL__ >= 801 --- | Generates a lambda expression which behaves like 'liftReadPrec2' (without --- requiring a 'Read2' instance). --- --- This function is only available with @base-4.10@ or later. -makeLiftReadPrec2 :: Name -> Q Exp -makeLiftReadPrec2 = makeReadPrecClass Read2 True - --- -- | Like 'makeLiftReadPrec2', but takes a 'ReadOptions' argument. --- -- --- -- This function is only available with @base-4.10@ or later. --- makeLiftReadPrec2Options :: ReadOptions -> Name -> Q Exp --- makeLiftReadPrec2Options _ = makeReadPrecClass Read2 True --- --- -- | Generates a lambda expression which behaves like 'liftReadListPrec2' (without --- -- requiring a 'Read2' instance). --- -- --- -- This function is only available with @base-4.10@ or later. --- makeLiftReadListPrec2 :: Name -> Q Exp --- makeLiftReadListPrec2 = makeLiftReadListPrec2Options defaultReadOptions --- --- -- | Like 'makeLiftReadListPrec2', but takes a 'ReadOptions' argument. --- -- --- -- This function is only available with @base-4.10@ or later. --- makeLiftReadListPrec2Options :: ReadOptions -> Name -> Q Exp --- makeLiftReadListPrec2Options = undefined - --- | Generates a lambda expression which behaves like 'readPrec2' (without --- requiring a 'Read2' instance). --- --- This function is only available with @base-4.10@ or later. -makeReadPrec2 :: Name -> Q Exp -makeReadPrec2 name = makeLiftReadPrec2 name - `appE` varE readPrecValName - `appE` varE readListPrecValName - `appE` varE readPrecValName - `appE` varE readListPrecValName - --- -- | Like 'makeReadPrec2', but takes a 'ReadOptions' argument. --- -- --- -- This function is only available with @base-4.10@ or later. --- makeReadPrec2Options :: ReadOptions -> Name -> Q Exp --- makeReadPrec2Options opts name = makeLiftReadPrec2Options opts name --- `appE` varE readPrecValName --- `appE` varE readListPrecValName --- `appE` varE readPrecValName --- `appE` varE readListPrecValName -# endif - --- | Generates a lambda expression which behaves like 'readsPrec2' (without --- requiring a 'Read2' instance). --- --- This function is not available with @transformers-0.4@. -makeReadsPrec2 :: Name -> Q Exp -makeReadsPrec2 name = makeLiftReadsPrec2 name - `appE` varE readsPrecValName - `appE` varE readListValName - `appE` varE readsPrecValName - `appE` varE readListValName - --- -- | Like 'makeReadsPrec2', but takes a 'ReadOptions' argument. --- -- --- -- This function is not available with @transformers-0.4@. --- makeReadsPrec2Options :: ReadOptions -> Name -> Q Exp --- makeReadsPrec2Options opts name = makeLiftReadsPrec2Options opts name --- `appE` varE readsPrecValName --- `appE` varE readListValName --- `appE` varE readsPrecValName --- `appE` varE readListValName -#endif - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Derive a Read(1)(2) instance declaration (depending on the ReadClass --- argument's value). -deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec] -deriveReadClass rClass opts name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance rClass parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (readPrecDecs rClass opts instTypes cons) - --- | Generates a declaration defining the primary function corresponding to a --- particular class (read(s)Prec for Read, liftRead(s)Prec for Read1, and --- liftRead(s)Prec2 for Read2). -readPrecDecs :: ReadClass -> ReadOptions -> [Type] -> [ConstructorInfo] -> [Q Dec] -readPrecDecs rClass opts instTypes cons = - [ funD ((if defineReadPrec then readPrecName else readsPrecName) rClass) - [ clause [] - (normalB $ makeReadForCons rClass defineReadPrec instTypes cons) - [] - ] - ] ++ if defineReadPrec - then [ funD (readListPrecName rClass) - [ clause [] - (normalB . varE $ readListPrecDefaultName rClass) - [] - ] - ] - else [] - where - defineReadPrec :: Bool - defineReadPrec = shouldDefineReadPrec rClass opts - --- | Generates a lambda expression which behaves like read(s)Prec (for Read), --- liftRead(s)Prec (for Read1), or liftRead(s)Prec2 (for Read2). -makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp -makeReadPrecClass rClass urp name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have - -- read(s)Prec/liftRead(s)Prec/etc. implemented for it, and produces errors - -- if it can't. - buildTypeInstance rClass parentName ctxt instTypes variant - >> makeReadForCons rClass urp instTypes cons - --- | Generates a lambda expression for read(s)Prec/liftRead(s)Prec/etc. for the --- given constructors. All constructors must be from the same type. -makeReadForCons :: ReadClass -> Bool -> [Type] -> [ConstructorInfo] -> Q Exp -makeReadForCons rClass urp instTypes cons = do - p <- newName "p" - rps <- newNameList "rp" $ arity rClass - rls <- newNameList "rl" $ arity rClass - let rpls = zip rps rls - _rpsAndRls = interleave rps rls - lastTyVars = map varTToName $ drop (length instTypes - fromEnum rClass) instTypes - rplMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars rpls - - let nullaryCons, nonNullaryCons :: [ConstructorInfo] - (nullaryCons, nonNullaryCons) = partition isNullaryCon cons - - readConsExpr :: Q Exp - readConsExpr = do - readNonNullaryCons <- mapM (makeReadForCon rClass urp rplMap) - nonNullaryCons - foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons) - - readNullaryCons :: [Q Exp] - readNullaryCons = case nullaryCons of - [] -> [] - [con] - | nameBase (constructorName con) == "()" - -> [varE parenValName `appE` - mkDoStmts [] (varE returnValName `appE` tupE [])] - | otherwise -> [mkDoStmts (matchCon con) - (resultExpr (constructorName con) [])] - _ -> [varE chooseValName `appE` listE (map mkPair nullaryCons)] - - mkAlt :: Q Exp -> Q Exp -> Q Exp - mkAlt e1 e2 = infixApp e1 (varE altValName) e2 - - mkPair :: ConstructorInfo -> Q Exp - mkPair con = tupE [ stringE $ dataConStr con - , resultExpr (constructorName con) [] - ] - - matchCon :: ConstructorInfo -> [Q Stmt] - matchCon con - | isSym conStr = [symbolPat conStr] - | otherwise = identHPat conStr - where - conStr = dataConStr con - - mainRhsExpr :: Q Exp - mainRhsExpr - | null cons = varE pfailValName - | otherwise = varE parensValName `appE` readConsExpr - - lamE (map varP $ -#if defined(NEW_FUNCTOR_CLASSES) - _rpsAndRls ++ -#endif - if urp then [] else [p] - ) . appsE - $ [ varE $ (if urp then readPrecConstName else readsPrecConstName) rClass - , if urp - then mainRhsExpr - else varE readPrec_to_SValName `appE` mainRhsExpr `appE` varE p - ] -#if defined(NEW_FUNCTOR_CLASSES) - ++ map varE _rpsAndRls -#endif - ++ if urp then [] else [varE p] - -makeReadForCon :: ReadClass - -> Bool - -> TyVarMap2 - -> ConstructorInfo - -> Q Exp -makeReadForCon rClass urp tvMap - (ConstructorInfo { constructorName = conName - , constructorContext = ctxt - , constructorVariant = NormalConstructor - , constructorFields = argTys }) = do - argTys' <- mapM resolveTypeSynonyms argTys - args <- newNameList "arg" $ length argTys' - let conStr = nameBase conName - isTup = isNonUnitTupleString conStr - (readStmts, varExps) <- - zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys' args - let body = resultExpr conName varExps - - checkExistentialContext rClass tvMap ctxt conName $ - if isTup - then let tupleStmts = intersperse (readPunc ",") readStmts - in varE parenValName `appE` mkDoStmts tupleStmts body - else let prefixStmts = readPrefixCon conStr ++ readStmts - in mkParser appPrec prefixStmts body -makeReadForCon rClass urp tvMap - (ConstructorInfo { constructorName = conName - , constructorContext = ctxt - , constructorVariant = RecordConstructor argNames - , constructorFields = argTys }) = do - argTys' <- mapM resolveTypeSynonyms argTys - args <- newNameList "arg" $ length argTys' - (readStmts, varExps) <- zipWith3AndUnzipM - (\argName argTy arg -> makeReadForField rClass urp tvMap conName - (nameBase argName) argTy arg) - argNames argTys' args - let body = resultExpr conName varExps - conStr = nameBase conName - recordStmts = readPrefixCon conStr ++ [readPunc "{"] - ++ concat (intersperse [readPunc ","] readStmts) - ++ [readPunc "}"] - - checkExistentialContext rClass tvMap ctxt conName $ - mkParser appPrec1 recordStmts body -makeReadForCon rClass urp tvMap - (ConstructorInfo { constructorName = conName - , constructorContext = ctxt - , constructorVariant = InfixConstructor - , constructorFields = argTys }) = do - [alTy, arTy] <- mapM resolveTypeSynonyms argTys - al <- newName "argL" - ar <- newName "argR" - fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName - ([readStmt1, readStmt2], varExps) <- - zipWithAndUnzipM (makeReadForArg rClass False urp tvMap conName) - [alTy, arTy] [al, ar] - - let conPrec = case fi of Fixity prec _ -> prec - body = resultExpr conName varExps - conStr = nameBase conName - readInfixCon - | isSym conStr = [symbolPat conStr] - | otherwise = [readPunc "`"] ++ identHPat conStr ++ [readPunc "`"] - infixStmts = [readStmt1] ++ readInfixCon ++ [readStmt2] - - checkExistentialContext rClass tvMap ctxt conName $ - mkParser conPrec infixStmts body - -makeReadForArg :: ReadClass - -> Bool - -> Bool - -> TyVarMap2 - -> Name - -> Type - -> Name - -> Q (Q Stmt, Exp) -makeReadForArg rClass isTup urp tvMap conName ty tyExpName = do - (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty - let readStmt = bindS (varP tyExpName) $ - (if (not isTup) then appE (varE stepValName) else id) $ - wrapReadS urp (return rExp) - return (readStmt, varExp) - -makeReadForField :: ReadClass - -> Bool - -> TyVarMap2 - -> Name - -> String - -> Type - -> Name - -> Q ([Q Stmt], Exp) -makeReadForField rClass urp tvMap conName lblStr ty tyExpName = do - (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty - let readStmt = bindS (varP tyExpName) $ - read_field `appE` - (varE resetValName `appE` wrapReadS urp (return rExp)) - return ([readStmt], varExp) - where - mk_read_field readFieldName lbl - = varE readFieldName `appE` stringE lbl - read_field - | isSym lblStr - = mk_read_field readSymFieldValName lblStr - | Just (ss, '#') <- snocView lblStr - = mk_read_field readFieldHashValName ss - | otherwise - = mk_read_field readFieldValName lblStr - -makeReadForType :: ReadClass - -> Bool - -> TyVarMap2 - -> Name - -> Name - -> Bool - -> Type - -> Q (Exp, Exp) -#if defined(NEW_FUNCTOR_CLASSES) -makeReadForType _ urp tvMap _ tyExpName rl (VarT tyName) = - let tyExp = VarE tyExpName - in return $ case Map.lookup tyName tvMap of - Just (TwoNames rpExp rlExp) -> (VarE $ if rl then rlExp else rpExp, tyExp) - Nothing -> (VarE $ readsOrReadName urp rl Read, tyExp) -#else -makeReadForType _ urp _ _ tyExpName _ VarT{} = - return (VarE $ readsOrReadName urp False Read, VarE tyExpName) -#endif -makeReadForType rClass urp tvMap conName tyExpName rl (SigT ty _) = - makeReadForType rClass urp tvMap conName tyExpName rl ty -makeReadForType rClass urp tvMap conName tyExpName rl (ForallT _ _ ty) = - makeReadForType rClass urp tvMap conName tyExpName rl ty -#if defined(NEW_FUNCTOR_CLASSES) -makeReadForType rClass urp tvMap conName tyExpName rl ty = do - let tyCon :: Type - tyArgs :: [Type] - (tyCon, tyArgs) = unapplyTy ty - - numLastArgs :: Int - numLastArgs = min (arity rClass) (length tyArgs) - - lhsArgs, rhsArgs :: [Type] - (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - - tyVarNames :: [Name] - tyVarNames = Map.keys tvMap - - itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs - if any (`mentionsName` tyVarNames) lhsArgs - || itf && any (`mentionsName` tyVarNames) tyArgs - then outOfPlaceTyVarError rClass conName - else if any (`mentionsName` tyVarNames) rhsArgs - then do - readExp <- appsE $ [ varE . readsOrReadName urp rl $ toEnum numLastArgs] - ++ zipWith (\b -> fmap fst - . makeReadForType rClass urp tvMap conName tyExpName b) - (cycle [False,True]) - (interleave rhsArgs rhsArgs) - return (readExp, VarE tyExpName) - else return (VarE $ readsOrReadName urp rl Read, VarE tyExpName) -#else -makeReadForType rClass urp tvMap conName tyExpName _ ty = do - let varNames = Map.keys tvMap - rpExpr = VarE $ readsOrReadName urp False Read - rp1Expr = VarE $ readsOrReadName urp False Read1 - tyExpr = VarE tyExpName - - case varNames of - [] -> return (rpExpr, tyExpr) - varName:_ -> do - if mentionsName ty varNames - then do - applyExp <- makeFmapApplyPos rClass conName ty varName - return (rp1Expr, applyExp `AppE` tyExpr) - else return (rpExpr, tyExpr) -#endif - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- | A representation of which @Read@ variant is being derived. -data ReadClass = Read - | Read1 -#if defined(NEW_FUNCTOR_CLASSES) - | Read2 -#endif - deriving (Bounded, Enum) - -instance ClassRep ReadClass where - arity = fromEnum - - allowExQuant _ = False - - fullClassName Read = readTypeName - fullClassName Read1 = read1TypeName -#if defined(NEW_FUNCTOR_CLASSES) - fullClassName Read2 = read2TypeName -#endif - - classConstraint rClass i - | rMin <= i && i <= rMax = Just $ fullClassName (toEnum i :: ReadClass) - | otherwise = Nothing - where - rMin, rMax :: Int - rMin = fromEnum (minBound :: ReadClass) - rMax = fromEnum rClass - -readsPrecConstName :: ReadClass -> Name -readsPrecConstName Read = readsPrecConstValName -#if defined(NEW_FUNCTOR_CLASSES) -readsPrecConstName Read1 = liftReadsPrecConstValName -readsPrecConstName Read2 = liftReadsPrec2ConstValName -#else -readsPrecConstName Read1 = readsPrec1ConstValName -#endif - -readPrecConstName :: ReadClass -> Name -readPrecConstName Read = readPrecConstValName -readPrecConstName Read1 = liftReadPrecConstValName -#if defined(NEW_FUNCTOR_CLASSES) -readPrecConstName Read2 = liftReadPrec2ConstValName -#endif - -readsPrecName :: ReadClass -> Name -readsPrecName Read = readsPrecValName -#if defined(NEW_FUNCTOR_CLASSES) -readsPrecName Read1 = liftReadsPrecValName -readsPrecName Read2 = liftReadsPrec2ValName -#else -readsPrecName Read1 = readsPrec1ValName -#endif - -readPrecName :: ReadClass -> Name -readPrecName Read = readPrecValName -readPrecName Read1 = liftReadPrecValName -#if defined(NEW_FUNCTOR_CLASSES) -readPrecName Read2 = liftReadPrec2ValName -#endif - -readListPrecDefaultName :: ReadClass -> Name -readListPrecDefaultName Read = readListPrecDefaultValName -readListPrecDefaultName Read1 = liftReadListPrecDefaultValName -#if defined(NEW_FUNCTOR_CLASSES) -readListPrecDefaultName Read2 = liftReadListPrec2DefaultValName -#endif - -readListPrecName :: ReadClass -> Name -readListPrecName Read = readListPrecValName -readListPrecName Read1 = liftReadListPrecValName -#if defined(NEW_FUNCTOR_CLASSES) -readListPrecName Read2 = liftReadListPrec2ValName -#endif - -readListName :: ReadClass -> Name -readListName Read = readListValName -#if defined(NEW_FUNCTOR_CLASSES) -readListName Read1 = liftReadListValName -readListName Read2 = liftReadList2ValName -#else -readListName Read1 = error "Text.Read.Deriving.Internal.readListName" -#endif - -readsPrecOrListName :: Bool -- ^ readsListName if True, readsPrecName if False - -> ReadClass - -> Name -readsPrecOrListName False = readsPrecName -readsPrecOrListName True = readListName - -readPrecOrListName :: Bool -- ^ readListPrecName if True, readPrecName if False - -> ReadClass - -> Name -readPrecOrListName False = readPrecName -readPrecOrListName True = readListPrecName - -readsOrReadName :: Bool -- ^ readPrecOrListName if True, readsPrecOrListName if False - -> Bool -- ^ read(s)List(Prec)Name if True, read(s)PrecName if False - -> ReadClass - -> Name -readsOrReadName False = readsPrecOrListName -readsOrReadName True = readPrecOrListName - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - -mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp -mkParser p ss b = varE precValName `appE` integerE p `appE` mkDoStmts ss b - -mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp -mkDoStmts ss b = doE (ss ++ [noBindS b]) - -resultExpr :: Name -> [Exp] -> Q Exp -resultExpr conName as = varE returnValName `appE` conApp - where - conApp :: Q Exp - conApp = appsE $ conE conName : map return as - -identHPat :: String -> [Q Stmt] -identHPat s - | Just (ss, '#') <- snocView s = [identPat ss, symbolPat "#"] - | otherwise = [identPat s] - -bindLex :: Q Exp -> Q Stmt -bindLex pat = noBindS $ varE expectPValName `appE` pat - -identPat :: String -> Q Stmt -identPat s = bindLex $ conE identDataName `appE` stringE s - -symbolPat :: String -> Q Stmt -symbolPat s = bindLex $ conE symbolDataName `appE` stringE s - -readPunc :: String -> Q Stmt -readPunc c = bindLex $ conE puncDataName `appE` stringE c - -snocView :: [a] -> Maybe ([a],a) - -- Split off the last element -snocView [] = Nothing -snocView xs = go [] xs - where - -- Invariant: second arg is non-empty - go acc [a] = Just (reverse acc, a) - go acc (a:as) = go (a:acc) as - go _ [] = error "Util: snocView" - -dataConStr :: ConstructorInfo -> String -dataConStr = nameBase . constructorName - -readPrefixCon :: String -> [Q Stmt] -readPrefixCon conStr - | isSym conStr = [readPunc "(", symbolPat conStr, readPunc ")"] - | otherwise = identHPat conStr - -wrapReadS :: Bool -> Q Exp -> Q Exp -wrapReadS urp e = if urp then e - else varE readS_to_PrecValName `appE` e - -shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool -shouldDefineReadPrec rClass opts = useReadPrec opts && baseCompatible - where - base4'10OrLater :: Bool -#if __GLASGOW_HASKELL__ >= 801 - base4'10OrLater = True -#else - base4'10OrLater = False -#endif - - baseCompatible :: Bool - baseCompatible = case rClass of - Read -> True - Read1 -> base4'10OrLater -#if defined(NEW_FUNCTOR_CLASSES) - Read2 -> base4'10OrLater -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-| +Module: Text.Read.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Text.Read.Deriving.Internal ( + -- * 'Read' + deriveRead + , deriveReadOptions + , makeReadsPrec +-- , makeReadsPrecOptions +-- , makeReadList +-- , makeReadListOptions + , makeReadPrec +-- , makeReadPrecOptions +-- , makeReadListPrec +-- , makeReadListPrecOptions + -- * 'Read1' + , deriveRead1 + , deriveRead1Options +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftReadsPrec +-- , makeLiftReadsPrecOptions +-- , makeLiftReadList +-- , makeLiftReadListOptions +# if __GLASGOW_HASKELL__ >= 801 + , makeLiftReadPrec +-- , makeLiftReadPrecOptions +-- , makeLiftReadListPrec +-- , makeLiftReadListPrecOptions + , makeReadPrec1 +-- , makeReadPrec1Options +# endif +#endif + , makeReadsPrec1 +-- , makeReadsPrec1Options +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Read2' + , deriveRead2 + , deriveRead2Options + , makeLiftReadsPrec2 +-- , makeLiftReadsPrec2Options +-- , makeLiftReadList2 +-- , makeLiftReadList2Options +# if __GLASGOW_HASKELL__ >= 801 + , makeLiftReadPrec2 +-- , makeLiftReadPrec2Options +-- , makeLiftReadListPrec2 +-- , makeLiftReadListPrec2Options + , makeReadPrec2 +-- , makeReadPrec2Options +# endif + , makeReadsPrec2 +-- , makeReadsPrec2Options +#endif + -- * 'ReadOptions' + , ReadOptions(..) + , defaultReadOptions + ) where + +import Data.Deriving.Internal +import Data.List (intersperse, partition) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) + +import GHC.Show (appPrec, appPrec1) + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +-- | Options that further configure how the functions in "Text.Read.Deriving" +-- should behave. +newtype ReadOptions = ReadOptions + { useReadPrec :: Bool + -- ^ If 'True': + -- + -- * Derived 'Read' instances will implement 'readPrec', not 'readsPrec', and + -- will provide a default implementation of 'readListPrec' in terms of + -- 'readPrec'. + -- + -- * If built against @base-4.10@ or later, derived 'Read1'/'Read2' + -- instances will implement 'liftReadPrec'/'liftReadPrec2', not + -- 'liftReadsPrec'/'liftReadsPrec2', and will provide default implementations + -- of 'liftReadListPrec'/'liftReadListPrec2' in terms of + -- 'liftReadPrec'/'liftReadPrec2'. If built against an earlier version of + -- @base@, derived 'Read1'/'Read2' instances are not affected, so they will + -- act as if this flag were 'False'. + -- + -- If 'False': + -- + -- * Derived 'Read' instances will implement 'readsPrec'. + -- + -- * Derived 'Read1' instances will implement 'readsPrec1' (if built against + -- @transformers-0.4@) or 'liftReadsPrec' (otherwise). If not built against + -- @transformers-0.4@, derived 'Read2' instances will implement + -- 'liftReadsPrec2'. + -- + -- It's generally a good idea to enable this option, since 'readPrec' and + -- friends are more efficient than 'readsPrec' and friends, since the former + -- use the efficient 'ReadPrec' parser datatype while the latter use the + -- slower, list-based 'ReadS' type. + } deriving (Eq, Ord, Read, Show) + +-- | 'ReadOptions' that favor 'readPrec' over 'readsPrec'. +defaultReadOptions :: ReadOptions +defaultReadOptions = ReadOptions { useReadPrec = True } + +-- | Generates a 'Read' instance declaration for the given data type or data +-- family instance. +deriveRead :: Name -> Q [Dec] +deriveRead = deriveReadOptions defaultReadOptions + +-- | Like 'deriveRead', but takes a 'ReadOptions' argument. +deriveReadOptions :: ReadOptions -> Name -> Q [Dec] +deriveReadOptions = deriveReadClass Read + +-- | Generates a lambda expression which behaves like 'readsPrec' (without +-- requiring a 'Read' instance). +makeReadsPrec :: Name -> Q Exp +makeReadsPrec = makeReadPrecClass Read False + +-- -- | Like 'readsPrec', but takes a 'ReadOptions' argument. +-- makeReadsPrecOptions :: ReadOptions -> Name -> Q Exp +-- makeReadsPrecOptions _ = makeReadPrecClass Read False +-- +-- -- | Generates a lambda expression which behaves like 'readList' (without +-- -- requiring a 'Read' instance). +-- makeReadList :: Name -> Q Exp +-- makeReadList = makeReadListOptions defaultReadOptions +-- +-- -- | Like 'readList', but takes a 'ReadOptions' argument. +-- makeReadListOptions :: ReadOptions -> Name -> Q Exp +-- makeReadListOptions opts name = +-- if shouldDefineReadPrec Read opts +-- then varE readPrec_to_SValName +-- `appE` makeReadListPrecOptions opts name +-- `appE` integerE 0 +-- else varE readPrec_to_SValName +-- `appE` (varE listValName `appE` makeReadPrecOptions opts name) +-- `appE` integerE 0 + +-- | Generates a lambda expression which behaves like 'readPrec' (without +-- requiring a 'Read' instance). +makeReadPrec :: Name -> Q Exp +makeReadPrec = makeReadPrecClass Read True + +-- -- | Like 'readPrec', but takes a 'ReadOptions' argument. +-- makeReadPrecOptions :: ReadOptions -> Name -> Q Exp +-- makeReadPrecOptions _ = makeReadPrecClass Read True +-- +-- -- | Generates a lambda expression which behaves like 'readListPrec' (without +-- -- requiring a 'Read' instance). +-- makeReadListPrec :: Name -> Q Exp +-- makeReadListPrec = makeReadListPrecOptions defaultReadOptions +-- +-- -- | Like 'readListPrec', but takes a 'ReadOptions' argument. +-- makeReadListPrecOptions :: ReadOptions -> Name -> Q Exp +-- makeReadListPrecOptions opts name = +-- if shouldDefineReadPrec Read opts +-- then varE listValName `appE` makeReadPrecOptions opts name +-- else varE readS_to_PrecValName +-- `appE` (varE constValName `appE` makeReadListOptions opts name) + +-- | Generates a 'Read1' instance declaration for the given data type or data +-- family instance. +deriveRead1 :: Name -> Q [Dec] +deriveRead1 = deriveRead1Options defaultReadOptions + +-- | Like 'deriveRead1', but takes a 'ReadOptions' argument. +deriveRead1Options :: ReadOptions -> Name -> Q [Dec] +deriveRead1Options = deriveReadClass Read1 + +-- -- | Generates a lambda expression which behaves like 'readsPrec1' (without +-- -- requiring a 'Read1' instance). +-- makeReadsPrec1 :: Name -> Q Exp +-- makeReadsPrec1 = makeReadsPrec1Options defaultReadOptions + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a lambda expression which behaves like 'liftReadsPrec' (without +-- requiring a 'Read1' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftReadsPrec :: Name -> Q Exp +makeLiftReadsPrec = makeReadPrecClass Read1 False + +-- -- | Like 'makeLiftReadsPrec', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is not available with @transformers-0.4@. +-- makeLiftReadsPrecOptions :: ReadOptions -> Name -> Q Exp +-- makeLiftReadsPrecOptions _ = makeReadPrecClass Read1 False +-- +-- -- | Generates a lambda expression which behaves like 'liftReadList' (without +-- -- requiring a 'Read1' instance). +-- -- +-- -- This function is not available with @transformers-0.4@. +-- makeLiftReadList :: Name -> Q Exp +-- makeLiftReadList = makeLiftReadListOptions defaultReadOptions +-- +-- -- | Like 'makeLiftReadList', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is not available with @transformers-0.4@. +-- makeLiftReadListOptions :: ReadOptions -> Name -> Q Exp +-- makeLiftReadListOptions = undefined + +# if __GLASGOW_HASKELL__ >= 801 +-- | Generates a lambda expression which behaves like 'liftReadPrec' (without +-- requiring a 'Read1' instance). +-- +-- This function is only available with @base-4.10@ or later. +makeLiftReadPrec :: Name -> Q Exp +makeLiftReadPrec = makeReadPrecClass Read1 True + +-- -- | Like 'makeLiftReadPrec', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeLiftReadPrecOptions :: ReadOptions -> Name -> Q Exp +-- makeLiftReadPrecOptions _ = makeReadPrecClass Read1 True +-- +-- -- | Generates a lambda expression which behaves like 'liftReadListPrec' (without +-- -- requiring a 'Read1' instance). +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeLiftReadListPrec :: Name -> Q Exp +-- makeLiftReadListPrec = makeLiftReadListPrecOptions defaultReadOptions +-- +-- -- | Like 'makeLiftReadListPrec', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeLiftReadListPrecOptions :: ReadOptions -> Name -> Q Exp +-- makeLiftReadListPrecOptions = undefined + +-- | Generates a lambda expression which behaves like 'readPrec1' (without +-- requiring a 'Read1' instance). +-- +-- This function is only available with @base-4.10@ or later. +makeReadPrec1 :: Name -> Q Exp +makeReadPrec1 name = makeLiftReadPrec name + `appE` varE readPrecValName + `appE` varE readListPrecValName + +-- -- | Like 'makeReadPrec1', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeReadPrec1Options :: ReadOptions -> Name -> Q Exp +-- makeReadPrec1Options opts name = makeLiftReadPrecOptions opts name +-- `appE` varE readPrecValName +-- `appE` varE readListPrecValName +# endif +-- | Generates a lambda expression which behaves like 'readsPrec1' (without +-- requiring a 'Read1' instance). +makeReadsPrec1 :: Name -> Q Exp +makeReadsPrec1 name = makeLiftReadsPrec name + `appE` varE readsPrecValName + `appE` varE readListValName + +-- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument. +-- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp +-- makeReadsPrec1Options opts name = makeLiftReadsPrecOptions opts name +-- `appE` varE readsPrecValName +-- `appE` varE readListValName +#else +-- | Generates a lambda expression which behaves like 'readsPrec1' (without +-- requiring a 'Read1' instance). +makeReadsPrec1 :: Name -> Q Exp +makeReadsPrec1 = makeReadPrecClass Read1 False + +-- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument. +-- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp +-- makeReadsPrec1Options _ = makeReadPrecClass Read1 False +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a 'Read2' instance declaration for the given data type or data +-- family instance. +-- +-- This function is not available with @transformers-0.4@. +deriveRead2 :: Name -> Q [Dec] +deriveRead2 = deriveRead2Options defaultReadOptions + +-- | Like 'deriveRead2', but takes a 'ReadOptions' argument. +-- +-- This function is not available with @transformers-0.4@. +deriveRead2Options :: ReadOptions -> Name -> Q [Dec] +deriveRead2Options = deriveReadClass Read2 + +-- | Generates a lambda expression which behaves like 'liftReadsPrec2' (without +-- requiring a 'Read2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftReadsPrec2 :: Name -> Q Exp +makeLiftReadsPrec2 = makeReadPrecClass Read2 False + +-- -- | Like 'makeLiftReadsPrec2', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is not available with @transformers-0.4@. +-- makeLiftReadsPrec2Options :: ReadOptions -> Name -> Q Exp +-- makeLiftReadsPrec2Options _ = makeReadPrecClass Read2 False +-- +-- -- | Generates a lambda expression which behaves like 'liftReadList2' (without +-- -- requiring a 'Read2' instance). +-- -- +-- -- This function is not available with @transformers-0.4@. +-- makeLiftReadList2 :: Name -> Q Exp +-- makeLiftReadList2 = makeLiftReadList2Options defaultReadOptions +-- +-- -- | Like 'makeLiftReadList2', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is not available with @transformers-0.4@. +-- makeLiftReadList2Options :: ReadOptions -> Name -> Q Exp +-- makeLiftReadList2Options opts name = do +-- let rp1Expr = VarE `fmap` newName "rp1'" +-- rl1Expr = VarE `fmap` newName "rl1'" +-- rp2Expr = VarE `fmap` newName "rp2'" +-- rl2Expr = VarE `fmap` newName "rl2'" +-- let rp2sExpr = varE readPrec_to_SValName +-- rs2pExpr = varE readS_to_PrecValName +-- constExpr = varE constValName +-- if shouldDefineReadPrec Read2 opts +-- then rp2sExpr +-- `appE` (makeLiftReadListPrec2Options opts name +-- `appE` (rs2pExpr `appE` rp1Expr) +-- `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr)) +-- `appE` (rs2pExpr `appE` rp2Expr) +-- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr))) +-- `appE` integerE 0 +-- else rp2sExpr `appE` (varE listValName +-- `appE` (makeLiftReadPrec2Options opts name +-- `appE` (rs2pExpr `appE` rp1Expr) +-- `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr)) +-- `appE` (rs2pExpr `appE` rp2Expr) +-- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr)))) +-- `appE` integerE 0 + +# if __GLASGOW_HASKELL__ >= 801 +-- | Generates a lambda expression which behaves like 'liftReadPrec2' (without +-- requiring a 'Read2' instance). +-- +-- This function is only available with @base-4.10@ or later. +makeLiftReadPrec2 :: Name -> Q Exp +makeLiftReadPrec2 = makeReadPrecClass Read2 True + +-- -- | Like 'makeLiftReadPrec2', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeLiftReadPrec2Options :: ReadOptions -> Name -> Q Exp +-- makeLiftReadPrec2Options _ = makeReadPrecClass Read2 True +-- +-- -- | Generates a lambda expression which behaves like 'liftReadListPrec2' (without +-- -- requiring a 'Read2' instance). +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeLiftReadListPrec2 :: Name -> Q Exp +-- makeLiftReadListPrec2 = makeLiftReadListPrec2Options defaultReadOptions +-- +-- -- | Like 'makeLiftReadListPrec2', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeLiftReadListPrec2Options :: ReadOptions -> Name -> Q Exp +-- makeLiftReadListPrec2Options = undefined + +-- | Generates a lambda expression which behaves like 'readPrec2' (without +-- requiring a 'Read2' instance). +-- +-- This function is only available with @base-4.10@ or later. +makeReadPrec2 :: Name -> Q Exp +makeReadPrec2 name = makeLiftReadPrec2 name + `appE` varE readPrecValName + `appE` varE readListPrecValName + `appE` varE readPrecValName + `appE` varE readListPrecValName + +-- -- | Like 'makeReadPrec2', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is only available with @base-4.10@ or later. +-- makeReadPrec2Options :: ReadOptions -> Name -> Q Exp +-- makeReadPrec2Options opts name = makeLiftReadPrec2Options opts name +-- `appE` varE readPrecValName +-- `appE` varE readListPrecValName +-- `appE` varE readPrecValName +-- `appE` varE readListPrecValName +# endif + +-- | Generates a lambda expression which behaves like 'readsPrec2' (without +-- requiring a 'Read2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeReadsPrec2 :: Name -> Q Exp +makeReadsPrec2 name = makeLiftReadsPrec2 name + `appE` varE readsPrecValName + `appE` varE readListValName + `appE` varE readsPrecValName + `appE` varE readListValName + +-- -- | Like 'makeReadsPrec2', but takes a 'ReadOptions' argument. +-- -- +-- -- This function is not available with @transformers-0.4@. +-- makeReadsPrec2Options :: ReadOptions -> Name -> Q Exp +-- makeReadsPrec2Options opts name = makeLiftReadsPrec2Options opts name +-- `appE` varE readsPrecValName +-- `appE` varE readListValName +-- `appE` varE readsPrecValName +-- `appE` varE readListValName +#endif + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Derive a Read(1)(2) instance declaration (depending on the ReadClass +-- argument's value). +deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec] +deriveReadClass rClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance rClass parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (readPrecDecs rClass opts instTypes cons) + +-- | Generates a declaration defining the primary function corresponding to a +-- particular class (read(s)Prec for Read, liftRead(s)Prec for Read1, and +-- liftRead(s)Prec2 for Read2). +readPrecDecs :: ReadClass -> ReadOptions -> [Type] -> [ConstructorInfo] -> [Q Dec] +readPrecDecs rClass opts instTypes cons = + [ funD ((if defineReadPrec then readPrecName else readsPrecName) rClass) + [ clause [] + (normalB $ makeReadForCons rClass defineReadPrec instTypes cons) + [] + ] + ] ++ if defineReadPrec + then [ funD (readListPrecName rClass) + [ clause [] + (normalB . varE $ readListPrecDefaultName rClass) + [] + ] + ] + else [] + where + defineReadPrec :: Bool + defineReadPrec = shouldDefineReadPrec rClass opts + +-- | Generates a lambda expression which behaves like read(s)Prec (for Read), +-- liftRead(s)Prec (for Read1), or liftRead(s)Prec2 (for Read2). +makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp +makeReadPrecClass rClass urp name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have + -- read(s)Prec/liftRead(s)Prec/etc. implemented for it, and produces errors + -- if it can't. + buildTypeInstance rClass parentName ctxt instTypes variant + >> makeReadForCons rClass urp instTypes cons + +-- | Generates a lambda expression for read(s)Prec/liftRead(s)Prec/etc. for the +-- given constructors. All constructors must be from the same type. +makeReadForCons :: ReadClass -> Bool -> [Type] -> [ConstructorInfo] -> Q Exp +makeReadForCons rClass urp instTypes cons = do + p <- newName "p" + rps <- newNameList "rp" $ arity rClass + rls <- newNameList "rl" $ arity rClass + let rpls = zip rps rls + _rpsAndRls = interleave rps rls + lastTyVars = map varTToName $ drop (length instTypes - fromEnum rClass) instTypes + rplMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars rpls + + let nullaryCons, nonNullaryCons :: [ConstructorInfo] + (nullaryCons, nonNullaryCons) = partition isNullaryCon cons + + readConsExpr :: Q Exp + readConsExpr = do + readNonNullaryCons <- mapM (makeReadForCon rClass urp rplMap) + nonNullaryCons + foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons) + + readNullaryCons :: [Q Exp] + readNullaryCons = case nullaryCons of + [] -> [] + [con] + | nameBase (constructorName con) == "()" + -> [varE parenValName `appE` + mkDoStmts [] (varE returnValName `appE` tupE [])] + | otherwise -> [mkDoStmts (matchCon con) + (resultExpr (constructorName con) [])] + _ -> [varE chooseValName `appE` listE (map mkPair nullaryCons)] + + mkAlt :: Q Exp -> Q Exp -> Q Exp + mkAlt e1 e2 = infixApp e1 (varE altValName) e2 + + mkPair :: ConstructorInfo -> Q Exp + mkPair con = tupE [ stringE $ dataConStr con + , resultExpr (constructorName con) [] + ] + + matchCon :: ConstructorInfo -> [Q Stmt] + matchCon con + | isSym conStr = [symbolPat conStr] + | otherwise = identHPat conStr + where + conStr = dataConStr con + + mainRhsExpr :: Q Exp + mainRhsExpr + | null cons = varE pfailValName + | otherwise = varE parensValName `appE` readConsExpr + + lamE (map varP $ +#if defined(NEW_FUNCTOR_CLASSES) + _rpsAndRls ++ +#endif + if urp then [] else [p] + ) . appsE + $ [ varE $ (if urp then readPrecConstName else readsPrecConstName) rClass + , if urp + then mainRhsExpr + else varE readPrec_to_SValName `appE` mainRhsExpr `appE` varE p + ] +#if defined(NEW_FUNCTOR_CLASSES) + ++ map varE _rpsAndRls +#endif + ++ if urp then [] else [varE p] + +makeReadForCon :: ReadClass + -> Bool + -> TyVarMap2 + -> ConstructorInfo + -> Q Exp +makeReadForCon rClass urp tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorVariant = NormalConstructor + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' + let conStr = nameBase conName + isTup = isNonUnitTupleString conStr + (readStmts, varExps) <- + zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys' args + let body = resultExpr conName varExps + + checkExistentialContext rClass tvMap ctxt conName $ + if isTup + then let tupleStmts = intersperse (readPunc ",") readStmts + in varE parenValName `appE` mkDoStmts tupleStmts body + else let prefixStmts = readPrefixCon conStr ++ readStmts + in mkParser appPrec prefixStmts body +makeReadForCon rClass urp tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorVariant = RecordConstructor argNames + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' + (readStmts, varExps) <- zipWith3AndUnzipM + (\argName argTy arg -> makeReadForField rClass urp tvMap conName + (nameBase argName) argTy arg) + argNames argTys' args + let body = resultExpr conName varExps + conStr = nameBase conName + recordStmts = readPrefixCon conStr ++ [readPunc "{"] + ++ concat (intersperse [readPunc ","] readStmts) + ++ [readPunc "}"] + + checkExistentialContext rClass tvMap ctxt conName $ + mkParser appPrec1 recordStmts body +makeReadForCon rClass urp tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorVariant = InfixConstructor + , constructorFields = argTys }) = do + [alTy, arTy] <- mapM resolveTypeSynonyms argTys + al <- newName "argL" + ar <- newName "argR" + fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName + ([readStmt1, readStmt2], varExps) <- + zipWithAndUnzipM (makeReadForArg rClass False urp tvMap conName) + [alTy, arTy] [al, ar] + + let conPrec = case fi of Fixity prec _ -> prec + body = resultExpr conName varExps + conStr = nameBase conName + readInfixCon + | isSym conStr = [symbolPat conStr] + | otherwise = [readPunc "`"] ++ identHPat conStr ++ [readPunc "`"] + infixStmts = [readStmt1] ++ readInfixCon ++ [readStmt2] + + checkExistentialContext rClass tvMap ctxt conName $ + mkParser conPrec infixStmts body + +makeReadForArg :: ReadClass + -> Bool + -> Bool + -> TyVarMap2 + -> Name + -> Type + -> Name + -> Q (Q Stmt, Exp) +makeReadForArg rClass isTup urp tvMap conName ty tyExpName = do + (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty + let readStmt = bindS (varP tyExpName) $ + (if (not isTup) then appE (varE stepValName) else id) $ + wrapReadS urp (return rExp) + return (readStmt, varExp) + +makeReadForField :: ReadClass + -> Bool + -> TyVarMap2 + -> Name + -> String + -> Type + -> Name + -> Q ([Q Stmt], Exp) +makeReadForField rClass urp tvMap conName lblStr ty tyExpName = do + (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty + let readStmt = bindS (varP tyExpName) $ + read_field `appE` + (varE resetValName `appE` wrapReadS urp (return rExp)) + return ([readStmt], varExp) + where + mk_read_field readFieldName lbl + = varE readFieldName `appE` stringE lbl + read_field + | isSym lblStr + = mk_read_field readSymFieldValName lblStr + | Just (ss, '#') <- snocView lblStr + = mk_read_field readFieldHashValName ss + | otherwise + = mk_read_field readFieldValName lblStr + +makeReadForType :: ReadClass + -> Bool + -> TyVarMap2 + -> Name + -> Name + -> Bool + -> Type + -> Q (Exp, Exp) +#if defined(NEW_FUNCTOR_CLASSES) +makeReadForType _ urp tvMap _ tyExpName rl (VarT tyName) = + let tyExp = VarE tyExpName + in return $ case Map.lookup tyName tvMap of + Just (TwoNames rpExp rlExp) -> (VarE $ if rl then rlExp else rpExp, tyExp) + Nothing -> (VarE $ readsOrReadName urp rl Read, tyExp) +#else +makeReadForType _ urp _ _ tyExpName _ VarT{} = + return (VarE $ readsOrReadName urp False Read, VarE tyExpName) +#endif +makeReadForType rClass urp tvMap conName tyExpName rl (SigT ty _) = + makeReadForType rClass urp tvMap conName tyExpName rl ty +makeReadForType rClass urp tvMap conName tyExpName rl (ForallT _ _ ty) = + makeReadForType rClass urp tvMap conName tyExpName rl ty +#if defined(NEW_FUNCTOR_CLASSES) +makeReadForType rClass urp tvMap conName tyExpName rl ty = do + let tyCon :: Type + tyArgs :: [Type] + (tyCon, tyArgs) = unapplyTy ty + + numLastArgs :: Int + numLastArgs = min (arity rClass) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + + itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs + if any (`mentionsName` tyVarNames) lhsArgs + || itf && any (`mentionsName` tyVarNames) tyArgs + then outOfPlaceTyVarError rClass conName + else if any (`mentionsName` tyVarNames) rhsArgs + then do + readExp <- appsE $ [ varE . readsOrReadName urp rl $ toEnum numLastArgs] + ++ zipWith (\b -> fmap fst + . makeReadForType rClass urp tvMap conName tyExpName b) + (cycle [False,True]) + (interleave rhsArgs rhsArgs) + return (readExp, VarE tyExpName) + else return (VarE $ readsOrReadName urp rl Read, VarE tyExpName) +#else +makeReadForType rClass urp tvMap conName tyExpName _ ty = do + let varNames = Map.keys tvMap + rpExpr = VarE $ readsOrReadName urp False Read + rp1Expr = VarE $ readsOrReadName urp False Read1 + tyExpr = VarE tyExpName + + case varNames of + [] -> return (rpExpr, tyExpr) + varName:_ -> do + if mentionsName ty varNames + then do + applyExp <- makeFmapApplyPos rClass conName ty varName + return (rp1Expr, applyExp `AppE` tyExpr) + else return (rpExpr, tyExpr) +#endif + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which @Read@ variant is being derived. +data ReadClass = Read + | Read1 +#if defined(NEW_FUNCTOR_CLASSES) + | Read2 +#endif + deriving (Bounded, Enum) + +instance ClassRep ReadClass where + arity = fromEnum + + allowExQuant _ = False + + fullClassName Read = readTypeName + fullClassName Read1 = read1TypeName +#if defined(NEW_FUNCTOR_CLASSES) + fullClassName Read2 = read2TypeName +#endif + + classConstraint rClass i + | rMin <= i && i <= rMax = Just $ fullClassName (toEnum i :: ReadClass) + | otherwise = Nothing + where + rMin, rMax :: Int + rMin = fromEnum (minBound :: ReadClass) + rMax = fromEnum rClass + +readsPrecConstName :: ReadClass -> Name +readsPrecConstName Read = readsPrecConstValName +#if defined(NEW_FUNCTOR_CLASSES) +readsPrecConstName Read1 = liftReadsPrecConstValName +readsPrecConstName Read2 = liftReadsPrec2ConstValName +#else +readsPrecConstName Read1 = readsPrec1ConstValName +#endif + +readPrecConstName :: ReadClass -> Name +readPrecConstName Read = readPrecConstValName +readPrecConstName Read1 = liftReadPrecConstValName +#if defined(NEW_FUNCTOR_CLASSES) +readPrecConstName Read2 = liftReadPrec2ConstValName +#endif + +readsPrecName :: ReadClass -> Name +readsPrecName Read = readsPrecValName +#if defined(NEW_FUNCTOR_CLASSES) +readsPrecName Read1 = liftReadsPrecValName +readsPrecName Read2 = liftReadsPrec2ValName +#else +readsPrecName Read1 = readsPrec1ValName +#endif + +readPrecName :: ReadClass -> Name +readPrecName Read = readPrecValName +readPrecName Read1 = liftReadPrecValName +#if defined(NEW_FUNCTOR_CLASSES) +readPrecName Read2 = liftReadPrec2ValName +#endif + +readListPrecDefaultName :: ReadClass -> Name +readListPrecDefaultName Read = readListPrecDefaultValName +readListPrecDefaultName Read1 = liftReadListPrecDefaultValName +#if defined(NEW_FUNCTOR_CLASSES) +readListPrecDefaultName Read2 = liftReadListPrec2DefaultValName +#endif + +readListPrecName :: ReadClass -> Name +readListPrecName Read = readListPrecValName +readListPrecName Read1 = liftReadListPrecValName +#if defined(NEW_FUNCTOR_CLASSES) +readListPrecName Read2 = liftReadListPrec2ValName +#endif + +readListName :: ReadClass -> Name +readListName Read = readListValName +#if defined(NEW_FUNCTOR_CLASSES) +readListName Read1 = liftReadListValName +readListName Read2 = liftReadList2ValName +#else +readListName Read1 = error "Text.Read.Deriving.Internal.readListName" +#endif + +readsPrecOrListName :: Bool -- ^ readsListName if True, readsPrecName if False + -> ReadClass + -> Name +readsPrecOrListName False = readsPrecName +readsPrecOrListName True = readListName + +readPrecOrListName :: Bool -- ^ readListPrecName if True, readPrecName if False + -> ReadClass + -> Name +readPrecOrListName False = readPrecName +readPrecOrListName True = readListPrecName + +readsOrReadName :: Bool -- ^ readPrecOrListName if True, readsPrecOrListName if False + -> Bool -- ^ read(s)List(Prec)Name if True, read(s)PrecName if False + -> ReadClass + -> Name +readsOrReadName False = readsPrecOrListName +readsOrReadName True = readPrecOrListName + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp +mkParser p ss b = varE precValName `appE` integerE p `appE` mkDoStmts ss b + +mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp +mkDoStmts ss b = doE (ss ++ [noBindS b]) + +resultExpr :: Name -> [Exp] -> Q Exp +resultExpr conName as = varE returnValName `appE` conApp + where + conApp :: Q Exp + conApp = appsE $ conE conName : map return as + +identHPat :: String -> [Q Stmt] +identHPat s + | Just (ss, '#') <- snocView s = [identPat ss, symbolPat "#"] + | otherwise = [identPat s] + +bindLex :: Q Exp -> Q Stmt +bindLex pat = noBindS $ varE expectPValName `appE` pat + +identPat :: String -> Q Stmt +identPat s = bindLex $ conE identDataName `appE` stringE s + +symbolPat :: String -> Q Stmt +symbolPat s = bindLex $ conE symbolDataName `appE` stringE s + +readPunc :: String -> Q Stmt +readPunc c = bindLex $ conE puncDataName `appE` stringE c + +snocView :: [a] -> Maybe ([a],a) + -- Split off the last element +snocView [] = Nothing +snocView xs = go [] xs + where + -- Invariant: second arg is non-empty + go acc [a] = Just (reverse acc, a) + go acc (a:as) = go (a:acc) as + go _ [] = error "Util: snocView" + +dataConStr :: ConstructorInfo -> String +dataConStr = nameBase . constructorName + +readPrefixCon :: String -> [Q Stmt] +readPrefixCon conStr + | isSym conStr = [readPunc "(", symbolPat conStr, readPunc ")"] + | otherwise = identHPat conStr + +wrapReadS :: Bool -> Q Exp -> Q Exp +wrapReadS urp e = if urp then e + else varE readS_to_PrecValName `appE` e + +shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool +shouldDefineReadPrec rClass opts = useReadPrec opts && baseCompatible + where + base4'10OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 801 + base4'10OrLater = True +#else + base4'10OrLater = False +#endif + + baseCompatible :: Bool + baseCompatible = case rClass of + Read -> True + Read1 -> base4'10OrLater +#if defined(NEW_FUNCTOR_CLASSES) + Read2 -> base4'10OrLater +#endif diff --git a/src/Text/Show/Deriving.hs b/src/Text/Show/Deriving.hs --- a/src/Text/Show/Deriving.hs +++ b/src/Text/Show/Deriving.hs @@ -1,74 +1,74 @@ -{-# LANGUAGE CPP #-} -{-| -Module: Text.Show.Deriving -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. -Note that upstream GHC does not have the ability to derive 'Show1' or 'Show2' -instances, but since the functionality to derive 'Show' extends very naturally -'Show1' and 'Show2', the ability to derive the latter two classes is provided as a -convenience. --} -module Text.Show.Deriving ( - -- * 'Show' - deriveShow - , deriveShowOptions - , makeShowsPrec - , makeShowsPrecOptions - , makeShow - , makeShowOptions - , makeShowList - , makeShowListOptions - -- * 'Show1' - , deriveShow1 - , deriveShow1Options -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftShowsPrec - , makeLiftShowsPrecOptions - , makeLiftShowList - , makeLiftShowListOptions -#endif - , makeShowsPrec1 - , makeShowsPrec1Options -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Show2' - , deriveShow2 - , deriveShow2Options - , makeLiftShowsPrec2 - , makeLiftShowsPrec2Options - , makeLiftShowList2 - , makeLiftShowList2Options - , makeShowsPrec2 - , makeShowsPrec2Options -#endif - -- * 'ShowOptions' - , ShowOptions(..) - , defaultShowOptions - , legacyShowOptions - -- * 'deriveShow' limitations - -- $constraints - ) where - -import Text.Show.Deriving.Internal - -{- $constraints - -Be aware of the following potential gotchas: - -* Type variables of kind @*@ are assumed to have 'Show' constraints. - Type variables of kind @* -> *@ are assumed to have 'Show1' constraints. - Type variables of kind @* -> * -> *@ are assumed to have 'Show2' constraints. - If this is not desirable, use 'makeShowsPrec' or one of its cousins. - -* The 'Show1' class had a different definition in @transformers-0.4@, and as a result, - 'deriveShow1' implements different instances for the @transformers-0.4@ 'Show1' than - it otherwise does. Also, 'makeLiftShowsPrec' and 'makeLiftShowList' are not available - when this library is built against @transformers-0.4@, only 'makeShowsPrec1. - -* The 'Show2' class is not available in @transformers-0.4@, and as a - result, neither are Template Haskell functions that deal with 'Show2' when this - library is built against @transformers-0.4@. --} +{-# LANGUAGE CPP #-} +{-| +Module: Text.Show.Deriving +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. +Note that upstream GHC does not have the ability to derive 'Show1' or 'Show2' +instances, but since the functionality to derive 'Show' extends very naturally +'Show1' and 'Show2', the ability to derive the latter two classes is provided as a +convenience. +-} +module Text.Show.Deriving ( + -- * 'Show' + deriveShow + , deriveShowOptions + , makeShowsPrec + , makeShowsPrecOptions + , makeShow + , makeShowOptions + , makeShowList + , makeShowListOptions + -- * 'Show1' + , deriveShow1 + , deriveShow1Options +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftShowsPrec + , makeLiftShowsPrecOptions + , makeLiftShowList + , makeLiftShowListOptions +#endif + , makeShowsPrec1 + , makeShowsPrec1Options +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Show2' + , deriveShow2 + , deriveShow2Options + , makeLiftShowsPrec2 + , makeLiftShowsPrec2Options + , makeLiftShowList2 + , makeLiftShowList2Options + , makeShowsPrec2 + , makeShowsPrec2Options +#endif + -- * 'ShowOptions' + , ShowOptions(..) + , defaultShowOptions + , legacyShowOptions + -- * 'deriveShow' limitations + -- $constraints + ) where + +import Text.Show.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Show' constraints. + Type variables of kind @* -> *@ are assumed to have 'Show1' constraints. + Type variables of kind @* -> * -> *@ are assumed to have 'Show2' constraints. + If this is not desirable, use 'makeShowsPrec' or one of its cousins. + +* The 'Show1' class had a different definition in @transformers-0.4@, and as a result, + 'deriveShow1' implements different instances for the @transformers-0.4@ 'Show1' than + it otherwise does. Also, 'makeLiftShowsPrec' and 'makeLiftShowList' are not available + when this library is built against @transformers-0.4@, only 'makeShowsPrec1. + +* The 'Show2' class is not available in @transformers-0.4@, and as a + result, neither are Template Haskell functions that deal with 'Show2' when this + library is built against @transformers-0.4@. +-} diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -1,741 +1,741 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-| -Module: Text.Show.Deriving.Internal -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. - -Note: this is an internal module, and as such, the API presented here is not -guaranteed to be stable, even between minor releases of this library. --} -module Text.Show.Deriving.Internal ( - -- * 'Show' - deriveShow - , deriveShowOptions - , makeShowsPrec - , makeShowsPrecOptions - , makeShow - , makeShowOptions - , makeShowList - , makeShowListOptions - -- * 'Show1' - , deriveShow1 - , deriveShow1Options -#if defined(NEW_FUNCTOR_CLASSES) - , makeLiftShowsPrec - , makeLiftShowsPrecOptions - , makeLiftShowList - , makeLiftShowListOptions -#endif - , makeShowsPrec1 - , makeShowsPrec1Options -#if defined(NEW_FUNCTOR_CLASSES) - -- * 'Show2' - , deriveShow2 - , deriveShow2Options - , makeLiftShowsPrec2 - , makeLiftShowsPrec2Options - , makeLiftShowList2 - , makeLiftShowList2Options - , makeShowsPrec2 - , makeShowsPrec2Options -#endif - -- * 'ShowOptions' - , ShowOptions(..) - , defaultShowOptions - , legacyShowOptions - ) where - -import Data.Deriving.Internal -import qualified Data.List as List -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe (fromMaybe) - -import GHC.Show (appPrec, appPrec1) - -import Language.Haskell.TH.Datatype -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax - --- | Options that further configure how the functions in "Text.Show.Deriving" --- should behave. -data ShowOptions = ShowOptions - { ghc8ShowBehavior :: Bool - -- ^ If 'True', the derived 'Show', 'Show1', or 'Show2' instance will not - -- surround the output of showing fields of unlifted types with parentheses, - -- and the output will be suffixed with hash signs (@#@). - , showEmptyCaseBehavior :: Bool - -- ^ If 'True', derived instances for empty data types (i.e., ones with - -- no data constructors) will use the @EmptyCase@ language extension. - -- If 'False', derived instances will simply use 'seq' instead. - -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only - -- available in 7.8 or later.) - } deriving (Eq, Ord, Read, Show) - --- | 'ShowOptions' that match the behavior of the most recent GHC release. -defaultShowOptions :: ShowOptions -defaultShowOptions = - ShowOptions { ghc8ShowBehavior = True - , showEmptyCaseBehavior = False - } - --- | 'ShowOptions' that match the behavior of the installed version of GHC. -legacyShowOptions :: ShowOptions -legacyShowOptions = ShowOptions - { ghc8ShowBehavior = -#if __GLASGOW_HASKELL__ >= 711 - True -#else - False -#endif - , showEmptyCaseBehavior = False - } - --- | Generates a 'Show' instance declaration for the given data type or data --- family instance. -deriveShow :: Name -> Q [Dec] -deriveShow = deriveShowOptions defaultShowOptions - --- | Like 'deriveShow', but takes a 'ShowOptions' argument. -deriveShowOptions :: ShowOptions -> Name -> Q [Dec] -deriveShowOptions = deriveShowClass Show - --- | Generates a lambda expression which behaves like 'show' (without --- requiring a 'Show' instance). -makeShow :: Name -> Q Exp -makeShow = makeShowOptions defaultShowOptions - --- | Like 'makeShow', but takes a 'ShowOptions' argument. -makeShowOptions :: ShowOptions -> Name -> Q Exp -makeShowOptions opts name = do - x <- newName "x" - lam1E (varP x) $ makeShowsPrecOptions opts name - `appE` integerE 0 - `appE` varE x - `appE` stringE "" - --- | Generates a lambda expression which behaves like 'showsPrec' (without --- requiring a 'Show' instance). -makeShowsPrec :: Name -> Q Exp -makeShowsPrec = makeShowsPrecOptions defaultShowOptions - --- | Like 'makeShowsPrec', but takes a 'ShowOptions' argument. -makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp -makeShowsPrecOptions = makeShowsPrecClass Show - --- | Generates a lambda expression which behaves like 'showList' (without --- requiring a 'Show' instance). -makeShowList :: Name -> Q Exp -makeShowList = makeShowListOptions defaultShowOptions - --- | Like 'makeShowList', but takes a 'ShowOptions' argument. -makeShowListOptions :: ShowOptions -> Name -> Q Exp -makeShowListOptions opts name = - varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` integerE 0) - --- | Generates a 'Show1' instance declaration for the given data type or data --- family instance. -deriveShow1 :: Name -> Q [Dec] -deriveShow1 = deriveShow1Options defaultShowOptions - --- | Like 'deriveShow1', but takes a 'ShowOptions' argument. -deriveShow1Options :: ShowOptions -> Name -> Q [Dec] -deriveShow1Options = deriveShowClass Show1 - --- | Generates a lambda expression which behaves like 'showsPrec1' (without --- requiring a 'Show1' instance). -makeShowsPrec1 :: Name -> Q Exp -makeShowsPrec1 = makeShowsPrec1Options defaultShowOptions - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates a lambda expression which behaves like 'liftShowsPrec' (without --- requiring a 'Show1' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftShowsPrec :: Name -> Q Exp -makeLiftShowsPrec = makeLiftShowsPrecOptions defaultShowOptions - --- | Like 'makeLiftShowsPrec', but takes a 'ShowOptions' argument. --- --- This function is not available with @transformers-0.4@. -makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp -makeLiftShowsPrecOptions = makeShowsPrecClass Show1 - --- | Generates a lambda expression which behaves like 'liftShowList' (without --- requiring a 'Show' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftShowList :: Name -> Q Exp -makeLiftShowList = makeLiftShowListOptions defaultShowOptions - --- | Like 'makeLiftShowList', but takes a 'ShowOptions' argument. --- --- This function is not available with @transformers-0.4@. -makeLiftShowListOptions :: ShowOptions -> Name -> Q Exp -makeLiftShowListOptions opts name = do - sp' <- newName "sp'" - sl' <- newName "sl'" - lamE [varP sp', varP sl'] $ varE showListWithValName `appE` - (makeLiftShowsPrecOptions opts name `appE` varE sp' `appE` varE sl' - `appE` integerE 0) - --- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument. -makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp -makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name - `appE` varE showsPrecValName - `appE` varE showListValName -#else --- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument. -makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp -makeShowsPrec1Options = makeShowsPrecClass Show1 -#endif - -#if defined(NEW_FUNCTOR_CLASSES) --- | Generates a 'Show2' instance declaration for the given data type or data --- family instance. --- --- This function is not available with @transformers-0.4@. -deriveShow2 :: Name -> Q [Dec] -deriveShow2 = deriveShow2Options defaultShowOptions - --- | Like 'deriveShow2', but takes a 'ShowOptions' argument. --- --- This function is not available with @transformers-0.4@. -deriveShow2Options :: ShowOptions -> Name -> Q [Dec] -deriveShow2Options = deriveShowClass Show2 - --- | Generates a lambda expression which behaves like 'liftShowsPrec2' (without --- requiring a 'Show2' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftShowsPrec2 :: Name -> Q Exp -makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultShowOptions - --- | Like 'makeLiftShowsPrec2', but takes a 'ShowOptions' argument. --- --- This function is not available with @transformers-0.4@. -makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp -makeLiftShowsPrec2Options = makeShowsPrecClass Show2 - --- | Generates a lambda expression which behaves like 'liftShowList2' (without --- requiring a 'Show' instance). --- --- This function is not available with @transformers-0.4@. -makeLiftShowList2 :: Name -> Q Exp -makeLiftShowList2 = makeLiftShowList2Options defaultShowOptions - --- | Like 'makeLiftShowList2', but takes a 'ShowOptions' argument. --- --- This function is not available with @transformers-0.4@. -makeLiftShowList2Options :: ShowOptions -> Name -> Q Exp -makeLiftShowList2Options opts name = do - sp1' <- newName "sp1'" - sl1' <- newName "sl1'" - sp2' <- newName "sp2'" - sl2' <- newName "sl2'" - lamE [varP sp1', varP sl1', varP sp2', varP sl2'] $ - varE showListWithValName `appE` - (makeLiftShowsPrec2Options opts name `appE` varE sp1' `appE` varE sl1' - `appE` varE sp2' `appE` varE sl2' - `appE` integerE 0) - --- | Generates a lambda expression which behaves like 'showsPrec2' (without --- requiring a 'Show2' instance). --- --- This function is not available with @transformers-0.4@. -makeShowsPrec2 :: Name -> Q Exp -makeShowsPrec2 = makeShowsPrec2Options defaultShowOptions - --- | Like 'makeShowsPrec2', but takes a 'ShowOptions' argument. --- --- This function is not available with @transformers-0.4@. -makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp -makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name - `appE` varE showsPrecValName - `appE` varE showListValName - `appE` varE showsPrecValName - `appE` varE showListValName -#endif - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | Derive a Show(1)(2) instance declaration (depending on the ShowClass --- argument's value). -deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec] -deriveShowClass sClass opts name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - (instanceCxt, instanceType) - <- buildTypeInstance sClass parentName ctxt instTypes variant - (:[]) `fmap` instanceD (return instanceCxt) - (return instanceType) - (showsPrecDecs sClass opts instTypes cons) - --- | Generates a declaration defining the primary function corresponding to a --- particular class (showsPrec for Show, liftShowsPrec for Show1, and --- liftShowsPrec2 for Show2). -showsPrecDecs :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> [Q Dec] -showsPrecDecs sClass opts instTypes cons = - [ funD (showsPrecName sClass) - [ clause [] - (normalB $ makeShowForCons sClass opts instTypes cons) - [] - ] - ] - --- | Generates a lambda expression which behaves like showsPrec (for Show), --- liftShowsPrec (for Show1), or liftShowsPrec2 (for Show2). -makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp -makeShowsPrecClass sClass opts name = do - info <- reifyDatatype name - case info of - DatatypeInfo { datatypeContext = ctxt - , datatypeName = parentName - , datatypeInstTypes = instTypes - , datatypeVariant = variant - , datatypeCons = cons - } -> do - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have showsPrec/liftShowsPrec/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance sClass parentName ctxt instTypes variant - >> makeShowForCons sClass opts instTypes cons - --- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the --- given constructors. All constructors must be from the same type. -makeShowForCons :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> Q Exp -makeShowForCons sClass opts instTypes cons = do - p <- newName "p" - value <- newName "value" - sps <- newNameList "sp" $ arity sClass - sls <- newNameList "sl" $ arity sClass - let spls = zip sps sls - _spsAndSls = interleave sps sls - lastTyVars = map varTToName $ drop (length instTypes - fromEnum sClass) instTypes - splMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars spls - - makeFun - | null cons && showEmptyCaseBehavior opts && ghc7'8OrLater - = caseE (varE value) [] - - | null cons - = appE (varE seqValName) (varE value) `appE` - appE (varE errorValName) - (stringE $ "Void " ++ nameBase (showsPrecName sClass)) - - | otherwise - = caseE (varE value) - (map (makeShowForCon p sClass opts splMap) cons) - - lamE (map varP $ -#if defined(NEW_FUNCTOR_CLASSES) - _spsAndSls ++ -#endif - [p, value]) - . appsE - $ [ varE $ showsPrecConstName sClass - , makeFun - ] -#if defined(NEW_FUNCTOR_CLASSES) - ++ map varE _spsAndSls -#endif - ++ [varE p, varE value] - --- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a --- single constructor. -makeShowForCon :: Name - -> ShowClass - -> ShowOptions - -> TyVarMap2 - -> ConstructorInfo - -> Q Match -makeShowForCon _ _ _ _ - (ConstructorInfo { constructorName = conName, constructorFields = [] }) = - match - (conP conName []) - (normalB $ varE showStringValName `appE` stringE (parenInfixConName conName "")) - [] -makeShowForCon p sClass opts tvMap - (ConstructorInfo { constructorName = conName - , constructorVariant = NormalConstructor - , constructorFields = [argTy] }) = do - argTy' <- resolveTypeSynonyms argTy - arg <- newName "arg" - - let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy' arg - namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) - (varE composeValName) - showArg - - match - (conP conName [varP arg]) - (normalB $ varE showParenValName - `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) - `appE` namedArg) - [] -makeShowForCon p sClass opts tvMap - (ConstructorInfo { constructorName = conName - , constructorVariant = NormalConstructor - , constructorFields = argTys }) = do - argTys' <- mapM resolveTypeSynonyms argTys - args <- newNameList "arg" $ length argTys' - - if isNonUnitTuple conName - then do - let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys' args - parenCommaArgs = (varE showCharValName `appE` charE '(') - : List.intersperse (varE showCharValName `appE` charE ',') showArgs - mappendArgs = foldr (`infixApp` varE composeValName) - (varE showCharValName `appE` charE ')') - parenCommaArgs - - match (conP conName $ map varP args) - (normalB mappendArgs) - [] - else do - let showArgs = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys' args - mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName) - (infixApp (varE showSpaceValName) - (varE composeValName) - q)) showArgs - namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) - (varE composeValName) - mappendArgs - - match (conP conName $ map varP args) - (normalB $ varE showParenValName - `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) - `appE` namedArgs) - [] -makeShowForCon p sClass opts tvMap - (ConstructorInfo { constructorName = conName - , constructorVariant = RecordConstructor argNames - , constructorFields = argTys }) = do - argTys' <- mapM resolveTypeSynonyms argTys - args <- newNameList "arg" $ length argTys' - - let showArgs = concatMap (\(argName, argTy, arg) - -> let argNameBase = nameBase argName - infixRec = showParen (isSym argNameBase) - (showString argNameBase) "" - in [ varE showStringValName `appE` stringE (infixRec ++ " = ") - , makeShowForArg 0 sClass opts conName tvMap argTy arg - , varE showCommaSpaceValName - ] - ) - (zip3 argNames argTys' args) - braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs - mappendArgs = foldr (`infixApp` varE composeValName) - (varE showCharValName `appE` charE '}') - braceCommaArgs - namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) - (varE composeValName) - mappendArgs - - match - (conP conName $ map varP args) - (normalB $ varE showParenValName - `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) - `appE` namedArgs) - [] -makeShowForCon p sClass opts tvMap - (ConstructorInfo { constructorName = conName - , constructorVariant = InfixConstructor - , constructorFields = argTys }) = do - [alTy, arTy] <- mapM resolveTypeSynonyms argTys - al <- newName "argL" - ar <- newName "argR" - fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName - let conPrec = case fi of Fixity prec _ -> prec - opName = nameBase conName - infixOpE = appE (varE showStringValName) . stringE $ - if isInfixDataCon opName - then " " ++ opName ++ " " - else " `" ++ opName ++ "` " - - match - (infixP (varP al) conName (varP ar)) - (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE conPrec)) - `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al) - (varE composeValName) - (infixApp infixOpE - (varE composeValName) - (makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy ar))) - ) - [] - --- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for an --- argument of a constructor. -makeShowForArg :: Int - -> ShowClass - -> ShowOptions - -> Name - -> TyVarMap2 - -> Type - -> Name - -> Q Exp -makeShowForArg p _ opts _ _ (ConT tyName) tyExpName = - showE - where - tyVarE :: Q Exp - tyVarE = varE tyExpName - - showE :: Q Exp - showE = - case Map.lookup tyName primShowTbl of - Just ps -> showPrimE ps - Nothing -> varE showsPrecValName `appE` integerE p `appE` tyVarE - - showPrimE :: PrimShow -> Q Exp - showPrimE PrimShow{primShowBoxer, primShowPostfixMod, primShowConv} - -- Starting with GHC 8.0, data types containing unlifted types with - -- derived Show instances show hashed literals with actual hash signs, - -- and negative hashed literals are not surrounded with parentheses. - | ghc8ShowBehavior opts - = primShowConv $ infixApp (primE 0) (varE composeValName) primShowPostfixMod - | otherwise - = primE p - where - primE :: Int -> Q Exp - primE prec = varE showsPrecValName `appE` integerE prec - `appE` primShowBoxer tyVarE -makeShowForArg p sClass _ conName tvMap ty tyExpName = - makeShowForType sClass conName tvMap False ty `appE` integerE p `appE` varE tyExpName - --- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a --- specific type. The generated expression depends on the number of type variables. --- --- 1. If the type is of kind * (T), apply showsPrec. --- 2. If the type is of kind * -> * (T a), apply liftShowsPrec $(makeShowForType a) --- 3. If the type is of kind * -> * -> * (T a b), apply --- liftShowsPrec2 $(makeShowForType a) $(makeShowForType b) -makeShowForType :: ShowClass - -> Name - -> TyVarMap2 - -> Bool -- ^ True if we are using the function of type ([a] -> ShowS), - -- False if we are using the function of type (Int -> a -> ShowS). - -> Type - -> Q Exp -#if defined(NEW_FUNCTOR_CLASSES) -makeShowForType _ _ tvMap sl (VarT tyName) = - varE $ case Map.lookup tyName tvMap of - Just (TwoNames spExp slExp) -> if sl then slExp else spExp - Nothing -> if sl then showListValName else showsPrecValName -#else -makeShowForType _ _ _ _ VarT{} = varE showsPrecValName -#endif -makeShowForType sClass conName tvMap sl (SigT ty _) = makeShowForType sClass conName tvMap sl ty -makeShowForType sClass conName tvMap sl (ForallT _ _ ty) = makeShowForType sClass conName tvMap sl ty -#if defined(NEW_FUNCTOR_CLASSES) -makeShowForType sClass conName tvMap sl ty = do - let tyCon :: Type - tyArgs :: [Type] - (tyCon, tyArgs) = unapplyTy ty - - numLastArgs :: Int - numLastArgs = min (arity sClass) (length tyArgs) - - lhsArgs, rhsArgs :: [Type] - (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - - tyVarNames :: [Name] - tyVarNames = Map.keys tvMap - - itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs - if any (`mentionsName` tyVarNames) lhsArgs - || itf && any (`mentionsName` tyVarNames) tyArgs - then outOfPlaceTyVarError sClass conName - else if any (`mentionsName` tyVarNames) rhsArgs - then appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs] - ++ zipWith (makeShowForType sClass conName tvMap) - (cycle [False,True]) - (interleave rhsArgs rhsArgs) - else varE $ if sl then showListValName else showsPrecValName -#else -makeShowForType sClass conName tvMap _ ty = do - let varNames = Map.keys tvMap - - p' <- newName "p'" - value' <- newName "value'" - case varNames of - [] -> varE showsPrecValName - varName:_ -> - if mentionsName ty varNames - then lamE [varP p', varP value'] $ varE showsPrec1ValName - `appE` varE p' - `appE` (makeFmapApplyNeg sClass conName ty varName `appE` varE value') - else varE showsPrecValName -#endif - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- | A representation of which @Show@ variant is being derived. -data ShowClass = Show - | Show1 -#if defined(NEW_FUNCTOR_CLASSES) - | Show2 -#endif - deriving (Bounded, Enum) - -instance ClassRep ShowClass where - arity = fromEnum - - allowExQuant _ = True - - fullClassName Show = showTypeName - fullClassName Show1 = show1TypeName -#if defined(NEW_FUNCTOR_CLASSES) - fullClassName Show2 = show2TypeName -#endif - - classConstraint sClass i - | sMin <= i && i <= sMax = Just $ fullClassName (toEnum i :: ShowClass) - | otherwise = Nothing - where - sMin, sMax :: Int - sMin = fromEnum (minBound :: ShowClass) - sMax = fromEnum sClass - -showsPrecConstName :: ShowClass -> Name -showsPrecConstName Show = showsPrecConstValName -#if defined(NEW_FUNCTOR_CLASSES) -showsPrecConstName Show1 = liftShowsPrecConstValName -showsPrecConstName Show2 = liftShowsPrec2ConstValName -#else -showsPrecConstName Show1 = showsPrec1ConstValName -#endif - -showsPrecName :: ShowClass -> Name -showsPrecName Show = showsPrecValName -#if defined(NEW_FUNCTOR_CLASSES) -showsPrecName Show1 = liftShowsPrecValName -showsPrecName Show2 = liftShowsPrec2ValName -#else -showsPrecName Show1 = showsPrec1ValName -#endif - -#if defined(NEW_FUNCTOR_CLASSES) -showListName :: ShowClass -> Name -showListName Show = showListValName -showListName Show1 = liftShowListValName -showListName Show2 = liftShowList2ValName - -showsPrecOrListName :: Bool -- ^ showListName if True, showsPrecName if False - -> ShowClass - -> Name -showsPrecOrListName False = showsPrecName -showsPrecOrListName True = showListName -#endif - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - --- | Parenthesize an infix constructor name if it is being applied as a prefix --- function (e.g., data Amp a = (:&) a a) -parenInfixConName :: Name -> ShowS -parenInfixConName conName = - let conNameBase = nameBase conName - in showParen (isInfixDataCon conNameBase) $ showString conNameBase - -charE :: Char -> Q Exp -charE = litE . charL - -data PrimShow = PrimShow - { primShowBoxer :: Q Exp -> Q Exp - , primShowPostfixMod :: Q Exp - , primShowConv :: Q Exp -> Q Exp - } - -primShowTbl :: Map Name PrimShow -primShowTbl = Map.fromList - [ (charHashTypeName, PrimShow - { primShowBoxer = appE (conE cHashDataName) - , primShowPostfixMod = oneHashE - , primShowConv = id - }) - , (doubleHashTypeName, PrimShow - { primShowBoxer = appE (conE dHashDataName) - , primShowPostfixMod = twoHashE - , primShowConv = id - }) - , (floatHashTypeName, PrimShow - { primShowBoxer = appE (conE fHashDataName) - , primShowPostfixMod = oneHashE - , primShowConv = id - }) - , (intHashTypeName, PrimShow - { primShowBoxer = appE (conE iHashDataName) - , primShowPostfixMod = oneHashE - , primShowConv = id - }) - , (wordHashTypeName, PrimShow - { primShowBoxer = appE (conE wHashDataName) - , primShowPostfixMod = twoHashE - , primShowConv = id - }) -#if MIN_VERSION_base(4,13,0) - , (int8HashTypeName, PrimShow - { primShowBoxer = appE (conE iHashDataName) . appE (varE int8ToIntHashValName) - , primShowPostfixMod = oneHashE - , primShowConv = mkNarrowE intToInt8HashValName - }) - , (int16HashTypeName, PrimShow - { primShowBoxer = appE (conE iHashDataName) . appE (varE int16ToIntHashValName) - , primShowPostfixMod = oneHashE - , primShowConv = mkNarrowE intToInt16HashValName - }) - , (word8HashTypeName, PrimShow - { primShowBoxer = appE (conE wHashDataName) . appE (varE word8ToWordHashValName) - , primShowPostfixMod = twoHashE - , primShowConv = mkNarrowE wordToWord8HashValName - }) - , (word16HashTypeName, PrimShow - { primShowBoxer = appE (conE wHashDataName) . appE (varE word16ToWordHashValName) - , primShowPostfixMod = twoHashE - , primShowConv = mkNarrowE wordToWord16HashValName - }) -#endif -#if MIN_VERSION_base(4,16,0) - , (int32HashTypeName, PrimShow - { primShowBoxer = appE (conE iHashDataName) . appE (varE int32ToIntHashValName) - , primShowPostfixMod = oneHashE - , primShowConv = mkNarrowE intToInt32HashValName - }) - , (word32HashTypeName, PrimShow - { primShowBoxer = appE (conE wHashDataName) . appE (varE word32ToWordHashValName) - , primShowPostfixMod = twoHashE - , primShowConv = mkNarrowE wordToWord32HashValName - }) -#endif - ] - -#if MIN_VERSION_base(4,13,0) -mkNarrowE :: Name -> Q Exp -> Q Exp -mkNarrowE narrowName e = - foldr (`infixApp` varE composeValName) - (varE showCharValName `appE` charE ')') - [ varE showStringValName `appE` stringE ('(':nameBase narrowName ++ " ") - , e - ] -#endif - -oneHashE, twoHashE :: Q Exp -oneHashE = varE showCharValName `appE` charE '#' -twoHashE = varE showStringValName `appE` stringE "##" +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-| +Module: Text.Show.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Text.Show.Deriving.Internal ( + -- * 'Show' + deriveShow + , deriveShowOptions + , makeShowsPrec + , makeShowsPrecOptions + , makeShow + , makeShowOptions + , makeShowList + , makeShowListOptions + -- * 'Show1' + , deriveShow1 + , deriveShow1Options +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftShowsPrec + , makeLiftShowsPrecOptions + , makeLiftShowList + , makeLiftShowListOptions +#endif + , makeShowsPrec1 + , makeShowsPrec1Options +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Show2' + , deriveShow2 + , deriveShow2Options + , makeLiftShowsPrec2 + , makeLiftShowsPrec2Options + , makeLiftShowList2 + , makeLiftShowList2Options + , makeShowsPrec2 + , makeShowsPrec2Options +#endif + -- * 'ShowOptions' + , ShowOptions(..) + , defaultShowOptions + , legacyShowOptions + ) where + +import Data.Deriving.Internal +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromMaybe) + +import GHC.Show (appPrec, appPrec1) + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +-- | Options that further configure how the functions in "Text.Show.Deriving" +-- should behave. +data ShowOptions = ShowOptions + { ghc8ShowBehavior :: Bool + -- ^ If 'True', the derived 'Show', 'Show1', or 'Show2' instance will not + -- surround the output of showing fields of unlifted types with parentheses, + -- and the output will be suffixed with hash signs (@#@). + , showEmptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) + } deriving (Eq, Ord, Read, Show) + +-- | 'ShowOptions' that match the behavior of the most recent GHC release. +defaultShowOptions :: ShowOptions +defaultShowOptions = + ShowOptions { ghc8ShowBehavior = True + , showEmptyCaseBehavior = False + } + +-- | 'ShowOptions' that match the behavior of the installed version of GHC. +legacyShowOptions :: ShowOptions +legacyShowOptions = ShowOptions + { ghc8ShowBehavior = +#if __GLASGOW_HASKELL__ >= 711 + True +#else + False +#endif + , showEmptyCaseBehavior = False + } + +-- | Generates a 'Show' instance declaration for the given data type or data +-- family instance. +deriveShow :: Name -> Q [Dec] +deriveShow = deriveShowOptions defaultShowOptions + +-- | Like 'deriveShow', but takes a 'ShowOptions' argument. +deriveShowOptions :: ShowOptions -> Name -> Q [Dec] +deriveShowOptions = deriveShowClass Show + +-- | Generates a lambda expression which behaves like 'show' (without +-- requiring a 'Show' instance). +makeShow :: Name -> Q Exp +makeShow = makeShowOptions defaultShowOptions + +-- | Like 'makeShow', but takes a 'ShowOptions' argument. +makeShowOptions :: ShowOptions -> Name -> Q Exp +makeShowOptions opts name = do + x <- newName "x" + lam1E (varP x) $ makeShowsPrecOptions opts name + `appE` integerE 0 + `appE` varE x + `appE` stringE "" + +-- | Generates a lambda expression which behaves like 'showsPrec' (without +-- requiring a 'Show' instance). +makeShowsPrec :: Name -> Q Exp +makeShowsPrec = makeShowsPrecOptions defaultShowOptions + +-- | Like 'makeShowsPrec', but takes a 'ShowOptions' argument. +makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp +makeShowsPrecOptions = makeShowsPrecClass Show + +-- | Generates a lambda expression which behaves like 'showList' (without +-- requiring a 'Show' instance). +makeShowList :: Name -> Q Exp +makeShowList = makeShowListOptions defaultShowOptions + +-- | Like 'makeShowList', but takes a 'ShowOptions' argument. +makeShowListOptions :: ShowOptions -> Name -> Q Exp +makeShowListOptions opts name = + varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` integerE 0) + +-- | Generates a 'Show1' instance declaration for the given data type or data +-- family instance. +deriveShow1 :: Name -> Q [Dec] +deriveShow1 = deriveShow1Options defaultShowOptions + +-- | Like 'deriveShow1', but takes a 'ShowOptions' argument. +deriveShow1Options :: ShowOptions -> Name -> Q [Dec] +deriveShow1Options = deriveShowClass Show1 + +-- | Generates a lambda expression which behaves like 'showsPrec1' (without +-- requiring a 'Show1' instance). +makeShowsPrec1 :: Name -> Q Exp +makeShowsPrec1 = makeShowsPrec1Options defaultShowOptions + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a lambda expression which behaves like 'liftShowsPrec' (without +-- requiring a 'Show1' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrec :: Name -> Q Exp +makeLiftShowsPrec = makeLiftShowsPrecOptions defaultShowOptions + +-- | Like 'makeLiftShowsPrec', but takes a 'ShowOptions' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp +makeLiftShowsPrecOptions = makeShowsPrecClass Show1 + +-- | Generates a lambda expression which behaves like 'liftShowList' (without +-- requiring a 'Show' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowList :: Name -> Q Exp +makeLiftShowList = makeLiftShowListOptions defaultShowOptions + +-- | Like 'makeLiftShowList', but takes a 'ShowOptions' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowListOptions :: ShowOptions -> Name -> Q Exp +makeLiftShowListOptions opts name = do + sp' <- newName "sp'" + sl' <- newName "sl'" + lamE [varP sp', varP sl'] $ varE showListWithValName `appE` + (makeLiftShowsPrecOptions opts name `appE` varE sp' `appE` varE sl' + `appE` integerE 0) + +-- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument. +makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp +makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name + `appE` varE showsPrecValName + `appE` varE showListValName +#else +-- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument. +makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp +makeShowsPrec1Options = makeShowsPrecClass Show1 +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a 'Show2' instance declaration for the given data type or data +-- family instance. +-- +-- This function is not available with @transformers-0.4@. +deriveShow2 :: Name -> Q [Dec] +deriveShow2 = deriveShow2Options defaultShowOptions + +-- | Like 'deriveShow2', but takes a 'ShowOptions' argument. +-- +-- This function is not available with @transformers-0.4@. +deriveShow2Options :: ShowOptions -> Name -> Q [Dec] +deriveShow2Options = deriveShowClass Show2 + +-- | Generates a lambda expression which behaves like 'liftShowsPrec2' (without +-- requiring a 'Show2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrec2 :: Name -> Q Exp +makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultShowOptions + +-- | Like 'makeLiftShowsPrec2', but takes a 'ShowOptions' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp +makeLiftShowsPrec2Options = makeShowsPrecClass Show2 + +-- | Generates a lambda expression which behaves like 'liftShowList2' (without +-- requiring a 'Show' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowList2 :: Name -> Q Exp +makeLiftShowList2 = makeLiftShowList2Options defaultShowOptions + +-- | Like 'makeLiftShowList2', but takes a 'ShowOptions' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowList2Options :: ShowOptions -> Name -> Q Exp +makeLiftShowList2Options opts name = do + sp1' <- newName "sp1'" + sl1' <- newName "sl1'" + sp2' <- newName "sp2'" + sl2' <- newName "sl2'" + lamE [varP sp1', varP sl1', varP sp2', varP sl2'] $ + varE showListWithValName `appE` + (makeLiftShowsPrec2Options opts name `appE` varE sp1' `appE` varE sl1' + `appE` varE sp2' `appE` varE sl2' + `appE` integerE 0) + +-- | Generates a lambda expression which behaves like 'showsPrec2' (without +-- requiring a 'Show2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeShowsPrec2 :: Name -> Q Exp +makeShowsPrec2 = makeShowsPrec2Options defaultShowOptions + +-- | Like 'makeShowsPrec2', but takes a 'ShowOptions' argument. +-- +-- This function is not available with @transformers-0.4@. +makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp +makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name + `appE` varE showsPrecValName + `appE` varE showListValName + `appE` varE showsPrecValName + `appE` varE showListValName +#endif + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Derive a Show(1)(2) instance declaration (depending on the ShowClass +-- argument's value). +deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec] +deriveShowClass sClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance sClass parentName ctxt instTypes variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (showsPrecDecs sClass opts instTypes cons) + +-- | Generates a declaration defining the primary function corresponding to a +-- particular class (showsPrec for Show, liftShowsPrec for Show1, and +-- liftShowsPrec2 for Show2). +showsPrecDecs :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> [Q Dec] +showsPrecDecs sClass opts instTypes cons = + [ funD (showsPrecName sClass) + [ clause [] + (normalB $ makeShowForCons sClass opts instTypes cons) + [] + ] + ] + +-- | Generates a lambda expression which behaves like showsPrec (for Show), +-- liftShowsPrec (for Show1), or liftShowsPrec2 (for Show2). +makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp +makeShowsPrecClass sClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeInstTypes = instTypes + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have showsPrec/liftShowsPrec/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance sClass parentName ctxt instTypes variant + >> makeShowForCons sClass opts instTypes cons + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the +-- given constructors. All constructors must be from the same type. +makeShowForCons :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> Q Exp +makeShowForCons sClass opts instTypes cons = do + p <- newName "p" + value <- newName "value" + sps <- newNameList "sp" $ arity sClass + sls <- newNameList "sl" $ arity sClass + let spls = zip sps sls + _spsAndSls = interleave sps sls + lastTyVars = map varTToName $ drop (length instTypes - fromEnum sClass) instTypes + splMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars spls + + makeFun + | null cons && showEmptyCaseBehavior opts && ghc7'8OrLater + = caseE (varE value) [] + + | null cons + = appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (showsPrecName sClass)) + + | otherwise + = caseE (varE value) + (map (makeShowForCon p sClass opts splMap) cons) + + lamE (map varP $ +#if defined(NEW_FUNCTOR_CLASSES) + _spsAndSls ++ +#endif + [p, value]) + . appsE + $ [ varE $ showsPrecConstName sClass + , makeFun + ] +#if defined(NEW_FUNCTOR_CLASSES) + ++ map varE _spsAndSls +#endif + ++ [varE p, varE value] + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a +-- single constructor. +makeShowForCon :: Name + -> ShowClass + -> ShowOptions + -> TyVarMap2 + -> ConstructorInfo + -> Q Match +makeShowForCon _ _ _ _ + (ConstructorInfo { constructorName = conName, constructorFields = [] }) = + match + (conP conName []) + (normalB $ varE showStringValName `appE` stringE (parenInfixConName conName "")) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = NormalConstructor + , constructorFields = [argTy] }) = do + argTy' <- resolveTypeSynonyms argTy + arg <- newName "arg" + + let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy' arg + namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) + (varE composeValName) + showArg + + match + (conP conName [varP arg]) + (normalB $ varE showParenValName + `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) + `appE` namedArg) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = NormalConstructor + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' + + if isNonUnitTuple conName + then do + let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys' args + parenCommaArgs = (varE showCharValName `appE` charE '(') + : List.intersperse (varE showCharValName `appE` charE ',') showArgs + mappendArgs = foldr (`infixApp` varE composeValName) + (varE showCharValName `appE` charE ')') + parenCommaArgs + + match (conP conName $ map varP args) + (normalB mappendArgs) + [] + else do + let showArgs = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys' args + mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName) + (infixApp (varE showSpaceValName) + (varE composeValName) + q)) showArgs + namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) + (varE composeValName) + mappendArgs + + match (conP conName $ map varP args) + (normalB $ varE showParenValName + `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) + `appE` namedArgs) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = RecordConstructor argNames + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' + + let showArgs = concatMap (\(argName, argTy, arg) + -> let argNameBase = nameBase argName + infixRec = showParen (isSym argNameBase) + (showString argNameBase) "" + in [ varE showStringValName `appE` stringE (infixRec ++ " = ") + , makeShowForArg 0 sClass opts conName tvMap argTy arg + , varE showCommaSpaceValName + ] + ) + (zip3 argNames argTys' args) + braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs + mappendArgs = foldr (`infixApp` varE composeValName) + (varE showCharValName `appE` charE '}') + braceCommaArgs + namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) + (varE composeValName) + mappendArgs + + match + (conP conName $ map varP args) + (normalB $ varE showParenValName + `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) + `appE` namedArgs) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = InfixConstructor + , constructorFields = argTys }) = do + [alTy, arTy] <- mapM resolveTypeSynonyms argTys + al <- newName "argL" + ar <- newName "argR" + fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName + let conPrec = case fi of Fixity prec _ -> prec + opName = nameBase conName + infixOpE = appE (varE showStringValName) . stringE $ + if isInfixDataCon opName + then " " ++ opName ++ " " + else " `" ++ opName ++ "` " + + match + (infixP (varP al) conName (varP ar)) + (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE conPrec)) + `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al) + (varE composeValName) + (infixApp infixOpE + (varE composeValName) + (makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy ar))) + ) + [] + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for an +-- argument of a constructor. +makeShowForArg :: Int + -> ShowClass + -> ShowOptions + -> Name + -> TyVarMap2 + -> Type + -> Name + -> Q Exp +makeShowForArg p _ opts _ _ (ConT tyName) tyExpName = + showE + where + tyVarE :: Q Exp + tyVarE = varE tyExpName + + showE :: Q Exp + showE = + case Map.lookup tyName primShowTbl of + Just ps -> showPrimE ps + Nothing -> varE showsPrecValName `appE` integerE p `appE` tyVarE + + showPrimE :: PrimShow -> Q Exp + showPrimE PrimShow{primShowBoxer, primShowPostfixMod, primShowConv} + -- Starting with GHC 8.0, data types containing unlifted types with + -- derived Show instances show hashed literals with actual hash signs, + -- and negative hashed literals are not surrounded with parentheses. + | ghc8ShowBehavior opts + = primShowConv $ infixApp (primE 0) (varE composeValName) primShowPostfixMod + | otherwise + = primE p + where + primE :: Int -> Q Exp + primE prec = varE showsPrecValName `appE` integerE prec + `appE` primShowBoxer tyVarE +makeShowForArg p sClass _ conName tvMap ty tyExpName = + makeShowForType sClass conName tvMap False ty `appE` integerE p `appE` varE tyExpName + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a +-- specific type. The generated expression depends on the number of type variables. +-- +-- 1. If the type is of kind * (T), apply showsPrec. +-- 2. If the type is of kind * -> * (T a), apply liftShowsPrec $(makeShowForType a) +-- 3. If the type is of kind * -> * -> * (T a b), apply +-- liftShowsPrec2 $(makeShowForType a) $(makeShowForType b) +makeShowForType :: ShowClass + -> Name + -> TyVarMap2 + -> Bool -- ^ True if we are using the function of type ([a] -> ShowS), + -- False if we are using the function of type (Int -> a -> ShowS). + -> Type + -> Q Exp +#if defined(NEW_FUNCTOR_CLASSES) +makeShowForType _ _ tvMap sl (VarT tyName) = + varE $ case Map.lookup tyName tvMap of + Just (TwoNames spExp slExp) -> if sl then slExp else spExp + Nothing -> if sl then showListValName else showsPrecValName +#else +makeShowForType _ _ _ _ VarT{} = varE showsPrecValName +#endif +makeShowForType sClass conName tvMap sl (SigT ty _) = makeShowForType sClass conName tvMap sl ty +makeShowForType sClass conName tvMap sl (ForallT _ _ ty) = makeShowForType sClass conName tvMap sl ty +#if defined(NEW_FUNCTOR_CLASSES) +makeShowForType sClass conName tvMap sl ty = do + let tyCon :: Type + tyArgs :: [Type] + (tyCon, tyArgs) = unapplyTy ty + + numLastArgs :: Int + numLastArgs = min (arity sClass) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + + itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs + if any (`mentionsName` tyVarNames) lhsArgs + || itf && any (`mentionsName` tyVarNames) tyArgs + then outOfPlaceTyVarError sClass conName + else if any (`mentionsName` tyVarNames) rhsArgs + then appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs] + ++ zipWith (makeShowForType sClass conName tvMap) + (cycle [False,True]) + (interleave rhsArgs rhsArgs) + else varE $ if sl then showListValName else showsPrecValName +#else +makeShowForType sClass conName tvMap _ ty = do + let varNames = Map.keys tvMap + + p' <- newName "p'" + value' <- newName "value'" + case varNames of + [] -> varE showsPrecValName + varName:_ -> + if mentionsName ty varNames + then lamE [varP p', varP value'] $ varE showsPrec1ValName + `appE` varE p' + `appE` (makeFmapApplyNeg sClass conName ty varName `appE` varE value') + else varE showsPrecValName +#endif + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which @Show@ variant is being derived. +data ShowClass = Show + | Show1 +#if defined(NEW_FUNCTOR_CLASSES) + | Show2 +#endif + deriving (Bounded, Enum) + +instance ClassRep ShowClass where + arity = fromEnum + + allowExQuant _ = True + + fullClassName Show = showTypeName + fullClassName Show1 = show1TypeName +#if defined(NEW_FUNCTOR_CLASSES) + fullClassName Show2 = show2TypeName +#endif + + classConstraint sClass i + | sMin <= i && i <= sMax = Just $ fullClassName (toEnum i :: ShowClass) + | otherwise = Nothing + where + sMin, sMax :: Int + sMin = fromEnum (minBound :: ShowClass) + sMax = fromEnum sClass + +showsPrecConstName :: ShowClass -> Name +showsPrecConstName Show = showsPrecConstValName +#if defined(NEW_FUNCTOR_CLASSES) +showsPrecConstName Show1 = liftShowsPrecConstValName +showsPrecConstName Show2 = liftShowsPrec2ConstValName +#else +showsPrecConstName Show1 = showsPrec1ConstValName +#endif + +showsPrecName :: ShowClass -> Name +showsPrecName Show = showsPrecValName +#if defined(NEW_FUNCTOR_CLASSES) +showsPrecName Show1 = liftShowsPrecValName +showsPrecName Show2 = liftShowsPrec2ValName +#else +showsPrecName Show1 = showsPrec1ValName +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +showListName :: ShowClass -> Name +showListName Show = showListValName +showListName Show1 = liftShowListValName +showListName Show2 = liftShowList2ValName + +showsPrecOrListName :: Bool -- ^ showListName if True, showsPrecName if False + -> ShowClass + -> Name +showsPrecOrListName False = showsPrecName +showsPrecOrListName True = showListName +#endif + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +-- | Parenthesize an infix constructor name if it is being applied as a prefix +-- function (e.g., data Amp a = (:&) a a) +parenInfixConName :: Name -> ShowS +parenInfixConName conName = + let conNameBase = nameBase conName + in showParen (isInfixDataCon conNameBase) $ showString conNameBase + +charE :: Char -> Q Exp +charE = litE . charL + +data PrimShow = PrimShow + { primShowBoxer :: Q Exp -> Q Exp + , primShowPostfixMod :: Q Exp + , primShowConv :: Q Exp -> Q Exp + } + +primShowTbl :: Map Name PrimShow +primShowTbl = Map.fromList + [ (charHashTypeName, PrimShow + { primShowBoxer = appE (conE cHashDataName) + , primShowPostfixMod = oneHashE + , primShowConv = id + }) + , (doubleHashTypeName, PrimShow + { primShowBoxer = appE (conE dHashDataName) + , primShowPostfixMod = twoHashE + , primShowConv = id + }) + , (floatHashTypeName, PrimShow + { primShowBoxer = appE (conE fHashDataName) + , primShowPostfixMod = oneHashE + , primShowConv = id + }) + , (intHashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) + , primShowPostfixMod = oneHashE + , primShowConv = id + }) + , (wordHashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) + , primShowPostfixMod = twoHashE + , primShowConv = id + }) +#if MIN_VERSION_base(4,13,0) + , (int8HashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) . appE (varE int8ToIntHashValName) + , primShowPostfixMod = oneHashE + , primShowConv = mkNarrowE intToInt8HashValName + }) + , (int16HashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) . appE (varE int16ToIntHashValName) + , primShowPostfixMod = oneHashE + , primShowConv = mkNarrowE intToInt16HashValName + }) + , (word8HashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) . appE (varE word8ToWordHashValName) + , primShowPostfixMod = twoHashE + , primShowConv = mkNarrowE wordToWord8HashValName + }) + , (word16HashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) . appE (varE word16ToWordHashValName) + , primShowPostfixMod = twoHashE + , primShowConv = mkNarrowE wordToWord16HashValName + }) +#endif +#if MIN_VERSION_base(4,16,0) + , (int32HashTypeName, PrimShow + { primShowBoxer = appE (conE iHashDataName) . appE (varE int32ToIntHashValName) + , primShowPostfixMod = oneHashE + , primShowConv = mkNarrowE intToInt32HashValName + }) + , (word32HashTypeName, PrimShow + { primShowBoxer = appE (conE wHashDataName) . appE (varE word32ToWordHashValName) + , primShowPostfixMod = twoHashE + , primShowConv = mkNarrowE wordToWord32HashValName + }) +#endif + ] + +#if MIN_VERSION_base(4,13,0) +mkNarrowE :: Name -> Q Exp -> Q Exp +mkNarrowE narrowName e = + foldr (`infixApp` varE composeValName) + (varE showCharValName `appE` charE ')') + [ varE showStringValName `appE` stringE ('(':nameBase narrowName ++ " ") + , e + ] +#endif + +oneHashE, twoHashE :: Q Exp +oneHashE = varE showCharValName `appE` charE '#' +twoHashE = varE showStringValName `appE` stringE "##" diff --git a/tests/BoundedEnumIxSpec.hs b/tests/BoundedEnumIxSpec.hs --- a/tests/BoundedEnumIxSpec.hs +++ b/tests/BoundedEnumIxSpec.hs @@ -1,275 +1,275 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 -{-# LANGUAGE TypeInType #-} -#endif - -{-| -Module: BoundedEnumSpec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for derived 'Bounded', 'Enum', and 'Ix' instances. --} -module BoundedEnumIxSpec where - -import Data.Deriving -#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 -import Data.Kind -#endif - -import GHC.Arr (Ix(..)) - -import Prelude () -import Prelude.Compat - -import Test.Hspec - -------------------------------------------------------------------------------- - --- Plain data types - -data TyConEnum = TyConEnum1 | TyConEnum2 | TyConEnum3 - deriving (Eq, Ord, Show) - -data TyConProduct a b c = TyConProduct a b c - deriving (Eq, Ord, Show) - -data TyConUnit -#if __GLASGOW_HASKELL__ >= 706 - (f :: k -> *) (a :: k) -#else - (f :: * -> *) (a :: *) -#endif - = TyConUnit - deriving (Eq, Ord, Show) - -data TyConExQuant a = Show a => TyConExQuant -deriving instance Eq (TyConExQuant a) -deriving instance Ord (TyConExQuant a) -deriving instance Show (TyConExQuant a) - -data TyConGADT a where - TyConGADT :: Show a => a -> TyConGADT a -deriving instance Eq a => Eq (TyConGADT a) -deriving instance Ord a => Ord (TyConGADT a) -deriving instance Show a => Show (TyConGADT a) - --- Data families - -data family TyFamilyEnum :: * -data instance TyFamilyEnum = TyFamilyEnum1 | TyFamilyEnum2 | TyFamilyEnum3 - deriving (Eq, Ord, Show) - -data family TyFamilyProduct x y z :: * -data instance TyFamilyProduct a b c = TyFamilyProduct a b c - deriving (Eq, Ord, Show) - -data family TyFamilyUnit -#if __GLASGOW_HASKELL__ >= 706 - (f :: k -> *) (a :: k) -#else - (f :: * -> *) (a :: *) -#endif - :: * -data instance TyFamilyUnit f a = TyFamilyUnit - deriving (Eq, Ord, Show) - -data family TyFamilyExQuant x :: * -data instance TyFamilyExQuant a = Show a => TyFamilyExQuant -deriving instance Eq (TyFamilyExQuant a) -deriving instance Ord (TyFamilyExQuant a) -deriving instance Show (TyFamilyExQuant a) - -data family TyFamilyGADT x :: * -data instance TyFamilyGADT a where - TyFamilyGADT :: Show a => a -> TyFamilyGADT a -deriving instance Eq a => Eq (TyFamilyGADT a) -deriving instance Ord a => Ord (TyFamilyGADT a) -deriving instance Show a => Show (TyFamilyGADT a) - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveBounded ''TyConEnum) -$(deriveBounded ''TyConProduct) -instance Bounded (TyConUnit f a) where - minBound = $(makeMinBound ''TyConUnit) - maxBound = $(makeMaxBound ''TyConUnit) -instance Show a => Bounded (TyConExQuant a) where - minBound = $(makeMinBound ''TyConExQuant) - maxBound = $(makeMaxBound ''TyConExQuant) -instance (Bounded a, Show a) => Bounded (TyConGADT a) where - minBound = $(makeMinBound ''TyConGADT) - maxBound = $(makeMaxBound ''TyConGADT) - -$(deriveEnum ''TyConEnum) -instance Enum (TyConUnit f a) where - toEnum = $(makeToEnum ''TyConUnit) - fromEnum = $(makeFromEnum ''TyConUnit) - -$(deriveIx ''TyConEnum) -$(deriveIx ''TyConProduct) -instance Ix (TyConUnit f a) where - range = $(makeRange ''TyConUnit) - unsafeIndex = $(makeUnsafeIndex ''TyConUnit) - inRange = $(makeInRange ''TyConUnit) -instance Ix (TyConExQuant a) where - range = $(makeRange ''TyConExQuant) - unsafeIndex = $(makeUnsafeIndex ''TyConExQuant) - inRange = $(makeInRange ''TyConExQuant) -instance Ix a => Ix (TyConGADT a) where - range = $(makeRange ''TyConGADT) - unsafeIndex = $(makeUnsafeIndex ''TyConGADT) - inRange = $(makeInRange ''TyConGADT) - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveBounded 'TyFamilyEnum1) -$(deriveBounded 'TyFamilyProduct) -instance Bounded (TyFamilyUnit f a) where - minBound = $(makeMinBound 'TyFamilyUnit) - maxBound = $(makeMaxBound 'TyFamilyUnit) -instance Show a => Bounded (TyFamilyExQuant a) where - minBound = $(makeMinBound 'TyFamilyExQuant) - maxBound = $(makeMaxBound 'TyFamilyExQuant) -instance (Bounded a, Show a) => Bounded (TyFamilyGADT a) where - minBound = $(makeMinBound 'TyFamilyGADT) - maxBound = $(makeMaxBound 'TyFamilyGADT) - -$(deriveEnum 'TyFamilyEnum1) -instance Enum (TyFamilyUnit f a) where - toEnum = $(makeToEnum 'TyFamilyUnit) - fromEnum = $(makeFromEnum 'TyFamilyUnit) - -$(deriveIx 'TyFamilyEnum1) -$(deriveIx 'TyFamilyProduct) -instance Ix (TyFamilyUnit f a) where - range = $(makeRange 'TyFamilyUnit) - unsafeIndex = $(makeUnsafeIndex 'TyFamilyUnit) - inRange = $(makeInRange 'TyFamilyUnit) -instance Ix (TyFamilyExQuant a) where - range = $(makeRange 'TyFamilyExQuant) - unsafeIndex = $(makeUnsafeIndex 'TyFamilyExQuant) - inRange = $(makeInRange 'TyFamilyExQuant) -instance Ix a => Ix (TyFamilyGADT a) where - range = $(makeRange 'TyFamilyGADT) - unsafeIndex = $(makeUnsafeIndex 'TyFamilyGADT) - inRange = $(makeInRange 'TyFamilyGADT) -#endif - -------------------------------------------------------------------------------- - --- | Verifies an 'Ix' instance satisfies the laws. -ixLaws :: (Ix a, Show a) => a -> a -> a -> Expectation -ixLaws l u i = do - inRange (l,u) i `shouldBe` elem i (range (l,u)) - range (l,u) !! index (l,u) i `shouldBe` i - map (index (l,u)) (range (l,u)) `shouldBe` [0..rangeSize (l,u)-1] - rangeSize (l,u) `shouldBe` length (range (l,u)) - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ do - describe "TyConEnum" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyConEnum1 - maxBound `shouldBe` TyConEnum3 - - it "has a sensible Enum instance" $ - [minBound .. maxBound] `shouldBe` [TyConEnum1, TyConEnum2, TyConEnum3] - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound TyConEnum2 - describe "TyConProduct Bool Bool Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyConProduct False False False - maxBound `shouldBe` TyConProduct True True True - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound (TyConProduct False False False) - describe "TyConUnit Maybe Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyConUnit - maxBound `shouldBe` TyConUnit - - it "has a sensible Enum instance" $ - [minBound .. maxBound] `shouldBe` [TyConUnit] - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound TyConUnit - describe "TyConExQuant Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) - maxBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound (TyConExQuant :: TyConExQuant Bool) - describe "TyConGADT Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyConGADT False - maxBound `shouldBe` TyConGADT True - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound (TyConGADT False) -#if MIN_VERSION_template_haskell(2,7,0) - describe "TyFamilyEnum" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyFamilyEnum1 - maxBound `shouldBe` TyFamilyEnum3 - - it "has a sensible Enum instance" $ - [minBound .. maxBound] `shouldBe` [TyFamilyEnum1, TyFamilyEnum2, TyFamilyEnum3] - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound TyFamilyEnum2 - describe "TyFamilyProduct Bool Bool Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyFamilyProduct False False False - maxBound `shouldBe` TyFamilyProduct True True True - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound (TyFamilyProduct False False False) - describe "TyFamilyUnit Maybe Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyFamilyUnit - maxBound `shouldBe` TyFamilyUnit - - it "has a sensible Enum instance" $ - [minBound .. maxBound] `shouldBe` [TyFamilyUnit] - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound TyFamilyUnit - describe "TyFamilyExQuant Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) - maxBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound (TyFamilyExQuant :: TyFamilyExQuant Bool) - describe "TyFamilyGADT Bool" $ do - it "has a sensible Bounded instance" $ do - minBound `shouldBe` TyFamilyGADT False - maxBound `shouldBe` TyFamilyGADT True - - it "has a sensible Ix instance" $ - ixLaws minBound maxBound (TyFamilyGADT False) -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +{-| +Module: BoundedEnumSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Bounded', 'Enum', and 'Ix' instances. +-} +module BoundedEnumIxSpec where + +import Data.Deriving +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +import Data.Kind +#endif + +import GHC.Arr (Ix(..)) + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +------------------------------------------------------------------------------- + +-- Plain data types + +data TyConEnum = TyConEnum1 | TyConEnum2 | TyConEnum3 + deriving (Eq, Ord, Show) + +data TyConProduct a b c = TyConProduct a b c + deriving (Eq, Ord, Show) + +data TyConUnit +#if __GLASGOW_HASKELL__ >= 706 + (f :: k -> *) (a :: k) +#else + (f :: * -> *) (a :: *) +#endif + = TyConUnit + deriving (Eq, Ord, Show) + +data TyConExQuant a = Show a => TyConExQuant +deriving instance Eq (TyConExQuant a) +deriving instance Ord (TyConExQuant a) +deriving instance Show (TyConExQuant a) + +data TyConGADT a where + TyConGADT :: Show a => a -> TyConGADT a +deriving instance Eq a => Eq (TyConGADT a) +deriving instance Ord a => Ord (TyConGADT a) +deriving instance Show a => Show (TyConGADT a) + +-- Data families + +data family TyFamilyEnum :: * +data instance TyFamilyEnum = TyFamilyEnum1 | TyFamilyEnum2 | TyFamilyEnum3 + deriving (Eq, Ord, Show) + +data family TyFamilyProduct x y z :: * +data instance TyFamilyProduct a b c = TyFamilyProduct a b c + deriving (Eq, Ord, Show) + +data family TyFamilyUnit +#if __GLASGOW_HASKELL__ >= 706 + (f :: k -> *) (a :: k) +#else + (f :: * -> *) (a :: *) +#endif + :: * +data instance TyFamilyUnit f a = TyFamilyUnit + deriving (Eq, Ord, Show) + +data family TyFamilyExQuant x :: * +data instance TyFamilyExQuant a = Show a => TyFamilyExQuant +deriving instance Eq (TyFamilyExQuant a) +deriving instance Ord (TyFamilyExQuant a) +deriving instance Show (TyFamilyExQuant a) + +data family TyFamilyGADT x :: * +data instance TyFamilyGADT a where + TyFamilyGADT :: Show a => a -> TyFamilyGADT a +deriving instance Eq a => Eq (TyFamilyGADT a) +deriving instance Ord a => Ord (TyFamilyGADT a) +deriving instance Show a => Show (TyFamilyGADT a) + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveBounded ''TyConEnum) +$(deriveBounded ''TyConProduct) +instance Bounded (TyConUnit f a) where + minBound = $(makeMinBound ''TyConUnit) + maxBound = $(makeMaxBound ''TyConUnit) +instance Show a => Bounded (TyConExQuant a) where + minBound = $(makeMinBound ''TyConExQuant) + maxBound = $(makeMaxBound ''TyConExQuant) +instance (Bounded a, Show a) => Bounded (TyConGADT a) where + minBound = $(makeMinBound ''TyConGADT) + maxBound = $(makeMaxBound ''TyConGADT) + +$(deriveEnum ''TyConEnum) +instance Enum (TyConUnit f a) where + toEnum = $(makeToEnum ''TyConUnit) + fromEnum = $(makeFromEnum ''TyConUnit) + +$(deriveIx ''TyConEnum) +$(deriveIx ''TyConProduct) +instance Ix (TyConUnit f a) where + range = $(makeRange ''TyConUnit) + unsafeIndex = $(makeUnsafeIndex ''TyConUnit) + inRange = $(makeInRange ''TyConUnit) +instance Ix (TyConExQuant a) where + range = $(makeRange ''TyConExQuant) + unsafeIndex = $(makeUnsafeIndex ''TyConExQuant) + inRange = $(makeInRange ''TyConExQuant) +instance Ix a => Ix (TyConGADT a) where + range = $(makeRange ''TyConGADT) + unsafeIndex = $(makeUnsafeIndex ''TyConGADT) + inRange = $(makeInRange ''TyConGADT) + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveBounded 'TyFamilyEnum1) +$(deriveBounded 'TyFamilyProduct) +instance Bounded (TyFamilyUnit f a) where + minBound = $(makeMinBound 'TyFamilyUnit) + maxBound = $(makeMaxBound 'TyFamilyUnit) +instance Show a => Bounded (TyFamilyExQuant a) where + minBound = $(makeMinBound 'TyFamilyExQuant) + maxBound = $(makeMaxBound 'TyFamilyExQuant) +instance (Bounded a, Show a) => Bounded (TyFamilyGADT a) where + minBound = $(makeMinBound 'TyFamilyGADT) + maxBound = $(makeMaxBound 'TyFamilyGADT) + +$(deriveEnum 'TyFamilyEnum1) +instance Enum (TyFamilyUnit f a) where + toEnum = $(makeToEnum 'TyFamilyUnit) + fromEnum = $(makeFromEnum 'TyFamilyUnit) + +$(deriveIx 'TyFamilyEnum1) +$(deriveIx 'TyFamilyProduct) +instance Ix (TyFamilyUnit f a) where + range = $(makeRange 'TyFamilyUnit) + unsafeIndex = $(makeUnsafeIndex 'TyFamilyUnit) + inRange = $(makeInRange 'TyFamilyUnit) +instance Ix (TyFamilyExQuant a) where + range = $(makeRange 'TyFamilyExQuant) + unsafeIndex = $(makeUnsafeIndex 'TyFamilyExQuant) + inRange = $(makeInRange 'TyFamilyExQuant) +instance Ix a => Ix (TyFamilyGADT a) where + range = $(makeRange 'TyFamilyGADT) + unsafeIndex = $(makeUnsafeIndex 'TyFamilyGADT) + inRange = $(makeInRange 'TyFamilyGADT) +#endif + +------------------------------------------------------------------------------- + +-- | Verifies an 'Ix' instance satisfies the laws. +ixLaws :: (Ix a, Show a) => a -> a -> a -> Expectation +ixLaws l u i = do + inRange (l,u) i `shouldBe` elem i (range (l,u)) + range (l,u) !! index (l,u) i `shouldBe` i + map (index (l,u)) (range (l,u)) `shouldBe` [0..rangeSize (l,u)-1] + rangeSize (l,u) `shouldBe` length (range (l,u)) + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do + describe "TyConEnum" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyConEnum1 + maxBound `shouldBe` TyConEnum3 + + it "has a sensible Enum instance" $ + [minBound .. maxBound] `shouldBe` [TyConEnum1, TyConEnum2, TyConEnum3] + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound TyConEnum2 + describe "TyConProduct Bool Bool Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyConProduct False False False + maxBound `shouldBe` TyConProduct True True True + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound (TyConProduct False False False) + describe "TyConUnit Maybe Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyConUnit + maxBound `shouldBe` TyConUnit + + it "has a sensible Enum instance" $ + [minBound .. maxBound] `shouldBe` [TyConUnit] + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound TyConUnit + describe "TyConExQuant Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) + maxBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound (TyConExQuant :: TyConExQuant Bool) + describe "TyConGADT Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyConGADT False + maxBound `shouldBe` TyConGADT True + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound (TyConGADT False) +#if MIN_VERSION_template_haskell(2,7,0) + describe "TyFamilyEnum" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyFamilyEnum1 + maxBound `shouldBe` TyFamilyEnum3 + + it "has a sensible Enum instance" $ + [minBound .. maxBound] `shouldBe` [TyFamilyEnum1, TyFamilyEnum2, TyFamilyEnum3] + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound TyFamilyEnum2 + describe "TyFamilyProduct Bool Bool Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyFamilyProduct False False False + maxBound `shouldBe` TyFamilyProduct True True True + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound (TyFamilyProduct False False False) + describe "TyFamilyUnit Maybe Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyFamilyUnit + maxBound `shouldBe` TyFamilyUnit + + it "has a sensible Enum instance" $ + [minBound .. maxBound] `shouldBe` [TyFamilyUnit] + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound TyFamilyUnit + describe "TyFamilyExQuant Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) + maxBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound (TyFamilyExQuant :: TyFamilyExQuant Bool) + describe "TyFamilyGADT Bool" $ do + it "has a sensible Bounded instance" $ do + minBound `shouldBe` TyFamilyGADT False + maxBound `shouldBe` TyFamilyGADT True + + it "has a sensible Ix instance" $ + ixLaws minBound maxBound (TyFamilyGADT False) +#endif diff --git a/tests/DerivingViaSpec.hs b/tests/DerivingViaSpec.hs --- a/tests/DerivingViaSpec.hs +++ b/tests/DerivingViaSpec.hs @@ -1,84 +1,84 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#if MIN_VERSION_template_haskell(2,12,0) -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TypeApplications #-} -#endif - -{-| -Module: DerivingViaSpec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for 'deriveGND' and 'deriveVia'. --} -module DerivingViaSpec where - -import Prelude () -import Prelude.Compat - -import Test.Hspec - -#if MIN_VERSION_template_haskell(2,12,0) -import Data.Deriving.Via - -class Container (f :: * -> *) where - type Inside f a - peekInside :: f a -> Inside f a - -instance Container (Either a) where - type Inside (Either a) b = Maybe b - peekInside (Left{}) = Nothing - peekInside (Right x) = Just x - -newtype Down a = MkDown a deriving Show -$(deriveGND [t| forall a. Eq a => Eq (Down a) |]) - -instance Ord a => Ord (Down a) where - compare (MkDown x) (MkDown y) = y `compare` x - -newtype Id a = MkId a deriving Show -$(deriveGND [t| forall a. Eq a => Eq (Id a) |]) -$(deriveVia [t| forall a. Ord a => Ord (Id a) `Via` Down a |]) - -instance Container Id where - type Inside Id a = a - peekInside (MkId x) = x - -newtype MyEither a b = MkMyEither (Either a b) deriving Show -$(deriveGND [t| forall a. Functor (MyEither a) |]) -$(deriveVia [t| forall a b. (Eq a, Eq b) => Eq (MyEither a b) `Via` Id (Either a b) |]) -$(deriveVia [t| forall a. Applicative (MyEither a) `Via` (Either a) |]) -$(deriveVia [t| forall a. Container (MyEither a) `Via` (Either a) |]) - -newtype Wrap f a = MkWrap (f a) deriving Show -$(deriveGND [t| forall f. Container f => Container (Wrap f) |]) - -class MFunctor (t :: (* -> *) -> * -> *) where - hoist :: (forall a. m a -> n a) -> t m b -> t n b - -newtype TaggedTrans tag trans (m :: * -> *) a = MkTaggedTrans (trans m a) deriving Show -$(deriveGND [t| forall tag trans. MFunctor trans => MFunctor (TaggedTrans tag trans) |]) -#endif - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ do -#if MIN_VERSION_template_haskell(2,12,0) - describe "Id" $ - it "should compare items in reverse order" $ - compare (MkId "hello") (MkId "world") `shouldBe` GT -#endif - pure () +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeApplications #-} +#endif + +{-| +Module: DerivingViaSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for 'deriveGND' and 'deriveVia'. +-} +module DerivingViaSpec where + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +#if MIN_VERSION_template_haskell(2,12,0) +import Data.Deriving.Via + +class Container (f :: * -> *) where + type Inside f a + peekInside :: f a -> Inside f a + +instance Container (Either a) where + type Inside (Either a) b = Maybe b + peekInside (Left{}) = Nothing + peekInside (Right x) = Just x + +newtype Down a = MkDown a deriving Show +$(deriveGND [t| forall a. Eq a => Eq (Down a) |]) + +instance Ord a => Ord (Down a) where + compare (MkDown x) (MkDown y) = y `compare` x + +newtype Id a = MkId a deriving Show +$(deriveGND [t| forall a. Eq a => Eq (Id a) |]) +$(deriveVia [t| forall a. Ord a => Ord (Id a) `Via` Down a |]) + +instance Container Id where + type Inside Id a = a + peekInside (MkId x) = x + +newtype MyEither a b = MkMyEither (Either a b) deriving Show +$(deriveGND [t| forall a. Functor (MyEither a) |]) +$(deriveVia [t| forall a b. (Eq a, Eq b) => Eq (MyEither a b) `Via` Id (Either a b) |]) +$(deriveVia [t| forall a. Applicative (MyEither a) `Via` (Either a) |]) +$(deriveVia [t| forall a. Container (MyEither a) `Via` (Either a) |]) + +newtype Wrap f a = MkWrap (f a) deriving Show +$(deriveGND [t| forall f. Container f => Container (Wrap f) |]) + +class MFunctor (t :: (* -> *) -> * -> *) where + hoist :: (forall a. m a -> n a) -> t m b -> t n b + +newtype TaggedTrans tag trans (m :: * -> *) a = MkTaggedTrans (trans m a) deriving Show +$(deriveGND [t| forall tag trans. MFunctor trans => MFunctor (TaggedTrans tag trans) |]) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do +#if MIN_VERSION_template_haskell(2,12,0) + describe "Id" $ + it "should compare items in reverse order" $ + compare (MkId "hello") (MkId "world") `shouldBe` GT +#endif + pure () diff --git a/tests/EqSpec.hs b/tests/EqSpec.hs --- a/tests/EqSpec.hs +++ b/tests/EqSpec.hs @@ -1,25 +1,25 @@ -{-| -Module: EqSpec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for derived 'Eq', 'Eq1', and 'Eq2' instances. --} -module EqSpec where - -import Prelude () -import Prelude.Compat - -import Test.Hspec - -import Types.EqOrd () - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = pure () +{-| +Module: EqSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Eq', 'Eq1', and 'Eq2' instances. +-} +module EqSpec where + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +import Types.EqOrd () + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure () diff --git a/tests/FunctorSpec.hs b/tests/FunctorSpec.hs --- a/tests/FunctorSpec.hs +++ b/tests/FunctorSpec.hs @@ -1,390 +1,390 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE RoleAnnotations #-} -#endif - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -Wno-unused-foralls #-} -#endif - -{-| -Module: FunctorSpec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for derived 'Functor', 'Foldable', and 'Traversable' instances. --} -module FunctorSpec where - -import Data.Char (chr) -import Data.Foldable (fold) -import Data.Deriving -import Data.Functor.Classes (Eq1, Show1) -import Data.Functor.Compose (Compose(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Monoid -import Data.Orphans () - -import GHC.Exts (Int#) - -import Prelude () -import Prelude.Compat - -import Test.Hspec -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Arbitrary) - -------------------------------------------------------------------------------- - --- Adapted from the test cases from --- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch - --- Plain data types - -data Strange a b c - = T1 a b c - | T2 [a] [b] [c] -- lists - | T3 [[a]] [[b]] [[c]] -- nested lists - | T4 (c,(b,b),(c,c)) -- tuples - | T5 ([c],Strange a b c) -- tycons - -type IntFun a b = (b -> Int) -> a -data StrangeFunctions a b c - = T6 (a -> c) -- function types - | T7 (a -> (c,a)) -- functions and tuples - | T8 ((b -> a) -> c) -- continuation - | T9 (IntFun b c) -- type synonyms - -data StrangeGADT a b where - T10 :: Ord d => d -> StrangeGADT c d - T11 :: Int -> StrangeGADT e Int - T12 :: c ~ Int => c -> StrangeGADT f Int - T13 :: i ~ Int => Int -> StrangeGADT h i - T14 :: k ~ Int => k -> StrangeGADT j k - T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n - -data NotPrimitivelyRecursive a b - = S1 (NotPrimitivelyRecursive (a,a) (b, a)) - | S2 a - | S3 b - -newtype OneTwoCompose f g a b = OneTwoCompose (Either (f (g a)) (f (g b))) - deriving (Arbitrary, Eq, Show) - -newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) - -data Universal a b - = Universal (forall b. (b,[a])) - | Universal2 (forall f. Functor (f a) => f a b) - | Universal3 (forall a. Maybe a) -- reuse a - | NotReallyUniversal (forall b. a) - -data Existential a b - = forall a. ExistentialList [a] - | forall f. Traversable (f a) => ExistentialFunctor (f a b) - | forall b. SneakyUseSameName (Maybe b) - -data IntHash a b - = IntHash Int# Int# - | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) - -data IntHashFun a b - = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) - -data Empty1 a -data Empty2 a -#if __GLASGOW_HASKELL__ >= 708 -type role Empty2 nominal -#endif - -data TyCon29 a - = TyCon29a (forall b. b -> (forall c. a -> c) -> a) - | TyCon29b (Int -> forall c. c -> a) - -type family F :: * -> * -type instance F = Maybe - -data TyCon30 a = TyCon30 (F a) - --- Data families - -data family StrangeFam x y z -data instance StrangeFam a b c - = T1Fam a b c - | T2Fam [a] [b] [c] -- lists - | T3Fam [[a]] [[b]] [[c]] -- nested lists - | T4Fam (c,(b,b),(c,c)) -- tuples - | T5Fam ([c],Strange a b c) -- tycons - -data family StrangeFunctionsFam x y z -data instance StrangeFunctionsFam a b c - = T6Fam (a -> c) -- function types - | T7Fam (a -> (c,a)) -- functions and tuples - | T8Fam ((b -> a) -> c) -- continuation - | T9Fam (IntFun b c) -- type synonyms - -data family StrangeGADTFam x y -data instance StrangeGADTFam a b where - T10Fam :: Ord d => d -> StrangeGADTFam c d - T11Fam :: Int -> StrangeGADTFam e Int - T12Fam :: c ~ Int => c -> StrangeGADTFam f Int - T13Fam :: i ~ Int => Int -> StrangeGADTFam h i - T14Fam :: k ~ Int => k -> StrangeGADTFam j k - T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n - -data family NotPrimitivelyRecursiveFam x y -data instance NotPrimitivelyRecursiveFam a b - = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) - | S2Fam a - | S3Fam b - -data family OneTwoComposeFam (j :: * -> *) (k :: * -> *) x y -newtype instance OneTwoComposeFam f g a b = - OneTwoComposeFam (Either (f (g a)) (f (g b))) - deriving (Arbitrary, Eq, Show) - -data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y -newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) - -data family UniversalFam x y -data instance UniversalFam a b - = UniversalFam (forall b. (b,[a])) - | Universal2Fam (forall f. Functor (f a) => f a b) - | Universal3Fam (forall a. Maybe a) -- reuse a - | NotReallyUniversalFam (forall b. a) - -data family ExistentialFam x y -data instance ExistentialFam a b - = forall a. ExistentialListFam [a] - | forall f. Traversable (f a) => ExistentialFunctorFam (f a b) - | forall b. SneakyUseSameNameFam (Maybe b) - -data family IntHashFam x y -data instance IntHashFam a b - = IntHashFam Int# Int# - | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) - -data family IntHashFunFam x y -data instance IntHashFunFam a b - = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) - -data family TyFamily29 x -data instance TyFamily29 a - = TyFamily29a (forall b. b -> (forall c. a -> c) -> a) - | TyFamily29b (Int -> forall c. c -> a) - -data family TyFamily30 x -data instance TyFamily30 a = TyFamily30 (F a) - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveFunctor ''Strange) -$(deriveFoldable ''Strange) -$(deriveTraversable ''Strange) - -$(deriveFunctor ''StrangeFunctions) -$(deriveFoldable ''StrangeGADT) - -$(deriveFunctor ''NotPrimitivelyRecursive) -$(deriveFoldable ''NotPrimitivelyRecursive) -$(deriveTraversable ''NotPrimitivelyRecursive) - -$(deriveFunctor ''OneTwoCompose) -$(deriveFoldable ''OneTwoCompose) -$(deriveTraversable ''OneTwoCompose) - -instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where - fmap = $(makeFmap ''ComplexConstraint) - (<$) = $(makeReplace ''ComplexConstraint) -instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where - foldr = $(makeFoldr ''ComplexConstraint) - foldMap = $(makeFoldMap ''ComplexConstraint) - fold = $(makeFold ''ComplexConstraint) - foldl = $(makeFoldl ''ComplexConstraint) -#if MIN_VERSION_base(4,8,0) - null = $(makeNull ''ComplexConstraint) -#endif -instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where - traverse = $(makeTraverse ''ComplexConstraint) - sequenceA = $(makeSequenceA ''ComplexConstraint) - mapM = $(makeMapM ''ComplexConstraint) - sequence = $(makeSequence ''ComplexConstraint) - -$(deriveFunctor ''Universal) - -$(deriveFunctor ''Existential) -$(deriveFoldable ''Existential) -$(deriveTraversable ''Existential) - -$(deriveFunctor ''IntHash) -$(deriveFoldable ''IntHash) -$(deriveTraversable ''IntHash) - -$(deriveFunctor ''IntHashFun) - -$(deriveFunctor ''Empty1) -$(deriveFoldable ''Empty1) -$(deriveTraversable ''Empty1) - --- Use EmptyCase here -$(deriveFunctorOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) -$(deriveFoldableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) -$(deriveTraversableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) - -$(deriveFunctor ''TyCon29) - -$(deriveFunctor ''TyCon30) -$(deriveFoldable ''TyCon30) -$(deriveTraversable ''TyCon30) - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveFunctor 'T1Fam) -$(deriveFoldable 'T2Fam) -$(deriveTraversable 'T3Fam) - -$(deriveFunctor 'T6Fam) -$(deriveFoldable 'T10Fam) - -$(deriveFunctor 'S1Fam) -$(deriveFoldable 'S2Fam) -$(deriveTraversable 'S3Fam) - -$(deriveFunctor 'OneTwoComposeFam) -$(deriveFoldable 'OneTwoComposeFam) -$(deriveTraversable 'OneTwoComposeFam) - -instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where - fmap = $(makeFmap 'ComplexConstraintFam) - (<$) = $(makeReplace 'ComplexConstraintFam) -instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where - foldr = $(makeFoldr 'ComplexConstraintFam) - foldMap = $(makeFoldMap 'ComplexConstraintFam) - fold = $(makeFold 'ComplexConstraintFam) - foldl = $(makeFoldl 'ComplexConstraintFam) -# if MIN_VERSION_base(4,8,0) - null = $(makeNull 'ComplexConstraintFam) -# endif -instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where - traverse = $(makeTraverse 'ComplexConstraintFam) - sequenceA = $(makeSequenceA 'ComplexConstraintFam) - mapM = $(makeMapM 'ComplexConstraintFam) - sequence = $(makeSequence 'ComplexConstraintFam) - -$(deriveFunctor 'UniversalFam) - -$(deriveFunctor 'ExistentialListFam) -$(deriveFoldable 'ExistentialFunctorFam) -$(deriveTraversable 'SneakyUseSameNameFam) - -$(deriveFunctor 'IntHashFam) -$(deriveFoldable 'IntHashTupleFam) -$(deriveTraversable 'IntHashFam) - -$(deriveFunctor 'IntHashFunFam) - -$(deriveFunctor 'TyFamily29a) - -$(deriveFunctor 'TyFamily30) -$(deriveFoldable 'TyFamily30) -$(deriveTraversable 'TyFamily30) -#endif - -------------------------------------------------------------------------------- - -prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c), Show (f a), Show (f c)) - => (b -> c) -> (a -> b) -> f a -> Expectation -prop_FunctorLaws f g x = do - fmap id x `shouldBe` x - fmap (f . g) x `shouldBe` (fmap f . fmap g) x - -prop_FunctorEx :: (Functor f, Eq (f [Int]), Show (f [Int])) => f [Int] -> Expectation -prop_FunctorEx = prop_FunctorLaws reverse (++ [42]) - -prop_FoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z, - Monoid a, Monoid b, Foldable f) - => (a -> b) -> (a -> z -> z) -> z -> f a -> Expectation -prop_FoldableLaws f h z x = do - fold x `shouldBe` foldMap id x - foldMap f x `shouldBe` foldr (mappend . f) mempty x - foldr h z x `shouldBe` appEndo (foldMap (Endo . h) x) z - -prop_FoldableEx :: Foldable f => f [Int] -> Expectation -prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0 - -prop_TraversableLaws :: forall t f g a b c. - (Applicative f, Applicative g, Traversable t, - Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), - Eq (t a), Eq (t c), Eq1 f, Eq1 g, - Show (t (f a)), Show (g (t a)), Show (g (t b)), - Show (t a), Show (t c), Show1 f, Show1 g) - => (a -> f b) -> (b -> f c) - -> (forall x. f x -> g x) -> t a -> Expectation -prop_TraversableLaws f g t x = do - (t . traverse f) x `shouldBe` traverse (t . f) x - traverse Identity x `shouldBe` Identity x - traverse (Compose . fmap g . f) x - `shouldBe` (Compose . fmap (traverse g) . traverse f) x - - (t . sequenceA) y `shouldBe` (sequenceA . fmap t) y - (sequenceA . fmap Identity) y `shouldBe` Identity y - (sequenceA . fmap Compose) z - `shouldBe` (Compose . fmap sequenceA . sequenceA) z - where - y :: t (f a) - y = fmap pure x - - z :: t (f (g a)) - z = fmap (fmap pure) y - -prop_TraversableEx :: (Traversable t, - Eq (t [[Int]]), Eq (t [Int]), Eq (t String), Eq (t Char), - Show (t [[Int]]), Show (t [Int]), Show (t String), Show (t Char)) - => t [Int] -> Expectation -prop_TraversableEx = prop_TraversableLaws - (replicate 2 . map (chr . abs)) - (++ "Hello") - reverse - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ do - describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do - prop "satisfies the Functor laws" - (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) - prop "satisfies the Foldable laws" - (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) - prop "satisfies the Traversable laws" - (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) -#if MIN_VERSION_template_haskell(2,7,0) - describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do - prop "satisfies the Functor laws" - (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) - prop "satisfies the Foldable laws" - (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) - prop "satisfies the Traversable laws" - (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE RoleAnnotations #-} +#endif + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-unused-foralls #-} +#endif + +{-| +Module: FunctorSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Functor', 'Foldable', and 'Traversable' instances. +-} +module FunctorSpec where + +import Data.Char (chr) +import Data.Foldable (fold) +import Data.Deriving +import Data.Functor.Classes (Eq1, Show1) +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid +import Data.Orphans () + +import GHC.Exts (Int#) + +import Prelude () +import Prelude.Compat + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary) + +------------------------------------------------------------------------------- + +-- Adapted from the test cases from +-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch + +-- Plain data types + +data Strange a b c + = T1 a b c + | T2 [a] [b] [c] -- lists + | T3 [[a]] [[b]] [[c]] -- nested lists + | T4 (c,(b,b),(c,c)) -- tuples + | T5 ([c],Strange a b c) -- tycons + +type IntFun a b = (b -> Int) -> a +data StrangeFunctions a b c + = T6 (a -> c) -- function types + | T7 (a -> (c,a)) -- functions and tuples + | T8 ((b -> a) -> c) -- continuation + | T9 (IntFun b c) -- type synonyms + +data StrangeGADT a b where + T10 :: Ord d => d -> StrangeGADT c d + T11 :: Int -> StrangeGADT e Int + T12 :: c ~ Int => c -> StrangeGADT f Int + T13 :: i ~ Int => Int -> StrangeGADT h i + T14 :: k ~ Int => k -> StrangeGADT j k + T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n + +data NotPrimitivelyRecursive a b + = S1 (NotPrimitivelyRecursive (a,a) (b, a)) + | S2 a + | S3 b + +newtype OneTwoCompose f g a b = OneTwoCompose (Either (f (g a)) (f (g b))) + deriving (Arbitrary, Eq, Show) + +newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) + +data Universal a b + = Universal (forall b. (b,[a])) + | Universal2 (forall f. Functor (f a) => f a b) + | Universal3 (forall a. Maybe a) -- reuse a + | NotReallyUniversal (forall b. a) + +data Existential a b + = forall a. ExistentialList [a] + | forall f. Traversable (f a) => ExistentialFunctor (f a b) + | forall b. SneakyUseSameName (Maybe b) + +data IntHash a b + = IntHash Int# Int# + | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) + +data IntHashFun a b + = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) + +data Empty1 a +data Empty2 a +#if __GLASGOW_HASKELL__ >= 708 +type role Empty2 nominal +#endif + +data TyCon29 a + = TyCon29a (forall b. b -> (forall c. a -> c) -> a) + | TyCon29b (Int -> forall c. c -> a) + +type family F :: * -> * +type instance F = Maybe + +data TyCon30 a = TyCon30 (F a) + +-- Data families + +data family StrangeFam x y z +data instance StrangeFam a b c + = T1Fam a b c + | T2Fam [a] [b] [c] -- lists + | T3Fam [[a]] [[b]] [[c]] -- nested lists + | T4Fam (c,(b,b),(c,c)) -- tuples + | T5Fam ([c],Strange a b c) -- tycons + +data family StrangeFunctionsFam x y z +data instance StrangeFunctionsFam a b c + = T6Fam (a -> c) -- function types + | T7Fam (a -> (c,a)) -- functions and tuples + | T8Fam ((b -> a) -> c) -- continuation + | T9Fam (IntFun b c) -- type synonyms + +data family StrangeGADTFam x y +data instance StrangeGADTFam a b where + T10Fam :: Ord d => d -> StrangeGADTFam c d + T11Fam :: Int -> StrangeGADTFam e Int + T12Fam :: c ~ Int => c -> StrangeGADTFam f Int + T13Fam :: i ~ Int => Int -> StrangeGADTFam h i + T14Fam :: k ~ Int => k -> StrangeGADTFam j k + T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n + +data family NotPrimitivelyRecursiveFam x y +data instance NotPrimitivelyRecursiveFam a b + = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) + | S2Fam a + | S3Fam b + +data family OneTwoComposeFam (j :: * -> *) (k :: * -> *) x y +newtype instance OneTwoComposeFam f g a b = + OneTwoComposeFam (Either (f (g a)) (f (g b))) + deriving (Arbitrary, Eq, Show) + +data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y +newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) + +data family UniversalFam x y +data instance UniversalFam a b + = UniversalFam (forall b. (b,[a])) + | Universal2Fam (forall f. Functor (f a) => f a b) + | Universal3Fam (forall a. Maybe a) -- reuse a + | NotReallyUniversalFam (forall b. a) + +data family ExistentialFam x y +data instance ExistentialFam a b + = forall a. ExistentialListFam [a] + | forall f. Traversable (f a) => ExistentialFunctorFam (f a b) + | forall b. SneakyUseSameNameFam (Maybe b) + +data family IntHashFam x y +data instance IntHashFam a b + = IntHashFam Int# Int# + | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) + +data family IntHashFunFam x y +data instance IntHashFunFam a b + = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) + +data family TyFamily29 x +data instance TyFamily29 a + = TyFamily29a (forall b. b -> (forall c. a -> c) -> a) + | TyFamily29b (Int -> forall c. c -> a) + +data family TyFamily30 x +data instance TyFamily30 a = TyFamily30 (F a) + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveFunctor ''Strange) +$(deriveFoldable ''Strange) +$(deriveTraversable ''Strange) + +$(deriveFunctor ''StrangeFunctions) +$(deriveFoldable ''StrangeGADT) + +$(deriveFunctor ''NotPrimitivelyRecursive) +$(deriveFoldable ''NotPrimitivelyRecursive) +$(deriveTraversable ''NotPrimitivelyRecursive) + +$(deriveFunctor ''OneTwoCompose) +$(deriveFoldable ''OneTwoCompose) +$(deriveTraversable ''OneTwoCompose) + +instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where + fmap = $(makeFmap ''ComplexConstraint) + (<$) = $(makeReplace ''ComplexConstraint) +instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where + foldr = $(makeFoldr ''ComplexConstraint) + foldMap = $(makeFoldMap ''ComplexConstraint) + fold = $(makeFold ''ComplexConstraint) + foldl = $(makeFoldl ''ComplexConstraint) +#if MIN_VERSION_base(4,8,0) + null = $(makeNull ''ComplexConstraint) +#endif +instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where + traverse = $(makeTraverse ''ComplexConstraint) + sequenceA = $(makeSequenceA ''ComplexConstraint) + mapM = $(makeMapM ''ComplexConstraint) + sequence = $(makeSequence ''ComplexConstraint) + +$(deriveFunctor ''Universal) + +$(deriveFunctor ''Existential) +$(deriveFoldable ''Existential) +$(deriveTraversable ''Existential) + +$(deriveFunctor ''IntHash) +$(deriveFoldable ''IntHash) +$(deriveTraversable ''IntHash) + +$(deriveFunctor ''IntHashFun) + +$(deriveFunctor ''Empty1) +$(deriveFoldable ''Empty1) +$(deriveTraversable ''Empty1) + +-- Use EmptyCase here +$(deriveFunctorOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) +$(deriveFoldableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) +$(deriveTraversableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) + +$(deriveFunctor ''TyCon29) + +$(deriveFunctor ''TyCon30) +$(deriveFoldable ''TyCon30) +$(deriveTraversable ''TyCon30) + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveFunctor 'T1Fam) +$(deriveFoldable 'T2Fam) +$(deriveTraversable 'T3Fam) + +$(deriveFunctor 'T6Fam) +$(deriveFoldable 'T10Fam) + +$(deriveFunctor 'S1Fam) +$(deriveFoldable 'S2Fam) +$(deriveTraversable 'S3Fam) + +$(deriveFunctor 'OneTwoComposeFam) +$(deriveFoldable 'OneTwoComposeFam) +$(deriveTraversable 'OneTwoComposeFam) + +instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where + fmap = $(makeFmap 'ComplexConstraintFam) + (<$) = $(makeReplace 'ComplexConstraintFam) +instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where + foldr = $(makeFoldr 'ComplexConstraintFam) + foldMap = $(makeFoldMap 'ComplexConstraintFam) + fold = $(makeFold 'ComplexConstraintFam) + foldl = $(makeFoldl 'ComplexConstraintFam) +# if MIN_VERSION_base(4,8,0) + null = $(makeNull 'ComplexConstraintFam) +# endif +instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where + traverse = $(makeTraverse 'ComplexConstraintFam) + sequenceA = $(makeSequenceA 'ComplexConstraintFam) + mapM = $(makeMapM 'ComplexConstraintFam) + sequence = $(makeSequence 'ComplexConstraintFam) + +$(deriveFunctor 'UniversalFam) + +$(deriveFunctor 'ExistentialListFam) +$(deriveFoldable 'ExistentialFunctorFam) +$(deriveTraversable 'SneakyUseSameNameFam) + +$(deriveFunctor 'IntHashFam) +$(deriveFoldable 'IntHashTupleFam) +$(deriveTraversable 'IntHashFam) + +$(deriveFunctor 'IntHashFunFam) + +$(deriveFunctor 'TyFamily29a) + +$(deriveFunctor 'TyFamily30) +$(deriveFoldable 'TyFamily30) +$(deriveTraversable 'TyFamily30) +#endif + +------------------------------------------------------------------------------- + +prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c), Show (f a), Show (f c)) + => (b -> c) -> (a -> b) -> f a -> Expectation +prop_FunctorLaws f g x = do + fmap id x `shouldBe` x + fmap (f . g) x `shouldBe` (fmap f . fmap g) x + +prop_FunctorEx :: (Functor f, Eq (f [Int]), Show (f [Int])) => f [Int] -> Expectation +prop_FunctorEx = prop_FunctorLaws reverse (++ [42]) + +prop_FoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z, + Monoid a, Monoid b, Foldable f) + => (a -> b) -> (a -> z -> z) -> z -> f a -> Expectation +prop_FoldableLaws f h z x = do + fold x `shouldBe` foldMap id x + foldMap f x `shouldBe` foldr (mappend . f) mempty x + foldr h z x `shouldBe` appEndo (foldMap (Endo . h) x) z + +prop_FoldableEx :: Foldable f => f [Int] -> Expectation +prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0 + +prop_TraversableLaws :: forall t f g a b c. + (Applicative f, Applicative g, Traversable t, + Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), + Eq (t a), Eq (t c), Eq1 f, Eq1 g, + Show (t (f a)), Show (g (t a)), Show (g (t b)), + Show (t a), Show (t c), Show1 f, Show1 g) + => (a -> f b) -> (b -> f c) + -> (forall x. f x -> g x) -> t a -> Expectation +prop_TraversableLaws f g t x = do + (t . traverse f) x `shouldBe` traverse (t . f) x + traverse Identity x `shouldBe` Identity x + traverse (Compose . fmap g . f) x + `shouldBe` (Compose . fmap (traverse g) . traverse f) x + + (t . sequenceA) y `shouldBe` (sequenceA . fmap t) y + (sequenceA . fmap Identity) y `shouldBe` Identity y + (sequenceA . fmap Compose) z + `shouldBe` (Compose . fmap sequenceA . sequenceA) z + where + y :: t (f a) + y = fmap pure x + + z :: t (f (g a)) + z = fmap (fmap pure) y + +prop_TraversableEx :: (Traversable t, + Eq (t [[Int]]), Eq (t [Int]), Eq (t String), Eq (t Char), + Show (t [[Int]]), Show (t [Int]), Show (t String), Show (t Char)) + => t [Int] -> Expectation +prop_TraversableEx = prop_TraversableLaws + (replicate 2 . map (chr . abs)) + (++ "Hello") + reverse + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do + describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do + prop "satisfies the Functor laws" + (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) + prop "satisfies the Foldable laws" + (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) + prop "satisfies the Traversable laws" + (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) +#if MIN_VERSION_template_haskell(2,7,0) + describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do + prop "satisfies the Functor laws" + (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) + prop "satisfies the Foldable laws" + (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) + prop "satisfies the Traversable laws" + (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) +#endif diff --git a/tests/GH24Spec.hs b/tests/GH24Spec.hs --- a/tests/GH24Spec.hs +++ b/tests/GH24Spec.hs @@ -1,46 +1,46 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 -{-# LANGUAGE TypeInType #-} -#endif - -{-| -Module: GH24Spec -Copyright: (C) 2019 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -A regression test for -https://github.com/haskell-compat/deriving-compat/issues/24. --} -module GH24Spec (main, spec) where - -#if __GLASGOW_HASKELL__ >= 800 -import Data.Deriving -#endif - -import Prelude () -import Prelude.Compat - -import Test.Hspec - -#if __GLASGOW_HASKELL__ >= 800 -data family P (a :: j) (b :: k) -data instance P (a :: k) k = MkP deriving (Eq, Ord) - -$(deriveEnum 'MkP) -$(deriveIx 'MkP) -#endif - -main :: IO () -main = hspec spec - -spec :: Spec -spec = pure () +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + +{-| +Module: GH24Spec +Copyright: (C) 2019 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +A regression test for +https://github.com/haskell-compat/deriving-compat/issues/24. +-} +module GH24Spec (main, spec) where + +#if __GLASGOW_HASKELL__ >= 800 +import Data.Deriving +#endif + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +#if __GLASGOW_HASKELL__ >= 800 +data family P (a :: j) (b :: k) +data instance P (a :: k) k = MkP deriving (Eq, Ord) + +$(deriveEnum 'MkP) +$(deriveIx 'MkP) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure () diff --git a/tests/GH27Spec.hs b/tests/GH27Spec.hs --- a/tests/GH27Spec.hs +++ b/tests/GH27Spec.hs @@ -1,40 +1,40 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - -#if MIN_VERSION_template_haskell(2,12,0) -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TypeApplications #-} -#endif - -{-| -Module: GH27Spec -Copyright: (C) 2019 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -A regression test for -https://github.com/haskell-compat/deriving-compat/issues/27. --} -module GH27Spec where - -import Prelude () -import Prelude.Compat - -import Test.Hspec - -#if MIN_VERSION_template_haskell(2,12,0) -import Data.Deriving.Via -import Data.Functor.Const - -newtype Age = MkAge Int -$(deriveVia [t| forall a. Show Age `Via` Const Int a |]) -#endif - -main :: IO () -main = hspec spec - -spec :: Spec -spec = pure () +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeApplications #-} +#endif + +{-| +Module: GH27Spec +Copyright: (C) 2019 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +A regression test for +https://github.com/haskell-compat/deriving-compat/issues/27. +-} +module GH27Spec where + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +#if MIN_VERSION_template_haskell(2,12,0) +import Data.Deriving.Via +import Data.Functor.Const + +newtype Age = MkAge Int +$(deriveVia [t| forall a. Show Age `Via` Const Int a |]) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure () diff --git a/tests/GH31Spec.hs b/tests/GH31Spec.hs --- a/tests/GH31Spec.hs +++ b/tests/GH31Spec.hs @@ -1,59 +1,59 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module: GH31Spec -Copyright: (C) 2020 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -A regression test for -https://github.com/haskell-compat/deriving-compat/issues/31. --} -module GH31Spec (main, spec) where - -import Data.Deriving (deriveEq1, deriveOrd1) -import Data.Functor.Classes (compare1) -import Data.Proxy (Proxy(..)) -import Data.Void (Void) - -import OrdSpec (ordSpec) - -import Prelude () -import Prelude.Compat - -import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) -import Test.QuickCheck (Arbitrary(..), oneof) - -data T a - = A - | B Int - | C Int - | D - | E Int - | F - deriving (Eq, Ord, Show) - -deriveEq1 ''T -deriveOrd1 ''T - -instance Arbitrary (T a) where - arbitrary = oneof [ pure A - , B <$> arbitrary - , C <$> arbitrary - , pure D - , E <$> arbitrary - , pure F - ] - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ - describe "GH31" $ do - ordSpec (Proxy :: Proxy (T Void)) - it "obeys reflexivity" $ - let x :: T Void - x = E 0 - in compare1 x x `shouldBe` EQ +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module: GH31Spec +Copyright: (C) 2020 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +A regression test for +https://github.com/haskell-compat/deriving-compat/issues/31. +-} +module GH31Spec (main, spec) where + +import Data.Deriving (deriveEq1, deriveOrd1) +import Data.Functor.Classes (compare1) +import Data.Proxy (Proxy(..)) +import Data.Void (Void) + +import OrdSpec (ordSpec) + +import Prelude () +import Prelude.Compat + +import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) +import Test.QuickCheck (Arbitrary(..), oneof) + +data T a + = A + | B Int + | C Int + | D + | E Int + | F + deriving (Eq, Ord, Show) + +deriveEq1 ''T +deriveOrd1 ''T + +instance Arbitrary (T a) where + arbitrary = oneof [ pure A + , B <$> arbitrary + , C <$> arbitrary + , pure D + , E <$> arbitrary + , pure F + ] + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ + describe "GH31" $ do + ordSpec (Proxy :: Proxy (T Void)) + it "obeys reflexivity" $ + let x :: T Void + x = E 0 + in compare1 x x `shouldBe` EQ diff --git a/tests/GH6Spec.hs b/tests/GH6Spec.hs --- a/tests/GH6Spec.hs +++ b/tests/GH6Spec.hs @@ -1,44 +1,44 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module: GH6Spec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -A regression test for -https://github.com/haskell-compat/deriving-compat/issues/6. --} -module GH6Spec (main, spec) where - -import Data.Deriving (deriveEq1, deriveOrd1) -import Data.Proxy (Proxy(..)) - -import OrdSpec (ordSpec) - -import Prelude () -import Prelude.Compat - -import Test.Hspec (Spec, describe, hspec, parallel) -import Test.QuickCheck (Arbitrary(..), oneof) - -data Foo a - = Foo1 a - | Foo2 a - | Foo3 a - | Foo4 a - | Foo5 a - deriving (Eq, Ord, Show) - -deriveEq1 ''Foo -deriveOrd1 ''Foo - -instance Arbitrary a => Arbitrary (Foo a) where - arbitrary = oneof $ map (<$> arbitrary) [Foo1, Foo2, Foo3, Foo4, Foo5] - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ describe "GH6" $ ordSpec (Proxy :: Proxy (Foo Int)) +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module: GH6Spec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +A regression test for +https://github.com/haskell-compat/deriving-compat/issues/6. +-} +module GH6Spec (main, spec) where + +import Data.Deriving (deriveEq1, deriveOrd1) +import Data.Proxy (Proxy(..)) + +import OrdSpec (ordSpec) + +import Prelude () +import Prelude.Compat + +import Test.Hspec (Spec, describe, hspec, parallel) +import Test.QuickCheck (Arbitrary(..), oneof) + +data Foo a + = Foo1 a + | Foo2 a + | Foo3 a + | Foo4 a + | Foo5 a + deriving (Eq, Ord, Show) + +deriveEq1 ''Foo +deriveOrd1 ''Foo + +instance Arbitrary a => Arbitrary (Foo a) where + arbitrary = oneof $ map (<$> arbitrary) [Foo1, Foo2, Foo3, Foo4, Foo5] + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ describe "GH6" $ ordSpec (Proxy :: Proxy (Foo Int)) diff --git a/tests/OrdSpec.hs b/tests/OrdSpec.hs --- a/tests/OrdSpec.hs +++ b/tests/OrdSpec.hs @@ -1,41 +1,41 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -{-| -Module: OrdSpec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for derived 'Ord', 'Ord1', and 'Ord2' instances. --} -module OrdSpec where - -import Data.Functor.Classes - -import Prelude () -import Prelude.Compat - -import Test.Hspec -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Arbitrary) - -import Types.EqOrd () - -------------------------------------------------------------------------------- - -prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Expectation -prop_Ord x y = compare x y `shouldBe` compare1 x y - -ordSpec :: forall proxy f a. (Arbitrary (f a), Show (f a), - Ord a, Ord (f a), Ord1 f) - => proxy (f a) -> Spec -ordSpec _ = prop "has a valid Ord1 instance" (prop_Ord :: f a -> f a -> Expectation) - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = pure () +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Module: OrdSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Ord', 'Ord1', and 'Ord2' instances. +-} +module OrdSpec where + +import Data.Functor.Classes + +import Prelude () +import Prelude.Compat + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary) + +import Types.EqOrd () + +------------------------------------------------------------------------------- + +prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Expectation +prop_Ord x y = compare x y `shouldBe` compare1 x y + +ordSpec :: forall proxy f a. (Arbitrary (f a), Show (f a), + Ord a, Ord (f a), Ord1 f) + => proxy (f a) -> Spec +ordSpec _ = prop "has a valid Ord1 instance" (prop_Ord :: f a -> f a -> Expectation) + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure () diff --git a/tests/ReadSpec.hs b/tests/ReadSpec.hs --- a/tests/ReadSpec.hs +++ b/tests/ReadSpec.hs @@ -1,124 +1,124 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module: ReadSpec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for derived 'Read', 'Read1', and 'Read2' instances. --} -module ReadSpec where - -import Data.Deriving -import Data.Functor.Classes (Read1, readsPrec1) -import Data.Proxy - -import Prelude () -import Prelude.Compat - -import Test.Hspec -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Arbitrary(..)) - -import Text.Read (minPrec) - -import Types.ReadShow () - -------------------------------------------------------------------------------- - --- Plain data types - -data TyCon# a b = TyCon# { - tcA# :: a - , tcB# :: b -} deriving (Eq, Show) - -data Empty a b - --- Data families - -data family TyFamily# y z :: * - -data instance TyFamily# a b = TyFamily# { - tfA# :: a - , tfB# :: b -} deriving (Eq, Show) - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveRead ''TyCon#) -$(deriveRead1 ''TyCon#) -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveRead2 ''TyCon#) -#endif - -instance (Arbitrary a, Arbitrary b) => Arbitrary (TyCon# a b) where - arbitrary = TyCon# <$> arbitrary <*> arbitrary - -$(deriveRead ''Empty) -$(deriveRead1 ''Empty) -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveRead2 ''Empty) -#endif - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveRead 'TyFamily#) -$(deriveRead1 'TyFamily#) -# if defined(NEW_FUNCTOR_CLASSES) -$(deriveRead2 'TyFamily#) -# endif - -instance (Arbitrary a, Arbitrary b) => Arbitrary (TyFamily# a b) where - arbitrary = TyFamily# <$> arbitrary <*> arbitrary -#endif - -------------------------------------------------------------------------------- - -prop_Read :: forall f a. (Read a, Read (f a), Read1 f, - Eq (f a), Show (f a)) - => f a -> Expectation -prop_Read x = readArb readsPrec `shouldBe` readArb readsPrec1 - where - readArb :: (Int -> ReadS (f a)) -> f a - readArb = read' (show x) - -readSpec :: forall f a. (Arbitrary (f a), Eq (f a), Show (f a), - Read a, Read (f a), Read1 f) - => Proxy (f a) -> Spec -readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Expectation) - --- Adapted from the definition of readEither -readEither' :: String -> (Int -> ReadS a) -> Either String a -readEither' s rs = - case [ x | (x,"") <- rs minPrec s ] of - [x] -> Right x - [] -> Left "Prelude.read: no parse" - _ -> Left "Prelude.read: ambiguous parse" - -read' :: String -> (Int -> ReadS a) -> a -read' s = either error id . readEither' s - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = parallel $ do - describe "TyCon#" $ - readSpec (Proxy :: Proxy (TyCon# Char Int)) -#if MIN_VERSION_template_haskell(2,7,0) - describe "TyFamily#" $ - readSpec (Proxy :: Proxy (TyFamily# Char Int)) -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: ReadSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Read', 'Read1', and 'Read2' instances. +-} +module ReadSpec where + +import Data.Deriving +import Data.Functor.Classes (Read1, readsPrec1) +import Data.Proxy + +import Prelude () +import Prelude.Compat + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary(..)) + +import Text.Read (minPrec) + +import Types.ReadShow () + +------------------------------------------------------------------------------- + +-- Plain data types + +data TyCon# a b = TyCon# { + tcA# :: a + , tcB# :: b +} deriving (Eq, Show) + +data Empty a b + +-- Data families + +data family TyFamily# y z :: * + +data instance TyFamily# a b = TyFamily# { + tfA# :: a + , tfB# :: b +} deriving (Eq, Show) + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveRead ''TyCon#) +$(deriveRead1 ''TyCon#) +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead2 ''TyCon#) +#endif + +instance (Arbitrary a, Arbitrary b) => Arbitrary (TyCon# a b) where + arbitrary = TyCon# <$> arbitrary <*> arbitrary + +$(deriveRead ''Empty) +$(deriveRead1 ''Empty) +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead2 ''Empty) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveRead 'TyFamily#) +$(deriveRead1 'TyFamily#) +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead2 'TyFamily#) +# endif + +instance (Arbitrary a, Arbitrary b) => Arbitrary (TyFamily# a b) where + arbitrary = TyFamily# <$> arbitrary <*> arbitrary +#endif + +------------------------------------------------------------------------------- + +prop_Read :: forall f a. (Read a, Read (f a), Read1 f, + Eq (f a), Show (f a)) + => f a -> Expectation +prop_Read x = readArb readsPrec `shouldBe` readArb readsPrec1 + where + readArb :: (Int -> ReadS (f a)) -> f a + readArb = read' (show x) + +readSpec :: forall f a. (Arbitrary (f a), Eq (f a), Show (f a), + Read a, Read (f a), Read1 f) + => Proxy (f a) -> Spec +readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Expectation) + +-- Adapted from the definition of readEither +readEither' :: String -> (Int -> ReadS a) -> Either String a +readEither' s rs = + case [ x | (x,"") <- rs minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + +read' :: String -> (Int -> ReadS a) -> a +read' s = either error id . readEither' s + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do + describe "TyCon#" $ + readSpec (Proxy :: Proxy (TyCon# Char Int)) +#if MIN_VERSION_template_haskell(2,7,0) + describe "TyFamily#" $ + readSpec (Proxy :: Proxy (TyFamily# Char Int)) +#endif diff --git a/tests/ShowSpec.hs b/tests/ShowSpec.hs --- a/tests/ShowSpec.hs +++ b/tests/ShowSpec.hs @@ -1,177 +1,177 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE EmptyCase #-} -#endif - -{-| -Module: ShowSpec -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for derived 'Show', 'Show1', and 'Show2' instances. --} -module ShowSpec where - -import Data.Deriving - -import GHC.Exts ( Char#, Double#, Float#, Int#, Word# -#if MIN_VERSION_base(4,13,0) - , Int8#, Int16#, Word8#, Word16# -#endif -#if MIN_VERSION_base(4,16,0) - , Int32#, Word32# -#endif - ) - -import Prelude () -import Prelude.Compat - -import Test.Hspec - -import Types.ReadShow () - -------------------------------------------------------------------------------- - --- Plain data types - -data TyCon# a b = TyCon# { - tcA :: a - , tcB :: b - , tcInt# :: Int# - , tcFloat# :: Float# - , tcDouble# :: Double# - , tcChar# :: Char# - , tcWord# :: Word# -#if MIN_VERSION_base(4,13,0) - , tcInt8# :: Int8# - , tcInt16# :: Int16# - , tcWord8# :: Word8# - , tcWord16# :: Word16# -#endif -#if MIN_VERSION_base(4,16,0) - , tcInt32# :: Int32# - , tcWord32# :: Word32# -#endif -} - -data TyCon2 a b c d where - TyConClassConstraints :: (Ord m, Ord n, Ord o, Ord p) - => m -> n -> o -> p - -> TyCon2 m n o p - - TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) - => e -> f -> g -> h - -> TyCon2 e f g h - - TyConTypeRefinement1, - TyConTypeRefinement2 :: Int -> z - -> TyCon2 Int Int z z - - TyConForalls :: forall p q r s t u. - (Show p, Show q) - => p -> q -> u -> t - -> TyCon2 r s t u - -data Empty1 a b -data Empty2 a b - --- Data families - -data family TyFamily# y z :: * - -data instance TyFamily# a b = TyFamily# { - tfA :: a - , tfB :: b - , tfInt# :: Int# - , tfFloat# :: Float# - , tfDouble# :: Double# - , tfChar# :: Char# - , tfWord# :: Word# -#if MIN_VERSION_base(4,13,0) - , tfInt8# :: Int8# - , tfInt16# :: Int16# - , tfWord8# :: Word8# - , tfWord16# :: Word16# -#endif -#if MIN_VERSION_base(4,16,0) - , tfInt32# :: Int32# - , tfWord32# :: Word32# -#endif -} - -data family TyFamily2 w x y z :: * - -data instance TyFamily2 a b c d where - TyFamilyClassConstraints :: (Ord m, Ord n, Ord o, Ord p) - => m -> n -> o -> p - -> TyFamily2 m n o p - - TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) - => e -> f -> g -> h - -> TyFamily2 e f g h - - TyFamilyTypeRefinement1, - TyFamilyTypeRefinement2 :: Int -> z - -> TyFamily2 Int Int z z - - TyFamilyForalls :: forall p q r s t u. - (Show p, Show q) - => p -> q -> u -> t - -> TyFamily2 r s t u - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveShow ''TyCon#) -$(deriveShow ''TyCon2) -$(deriveShow ''Empty1) - -$(deriveShow1 ''TyCon#) -$(deriveShow1 ''TyCon2) -$(deriveShow1 ''Empty1) - -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveShow2 ''TyCon#) -$(deriveShow2 ''TyCon2) -$(deriveShow2 ''Empty1) -#endif - --- Use EmptyCase here -$(deriveShowOptions defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) -$(deriveShow1Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveShow2Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) -#endif - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveShow 'TyFamily#) -$(deriveShow 'TyFamilyClassConstraints) - -$(deriveShow1 'TyFamily#) -$(deriveShow1 'TyFamilyEqualityConstraints) - -# if defined(NEW_FUNCTOR_CLASSES) -$(deriveShow2 'TyFamily#) -$(deriveShow2 'TyFamilyTypeRefinement1) -# endif -#endif - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = pure () +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +#endif + +{-| +Module: ShowSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Show', 'Show1', and 'Show2' instances. +-} +module ShowSpec where + +import Data.Deriving + +import GHC.Exts ( Char#, Double#, Float#, Int#, Word# +#if MIN_VERSION_base(4,13,0) + , Int8#, Int16#, Word8#, Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , Int32#, Word32# +#endif + ) + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +import Types.ReadShow () + +------------------------------------------------------------------------------- + +-- Plain data types + +data TyCon# a b = TyCon# { + tcA :: a + , tcB :: b + , tcInt# :: Int# + , tcFloat# :: Float# + , tcDouble# :: Double# + , tcChar# :: Char# + , tcWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tcInt8# :: Int8# + , tcInt16# :: Int16# + , tcWord8# :: Word8# + , tcWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tcInt32# :: Int32# + , tcWord32# :: Word32# +#endif +} + +data TyCon2 a b c d where + TyConClassConstraints :: (Ord m, Ord n, Ord o, Ord p) + => m -> n -> o -> p + -> TyCon2 m n o p + + TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyCon2 e f g h + + TyConTypeRefinement1, + TyConTypeRefinement2 :: Int -> z + -> TyCon2 Int Int z z + + TyConForalls :: forall p q r s t u. + (Show p, Show q) + => p -> q -> u -> t + -> TyCon2 r s t u + +data Empty1 a b +data Empty2 a b + +-- Data families + +data family TyFamily# y z :: * + +data instance TyFamily# a b = TyFamily# { + tfA :: a + , tfB :: b + , tfInt# :: Int# + , tfFloat# :: Float# + , tfDouble# :: Double# + , tfChar# :: Char# + , tfWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tfInt8# :: Int8# + , tfInt16# :: Int16# + , tfWord8# :: Word8# + , tfWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tfInt32# :: Int32# + , tfWord32# :: Word32# +#endif +} + +data family TyFamily2 w x y z :: * + +data instance TyFamily2 a b c d where + TyFamilyClassConstraints :: (Ord m, Ord n, Ord o, Ord p) + => m -> n -> o -> p + -> TyFamily2 m n o p + + TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyFamily2 e f g h + + TyFamilyTypeRefinement1, + TyFamilyTypeRefinement2 :: Int -> z + -> TyFamily2 Int Int z z + + TyFamilyForalls :: forall p q r s t u. + (Show p, Show q) + => p -> q -> u -> t + -> TyFamily2 r s t u + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveShow ''TyCon#) +$(deriveShow ''TyCon2) +$(deriveShow ''Empty1) + +$(deriveShow1 ''TyCon#) +$(deriveShow1 ''TyCon2) +$(deriveShow1 ''Empty1) + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow2 ''TyCon#) +$(deriveShow2 ''TyCon2) +$(deriveShow2 ''Empty1) +#endif + +-- Use EmptyCase here +$(deriveShowOptions defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) +$(deriveShow1Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow2Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveShow 'TyFamily#) +$(deriveShow 'TyFamilyClassConstraints) + +$(deriveShow1 'TyFamily#) +$(deriveShow1 'TyFamilyEqualityConstraints) + +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow2 'TyFamily#) +$(deriveShow2 'TyFamilyTypeRefinement1) +# endif +#endif + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure () diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Types/EqOrd.hs b/tests/Types/EqOrd.hs --- a/tests/Types/EqOrd.hs +++ b/tests/Types/EqOrd.hs @@ -1,295 +1,296 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-| -Module: Types.EqOrd -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Shared datatypes between "EqSpec" and "OrdSpec". --} -module Types.EqOrd where - -#if !defined(NEW_FUNCTOR_CLASSES) -import Data.Functor.Classes (Eq1(..), Ord1(..)) -#endif -import Data.Deriving - -import GHC.Exts ( Addr#, Char#, Double#, Float#, Int#, Word# -#if MIN_VERSION_base(4,13,0) - , Int8#, Int16#, Word8#, Word16# -#endif -#if MIN_VERSION_base(4,16,0) - , Int32#, Word32# -#endif - ) - --- Plain data types - -data TyCon1 a m = - TyCon1A a - | TyCon1B - | TyCon1C - | TyCon1D - | TyCon1E - | TyCon1F - | TyCon1G - | TyCon1H - | TyCon1I - | TyCon1J - | TyCon1K - | TyCon1L - | TyCon1M m - -data TyCon# a b = TyCon# { - tcA :: a - , tcB :: b - , tcAddr# :: Addr# - , tcInt# :: Int# - , tcFloat# :: Float# - , tcDouble# :: Double# - , tcChar# :: Char# - , tcWord# :: Word# -#if MIN_VERSION_base(4,13,0) - , tcInt8# :: Int8# - , tcInt16# :: Int16# - , tcWord8# :: Word8# - , tcWord16# :: Word16# -#endif -#if MIN_VERSION_base(4,16,0) - , tcInt32# :: Int32# - , tcWord32# :: Word32# -#endif -} - -data TyCon2 a b c d where - TyConClassConstraints :: (Show m, Show n, Show o, Show p) - => m -> n -> o -> p - -> TyCon2 m n o p - - TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) - => e -> f -> g -> h - -> TyCon2 e f g h - - TyConTypeRefinement1, - TyConTypeRefinement2 :: Int -> z - -> TyCon2 Int Int z z - -data TyConWrap f g h a = TyConWrap1 (f a) - | TyConWrap2 (f (g a)) - | TyConWrap3 (f (g (h a))) - -data Empty a b - -data TyConNullary a b - = TyConNullary1 - | TyConNullary2 - | TyConNullary3 - --- Data families - -data family TyFamily1 y z :: * - -data instance TyFamily1 a m = - TyFamily1A a - | TyFamily1B - | TyFamily1C - | TyFamily1D - | TyFamily1E - | TyFamily1F - | TyFamily1G - | TyFamily1H - | TyFamily1I - | TyFamily1J - | TyFamily1K - | TyFamily1L - | TyFamily1M m - -data family TyFamily# y z :: * - -data instance TyFamily# a b = TyFamily# { - tfA :: a - , tfB :: b - , tfInt# :: Int# - , tfFloat# :: Float# - , tfDouble# :: Double# - , tfChar# :: Char# - , tfWord# :: Word# -#if MIN_VERSION_base(4,13,0) - , tfInt8# :: Int8# - , tfInt16# :: Int16# - , tfWord8# :: Word8# - , tfWord16# :: Word16# -#endif -#if MIN_VERSION_base(4,16,0) - , tfInt32# :: Int32# - , tfWord32# :: Word32# -#endif -} - -data family TyFamily2 w x y z :: * - -data instance TyFamily2 a b c d where - TyFamilyClassConstraints :: (Show m, Show n, Show o, Show p) - => m -> n -> o -> p - -> TyFamily2 m n o p - - TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) - => e -> f -> g -> h - -> TyFamily2 e f g h - - TyFamilyTypeRefinement1, - TyFamilyTypeRefinement2 :: Int -> z - -> TyFamily2 Int Int z z - -data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * - -data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) - | TyFamilyWrap2 (f (g a)) - | TyFamilyWrap3 (f (g (h a))) - -data family TyFamilyNullary x y :: * - -data instance TyFamilyNullary a b - = TyFamilyNullary1 - | TyFamilyNullary2 - | TyFamilyNullary3 - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveEq ''TyCon1) -$(deriveEq ''TyCon#) -$(deriveEq ''TyCon2) -instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) - => Eq (TyConWrap f g h a) where - (==) = $(makeEq ''TyConWrap) - (/=) = $(makeNotEq ''TyConWrap) -$(deriveEq ''Empty) -$(deriveEq ''TyConNullary) - -$(deriveEq1 ''TyCon1) -$(deriveEq1 ''TyCon#) -$(deriveEq1 ''TyCon2) -$(deriveEq1 ''Empty) -$(deriveEq1 ''TyConNullary) - -$(deriveOrd ''TyCon1) -$(deriveOrd ''TyCon#) -$(deriveOrd ''TyCon2) -instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) - => Ord (TyConWrap f g h a) where - compare = $(makeCompare ''TyConWrap) - (>) = $(makeLT ''TyConWrap) - (>=) = $(makeLE ''TyConWrap) - (<) = $(makeGT ''TyConWrap) - (<=) = $(makeGE ''TyConWrap) - max = $(makeMax ''TyConWrap) - min = $(makeMin ''TyConWrap) -$(deriveOrd ''Empty) - -$(deriveOrd1 ''TyCon1) -$(deriveOrd1 ''TyCon#) -$(deriveOrd1 ''TyCon2) -$(deriveOrd1 ''Empty) -$(deriveOrd1 ''TyConNullary) - -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveEq1 ''TyConWrap) - -$(deriveOrd1 ''TyConWrap) -#else -instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) - => Eq1 (TyConWrap f g h) where - eq1 = $(makeEq1 ''TyConWrap) - -instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) - => Ord1 (TyConWrap f g h) where - compare1 = $(makeCompare1 ''TyConWrap) -#endif - -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveEq2 ''TyCon1) -$(deriveEq2 ''TyCon#) -$(deriveEq2 ''TyCon2) -$(deriveEq2 ''Empty) -$(deriveEq2 ''TyConNullary) - -$(deriveOrd2 ''TyCon1) -$(deriveOrd2 ''TyCon#) -$(deriveOrd2 ''TyCon2) -$(deriveOrd2 ''Empty) -$(deriveOrd2 ''TyConNullary) -#endif - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveEq 'TyFamily1A) -$(deriveEq 'TyFamily#) -$(deriveEq 'TyFamilyClassConstraints) -instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) - => Eq (TyFamilyWrap f g h a) where - (==) = $(makeEq 'TyFamilyWrap1) - (/=) = $(makeNotEq 'TyFamilyWrap1) -$(deriveEq 'TyFamilyNullary1) - -$(deriveEq1 'TyFamily1B) -$(deriveEq1 'TyFamily#) -$(deriveEq1 'TyFamilyEqualityConstraints) -$(deriveEq1 'TyFamilyNullary1) - -$(deriveOrd 'TyFamily1A) -$(deriveOrd 'TyFamily#) -$(deriveOrd 'TyFamilyClassConstraints) -instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) - => Ord (TyFamilyWrap f g h a) where - compare = $(makeCompare 'TyFamilyWrap1) - (>) = $(makeLT 'TyFamilyWrap1) - (>=) = $(makeLE 'TyFamilyWrap1) - (<) = $(makeGT 'TyFamilyWrap1) - (<=) = $(makeGE 'TyFamilyWrap1) - max = $(makeMax 'TyFamilyWrap1) - min = $(makeMin 'TyFamilyWrap1) -$(deriveOrd 'TyFamilyNullary1) - -$(deriveOrd1 'TyFamily1B) -$(deriveOrd1 'TyFamily#) -$(deriveOrd1 'TyFamilyEqualityConstraints) -$(deriveOrd1 'TyFamilyNullary1) - -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveEq1 'TyFamilyWrap2) - -$(deriveOrd1 'TyFamilyWrap2) -#else -instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) - => Eq1 (TyFamilyWrap f g h) where - eq1 = $(makeEq1 'TyFamilyWrap3) - -instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) - => Ord1 (TyFamilyWrap f g h) where - compare1 = $(makeCompare1 'TyFamilyWrap3) -#endif - -# if defined(NEW_FUNCTOR_CLASSES) -$(deriveEq2 'TyFamily1C) -$(deriveEq2 'TyFamily#) -$(deriveEq2 'TyFamilyTypeRefinement1) -$(deriveEq2 'TyFamilyNullary1) - -$(deriveOrd2 'TyFamily1C) -$(deriveOrd2 'TyFamily#) -$(deriveOrd2 'TyFamilyTypeRefinement1) -$(deriveOrd2 'TyFamilyNullary1) -# endif -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: Types.EqOrd +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Shared datatypes between "EqSpec" and "OrdSpec". +-} +module Types.EqOrd where + +#if !defined(NEW_FUNCTOR_CLASSES) +import Data.Functor.Classes (Eq1(..), Ord1(..)) +#endif +import Data.Deriving + +import GHC.Exts ( Addr#, Char#, Double#, Float#, Int#, Word# +#if MIN_VERSION_base(4,13,0) + , Int8#, Int16#, Word8#, Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , Int32#, Word32# +#endif + ) + +-- Plain data types + +data TyCon1 a m = + TyCon1A a + | TyCon1B + | TyCon1C + | TyCon1D + | TyCon1E + | TyCon1F + | TyCon1G + | TyCon1H + | TyCon1I + | TyCon1J + | TyCon1K + | TyCon1L + | TyCon1M m + +data TyCon# a b = TyCon# { + tcA :: a + , tcB :: b + , tcAddr# :: Addr# + , tcInt# :: Int# + , tcFloat# :: Float# + , tcDouble# :: Double# + , tcChar# :: Char# + , tcWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tcInt8# :: Int8# + , tcInt16# :: Int16# + , tcWord8# :: Word8# + , tcWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tcInt32# :: Int32# + , tcWord32# :: Word32# +#endif +} + +data TyCon2 a b c d where + TyConClassConstraints :: (Show m, Show n, Show o, Show p) + => m -> n -> o -> p + -> TyCon2 m n o p + + TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyCon2 e f g h + + TyConTypeRefinement1, + TyConTypeRefinement2 :: Int -> z + -> TyCon2 Int Int z z + +data TyConWrap f g h a = TyConWrap1 (f a) + | TyConWrap2 (f (g a)) + | TyConWrap3 (f (g (h a))) + +data Empty a b + +data TyConNullary a b + = TyConNullary1 + | TyConNullary2 + | TyConNullary3 + +-- Data families + +data family TyFamily1 y z :: * + +data instance TyFamily1 a m = + TyFamily1A a + | TyFamily1B + | TyFamily1C + | TyFamily1D + | TyFamily1E + | TyFamily1F + | TyFamily1G + | TyFamily1H + | TyFamily1I + | TyFamily1J + | TyFamily1K + | TyFamily1L + | TyFamily1M m + +data family TyFamily# y z :: * + +data instance TyFamily# a b = TyFamily# { + tfA :: a + , tfB :: b + , tfInt# :: Int# + , tfFloat# :: Float# + , tfDouble# :: Double# + , tfChar# :: Char# + , tfWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tfInt8# :: Int8# + , tfInt16# :: Int16# + , tfWord8# :: Word8# + , tfWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tfInt32# :: Int32# + , tfWord32# :: Word32# +#endif +} + +data family TyFamily2 w x y z :: * + +data instance TyFamily2 a b c d where + TyFamilyClassConstraints :: (Show m, Show n, Show o, Show p) + => m -> n -> o -> p + -> TyFamily2 m n o p + + TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyFamily2 e f g h + + TyFamilyTypeRefinement1, + TyFamilyTypeRefinement2 :: Int -> z + -> TyFamily2 Int Int z z + +data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * + +data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) + | TyFamilyWrap2 (f (g a)) + | TyFamilyWrap3 (f (g (h a))) + +data family TyFamilyNullary x y :: * + +data instance TyFamilyNullary a b + = TyFamilyNullary1 + | TyFamilyNullary2 + | TyFamilyNullary3 + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveEq ''TyCon1) +$(deriveEq ''TyCon#) +$(deriveEq ''TyCon2) +instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) + => Eq (TyConWrap f g h a) where + (==) = $(makeEq ''TyConWrap) + (/=) = $(makeNotEq ''TyConWrap) +$(deriveEq ''Empty) +$(deriveEq ''TyConNullary) + +$(deriveEq1 ''TyCon1) +$(deriveEq1 ''TyCon#) +$(deriveEq1 ''TyCon2) +$(deriveEq1 ''Empty) +$(deriveEq1 ''TyConNullary) + +$(deriveOrd ''TyCon1) +$(deriveOrd ''TyCon#) +$(deriveOrd ''TyCon2) +instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) + => Ord (TyConWrap f g h a) where + compare = $(makeCompare ''TyConWrap) + (>) = $(makeLT ''TyConWrap) + (>=) = $(makeLE ''TyConWrap) + (<) = $(makeGT ''TyConWrap) + (<=) = $(makeGE ''TyConWrap) + max = $(makeMax ''TyConWrap) + min = $(makeMin ''TyConWrap) +$(deriveOrd ''Empty) +$(deriveOrd ''TyConNullary) + +$(deriveOrd1 ''TyCon1) +$(deriveOrd1 ''TyCon#) +$(deriveOrd1 ''TyCon2) +$(deriveOrd1 ''Empty) +$(deriveOrd1 ''TyConNullary) + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq1 ''TyConWrap) + +$(deriveOrd1 ''TyConWrap) +#else +instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) + => Eq1 (TyConWrap f g h) where + eq1 = $(makeEq1 ''TyConWrap) + +instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) + => Ord1 (TyConWrap f g h) where + compare1 = $(makeCompare1 ''TyConWrap) +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq2 ''TyCon1) +$(deriveEq2 ''TyCon#) +$(deriveEq2 ''TyCon2) +$(deriveEq2 ''Empty) +$(deriveEq2 ''TyConNullary) + +$(deriveOrd2 ''TyCon1) +$(deriveOrd2 ''TyCon#) +$(deriveOrd2 ''TyCon2) +$(deriveOrd2 ''Empty) +$(deriveOrd2 ''TyConNullary) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveEq 'TyFamily1A) +$(deriveEq 'TyFamily#) +$(deriveEq 'TyFamilyClassConstraints) +instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) + => Eq (TyFamilyWrap f g h a) where + (==) = $(makeEq 'TyFamilyWrap1) + (/=) = $(makeNotEq 'TyFamilyWrap1) +$(deriveEq 'TyFamilyNullary1) + +$(deriveEq1 'TyFamily1B) +$(deriveEq1 'TyFamily#) +$(deriveEq1 'TyFamilyEqualityConstraints) +$(deriveEq1 'TyFamilyNullary1) + +$(deriveOrd 'TyFamily1A) +$(deriveOrd 'TyFamily#) +$(deriveOrd 'TyFamilyClassConstraints) +instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) + => Ord (TyFamilyWrap f g h a) where + compare = $(makeCompare 'TyFamilyWrap1) + (>) = $(makeLT 'TyFamilyWrap1) + (>=) = $(makeLE 'TyFamilyWrap1) + (<) = $(makeGT 'TyFamilyWrap1) + (<=) = $(makeGE 'TyFamilyWrap1) + max = $(makeMax 'TyFamilyWrap1) + min = $(makeMin 'TyFamilyWrap1) +$(deriveOrd 'TyFamilyNullary1) + +$(deriveOrd1 'TyFamily1B) +$(deriveOrd1 'TyFamily#) +$(deriveOrd1 'TyFamilyEqualityConstraints) +$(deriveOrd1 'TyFamilyNullary1) + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq1 'TyFamilyWrap2) + +$(deriveOrd1 'TyFamilyWrap2) +#else +instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) + => Eq1 (TyFamilyWrap f g h) where + eq1 = $(makeEq1 'TyFamilyWrap3) + +instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) + => Ord1 (TyFamilyWrap f g h) where + compare1 = $(makeCompare1 'TyFamilyWrap3) +#endif + +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq2 'TyFamily1C) +$(deriveEq2 'TyFamily#) +$(deriveEq2 'TyFamilyTypeRefinement1) +$(deriveEq2 'TyFamilyNullary1) + +$(deriveOrd2 'TyFamily1C) +$(deriveOrd2 'TyFamily#) +$(deriveOrd2 'TyFamilyTypeRefinement1) +$(deriveOrd2 'TyFamilyNullary1) +# endif +#endif diff --git a/tests/Types/ReadShow.hs b/tests/Types/ReadShow.hs --- a/tests/Types/ReadShow.hs +++ b/tests/Types/ReadShow.hs @@ -1,214 +1,214 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module: Types.ReadShow -Copyright: (C) 2015-2017 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -Shared datatypes between "ReadSpec" and "ShowSpec". --} -module Types.ReadShow where - -#if !defined(NEW_FUNCTOR_CLASSES) -import Data.Functor.Classes (Read1(..), Show1(..)) -#endif -import Data.Deriving - -import Text.Read (Read(..), readListPrecDefault) - -------------------------------------------------------------------------------- - --- Plain data types - -infixl 4 :@: -data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b } - | (:@:) { tc3 :: b, (##) :: a } - -infixl 3 :!!: -infix 4 :@@: -infixr 5 `TyConPlain` -infixr 6 `TyConFakeInfix` -data TyConPlain a b = (:!!:) a b - | a :@@: b - | a `TyConPlain` b - | TyConFakeInfix a b - -data TyConGADT a b where - (:.) :: c -> d -> TyConGADT c d - (:..) :: e -> f -> TyConGADT e f - (:...) :: g -> h -> Int -> TyConGADT g h - (:....) :: { tcg1 :: i, tcg2 :: j } -> TyConGADT i j - -data TyConWrap f g h a = TyConWrap1 (f a) - | TyConWrap2 (f (g a)) - | TyConWrap3 (f (g (h a))) - -data TC# a b = MkTC1# a b - | MkTC2# { getTC2# :: b, (#~#) :: a } - | a `MkTC3#` b - --- Data families - -data family TyFamily1 y z :: * - -infixl 4 :!: -data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b } - | (:!:) { tf3 :: b, (###) :: a } - -data family TyFamilyPlain y z :: * - -infixl 3 :#: -infix 4 :$: -infixr 5 `TyFamilyPlain` -infixr 6 `TyFamilyFakeInfix` -data instance TyFamilyPlain a b = (:#:) a b - | a :$: b - | a `TyFamilyPlain` b - | TyFamilyFakeInfix a b - - -data family TyFamilyGADT y z :: * - -infixr 1 :*, :***, :**** -data instance TyFamilyGADT a b where - (:*) :: c -> d -> TyFamilyGADT c d - (:**) :: e -> f -> TyFamilyGADT e f - (:***) :: g -> h -> Int -> TyFamilyGADT g h - (:****) :: { tfg1 :: i, tfg2 :: j } -> TyFamilyGADT i j - -data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * - -data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) - | TyFamilyWrap2 (f (g a)) - | TyFamilyWrap3 (f (g (h a))) - -data family TF# y z :: * - -data instance TF# a b = MkTF1# a b - | MkTF2# { getTF2# :: b, (#~~#) :: a } - | a `MkTF3#` b - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveRead ''TyCon1) -$(deriveRead ''TyConPlain) -$(deriveRead ''TyConGADT) -instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) - => Read (TyConWrap f g h a) where - readPrec = $(makeReadPrec ''TyConWrap) - readListPrec = readListPrecDefault -$(deriveRead ''TC#) - -$(deriveRead1 ''TyCon1) -$(deriveRead1 ''TyConPlain) -$(deriveRead1 ''TyConGADT) -$(deriveRead1 ''TC#) - -$(deriveShow ''TyCon1) -$(deriveShow ''TyConPlain) -$(deriveShow ''TyConGADT) -instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) - => Show (TyConWrap f g h a) where - showsPrec = $(makeShowsPrec ''TyConWrap) - show = $(makeShow ''TyConWrap) - showList = $(makeShowList ''TyConWrap) -$(deriveShow ''TC#) - -$(deriveShow1 ''TyCon1) -$(deriveShow1 ''TyConPlain) -$(deriveShow1 ''TyConGADT) -$(deriveShow1 ''TC#) - -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveRead1 ''TyConWrap) - -$(deriveShow1 ''TyConWrap) -#else -instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h) - => Read1 (TyConWrap f g h) where - readsPrec1 = $(makeReadsPrec1 ''TyConWrap) - -instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) - => Show1 (TyConWrap f g h) where - showsPrec1 = $(makeShowsPrec1 ''TyConWrap) -#endif - -#if defined(NEW_FUNCTOR_CLASSES) -$(deriveRead2 ''TyCon1) -$(deriveRead2 ''TyConPlain) -$(deriveRead2 ''TyConGADT) -$(deriveRead2 ''TC#) - -$(deriveShow2 ''TyCon1) -$(deriveShow2 ''TyConPlain) -$(deriveShow2 ''TyConGADT) -$(deriveShow2 ''TC#) -#endif - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveRead 'TyFamilyPrefix) -$(deriveRead '(:#:)) -$(deriveRead '(:*)) -instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) - => Read (TyFamilyWrap f g h a) where - readsPrec = $(makeReadsPrec 'TyFamilyWrap1) -$(deriveRead 'MkTF1#) - -$(deriveRead1 '(:!:)) -$(deriveRead1 '(:$:)) -$(deriveRead1 '(:**)) -$(deriveRead1 'MkTF2#) - -$(deriveShow 'TyFamilyPrefix) -$(deriveShow '(:#:)) -$(deriveShow '(:*)) -instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) - => Show (TyFamilyWrap f g h a) where - showsPrec = $(makeShowsPrec 'TyFamilyWrap1) - show = $(makeShow 'TyFamilyWrap1) - showList = $(makeShowList 'TyFamilyWrap1) -$(deriveShow 'MkTF3#) - -$(deriveShow1 '(:!:)) -$(deriveShow1 '(:$:)) -$(deriveShow1 '(:**)) -$(deriveShow1 'MkTF1#) - -# if defined(NEW_FUNCTOR_CLASSES) -$(deriveRead1 'TyFamilyWrap2) - -$(deriveShow1 'TyFamilyWrap2) -# else -instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h) - => Read1 (TyFamilyWrap f g h) where - readsPrec1 = $(makeReadsPrec1 'TyFamilyWrap3) - -instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) - => Show1 (TyFamilyWrap f g h) where - showsPrec1 = $(makeShowsPrec1 'TyFamilyWrap3) -# endif - -# if defined(NEW_FUNCTOR_CLASSES) -$(deriveRead2 'TyFamilyPrefix) -$(deriveRead2 'TyFamilyPlain) -$(deriveRead2 '(:***)) -$(deriveRead2 'MkTF2#) - -$(deriveShow2 'TyFamilyPrefix) -$(deriveShow2 'TyFamilyPlain) -$(deriveShow2 '(:***)) -$(deriveShow2 'MkTF3#) -# endif -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: Types.ReadShow +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Shared datatypes between "ReadSpec" and "ShowSpec". +-} +module Types.ReadShow where + +#if !defined(NEW_FUNCTOR_CLASSES) +import Data.Functor.Classes (Read1(..), Show1(..)) +#endif +import Data.Deriving + +import Text.Read (Read(..), readListPrecDefault) + +------------------------------------------------------------------------------- + +-- Plain data types + +infixl 4 :@: +data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b } + | (:@:) { tc3 :: b, (##) :: a } + +infixl 3 :!!: +infix 4 :@@: +infixr 5 `TyConPlain` +infixr 6 `TyConFakeInfix` +data TyConPlain a b = (:!!:) a b + | a :@@: b + | a `TyConPlain` b + | TyConFakeInfix a b + +data TyConGADT a b where + (:.) :: c -> d -> TyConGADT c d + (:..) :: e -> f -> TyConGADT e f + (:...) :: g -> h -> Int -> TyConGADT g h + (:....) :: { tcg1 :: i, tcg2 :: j } -> TyConGADT i j + +data TyConWrap f g h a = TyConWrap1 (f a) + | TyConWrap2 (f (g a)) + | TyConWrap3 (f (g (h a))) + +data TC# a b = MkTC1# a b + | MkTC2# { getTC2# :: b, (#~#) :: a } + | a `MkTC3#` b + +-- Data families + +data family TyFamily1 y z :: * + +infixl 4 :!: +data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b } + | (:!:) { tf3 :: b, (###) :: a } + +data family TyFamilyPlain y z :: * + +infixl 3 :#: +infix 4 :$: +infixr 5 `TyFamilyPlain` +infixr 6 `TyFamilyFakeInfix` +data instance TyFamilyPlain a b = (:#:) a b + | a :$: b + | a `TyFamilyPlain` b + | TyFamilyFakeInfix a b + + +data family TyFamilyGADT y z :: * + +infixr 1 :*, :***, :**** +data instance TyFamilyGADT a b where + (:*) :: c -> d -> TyFamilyGADT c d + (:**) :: e -> f -> TyFamilyGADT e f + (:***) :: g -> h -> Int -> TyFamilyGADT g h + (:****) :: { tfg1 :: i, tfg2 :: j } -> TyFamilyGADT i j + +data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * + +data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) + | TyFamilyWrap2 (f (g a)) + | TyFamilyWrap3 (f (g (h a))) + +data family TF# y z :: * + +data instance TF# a b = MkTF1# a b + | MkTF2# { getTF2# :: b, (#~~#) :: a } + | a `MkTF3#` b + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveRead ''TyCon1) +$(deriveRead ''TyConPlain) +$(deriveRead ''TyConGADT) +instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) + => Read (TyConWrap f g h a) where + readPrec = $(makeReadPrec ''TyConWrap) + readListPrec = readListPrecDefault +$(deriveRead ''TC#) + +$(deriveRead1 ''TyCon1) +$(deriveRead1 ''TyConPlain) +$(deriveRead1 ''TyConGADT) +$(deriveRead1 ''TC#) + +$(deriveShow ''TyCon1) +$(deriveShow ''TyConPlain) +$(deriveShow ''TyConGADT) +instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) + => Show (TyConWrap f g h a) where + showsPrec = $(makeShowsPrec ''TyConWrap) + show = $(makeShow ''TyConWrap) + showList = $(makeShowList ''TyConWrap) +$(deriveShow ''TC#) + +$(deriveShow1 ''TyCon1) +$(deriveShow1 ''TyConPlain) +$(deriveShow1 ''TyConGADT) +$(deriveShow1 ''TC#) + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead1 ''TyConWrap) + +$(deriveShow1 ''TyConWrap) +#else +instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h) + => Read1 (TyConWrap f g h) where + readsPrec1 = $(makeReadsPrec1 ''TyConWrap) + +instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) + => Show1 (TyConWrap f g h) where + showsPrec1 = $(makeShowsPrec1 ''TyConWrap) +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead2 ''TyCon1) +$(deriveRead2 ''TyConPlain) +$(deriveRead2 ''TyConGADT) +$(deriveRead2 ''TC#) + +$(deriveShow2 ''TyCon1) +$(deriveShow2 ''TyConPlain) +$(deriveShow2 ''TyConGADT) +$(deriveShow2 ''TC#) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveRead 'TyFamilyPrefix) +$(deriveRead '(:#:)) +$(deriveRead '(:*)) +instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) + => Read (TyFamilyWrap f g h a) where + readsPrec = $(makeReadsPrec 'TyFamilyWrap1) +$(deriveRead 'MkTF1#) + +$(deriveRead1 '(:!:)) +$(deriveRead1 '(:$:)) +$(deriveRead1 '(:**)) +$(deriveRead1 'MkTF2#) + +$(deriveShow 'TyFamilyPrefix) +$(deriveShow '(:#:)) +$(deriveShow '(:*)) +instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) + => Show (TyFamilyWrap f g h a) where + showsPrec = $(makeShowsPrec 'TyFamilyWrap1) + show = $(makeShow 'TyFamilyWrap1) + showList = $(makeShowList 'TyFamilyWrap1) +$(deriveShow 'MkTF3#) + +$(deriveShow1 '(:!:)) +$(deriveShow1 '(:$:)) +$(deriveShow1 '(:**)) +$(deriveShow1 'MkTF1#) + +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead1 'TyFamilyWrap2) + +$(deriveShow1 'TyFamilyWrap2) +# else +instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h) + => Read1 (TyFamilyWrap f g h) where + readsPrec1 = $(makeReadsPrec1 'TyFamilyWrap3) + +instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) + => Show1 (TyFamilyWrap f g h) where + showsPrec1 = $(makeShowsPrec1 'TyFamilyWrap3) +# endif + +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead2 'TyFamilyPrefix) +$(deriveRead2 'TyFamilyPlain) +$(deriveRead2 '(:***)) +$(deriveRead2 'MkTF2#) + +$(deriveShow2 'TyFamilyPrefix) +$(deriveShow2 'TyFamilyPlain) +$(deriveShow2 '(:***)) +$(deriveShow2 'MkTF3#) +# endif +#endif