deriving-compat 0.6.2 → 0.6.3
raw patch · 41 files changed
+10085/−10070 lines, 41 filesdep ~template-haskelldep ~th-abstractionsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell, th-abstraction
API changes (from Hackage documentation)
+ Data.Deriving.Internal: typeDataError :: Name -> Q a
Files
- CHANGELOG.md +179/−176
- LICENSE +30/−30
- README.md +42/−42
- Setup.hs +2/−2
- deriving-compat.cabal +216/−214
- src/Data/Bounded/Deriving.hs +27/−27
- src/Data/Bounded/Deriving/Internal.hs +141/−141
- src/Data/Deriving.hs +300/−300
- src/Data/Deriving/Internal.hs +2314/−2304
- src/Data/Deriving/Via.hs +71/−71
- src/Data/Deriving/Via/Internal.hs +244/−244
- src/Data/Enum/Deriving.hs +34/−34
- src/Data/Enum/Deriving/Internal.hs +253/−253
- src/Data/Eq/Deriving.hs +55/−55
- src/Data/Eq/Deriving/Internal.hs +410/−410
- src/Data/Foldable/Deriving.hs +64/−64
- src/Data/Functor/Deriving.hs +36/−36
- src/Data/Functor/Deriving/Internal.hs +943/−943
- src/Data/Ix/Deriving.hs +31/−31
- src/Data/Ix/Deriving/Internal.hs +240/−240
- src/Data/Ord/Deriving.hs +60/−60
- src/Data/Ord/Deriving/Internal.hs +707/−707
- src/Data/Traversable/Deriving.hs +61/−61
- src/Text/Read/Deriving.hs +98/−98
- src/Text/Read/Deriving/Internal.hs +896/−896
- src/Text/Show/Deriving.hs +74/−74
- src/Text/Show/Deriving/Internal.hs +741/−741
- tests/BoundedEnumIxSpec.hs +275/−275
- tests/DerivingViaSpec.hs +84/−84
- tests/EqSpec.hs +25/−25
- tests/FunctorSpec.hs +390/−390
- tests/GH24Spec.hs +46/−46
- tests/GH27Spec.hs +40/−40
- tests/GH31Spec.hs +59/−59
- tests/GH6Spec.hs +44/−44
- tests/OrdSpec.hs +41/−41
- tests/ReadSpec.hs +124/−124
- tests/ShowSpec.hs +177/−177
- tests/Spec.hs +1/−1
- tests/Types/EqOrd.hs +296/−296
- tests/Types/ReadShow.hs +214/−214
CHANGELOG.md view
@@ -1,176 +1,179 @@-### 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 +### 0.6.3 [2023.02.27]+* Support `th-abstraction-0.5.*`.++### 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
LICENSE view
@@ -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.
README.md view
@@ -1,42 +1,42 @@-# `deriving-compat` -[][Hackage: deriving-compat] -[](http://packdeps.haskellers.com/reverse/deriving-compat) -[][Haskell.org] -[][tl;dr Legal: BSD3] -[](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: deriving-compat]+[](http://packdeps.haskellers.com/reverse/deriving-compat)+[][Haskell.org]+[][tl;dr Legal: BSD3]+[](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.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
deriving-compat.cabal view
@@ -1,214 +1,216 @@-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 - @<http://hackage.haskell.org/package/generic-deriving 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 - @<http://hackage.haskell.org/package/th-lift 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 - @<http://hackage.haskell.org/package/bifunctors bifunctors>@ - 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 <ryan.gl.scott@gmail.com> -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 +name: deriving-compat+version: 0.6.3+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+ @<http://hackage.haskell.org/package/generic-deriving 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+ @<http://hackage.haskell.org/package/th-lift 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+ @<http://hackage.haskell.org/package/bifunctors bifunctors>@+ 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 <ryan.gl.scott@gmail.com>+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.6+ , GHC == 9.4.4+ , GHC == 9.6.1+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.6++ 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.21+ , 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.21+ , 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
src/Data/Bounded/Deriving.hs view
@@ -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.+-}
src/Data/Bounded/Deriving/Internal.hs view
@@ -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
src/Data/Deriving.hs view
@@ -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)+@++-}
src/Data/Deriving/Internal.hs view
@@ -1,2304 +1,2314 @@-{-# 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 qualified Control.Applicative as App (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 as 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 <-+ case variant of+ Datatype -> return False+ Newtype -> return False+ DataInstance -> return True+ NewtypeInstance -> return True+#if MIN_VERSION_th_abstraction(0,5,0)+ Datatype.TypeData -> typeDataError tyConName+#endif++ let 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)"++typeDataError :: Name -> Q a+typeDataError dataName = fail+ . showString "Cannot derive instance for ‘"+ . showString (nameBase dataName)+ . showString "‘, which is a ‘type data‘ declaration"+ $ ""++-------------------------------------------------------------------------------+-- 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 (App.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
src/Data/Deriving/Via.hs view
@@ -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 - <https://ghc.haskell.org/trac/ghc/ticket/14728 Trac #14728>.) --} -#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+ <https://ghc.haskell.org/trac/ghc/ticket/14728 Trac #14728>.)+-}+#endif
src/Data/Deriving/Via/Internal.hs view
@@ -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
src/Data/Enum/Deriving.hs view
@@ -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.+-}
src/Data/Enum/Deriving/Internal.hs view
@@ -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 ")")))))
src/Data/Eq/Deriving.hs view
@@ -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@.+-}
src/Data/Eq/Deriving/Internal.hs view
@@ -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
src/Data/Foldable/Deriving.hs view
@@ -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 -<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>. --} -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+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.+-}+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'.+-}
src/Data/Functor/Deriving.hs view
@@ -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 -<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>. --} -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+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.+-}+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'.+-}
src/Data/Functor/Deriving/Internal.hs view
@@ -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 -<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>. - -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+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.++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
src/Data/Ix/Deriving.hs view
@@ -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.+-}
src/Data/Ix/Deriving/Internal.hs view
@@ -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
src/Data/Ord/Deriving.hs view
@@ -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@.+-}
src/Data/Ord/Deriving/Internal.hs view
@@ -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
src/Data/Traversable/Deriving.hs view
@@ -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 -<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>. --} -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+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.+-}+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'.+-}
src/Text/Read/Deriving.hs view
@@ -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@.+-}
src/Text/Read/Deriving/Internal.hs view
@@ -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
src/Text/Show/Deriving.hs view
@@ -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@.+-}
src/Text/Show/Deriving/Internal.hs view
@@ -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 "##"
tests/BoundedEnumIxSpec.hs view
@@ -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
tests/DerivingViaSpec.hs view
@@ -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 ()
tests/EqSpec.hs view
@@ -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 ()
tests/FunctorSpec.hs view
@@ -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
tests/GH24Spec.hs view
@@ -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 ()
tests/GH27Spec.hs view
@@ -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 ()
tests/GH31Spec.hs view
@@ -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
tests/GH6Spec.hs view
@@ -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))
tests/OrdSpec.hs view
@@ -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 ()
tests/ReadSpec.hs view
@@ -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
tests/ShowSpec.hs view
@@ -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 ()
tests/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
tests/Types/EqOrd.hs view
@@ -1,296 +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) -$(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 +{-# 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
tests/Types/ReadShow.hs view
@@ -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