deriving-compat 0.6.1 → 0.6.2
raw patch · 41 files changed
+10070/−10066 lines, 41 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Deriving.Internal: eqInt32HashValName :: Name
+ Data.Deriving.Internal: eqWord32HashValName :: Name
+ Data.Deriving.Internal: geInt32HashValName :: Name
+ Data.Deriving.Internal: geWord32HashValName :: Name
+ Data.Deriving.Internal: gtInt32HashValName :: Name
+ Data.Deriving.Internal: gtWord32HashValName :: Name
+ Data.Deriving.Internal: int32HashTypeName :: Name
+ Data.Deriving.Internal: int32ToIntHashValName :: Name
+ Data.Deriving.Internal: intToInt32HashValName :: Name
+ Data.Deriving.Internal: leInt32HashValName :: Name
+ Data.Deriving.Internal: leWord32HashValName :: Name
+ Data.Deriving.Internal: ltInt32HashValName :: Name
+ Data.Deriving.Internal: ltWord32HashValName :: Name
+ Data.Deriving.Internal: word32HashTypeName :: Name
+ Data.Deriving.Internal: word32ToWordHashValName :: Name
+ Data.Deriving.Internal: wordToWord32HashValName :: Name
Files
- CHANGELOG.md +176/−173
- LICENSE +30/−30
- README.md +42/−42
- Setup.hs +2/−2
- deriving-compat.cabal +214/−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 +2304/−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/−295
- tests/Types/ReadShow.hs +214/−214
CHANGELOG.md view
@@ -1,173 +1,176 @@-### 0.6.1 [2022.05.07]-* Backport [GHC!6955](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6955),- which makes derived `Eq` instances check data constructor tags, which can- improve runtime performance for data types with nullary constructors.-* Allow building the test suite with `transformers-0.6.*`.--## 0.6 [2021.08.29]-* Allow building with `template-haskell-2.18.0.0` (GHC 9.2).-* Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may- now require the use of the `TypeInType` extension if using GHC 8.0, 8.2, or- 8.4. (On later versions of GHC, `TypeInType`'s functionality has been folded- into `PolyKinds`.)-* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields- of type `Int32#` or `Word32#` on GHC 9.2 or later.-* `deriveVia` now instantiates "floating" `via` type variables (i.e., type- variables mentioned in the `via` type that are not mentioned in the instance- context or the first argument to `Via`) to `Any` in the generated code. As a- result, `deriveVia` no longer generates code that produces `-Wunused-foralls`- warnings.--### 0.5.10 [2020.09.30]-* Allow building with `template-haskell-2.17.0.0` (GHC 9.0).--### 0.5.9 [2019.06.08]-* Have `deriveFunctor` and `deriveFoldable` derive implementations of `(<$)`- and `null`, which GHC starting doing in 8.2 and 8.4, respectively.-* Fix a bug in which `deriveOrd{,1,2}` could generate incorrect code for data- types with a combination of nullary and non-nullary constructors.-* Fix a bug in which `deriveFunctor` would fail on sufficiently complex uses- of rank-n types in constructor fields.-* Fix a bug in which `deriveFunctor` and related functions would needlessly- reject data types whose last type parameters appear as oversaturated- arguments to a type family.--### 0.5.8 [2019.11.26]-* Allow building with GHC 8.10.--### 0.5.7 [2019.08.27]-* Permit `deriveVia` to use "floating" `via` type variables, such as the `a`- in:-- ```hs- deriveVia [t| forall a. Show MyInt `Via` Const Int a |]- ```--### 0.5.6 [2019.05.02]-* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields- of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later.--### 0.5.5 [2019.04.26]-* Support `th-abstraction-0.3` or later.--### 0.5.4 [2019.01.21]-* Expose `Internal` modules.--### 0.5.3 [2019.01.20]-* Fix a bug in which `deriveEnum`/`deriveIx` would generate ill-scoped code- for certain poly-kinded data types.--### 0.5.2 [2018.09.13]-* Fix a bug (on GHC 8.7 and above) in which `deriveGND`/`deriveVia` would- generate ill-scoped code.--### 0.5.1 [2018.07.11]-* Have `deriveGND`/`deriveVia` throw an error if an incorrect number of- arguments are supplied to the type class.--## 0.5 [2018.07.01]-* Backport the changes to `GeneralizedNewtypeDeriving` and `DerivingVia` code- generation from- [Trac #15290](https://ghc.haskell.org/trac/ghc/ticket/15290).-- As a result, code generated by `deriveGND` or `deriveVia` now requires the- `InstanceSigs` and `ScopedTypeVariables` language extensions. On the other- hand, the generated code no longer requires the `ImpredicativeTypes`- extension (unless any class methods use higher-rank types).-* Allow building with `containers-0.6` and `template-haskell-2.14`.--### 0.4.3 [2018.06.16]-* Fix a bug that caused debug-enabled GHC builds to panic when generating- code from this library (see- [Trac #15270](https://ghc.haskell.org/trac/ghc/ticket/15270)).- The fix only affects the library's internals, so no changes are user-facing.--### 0.4.2 [2018.05.14]-* Backport the fixes for GHC Trac- [#14364](https://ghc.haskell.org/trac/ghc/ticket/14364)- and- [#14918](https://ghc.haskell.org/trac/ghc/ticket/14918),- which significantly improve the compliation times of derived `Read`- instances.--### 0.4.1 [2018.02.04]-* Add `Data.Deriving.Via`, which allows emulating the behavior of the- `GeneralizedNewtypeDeriving` and `DerivingVia` extensions.-* Test suite fixes for GHC 8.4.--## 0.4 [2017.12.07]-* Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC- as of 8.4):- * For derived `Eq` and `Ord` instances for empty data types, simply return- `True` and `EQ`, respectively, without inspecting the arguments.- * For derived `Read` instances for empty data types, simply return `pfail`- (without `parens`).- * For derived `Show` instances for empty data types, inspect the argument- (instead of `error`ing). In addition, add `showEmptyCaseBehavior` to- `ShowOptions`, which configures whether derived instances for empty data- types should use the `EmptyCase` extension (this is disabled by default).- * For derived `Functor` and `Traversable` instances for empty data- types, make `fmap` and `traverse` strict in its argument.- * For derived `Foldable` instances, do not error on empty data types.- Instead, simply return the folded state (for `foldr`) or `mempty` (for- `foldMap`), without inspecting the arguments.- * Add `FFTOptions` (`Functor`/`Foldable`/`Traversable` options) to- `Data.Functor.Deriving`, along with variants of existing functions that- take `FFTOptions` as an argument. For now, the only configurable option is- whether derived instances for empty data types should use the `EmptyCase`- extension (this is disabled by default).-* Backport the fix to #13328. That is, when deriving `Functor` or- `Traversable` instances for data types where the last type variable is at- phantom role, generated `fmap`/`traverse` implementations now use `coerce`- for efficiency.-* Rename `emptyCaseBehavior` from `Data.Functor.Deriving` to- `fftEmptyCaseBehavior`.--### 0.3.6 [2017.04.10]-* Make `deriveTraversable` use `liftA2` in derived implementations of- `traverse` when possible, now that `liftA2` is a class method of- `Applicative` (as of GHC 8.2)-* Make `deriveShow` use `showCommaSpace`, a change introduced in GHC 8.2--### 0.3.5 [2016.12.12]-* Fix bug in which derived `Ord` instances for datatypes with many constructors- would fail to typecheck--### 0.3.4 [2016.10.20]-* Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances-* Fix bug in which record selectors weren't parsed correctly in derived `Read` instances--### 0.3.3 [2016.09.11]-* Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH.-* Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH.-* Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH.-* Fix bug in which derived `Show` instance would parenthesize the output too eagerly--### 0.3.2-* Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2-* Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods-* Fix GHC HEAD build--### 0.3.1-* Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples-* Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show`--## 0.3-* Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH.-* Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH.-* Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH.-* Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules.--### 0.2.2-* Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types--### 0.2.1-* Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH.--## 0.2-* Added support for GHC 8.0-* Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH.-* Added `Data.Deriving`, which reexports all other modules--## 0.1-* Initial commit+### 0.6.2 [2022.12.07] +* Make the test suite build with GHC 9.6 or later. + +### 0.6.1 [2022.05.07] +* Backport [GHC!6955](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6955), + which makes derived `Eq` instances check data constructor tags, which can + improve runtime performance for data types with nullary constructors. +* Allow building the test suite with `transformers-0.6.*`. + +## 0.6 [2021.08.29] +* Allow building with `template-haskell-2.18.0.0` (GHC 9.2). +* Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may + now require the use of the `TypeInType` extension if using GHC 8.0, 8.2, or + 8.4. (On later versions of GHC, `TypeInType`'s functionality has been folded + into `PolyKinds`.) +* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields + of type `Int32#` or `Word32#` on GHC 9.2 or later. +* `deriveVia` now instantiates "floating" `via` type variables (i.e., type + variables mentioned in the `via` type that are not mentioned in the instance + context or the first argument to `Via`) to `Any` in the generated code. As a + result, `deriveVia` no longer generates code that produces `-Wunused-foralls` + warnings. + +### 0.5.10 [2020.09.30] +* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). + +### 0.5.9 [2019.06.08] +* Have `deriveFunctor` and `deriveFoldable` derive implementations of `(<$)` + and `null`, which GHC starting doing in 8.2 and 8.4, respectively. +* Fix a bug in which `deriveOrd{,1,2}` could generate incorrect code for data + types with a combination of nullary and non-nullary constructors. +* Fix a bug in which `deriveFunctor` would fail on sufficiently complex uses + of rank-n types in constructor fields. +* Fix a bug in which `deriveFunctor` and related functions would needlessly + reject data types whose last type parameters appear as oversaturated + arguments to a type family. + +### 0.5.8 [2019.11.26] +* Allow building with GHC 8.10. + +### 0.5.7 [2019.08.27] +* Permit `deriveVia` to use "floating" `via` type variables, such as the `a` + in: + + ```hs + deriveVia [t| forall a. Show MyInt `Via` Const Int a |] + ``` + +### 0.5.6 [2019.05.02] +* Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields + of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later. + +### 0.5.5 [2019.04.26] +* Support `th-abstraction-0.3` or later. + +### 0.5.4 [2019.01.21] +* Expose `Internal` modules. + +### 0.5.3 [2019.01.20] +* Fix a bug in which `deriveEnum`/`deriveIx` would generate ill-scoped code + for certain poly-kinded data types. + +### 0.5.2 [2018.09.13] +* Fix a bug (on GHC 8.7 and above) in which `deriveGND`/`deriveVia` would + generate ill-scoped code. + +### 0.5.1 [2018.07.11] +* Have `deriveGND`/`deriveVia` throw an error if an incorrect number of + arguments are supplied to the type class. + +## 0.5 [2018.07.01] +* Backport the changes to `GeneralizedNewtypeDeriving` and `DerivingVia` code + generation from + [Trac #15290](https://ghc.haskell.org/trac/ghc/ticket/15290). + + As a result, code generated by `deriveGND` or `deriveVia` now requires the + `InstanceSigs` and `ScopedTypeVariables` language extensions. On the other + hand, the generated code no longer requires the `ImpredicativeTypes` + extension (unless any class methods use higher-rank types). +* Allow building with `containers-0.6` and `template-haskell-2.14`. + +### 0.4.3 [2018.06.16] +* Fix a bug that caused debug-enabled GHC builds to panic when generating + code from this library (see + [Trac #15270](https://ghc.haskell.org/trac/ghc/ticket/15270)). + The fix only affects the library's internals, so no changes are user-facing. + +### 0.4.2 [2018.05.14] +* Backport the fixes for GHC Trac + [#14364](https://ghc.haskell.org/trac/ghc/ticket/14364) + and + [#14918](https://ghc.haskell.org/trac/ghc/ticket/14918), + which significantly improve the compliation times of derived `Read` + instances. + +### 0.4.1 [2018.02.04] +* Add `Data.Deriving.Via`, which allows emulating the behavior of the + `GeneralizedNewtypeDeriving` and `DerivingVia` extensions. +* Test suite fixes for GHC 8.4. + +## 0.4 [2017.12.07] +* Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC + as of 8.4): + * For derived `Eq` and `Ord` instances for empty data types, simply return + `True` and `EQ`, respectively, without inspecting the arguments. + * For derived `Read` instances for empty data types, simply return `pfail` + (without `parens`). + * For derived `Show` instances for empty data types, inspect the argument + (instead of `error`ing). In addition, add `showEmptyCaseBehavior` to + `ShowOptions`, which configures whether derived instances for empty data + types should use the `EmptyCase` extension (this is disabled by default). + * For derived `Functor` and `Traversable` instances for empty data + types, make `fmap` and `traverse` strict in its argument. + * For derived `Foldable` instances, do not error on empty data types. + Instead, simply return the folded state (for `foldr`) or `mempty` (for + `foldMap`), without inspecting the arguments. + * Add `FFTOptions` (`Functor`/`Foldable`/`Traversable` options) to + `Data.Functor.Deriving`, along with variants of existing functions that + take `FFTOptions` as an argument. For now, the only configurable option is + whether derived instances for empty data types should use the `EmptyCase` + extension (this is disabled by default). +* Backport the fix to #13328. That is, when deriving `Functor` or + `Traversable` instances for data types where the last type variable is at + phantom role, generated `fmap`/`traverse` implementations now use `coerce` + for efficiency. +* Rename `emptyCaseBehavior` from `Data.Functor.Deriving` to + `fftEmptyCaseBehavior`. + +### 0.3.6 [2017.04.10] +* Make `deriveTraversable` use `liftA2` in derived implementations of + `traverse` when possible, now that `liftA2` is a class method of + `Applicative` (as of GHC 8.2) +* Make `deriveShow` use `showCommaSpace`, a change introduced in GHC 8.2 + +### 0.3.5 [2016.12.12] +* Fix bug in which derived `Ord` instances for datatypes with many constructors + would fail to typecheck + +### 0.3.4 [2016.10.20] +* Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances +* Fix bug in which record selectors weren't parsed correctly in derived `Read` instances + +### 0.3.3 [2016.09.11] +* Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH. +* Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH. +* Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH. +* Fix bug in which derived `Show` instance would parenthesize the output too eagerly + +### 0.3.2 +* Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2 +* Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods +* Fix GHC HEAD build + +### 0.3.1 +* Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples +* Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show` + +## 0.3 +* Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH. +* Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH. +* Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH. +* Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules. + +### 0.2.2 +* Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types + +### 0.2.1 +* Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH. + +## 0.2 +* Added support for GHC 8.0 +* Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH. +* Added `Data.Deriving`, which reexports all other modules + +## 0.1 +* Initial commit
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,214 @@-name: deriving-compat-version: 0.6.1-synopsis: Backports of GHC deriving extensions-description: @deriving-compat@ provides Template Haskell functions that- mimic @deriving@ extensions that were introduced or modified- in recent versions of GHC. Currently, the following- typeclasses/extensions are covered:- .- * Deriving @Bounded@- .- * Deriving @Enum@- .- * Deriving @Ix@- .- * Deriving @Eq@- .- * Deriving @Ord@- .- * Deriving @Read@- .- * Deriving @Show@- .- * @DeriveFoldable@- .- * @DeriveFunctor@- .- * @DeriveTraversable@- .- * @GeneralizedNewtypeDeriving@ (with GHC 8.2 or later)- .- * @DerivingVia@ (with GHC 8.2 or later)- .- See the "Data.Deriving" module for a full list of backported changes.- .- In addition, @deriving-compat@ also provides some additional- @deriving@ functionality that has not yet been merged into- upstream GHC. Aside from the GHC @deriving@ extensions- mentioned above, @deriving-compat@ also permits deriving- instances of classes in the @Data.Functor.Classes@ module,- covering the @Eq1@, @Eq2@, @Ord1@, @Ord2@, @Read1@,- @Read2@, @Show1@, and @Show2@ classes. This extra- functionality is outside of the main scope of- @deriving-compat@, as it does not backport extensions that- exist in today's GHC. Nevertheless, the underlying Template- Haskell machinery needed to derive @Eq@ and friends- extends very naturally to @Eq1@ and friends, so this extra- functionality is included in @deriving-compat@ as a- convenience.- .- Note that some recent GHC typeclasses/extensions are not covered by this package:- .- * @DeriveDataTypeable@- .- * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving- @Generic@ instances, and modified in GHC 7.6 to allow derivation- of @Generic1@ instances. Use @Generics.Deriving.TH@ from- @<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.19- , ghc-boot-th- else- build-depends: template-haskell >= 2.5 && < 2.11-- if flag(new-functor-classes)- build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7)- , transformers-compat >= 0.5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: transformers == 0.4.*-- hs-source-dirs: src- default-language: Haskell2010- ghc-options: -Wall--test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules: BoundedEnumIxSpec- DerivingViaSpec- EqSpec- FunctorSpec- OrdSpec- ReadSpec- ShowSpec- GH6Spec- GH24Spec- GH27Spec- GH31Spec-- Types.EqOrd- Types.ReadShow- build-depends: base-compat >= 0.8.1 && < 1- , base-orphans >= 0.5 && < 1- , deriving-compat- , hspec >= 1.8- , QuickCheck >= 2 && < 3- , tagged >= 0.7 && < 1- , template-haskell >= 2.5 && < 2.19- , void >= 0.5.10 && < 1- build-tool-depends: hspec-discover:hspec-discover >= 1.8-- if flag(base-4-9)- build-depends: base >= 4.9 && < 5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: base >= 4.3 && < 4.9-- if flag(new-functor-classes)- build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.7)- , transformers-compat >= 0.5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: transformers == 0.4.*-- hs-source-dirs: tests- default-language: Haskell2010- ghc-options: -Wall -threaded -rtsopts- if impl(ghc >= 8.6)- ghc-options: -Wno-star-is-type- if impl(ghc >= 9.0)- ghc-options: -fenable-th-splice-warnings+name: deriving-compat +version: 0.6.2 +synopsis: Backports of GHC deriving extensions +description: @deriving-compat@ provides Template Haskell functions that + mimic @deriving@ extensions that were introduced or modified + in recent versions of GHC. Currently, the following + typeclasses/extensions are covered: + . + * Deriving @Bounded@ + . + * Deriving @Enum@ + . + * Deriving @Ix@ + . + * Deriving @Eq@ + . + * Deriving @Ord@ + . + * Deriving @Read@ + . + * Deriving @Show@ + . + * @DeriveFoldable@ + . + * @DeriveFunctor@ + . + * @DeriveTraversable@ + . + * @GeneralizedNewtypeDeriving@ (with GHC 8.2 or later) + . + * @DerivingVia@ (with GHC 8.2 or later) + . + See the "Data.Deriving" module for a full list of backported changes. + . + In addition, @deriving-compat@ also provides some additional + @deriving@ functionality that has not yet been merged into + upstream GHC. Aside from the GHC @deriving@ extensions + mentioned above, @deriving-compat@ also permits deriving + instances of classes in the @Data.Functor.Classes@ module, + covering the @Eq1@, @Eq2@, @Ord1@, @Ord2@, @Read1@, + @Read2@, @Show1@, and @Show2@ classes. This extra + functionality is outside of the main scope of + @deriving-compat@, as it does not backport extensions that + exist in today's GHC. Nevertheless, the underlying Template + Haskell machinery needed to derive @Eq@ and friends + extends very naturally to @Eq1@ and friends, so this extra + functionality is included in @deriving-compat@ as a + convenience. + . + Note that some recent GHC typeclasses/extensions are not covered by this package: + . + * @DeriveDataTypeable@ + . + * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving + @Generic@ instances, and modified in GHC 7.6 to allow derivation + of @Generic1@ instances. Use @Generics.Deriving.TH@ from + @<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
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,2304 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MagicHash #-}--#if !(MIN_VERSION_base(4,9,0))-# if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE TemplateHaskellQuotes #-}-# else-{-# LANGUAGE TemplateHaskell #-}-# endif-#endif--{-|-Module: Data.Deriving.Internal-Copyright: (C) 2015-2017 Ryan Scott-License: BSD-style (see the file LICENSE)-Maintainer: Ryan Scott-Portability: Template Haskell--Template Haskell-related utilities.--Note: this is an internal module, and as such, the API presented here is not-guaranteed to be stable, even between minor releases of this library.--}-module Data.Deriving.Internal where--import Control.Applicative (liftA2)-import Control.Monad (when, unless)--import Data.Foldable (foldr')-#if !(MIN_VERSION_base(4,9,0))-import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..))-# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)-import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..))-# endif-#endif-import qualified Data.List as List-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Traversable as T--import Text.ParserCombinators.ReadPrec (ReadPrec)-import qualified Text.Read.Lex as L--#if MIN_VERSION_base(4,7,0)-import GHC.Read (expectP)-#else-import GHC.Read (lexP)--import Text.Read (pfail)-import Text.Read.Lex (Lexeme)-#endif--#if MIN_VERSION_ghc_prim(0,3,1)-import GHC.Prim (Int#, tagToEnum#)-#endif--#if defined(MIN_VERSION_ghc_boot_th)-import GHC.Lexeme (startsConSym, startsVarSym)-#else-import Data.Char (isSymbol, ord)-#endif--import Language.Haskell.TH.Datatype-import Language.Haskell.TH.Datatype.TyVarBndr-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr (pprint)-import Language.Haskell.TH.Syntax---- Ensure, beyond a shadow of a doubt, that the instances are in-scope-import Data.Functor ()-import Data.Functor.Classes ()-import Data.Foldable ()-import Data.Traversable ()--#ifndef CURRENT_PACKAGE_KEY-import Data.Version (showVersion)-import Paths_deriving_compat (version)-#endif------------------------------------------------------------------------------------ Expanding type synonyms----------------------------------------------------------------------------------applySubstitutionKind :: Map Name Kind -> Type -> Type-#if MIN_VERSION_template_haskell(2,8,0)-applySubstitutionKind = applySubstitution-#else-applySubstitutionKind _ t = t-#endif--substNameWithKind :: Name -> Kind -> Type -> Type-substNameWithKind n k = applySubstitutionKind (Map.singleton n k)--substNamesWithKindStar :: [Name] -> Type -> Type-substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns------------------------------------------------------------------------------------ Via------------------------------------------------------------------------------------ | A type-level modifier intended to be used in conjunction with 'deriveVia'.--- Refer to the documentation for 'deriveVia' for more details.-data a `Via` b-infix 0 `Via`------------------------------------------------------------------------------------ Type-specialized const functions----------------------------------------------------------------------------------fmapConst :: f b -> (a -> b) -> f a -> f b-fmapConst x _ _ = x-{-# INLINE fmapConst #-}--replaceConst :: f a -> a -> f b -> f a-replaceConst x _ _ = x-{-# INLINE replaceConst #-}--foldrConst :: b -> (a -> b -> b) -> b -> t a -> b-foldrConst x _ _ _ = x-{-# INLINE foldrConst #-}--foldMapConst :: m -> (a -> m) -> t a -> m-foldMapConst x _ _ = x-{-# INLINE foldMapConst #-}--nullConst :: Bool -> t a -> Bool-nullConst x _ = x-{-# INLINE nullConst #-}--traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b)-traverseConst x _ _ = x-{-# INLINE traverseConst #-}--eqConst :: Bool- -> a -> a -> Bool-eqConst x _ _ = x-{-# INLINE eqConst #-}--eq1Const :: Bool- -> f a -> f a-> Bool-eq1Const x _ _ = x-{-# INLINE eq1Const #-}--liftEqConst :: Bool- -> (a -> b -> Bool) -> f a -> f b -> Bool-liftEqConst x _ _ _ = x-{-# INLINE liftEqConst #-}--liftEq2Const :: Bool- -> (a -> b -> Bool) -> (c -> d -> Bool)- -> f a c -> f b d -> Bool-liftEq2Const x _ _ _ _ = x-{-# INLINE liftEq2Const #-}--compareConst :: Ordering -> a -> a -> Ordering-compareConst x _ _ = x-{-# INLINE compareConst #-}--ltConst :: Bool -> a -> a -> Bool-ltConst x _ _ = x-{-# INLINE ltConst #-}--compare1Const :: Ordering -> f a -> f a -> Ordering-compare1Const x _ _ = x-{-# INLINE compare1Const #-}--liftCompareConst :: Ordering- -> (a -> b -> Ordering) -> f a -> f b -> Ordering-liftCompareConst x _ _ _ = x-{-# INLINE liftCompareConst #-}--liftCompare2Const :: Ordering- -> (a -> b -> Ordering) -> (c -> d -> Ordering)- -> f a c -> f b d -> Ordering-liftCompare2Const x _ _ _ _ = x-{-# INLINE liftCompare2Const #-}--readsPrecConst :: ReadS a -> Int -> ReadS a-readsPrecConst x _ = x-{-# INLINE readsPrecConst #-}---- This isn't really necessary, but it makes for an easier implementation-readPrecConst :: ReadPrec a -> ReadPrec a-readPrecConst x = x-{-# INLINE readPrecConst #-}--readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a)-readsPrec1Const x _ = x-{-# INLINE readsPrec1Const #-}--liftReadsPrecConst :: ReadS (f a)- -> (Int -> ReadS a) -> ReadS [a]- -> Int -> ReadS (f a)-liftReadsPrecConst x _ _ _ = x-{-# INLINE liftReadsPrecConst #-}--liftReadPrecConst :: ReadPrec (f a)- -> ReadPrec a -> ReadPrec [a]- -> ReadPrec (f a)-liftReadPrecConst x _ _ = x-{-# INLINE liftReadPrecConst #-}--liftReadsPrec2Const :: ReadS (f a b)- -> (Int -> ReadS a) -> ReadS [a]- -> (Int -> ReadS b) -> ReadS [b]- -> Int -> ReadS (f a b)-liftReadsPrec2Const x _ _ _ _ _ = x-{-# INLINE liftReadsPrec2Const #-}--liftReadPrec2Const :: ReadPrec (f a b)- -> ReadPrec a -> ReadPrec [a]- -> ReadPrec b -> ReadPrec [b]- -> ReadPrec (f a b)-liftReadPrec2Const x _ _ _ _ = x-{-# INLINE liftReadPrec2Const #-}--showsPrecConst :: ShowS- -> Int -> a -> ShowS-showsPrecConst x _ _ = x-{-# INLINE showsPrecConst #-}--showsPrec1Const :: ShowS- -> Int -> f a -> ShowS-showsPrec1Const x _ _ = x-{-# INLINE showsPrec1Const #-}--liftShowsPrecConst :: ShowS- -> (Int -> a -> ShowS) -> ([a] -> ShowS)- -> Int -> f a -> ShowS-liftShowsPrecConst x _ _ _ _ = x-{-# INLINE liftShowsPrecConst #-}--liftShowsPrec2Const :: ShowS- -> (Int -> a -> ShowS) -> ([a] -> ShowS)- -> (Int -> b -> ShowS) -> ([b] -> ShowS)- -> Int -> f a b -> ShowS-liftShowsPrec2Const x _ _ _ _ _ _ = x-{-# INLINE liftShowsPrec2Const #-}------------------------------------------------------------------------------------ StarKindStatus------------------------------------------------------------------------------------ | Whether a type is not of kind *, is of kind *, or is a kind variable.-data StarKindStatus = NotKindStar- | KindStar- | IsKindVar Name- deriving Eq---- | Does a Type have kind * or k (for some kind variable k)?-canRealizeKindStar :: Type -> StarKindStatus-canRealizeKindStar t- | hasKindStar t = KindStar- | otherwise = case t of-#if MIN_VERSION_template_haskell(2,8,0)- SigT _ (VarT k) -> IsKindVar k-#endif- _ -> NotKindStar---- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.--- Otherwise, returns 'Nothing'.-starKindStatusToName :: StarKindStatus -> Maybe Name-starKindStatusToName (IsKindVar n) = Just n-starKindStatusToName _ = Nothing---- | Concat together all of the StarKindStatuses that are IsKindVar and extract--- the kind variables' Names out.-catKindVarNames :: [StarKindStatus] -> [Name]-catKindVarNames = mapMaybe starKindStatusToName------------------------------------------------------------------------------------ ClassRep----------------------------------------------------------------------------------class ClassRep a where- arity :: a -> Int- allowExQuant :: a -> Bool- fullClassName :: a -> Name- classConstraint :: a -> Int -> Maybe Name------------------------------------------------------------------------------------ Template Haskell reifying and AST manipulation------------------------------------------------------------------------------------ For the given Types, generate an instance context and head. Coming up with--- the instance type isn't as simple as dropping the last types, as you need to--- be wary of kinds being instantiated with *.--- See Note [Type inference in derived instances]-buildTypeInstance :: ClassRep a- => a- -- ^ The typeclass for which an instance should be derived- -> Name- -- ^ The type constructor or data family name- -> Cxt- -- ^ The datatype context- -> [Type]- -- ^ The types to instantiate the instance with- -> DatatypeVariant- -- ^ Are we dealing with a data family instance or not- -> Q (Cxt, Type)-buildTypeInstance cRep tyConName dataCxt varTysOrig variant = do- -- Make sure to expand through type/kind synonyms! Otherwise, the- -- eta-reduction check might get tripped up over type variables in a- -- synonym that are actually dropped.- -- (See GHC Trac #11416 for a scenario where this actually happened.)- varTysExp <- mapM resolveTypeSynonyms varTysOrig-- let remainingLength :: Int- remainingLength = length varTysOrig - arity cRep-- droppedTysExp :: [Type]- droppedTysExp = drop remainingLength varTysExp-- droppedStarKindStati :: [StarKindStatus]- droppedStarKindStati = map canRealizeKindStar droppedTysExp-- -- Check there are enough types to drop and that all of them are either of- -- kind * or kind k (for some kind variable k). If not, throw an error.- when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $- derivingKindError cRep tyConName-- let droppedKindVarNames :: [Name]- droppedKindVarNames = catKindVarNames droppedStarKindStati-- -- Substitute kind * for any dropped kind variables- varTysExpSubst :: [Type]- varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp-- remainingTysExpSubst, droppedTysExpSubst :: [Type]- (remainingTysExpSubst, droppedTysExpSubst) =- splitAt remainingLength varTysExpSubst-- -- All of the type variables mentioned in the dropped types- -- (post-synonym expansion)- droppedTyVarNames :: [Name]- droppedTyVarNames = freeVariables droppedTysExpSubst-- -- If any of the dropped types were polykinded, ensure that they are of kind *- -- after substituting * for the dropped kind variables. If not, throw an error.- unless (all hasKindStar droppedTysExpSubst) $- derivingKindError cRep tyConName-- let preds :: [Maybe Pred]- kvNames :: [[Name]]- kvNames' :: [Name]- -- Derive instance constraints (and any kind variables which are specialized- -- to * in those constraints)- (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst- kvNames' = concat kvNames-- -- Substitute the kind variables specialized in the constraints with *- remainingTysExpSubst' :: [Type]- remainingTysExpSubst' =- map (substNamesWithKindStar kvNames') remainingTysExpSubst-- -- We now substitute all of the specialized-to-* kind variable names with- -- *, but in the original types, not the synonym-expanded types. The reason- -- we do this is a superficial one: we want the derived instance to resemble- -- the datatype written in source code as closely as possible. For example,- -- for the following data family instance:- --- -- data family Fam a- -- newtype instance Fam String = Fam String- --- -- We'd want to generate the instance:- --- -- instance C (Fam String)- --- -- Not:- --- -- instance C (Fam [Char])- remainingTysOrigSubst :: [Type]- remainingTysOrigSubst =- map (substNamesWithKindStar (List.union droppedKindVarNames kvNames'))- $ take remainingLength varTysOrig-- isDataFamily :: Bool- isDataFamily = case variant of- Datatype -> False- Newtype -> False- DataInstance -> True- NewtypeInstance -> True-- remainingTysOrigSubst' :: [Type]- -- See Note [Kind signatures in derived instances] for an explanation- -- of the isDataFamily check.- remainingTysOrigSubst' =- if isDataFamily- then remainingTysOrigSubst- else map unSigT remainingTysOrigSubst-- instanceCxt :: Cxt- instanceCxt = catMaybes preds-- instanceType :: Type- instanceType = AppT (ConT (fullClassName cRep))- $ applyTyCon tyConName remainingTysOrigSubst'-- -- If the datatype context mentions any of the dropped type variables,- -- we can't derive an instance, so throw an error.- when (any (`predMentionsName` droppedTyVarNames) dataCxt) $- datatypeContextError tyConName instanceType- -- Also ensure the dropped types can be safely eta-reduced. Otherwise,- -- throw an error.- unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $- etaReductionError instanceType- return (instanceCxt, instanceType)---- | Attempt to derive a constraint on a Type. If successful, return--- Just the constraint and any kind variable names constrained to *.--- Otherwise, return Nothing and the empty list.------ See Note [Type inference in derived instances] for the heuristics used to--- come up with constraints.-deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name])-deriveConstraint cRep t- | not (isTyVar t) = (Nothing, [])- | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, [])- | otherwise = case hasKindVarChain 1 t of- Just ns | cRepArity >= 1- -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns)- _ -> case hasKindVarChain 2 t of- Just ns | cRepArity == 2- -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns)- _ -> (Nothing, [])- where- tName :: Name- tName = varTToName t-- cRepArity :: Int- cRepArity = arity cRep--{--Note [Kind signatures in derived instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is possible to put explicit kind signatures into the derived instances, e.g.,-- instance C a => C (Data (f :: * -> *)) where ...--But it is preferable to avoid this if possible. If we come up with an incorrect-kind signature (which is entirely possible, since our type inferencer is pretty-unsophisticated - see Note [Type inference in derived instances]), then GHC will-flat-out reject the instance, which is quite unfortunate.--Plain old datatypes have the advantage that you can avoid using any kind signatures-at all in their instances. This is because a datatype declaration uses all type-variables, so the types that we use in a derived instance uniquely determine their-kinds. As long as we plug in the right types, the kind inferencer can do the rest-of the work. For this reason, we use unSigT to remove all kind signatures before-splicing in the instance context and head.--Data family instances are trickier, since a data family can have two instances that-are distinguished by kind alone, e.g.,-- data family Fam (a :: k)- data instance Fam (a :: * -> *)- data instance Fam (a :: *)--If we dropped the kind signatures for C (Fam a), then GHC will have no way of-knowing which instance we are talking about. To avoid this scenario, we always-include explicit kind signatures in data family instances. There is a chance that-the inferred kind signatures will be incorrect, but if so, we can always fall back-on the make- functions.--Note [Type inference in derived instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Type inference is can be tricky to get right, and we want to avoid recreating the-entirety of GHC's type inferencer in Template Haskell. For this reason, we will-probably never come up with derived instance contexts that are as accurate as-GHC's. But that doesn't mean we can't do anything! There are a couple of simple-things we can do to make instance contexts that work for 80% of use cases:--1. If one of the last type parameters is polykinded, then its kind will be- specialized to * in the derived instance. We note what kind variable the type- parameter had and substitute it with * in the other types as well. For example,- imagine you had-- data Data (a :: k) (b :: k)-- Then you'd want to derived instance to be:-- instance C (Data (a :: *))-- Not:-- instance C (Data (a :: k))--2. We naïvely come up with instance constraints using the following criteria, using- Show(1)(2) as the example typeclasses:-- (i) If there's a type parameter n of kind *, generate a Show n constraint.- (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind- variables), then generate a Show1 n constraint, and if k1/k2 are kind- variables, then substitute k1/k2 with * elsewhere in the types. We must- consider the case where they are kind variables because you might have a- scenario like this:-- newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)- = Compose (f (g a))-- Which would have a derived Show1 instance of:-- instance (Show1 f, Show1 g) => Show1 (Compose f g) where ...- (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are- * or kind variables), then generate a Show2 constraint and perform- kind substitution as in the other cases.--}--checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name- -> Q c -> Q c-checkExistentialContext cRep tvMap ctxt conName q =- if (any (`predMentionsName` Map.keys tvMap) ctxt- || Map.size tvMap < arity cRep)- && not (allowExQuant cRep)- then existentialContextError conName- else q--{--Note [Matching functions with GADT type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When deriving category-2 classes like Show2, there is a tricky corner case to consider:-- data Both a b where- BothCon :: x -> x -> Both x x--Which show functions should be applied to which arguments of BothCon? We have a-choice, since both the function of type (Int -> a -> ShowS) and of type-(Int -> b -> ShowS) can be applied to either argument. In such a scenario, the-second show function takes precedence over the first show function, so the-derived Show2 instance would be:-- instance Show2 Both where- liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) =- showsParen (p > appPrec) $- showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2--This is not an arbitrary choice, as this definition ensures that-liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for-Both.--}------------------------------------------------------------------------------------ Error messages------------------------------------------------------------------------------------ | The given datatype has no constructors, and we don't know what to do with it.-noConstructorsError :: Q a-noConstructorsError = fail "Must have at least one data constructor"---- | Either the given data type doesn't have enough type variables, or one of--- the type variables to be eta-reduced cannot realize kind *.-derivingKindError :: ClassRep a => a -> Name -> Q b-derivingKindError cRep tyConName = fail- . showString "Cannot derive well-kinded instance of form ‘"- . showString className- . showChar ' '- . showParen True- ( showString (nameBase tyConName)- . showString " ..."- )- . showString "‘\n\tClass "- . showString className- . showString " expects an argument of kind "- . showString (pprint . createKindChain $ arity cRep)- $ ""- where- className :: String- className = nameBase $ fullClassName cRep---- | The last type variable appeared in a contravariant position--- when deriving Functor.-contravarianceError :: Name -> Q a-contravarianceError conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must not use the last type variable in a function argument"- $ ""---- | A constructor has a function argument in a derived Foldable or Traversable--- instance.-noFunctionsError :: Name -> Q a-noFunctionsError conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must not contain function types"- $ ""---- | One of the last type variables cannot be eta-reduced (see the canEtaReduce--- function for the criteria it would have to meet).-etaReductionError :: Type -> Q a-etaReductionError instanceType = fail $- "Cannot eta-reduce to an instance of form \n\tinstance (...) => "- ++ pprint instanceType---- | The data type has a DatatypeContext which mentions one of the eta-reduced--- type variables.-datatypeContextError :: Name -> Type -> Q a-datatypeContextError dataName instanceType = fail- . showString "Can't make a derived instance of ‘"- . showString (pprint instanceType)- . showString "‘:\n\tData type ‘"- . showString (nameBase dataName)- . showString "‘ must not have a class context involving the last type argument(s)"- $ ""---- | The data type has an existential constraint which mentions one of the--- eta-reduced type variables.-existentialContextError :: Name -> Q a-existentialContextError conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must be truly polymorphic in the last argument(s) of the data type"- $ ""---- | The data type mentions one of the n eta-reduced type variables in a place other--- than the last nth positions of a data type in a constructor's field.-outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b-outOfPlaceTyVarError cRep conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must only use its last "- . shows n- . showString " type variable(s) within the last "- . shows n- . showString " argument(s) of a data type"- $ ""- where- n :: Int- n = arity cRep--enumerationError :: String -> Q a-enumerationError = fail . enumerationErrorStr--enumerationOrProductError :: String -> Q a-enumerationOrProductError nb = fail $ unlines- [ enumerationErrorStr nb- , "\tor a product type (precisely one constructor)"- ]--enumerationErrorStr :: String -> String-enumerationErrorStr nb =- '\'':nb ++ "’ must be an enumeration type"- ++ " (one or more nullary, non-GADT constructors)"------------------------------------------------------------------------------------ Assorted utilities------------------------------------------------------------------------------------ | A mapping of type variable Names to their auxiliary function Names.-type TyVarMap a = Map Name (OneOrTwoNames a)-type TyVarMap1 = TyVarMap One-type TyVarMap2 = TyVarMap Two--data OneOrTwoNames a where- OneName :: Name -> OneOrTwoNames One- TwoNames :: Name -> Name -> OneOrTwoNames Two--data One-data Two--interleave :: [a] -> [a] -> [a]-interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s-interleave _ _ = []--#if MIN_VERSION_ghc_prim(0,3,1)-isTrue# :: Int# -> Bool-isTrue# x = tagToEnum# x-#else-isTrue# :: Bool -> Bool-isTrue# x = x-#endif-{-# INLINE isTrue# #-}---- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed)---- | 'filterByList' takes a list of Bools and a list of some elements and--- filters out these elements for which the corresponding value in the list of--- Bools is False. This function does not check whether the lists have equal--- length.-filterByList :: [Bool] -> [a] -> [a]-filterByList (True:bs) (x:xs) = x : filterByList bs xs-filterByList (False:bs) (_:xs) = filterByList bs xs-filterByList _ _ = []---- | 'filterByLists' takes a list of Bools and two lists as input, and--- outputs a new list consisting of elements from the last two input lists. For--- each Bool in the list, if it is 'True', then it takes an element from the--- former list. If it is 'False', it takes an element from the latter list.--- The elements taken correspond to the index of the Bool in its list.--- For example:------ @--- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"--- @------ This function does not check whether the lists have equal length.-filterByLists :: [Bool] -> [a] -> [a] -> [a]-filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys-filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys-filterByLists _ _ _ = []---- | 'partitionByList' takes a list of Bools and a list of some elements and--- partitions the list according to the list of Bools. Elements corresponding--- to 'True' go to the left; elements corresponding to 'False' go to the right.--- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@--- This function does not check whether the lists have equal--- length.-partitionByList :: [Bool] -> [a] -> ([a], [a])-partitionByList = go [] []- where- go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs- go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs- go trues falses _ _ = (reverse trues, reverse falses)--integerE :: Int -> Q Exp-integerE = litE . integerL . fromIntegral---- | Returns True if a Type has kind *.-hasKindStar :: Type -> Bool-hasKindStar VarT{} = True-#if MIN_VERSION_template_haskell(2,8,0)-hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif-hasKindStar _ = False---- Returns True is a kind is equal to *, or if it is a kind variable.-isStarOrVar :: Kind -> Bool-#if MIN_VERSION_template_haskell(2,8,0)-isStarOrVar StarT = True-isStarOrVar VarT{} = True-#else-isStarOrVar StarK = True-#endif-isStarOrVar _ = False---- | @hasKindVarChain n kind@ Checks if @kind@ is of the form--- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or--- kind variables.-hasKindVarChain :: Int -> Type -> Maybe [Name]-hasKindVarChain kindArrows t =- let uk = uncurryKind (tyKind t)- in if (length uk - 1 == kindArrows) && all isStarOrVar uk- then Just (freeVariables uk)- else Nothing---- | If a Type is a SigT, returns its kind signature. Otherwise, return *.-tyKind :: Type -> Kind-tyKind (SigT _ k) = k-tyKind _ = starK--zipWithAndUnzipM :: Monad m- => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])-zipWithAndUnzipM f (x:xs) (y:ys) = do- (c, d) <- f x y- (cs, ds) <- zipWithAndUnzipM f xs ys- return (c:cs, d:ds)-zipWithAndUnzipM _ _ _ = return ([], [])-{-# INLINE zipWithAndUnzipM #-}--zipWith3AndUnzipM :: Monad m- => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c]- -> m ([d], [e])-zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do- (d, e) <- f x y z- (ds, es) <- zipWith3AndUnzipM f xs ys zs- return (d:ds, e:es)-zipWith3AndUnzipM _ _ _ _ = return ([], [])-{-# INLINE zipWith3AndUnzipM #-}--thd3 :: (a, b, c) -> c-thd3 (_, _, c) = c--unsnoc :: [a] -> Maybe ([a], a)-unsnoc [] = Nothing-unsnoc (x:xs) = case unsnoc xs of- Nothing -> Just ([], x)- Just (a,b) -> Just (x:a, b)--isNullaryCon :: ConstructorInfo -> Bool-isNullaryCon (ConstructorInfo { constructorFields = tys }) = null tys---- | Returns the number of fields for the constructor.-conArity :: ConstructorInfo -> Int-conArity (ConstructorInfo { constructorFields = tys }) = length tys---- | Returns 'True' if it's a datatype with exactly one, non-existential constructor.-isProductType :: [ConstructorInfo] -> Bool-isProductType [con] = null (constructorVars con)-isProductType _ = False---- | Returns 'True' if it's a datatype with one or more nullary, non-GADT--- constructors.-isEnumerationType :: [ConstructorInfo] -> Bool-isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons-isEnumerationType _ = False---- | Returns 'False' if we're dealing with existential quantification or GADTs.-isVanillaCon :: ConstructorInfo -> Bool-isVanillaCon (ConstructorInfo { constructorContext = ctxt, constructorVars = vars }) =- null ctxt && null vars---- | Generate a list of fresh names with a common prefix, and numbered suffixes.-newNameList :: String -> Int -> Q [Name]-newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]---- | Extracts the kind from a TyVarBndr.-tvbKind :: TyVarBndr_ flag -> Kind-tvbKind = elimTV (\_ -> starK) (\_ k -> k)---- | Convert a TyVarBndr to a Type.-tvbToType :: TyVarBndr_ flag -> Type-tvbToType = elimTV VarT (\n k -> SigT (VarT n) k)---- | Applies a typeclass constraint to a type.-applyClass :: Name -> Name -> Pred-#if MIN_VERSION_template_haskell(2,10,0)-applyClass con t = AppT (ConT con) (VarT t)-#else-applyClass con t = ClassP con [VarT t]-#endif--createKindChain :: Int -> Kind-createKindChain = go starK- where- go :: Kind -> Int -> Kind- go k !0 = k-#if MIN_VERSION_template_haskell(2,8,0)- go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)-#else- go k !n = go (ArrowK StarK k) (n - 1)-#endif---- | Checks to see if the last types in a data family instance can be safely eta---- reduced (i.e., dropped), given the other types. This checks for three conditions:------ (1) All of the dropped types are type variables--- (2) All of the dropped types are distinct--- (3) None of the remaining types mention any of the dropped types-canEtaReduce :: [Type] -> [Type] -> Bool-canEtaReduce remaining dropped =- all isTyVar dropped- && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type- -- didn't have an Ord instance until template-haskell-2.10.0.0- && not (any (`mentionsName` droppedNames) remaining)- where- droppedNames :: [Name]- droppedNames = map varTToName dropped---- | Extract the Name from a type constructor. If the argument Type is not a--- type variable, throw an error.-conTToName :: Type -> Name-conTToName (ConT n) = n-conTToName (SigT t _) = conTToName t-conTToName _ = error "Not a type constructor!"---- | Extract Just the Name from a type variable. If the argument Type is not a--- type variable, return Nothing.-varTToName_maybe :: Type -> Maybe Name-varTToName_maybe (VarT n) = Just n-varTToName_maybe (SigT t _) = varTToName_maybe t-varTToName_maybe _ = Nothing---- | Extract the Name from a type variable. If the argument Type is not a--- type variable, throw an error.-varTToName :: Type -> Name-varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe---- | Peel off a kind signature from a Type (if it has one).-unSigT :: Type -> Type-unSigT (SigT t _) = t-unSigT t = t---- | Is the given type a variable?-isTyVar :: Type -> Bool-isTyVar (VarT _) = True-isTyVar (SigT t _) = isTyVar t-isTyVar _ = False---- | Detect if a Name in a list of provided Names occurs as an argument to some--- type family. This makes an effort to exclude /oversaturated/ arguments to--- type families. For instance, if one declared the following type family:------ @--- type family F a :: Type -> Type--- @------ Then in the type @F a b@, we would consider @a@ to be an argument to @F@,--- but not @b@.-isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool-isInTypeFamilyApp names tyFun tyArgs =- case tyFun of- ConT tcName -> go tcName- _ -> return False- where- go :: Name -> Q Bool- go tcName = do- info <- reify tcName- case info of-#if MIN_VERSION_template_haskell(2,11,0)- FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _- -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ bndrs _) _- -> withinFirstArgs bndrs-#else- TyConI (FamilyD TypeFam _ bndrs _)- -> withinFirstArgs bndrs-#endif--#if MIN_VERSION_template_haskell(2,11,0)- FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _- -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,9,0)- FamilyI (ClosedTypeFamilyD _ bndrs _ _) _- -> withinFirstArgs bndrs-#endif-- _ -> return False- where- withinFirstArgs :: [a] -> Q Bool- withinFirstArgs bndrs =- let firstArgs = take (length bndrs) tyArgs- argFVs = freeVariables firstArgs- in return $ any (`elem` argFVs) names---- | Are all of the items in a list (which have an ordering) distinct?------ This uses Set (as opposed to nub) for better asymptotic time complexity.-allDistinct :: Ord a => [a] -> Bool-allDistinct = allDistinct' Set.empty- where- allDistinct' :: Ord a => Set a -> [a] -> Bool- allDistinct' uniqs (x:xs)- | x `Set.member` uniqs = False- | otherwise = allDistinct' (Set.insert x uniqs) xs- allDistinct' _ _ = True---- | Does the given type mention any of the Names in the list?-mentionsName :: Type -> [Name] -> Bool-mentionsName = go- where- go :: Type -> [Name] -> Bool- go (AppT t1 t2) names = go t1 names || go t2 names- go (SigT t _k) names = go t names-#if MIN_VERSION_template_haskell(2,8,0)- || go _k names-#endif- go (VarT n) names = n `elem` names- go _ _ = False---- | Does an instance predicate mention any of the Names in the list?-predMentionsName :: Pred -> [Name] -> Bool-#if MIN_VERSION_template_haskell(2,10,0)-predMentionsName = mentionsName-#else-predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys-predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names-#endif---- | Construct a type via curried application.-applyTy :: Type -> [Type] -> Type-applyTy = List.foldl' AppT---- | Fully applies a type constructor to its type variables.-applyTyCon :: Name -> [Type] -> Type-applyTyCon = applyTy . ConT---- | Split an applied type into its individual components. For example, this:------ @--- Either Int Char--- @------ would split to this:------ @--- [Either, Int, Char]--- @-unapplyTy :: Type -> (Type, [Type])-unapplyTy ty = go ty ty []- where- go :: Type -> Type -> [Type] -> (Type, [Type])- go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args)- go origTy (SigT ty' _) args = go origTy ty' args-#if MIN_VERSION_template_haskell(2,11,0)- go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args- go origTy (ParensT ty') args = go origTy ty' args-#endif- go origTy _ args = (origTy, args)---- | Split a type signature by the arrows on its spine. For example, this:------ @--- forall a b. (a ~ b) => (a -> b) -> Char -> ()--- @------ would split to this:------ @--- (a ~ b, [a -> b, Char, ()])--- @-uncurryTy :: Type -> (Cxt, [Type])-uncurryTy (AppT (AppT ArrowT t1) t2) =- let (ctxt, tys) = uncurryTy t2- in (ctxt, t1:tys)-uncurryTy (SigT t _) = uncurryTy t-uncurryTy (ForallT _ ctxt t) =- let (ctxt', tys) = uncurryTy t- in (ctxt ++ ctxt', tys)-uncurryTy t = ([], [t])----- | Like uncurryType, except on a kind level.-uncurryKind :: Kind -> [Kind]-#if MIN_VERSION_template_haskell(2,8,0)-uncurryKind = snd . uncurryTy-#else-uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2-uncurryKind k = [k]-#endif--untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp-untagExpr [] e = e-untagExpr ((untagThis, putTagHere) : more) e =- caseE (varE getTagValName `appE` varE untagThis)- [match (varP putTagHere)- (normalB $ untagExpr more e)- []]--tag2ConExpr :: Type -> Q Exp-tag2ConExpr ty = do- iHash <- newName "i#"- ty' <- freshenType ty- lam1E (conP iHashDataName [varP iHash]) $- varE tagToEnumHashValName `appE` varE iHash- `sigE` return (quantifyType ty')- -- tagToEnum# is a hack, and won't typecheck unless it's in the- -- immediate presence of a type ascription like so:- --- -- tagToEnum# x :: Foo- --- -- We have to be careful when dealing with datatypes with type- -- variables, since Template Haskell might reject the type variables- -- we use for being out-of-scope. To avoid this, we explicitly- -- collect the type variable binders and shove them into a ForallT- -- (using th-abstraction's quantifyType function). Also make sure- -- to freshen the bound type variables to avoid shadowed variable- -- warnings on old versions of GHC when -Wall is enabled.--primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name)-primOrdFunTbl = Map.fromList- [ (addrHashTypeName, ( ltAddrHashValName- , leAddrHashValName- , eqAddrHashValName- , geAddrHashValName- , gtAddrHashValName- ))- , (charHashTypeName, ( ltCharHashValName- , leCharHashValName- , eqCharHashValName- , geCharHashValName- , gtCharHashValName- ))- , (doubleHashTypeName, ( ltDoubleHashValName- , leDoubleHashValName- , eqDoubleHashValName- , geDoubleHashValName- , gtDoubleHashValName- ))- , (floatHashTypeName, ( ltFloatHashValName- , leFloatHashValName- , eqFloatHashValName- , geFloatHashValName- , gtFloatHashValName- ))- , (intHashTypeName, ( ltIntHashValName- , leIntHashValName- , eqIntHashValName- , geIntHashValName- , gtIntHashValName- ))- , (wordHashTypeName, ( ltWordHashValName- , leWordHashValName- , eqWordHashValName- , geWordHashValName- , gtWordHashValName- ))-#if MIN_VERSION_base(4,13,0)- , (int8HashTypeName, ( ltInt8HashValName- , leInt8HashValName- , eqInt8HashValName- , geInt8HashValName- , gtInt8HashValName- ))- , (int16HashTypeName, ( ltInt16HashValName- , leInt16HashValName- , eqInt16HashValName- , geInt16HashValName- , gtInt16HashValName- ))- , (word8HashTypeName, ( ltWord8HashValName- , leWord8HashValName- , eqWord8HashValName- , geWord8HashValName- , gtWord8HashValName- ))- , (word16HashTypeName, ( ltWord16HashValName- , leWord16HashValName- , eqWord16HashValName- , geWord16HashValName- , gtWord16HashValName- ))-#endif-#if MIN_VERSION_base(4,16,0)- , (int32HashTypeName, ( ltInt32HashValName- , leInt32HashValName- , eqInt32HashValName- , geInt32HashValName- , gtInt32HashValName- ))- , (word32HashTypeName, ( ltWord32HashValName- , leWord32HashValName- , eqWord32HashValName- , geWord32HashValName- , gtWord32HashValName- ))-#endif- ]--removeClassApp :: Type -> Type-removeClassApp (AppT _ t2) = t2-removeClassApp t = t---- This is an ugly, but unfortunately necessary hack on older versions of GHC which--- don't have a properly working newName. On those GHCs, even running newName on a--- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by--- appending an uncommonly used string to the end of the name. This isn't foolproof,--- since a user could freshen a variable named x and still have another x_' variable in--- scope, but at least it's unlikely.-freshen :: Name -> Q Name-freshen n = newName (nameBase n ++ "_'")--freshenType :: Type -> Q Type-freshenType t =- do let xs = [(n, VarT `fmap` freshen n) | n <- freeVariables t]- subst <- T.sequence (Map.fromList xs)- return (applySubstitution subst t)--enumFromToExpr :: Q Exp -> Q Exp -> Q Exp-enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t--primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp-primOpAppExpr e1 op e2 = varE isTrueHashValName `appE`- infixApp e1 (varE op) e2---- | Checks if a 'Name' represents a tuple type constructor (other than '()')-isNonUnitTuple :: Name -> Bool-isNonUnitTuple = isNonUnitTupleString . nameBase---- | Checks if a 'String' represents a tuple (other than '()')-isNonUnitTupleString :: String -> Bool-isNonUnitTupleString ('(':',':_) = True-isNonUnitTupleString _ = False---- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does--- it begin with a colon?).-isInfixDataCon :: String -> Bool-isInfixDataCon (':':_) = True-isInfixDataCon _ = False--isSym :: String -> Bool-isSym "" = False-isSym (c : _) = startsVarSym c || startsConSym c--#if !defined(MIN_VERSION_ghc_boot_th)-startsVarSym, startsConSym :: Char -> Bool-startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids-startsConSym c = c == ':' -- Infix data constructors--startsVarSymASCII :: Char -> Bool-startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"-#endif--ghc7'8OrLater :: Bool-#if __GLASGOW_HASKELL__ >= 708-ghc7'8OrLater = True-#else-ghc7'8OrLater = False-#endif------------------------------------------------------------------------------------ Manually quoted names------------------------------------------------------------------------------------ By manually generating these names we avoid needing to use the--- TemplateHaskell language extension when compiling the deriving-compat library.--- This allows the library to be used in stage1 cross-compilers.--derivingCompatPackageKey :: String-#ifdef CURRENT_PACKAGE_KEY-derivingCompatPackageKey = CURRENT_PACKAGE_KEY-#else-derivingCompatPackageKey = "deriving-compat-" ++ showVersion version-#endif--gHC_IX :: String-#if MIN_VERSION_base(4,14,0)-gHC_IX = "GHC.Ix"-#else-gHC_IX = "GHC.Arr"-#endif--mkDerivingCompatName_v :: String -> Name-mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal"--mkDerivingCompatName_tc :: String -> Name-mkDerivingCompatName_tc = mkNameG_tc derivingCompatPackageKey "Data.Deriving.Internal"--isTrueHashValName :: Name-isTrueHashValName = mkDerivingCompatName_v "isTrue#"--fmapConstValName :: Name-fmapConstValName = mkDerivingCompatName_v "fmapConst"--replaceConstValName :: Name-replaceConstValName = mkDerivingCompatName_v "replaceConst"--foldrConstValName :: Name-foldrConstValName = mkDerivingCompatName_v "foldrConst"--foldMapConstValName :: Name-foldMapConstValName = mkDerivingCompatName_v "foldMapConst"--nullConstValName :: Name-nullConstValName = mkDerivingCompatName_v "nullConst"--traverseConstValName :: Name-traverseConstValName = mkDerivingCompatName_v "traverseConst"--eqConstValName :: Name-eqConstValName = mkDerivingCompatName_v "eqConst"--eq1ConstValName :: Name-eq1ConstValName = mkDerivingCompatName_v "eq1Const"--liftEqConstValName :: Name-liftEqConstValName = mkDerivingCompatName_v "liftEqConst"--liftEq2ConstValName :: Name-liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const"--compareConstValName :: Name-compareConstValName = mkDerivingCompatName_v "compareConst"--ltConstValName :: Name-ltConstValName = mkDerivingCompatName_v "ltConst"--compare1ConstValName :: Name-compare1ConstValName = mkDerivingCompatName_v "compare1Const"--liftCompareConstValName :: Name-liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst"--liftCompare2ConstValName :: Name-liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const"--readsPrecConstValName :: Name-readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst"--readPrecConstValName :: Name-readPrecConstValName = mkDerivingCompatName_v "readPrecConst"--readsPrec1ConstValName :: Name-readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const"--liftReadsPrecConstValName :: Name-liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst"--liftReadPrecConstValName :: Name-liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst"--liftReadsPrec2ConstValName :: Name-liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const"--liftReadPrec2ConstValName :: Name-liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const"--showsPrecConstValName :: Name-showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst"--showsPrec1ConstValName :: Name-showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const"--liftShowsPrecConstValName :: Name-liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst"--liftShowsPrec2ConstValName :: Name-liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const"--viaTypeName :: Name-viaTypeName = mkDerivingCompatName_tc "Via"--cHashDataName :: Name-cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#"--dHashDataName :: Name-dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#"--fHashDataName :: Name-fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#"--identDataName :: Name-identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident"--iHashDataName :: Name-iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#"--puncDataName :: Name-puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc"--symbolDataName :: Name-symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol"--wrapMonadDataName :: Name-wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad"--addrHashTypeName :: Name-addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#"--boundedTypeName :: Name-boundedTypeName = mkNameG_tc "base" "GHC.Enum" "Bounded"--charHashTypeName :: Name-charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#"--doubleHashTypeName :: Name-doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#"--enumTypeName :: Name-enumTypeName = mkNameG_tc "base" "GHC.Enum" "Enum"--floatHashTypeName :: Name-floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#"--foldableTypeName :: Name-foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable"--functorTypeName :: Name-functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"--intTypeName :: Name-intTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Int"--intHashTypeName :: Name-intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#"--ixTypeName :: Name-ixTypeName = mkNameG_tc "base" gHC_IX "Ix"--readTypeName :: Name-readTypeName = mkNameG_tc "base" "GHC.Read" "Read"--showTypeName :: Name-showTypeName = mkNameG_tc "base" "GHC.Show" "Show"--traversableTypeName :: Name-traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"--wordHashTypeName :: Name-wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#"--altValName :: Name-altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++"--appendValName :: Name-appendValName = mkNameG_v "base" "GHC.Base" "++"--chooseValName :: Name-chooseValName = mkNameG_v "base" "GHC.Read" "choose"--coerceValName :: Name-coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"--composeValName :: Name-composeValName = mkNameG_v "base" "GHC.Base" "."--constValName :: Name-constValName = mkNameG_v "base" "GHC.Base" "const"--enumFromValName :: Name-enumFromValName = mkNameG_v "base" "GHC.Enum" "enumFrom"--enumFromThenValName :: Name-enumFromThenValName = mkNameG_v "base" "GHC.Enum" "enumFromThen"--enumFromThenToValName :: Name-enumFromThenToValName = mkNameG_v "base" "GHC.Enum" "enumFromThenTo"--enumFromToValName :: Name-enumFromToValName = mkNameG_v "base" "GHC.Enum" "enumFromTo"--eqAddrHashValName :: Name-eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#"--eqCharHashValName :: Name-eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#"--eqDoubleHashValName :: Name-eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##"--eqFloatHashValName :: Name-eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#"--eqIntHashValName :: Name-eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#"--eqWordHashValName :: Name-eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#"--errorValName :: Name-errorValName = mkNameG_v "base" "GHC.Err" "error"--flipValName :: Name-flipValName = mkNameG_v "base" "GHC.Base" "flip"--fmapValName :: Name-fmapValName = mkNameG_v "base" "GHC.Base" "fmap"--foldrValName :: Name-foldrValName = mkNameG_v "base" "Data.Foldable" "foldr"--foldMapValName :: Name-foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap"--fromEnumValName :: Name-fromEnumValName = mkNameG_v "base" "GHC.Enum" "fromEnum"--geAddrHashValName :: Name-geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#"--geCharHashValName :: Name-geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#"--geDoubleHashValName :: Name-geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##"--geFloatHashValName :: Name-geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#"--geIntHashValName :: Name-geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#"--getTagValName :: Name-getTagValName = mkNameG_v "base" "GHC.Base" "getTag"--geWordHashValName :: Name-geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#"--gtAddrHashValName :: Name-gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#"--gtCharHashValName :: Name-gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#"--gtDoubleHashValName :: Name-gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##"--gtFloatHashValName :: Name-gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#"--gtIntHashValName :: Name-gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#"--gtWordHashValName :: Name-gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#"--idValName :: Name-idValName = mkNameG_v "base" "GHC.Base" "id"--indexValName :: Name-indexValName = mkNameG_v "base" gHC_IX "index"--inRangeValName :: Name-inRangeValName = mkNameG_v "base" gHC_IX "inRange"--leAddrHashValName :: Name-leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#"--leCharHashValName :: Name-leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#"--leDoubleHashValName :: Name-leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##"--leFloatHashValName :: Name-leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#"--leIntHashValName :: Name-leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#"--leWordHashValName :: Name-leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#"--liftReadListPrecDefaultValName :: Name-liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault"--liftReadListPrec2DefaultValName :: Name-liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default"--liftReadListPrecValName :: Name-liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec"--liftReadListPrec2ValName :: Name-liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2"--liftReadPrecValName :: Name-liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec"--liftReadPrec2ValName :: Name-liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2"--listValName :: Name-listValName = mkNameG_v "base" "GHC.Read" "list"--ltAddrHashValName :: Name-ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#"--ltCharHashValName :: Name-ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#"--ltDoubleHashValName :: Name-ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##"--ltFloatHashValName :: Name-ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#"--ltIntHashValName :: Name-ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#"--ltWordHashValName :: Name-ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#"--minBoundValName :: Name-minBoundValName = mkNameG_v "base" "GHC.Enum" "minBound"--mapValName :: Name-mapValName = mkNameG_v "base" "GHC.Base" "map"--maxBoundValName :: Name-maxBoundValName = mkNameG_v "base" "GHC.Enum" "maxBound"--minusIntHashValName :: Name-minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#"--neqIntHashValName :: Name-neqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "/=#"--parenValName :: Name-parenValName = mkNameG_v "base" "GHC.Read" "paren"--parensValName :: Name-parensValName = mkNameG_v "base" "GHC.Read" "parens"--pfailValName :: Name-pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail"--plusValName :: Name-plusValName = mkNameG_v "base" "GHC.Num" "+"--precValName :: Name-precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec"--predValName :: Name-predValName = mkNameG_v "base" "GHC.Enum" "pred"--rangeSizeValName :: Name-rangeSizeValName = mkNameG_v "base" gHC_IX "rangeSize"--rangeValName :: Name-rangeValName = mkNameG_v "base" gHC_IX "range"--readFieldHash :: String -> ReadPrec a -> ReadPrec a-readFieldHash fieldName readVal = do- expectP (L.Ident fieldName)- expectP (L.Symbol "#")- expectP (L.Punc "=")- readVal-{-# NOINLINE readFieldHash #-}--readFieldHashValName :: Name-readFieldHashValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readFieldHash"--readListValName :: Name-readListValName = mkNameG_v "base" "GHC.Read" "readList"--readListPrecDefaultValName :: Name-readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault"--readListPrecValName :: Name-readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec"--readPrec_to_SValName :: Name-readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S"--readPrecValName :: Name-readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec"--readS_to_PrecValName :: Name-readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec"--readsPrecValName :: Name-readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec"--replaceValName :: Name-replaceValName = mkNameG_v "base" "GHC.Base" "<$"--resetValName :: Name-resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset"--returnValName :: Name-returnValName = mkNameG_v "base" "GHC.Base" "return"--seqValName :: Name-seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"--showCharValName :: Name-showCharValName = mkNameG_v "base" "GHC.Show" "showChar"--showListValName :: Name-showListValName = mkNameG_v "base" "GHC.Show" "showList"--showListWithValName :: Name-showListWithValName = mkNameG_v "base" "Text.Show" "showListWith"--showParenValName :: Name-showParenValName = mkNameG_v "base" "GHC.Show" "showParen"--showsPrecValName :: Name-showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec"--showSpaceValName :: Name-showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace"--showStringValName :: Name-showStringValName = mkNameG_v "base" "GHC.Show" "showString"--stepValName :: Name-stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step"--succValName :: Name-succValName = mkNameG_v "base" "GHC.Enum" "succ"--tagToEnumHashValName :: Name-tagToEnumHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#"--timesValName :: Name-timesValName = mkNameG_v "base" "GHC.Num" "*"--toEnumValName :: Name-toEnumValName = mkNameG_v "base" "GHC.Enum" "toEnum"--traverseValName :: Name-traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"--unsafeIndexValName :: Name-unsafeIndexValName = mkNameG_v "base" gHC_IX "unsafeIndex"--unsafeRangeSizeValName :: Name-unsafeRangeSizeValName = mkNameG_v "base" gHC_IX "unsafeRangeSize"--unwrapMonadValName :: Name-unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"--#if MIN_VERSION_base(4,4,0)-boolTypeName :: Name-boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool"--falseDataName :: Name-falseDataName = mkNameG_d "ghc-prim" "GHC.Types" "False"--trueDataName :: Name-trueDataName = mkNameG_d "ghc-prim" "GHC.Types" "True"-#else-boolTypeName :: Name-boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool"--falseDataName :: Name-falseDataName = mkNameG_d "ghc-prim" "GHC.Bool" "False"--trueDataName :: Name-trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True"-#endif--#if MIN_VERSION_base(4,5,0)-eqDataName :: Name-eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ"--gtDataName :: Name-gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT"--ltDataName :: Name-ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT"--eqTypeName :: Name-eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq"--ordTypeName :: Name-ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord"--andValName :: Name-andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&"--compareValName :: Name-compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare"--eqValName :: Name-eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "=="--geValName :: Name-geValName = mkNameG_v "ghc-prim" "GHC.Classes" ">="--gtValName :: Name-gtValName = mkNameG_v "ghc-prim" "GHC.Classes" ">"--leValName :: Name-leValName = mkNameG_v "ghc-prim" "GHC.Classes" "<="--ltValName :: Name-ltValName = mkNameG_v "ghc-prim" "GHC.Classes" "<"--notValName :: Name-notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not"-#else-eqDataName :: Name-eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ"--gtDataName :: Name-gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT"--ltDataName :: Name-ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT"--eqTypeName :: Name-eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq"--ordTypeName :: Name-ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord"--andValName :: Name-andValName = mkNameG_v "base" "GHC.Classes" "&&"--compareValName :: Name-compareValName = mkNameG_v "base" "GHC.Classes" "compare"--eqValName :: Name-eqValName = mkNameG_v "base" "GHC.Classes" "=="--geValName :: Name-geValName = mkNameG_v "base" "GHC.Classes" ">="--gtValName :: Name-gtValName = mkNameG_v "base" "GHC.Classes" ">"--leValName :: Name-leValName = mkNameG_v "base" "GHC.Classes" "<="--ltValName :: Name-ltValName = mkNameG_v "base" "GHC.Classes" "<"--notValName :: Name-notValName = mkNameG_v "base" "GHC.Classes" "not"-#endif--#if MIN_VERSION_base(4,6,0)-wHashDataName :: Name-wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#"-#else-wHashDataName :: Name-wHashDataName = mkNameG_d "base" "GHC.Word" "W#"-#endif--#if MIN_VERSION_base(4,7,0)-expectPValName :: Name-expectPValName = mkNameG_v "base" "GHC.Read" "expectP"-#else-expectP :: Lexeme -> ReadPrec ()-expectP lexeme = do- thing <- lexP- if thing == lexeme then return () else pfail--expectPValName :: Name-expectPValName = mkDerivingCompatName_v "expectP"-#endif--#if MIN_VERSION_base(4,8,0)-allValName :: Name-allValName = mkNameG_v "base" "Data.Foldable" "all"--apValName :: Name-apValName = mkNameG_v "base" "GHC.Base" "<*>"--pureValName :: Name-pureValName = mkNameG_v "base" "GHC.Base" "pure"--liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2"--mappendValName :: Name-mappendValName = mkNameG_v "base" "GHC.Base" "mappend"--memptyValName :: Name-memptyValName = mkNameG_v "base" "GHC.Base" "mempty"--nullValName :: Name-nullValName = mkNameG_v "base" "Data.Foldable" "null"-#else-allValName :: Name-allValName = mkNameG_v "base" "GHC.List" "all"--apValName :: Name-apValName = mkNameG_v "base" "Control.Applicative" "<*>"--pureValName :: Name-pureValName = mkNameG_v "base" "Control.Applicative" "pure"--liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2"--mappendValName :: Name-mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"--memptyValName :: Name-memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"--nullValName :: Name-nullValName = mkNameG_v "base" "GHC.List" "null"-#endif--#if MIN_VERSION_base(4,9,0)-eq1TypeName :: Name-eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1"--eq2TypeName :: Name-eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2"--liftEqValName :: Name-liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq"--liftEq2ValName :: Name-liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2"--ord1TypeName :: Name-ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1"--ord2TypeName :: Name-ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2"--liftCompareValName :: Name-liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare"--liftCompare2ValName :: Name-liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2"--read1TypeName :: Name-read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1"--read2TypeName :: Name-read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2"--liftReadsPrecValName :: Name-liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec"--liftReadListValName :: Name-liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList"--liftReadsPrec2ValName :: Name-liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2"--liftReadList2ValName :: Name-liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2"--show1TypeName :: Name-show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1"--show2TypeName :: Name-show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2"--liftShowListValName :: Name-liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList"--liftShowsPrecValName :: Name-liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec"--liftShowList2ValName :: Name-liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2"--liftShowsPrec2ValName :: Name-liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2"-#else--- If Data.Functor.Classes isn't located in base, then sadly we can't refer to--- Names from that module without using -XTemplateHaskell.-# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)-eq1TypeName :: Name-eq1TypeName = ''Eq1--eq2TypeName :: Name-eq2TypeName = ''Eq2--liftEqValName :: Name-liftEqValName = 'liftEq--liftEq2ValName :: Name-liftEq2ValName = 'liftEq2--ord1TypeName :: Name-ord1TypeName = ''Ord1--ord2TypeName :: Name-ord2TypeName = ''Ord2--liftCompareValName :: Name-liftCompareValName = 'liftCompare--liftCompare2ValName :: Name-liftCompare2ValName = 'liftCompare2--read1TypeName :: Name-read1TypeName = ''Read1--read2TypeName :: Name-read2TypeName = ''Read2--liftReadsPrecValName :: Name-liftReadsPrecValName = 'liftReadsPrec--liftReadListValName :: Name-liftReadListValName = 'liftReadList--liftReadsPrec2ValName :: Name-liftReadsPrec2ValName = 'liftReadsPrec2--liftReadList2ValName :: Name-liftReadList2ValName = 'liftReadList2--show1TypeName :: Name-show1TypeName = ''Show1--show2TypeName :: Name-show2TypeName = ''Show2--liftShowListValName :: Name-liftShowListValName = 'liftShowList--liftShowsPrecValName :: Name-liftShowsPrecValName = 'liftShowsPrec--liftShowList2ValName :: Name-liftShowList2ValName = 'liftShowList2--liftShowsPrec2ValName :: Name-liftShowsPrec2ValName = 'liftShowsPrec2-# else-eq1TypeName :: Name-eq1TypeName = ''Eq1--eq1ValName :: Name-eq1ValName = 'eq1--ord1TypeName :: Name-ord1TypeName = ''Ord1--compare1ValName :: Name-compare1ValName = 'compare1--read1TypeName :: Name-read1TypeName = ''Read1--readsPrec1ValName :: Name-readsPrec1ValName = 'readsPrec1--show1TypeName :: Name-show1TypeName = ''Show1--showsPrec1ValName :: Name-showsPrec1ValName = 'showsPrec1--newtype Apply f a = Apply { unApply :: f a }--instance (Eq1 f, Eq a) => Eq (Apply f a) where- Apply x == Apply y = eq1 x y--instance (Ord1 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = compare1 x y--instance (Read1 f, Read a) => Read (Apply f a) where- readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]--instance (Show1 f, Show a) => Show (Apply f a) where- showsPrec p (Apply x) = showsPrec1 p x--makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp-makeFmapApplyNeg = makeFmapApply False--makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp-makeFmapApplyPos = makeFmapApply True--makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp-makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name-makeFmapApply pos cRep conName t name = do- let tyCon :: Type- tyArgs :: [Type]- (tyCon, tyArgs) = unapplyTy t-- numLastArgs :: Int- numLastArgs = min (arity cRep) (length tyArgs)-- lhsArgs, rhsArgs :: [Type]- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- inspectTy :: Type -> Q Exp- inspectTy (SigT ty _) = inspectTy ty- inspectTy (VarT a) | a == name = varE idValName- inspectTy beta = varE fmapValName `appE`- infixApp (if pos then makeFmapApply pos cRep conName beta name- else conE applyDataName)- (varE composeValName)- (if pos then varE unApplyValName- else makeFmapApply pos cRep conName beta name)-- itf <- isInTypeFamilyApp [name] tyCon tyArgs- if any (`mentionsName` [name]) lhsArgs || itf- then outOfPlaceTyVarError cRep conName- else inspectTy (head rhsArgs)--applyDataName :: Name-applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply"--unApplyValName :: Name-unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply"-# endif-#endif--#if MIN_VERSION_base(4,10,0)-showCommaSpaceValName :: Name-showCommaSpaceValName = mkNameG_v "base" "GHC.Show" "showCommaSpace"-#else-showCommaSpace :: ShowS-showCommaSpace = showString ", "--showCommaSpaceValName :: Name-showCommaSpaceValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "showCommaSpace"-#endif--#if MIN_VERSION_base(4,11,0)-appEndoValName :: Name-appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo"--dualDataName :: Name-dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual"--endoDataName :: Name-endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo"--getDualValName :: Name-getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual"--readFieldValName :: Name-readFieldValName = mkNameG_v "base" "GHC.Read" "readField"--readSymFieldValName :: Name-readSymFieldValName = mkNameG_v "base" "GHC.Read" "readSymField"-#else-appEndoValName :: Name-appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"--dualDataName :: Name-dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"--endoDataName :: Name-endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"--getDualValName :: Name-getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"--readField :: String -> ReadPrec a -> ReadPrec a-readField fieldName readVal = do- expectP (L.Ident fieldName)- expectP (L.Punc "=")- readVal-{-# NOINLINE readField #-}--readFieldValName :: Name-readFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readField"--readSymField :: String -> ReadPrec a -> ReadPrec a-readSymField fieldName readVal = do- expectP (L.Punc "(")- expectP (L.Symbol fieldName)- expectP (L.Punc ")")- expectP (L.Punc "=")- readVal-{-# NOINLINE readSymField #-}--readSymFieldValName :: Name-readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField"-#endif--#if MIN_VERSION_base(4,13,0)-eqInt8HashValName :: Name-eqInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt8#"--eqInt16HashValName :: Name-eqInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt16#"--eqWord8HashValName :: Name-eqWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord8#"--eqWord16HashValName :: Name-eqWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#"--geInt8HashValName :: Name-geInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#"--geInt16HashValName :: Name-geInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt16#"--geWord8HashValName :: Name-geWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord8#"--geWord16HashValName :: Name-geWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord16#"--gtInt8HashValName :: Name-gtInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt8#"--gtInt16HashValName :: Name-gtInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt16#"--gtWord8HashValName :: Name-gtWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord8#"--gtWord16HashValName :: Name-gtWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord16#"--int8HashTypeName :: Name-int8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#"--int8ToIntHashValName :: Name-int8ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "int8ToInt#"-# else- "extendInt8#"-# endif--int16HashTypeName :: Name-int16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#"--int16ToIntHashValName :: Name-int16ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "int16ToInt#"-# else- "extendInt16#"-# endif--intToInt8HashValName :: Name-intToInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "intToInt8#"-# else- "narrowInt8#"-# endif--intToInt16HashValName :: Name-intToInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "intToInt16#"-# else- "narrowInt16#"-# endif--leInt8HashValName :: Name-leInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#"--leInt16HashValName :: Name-leInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt16#"--leWord8HashValName :: Name-leWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord8#"--leWord16HashValName :: Name-leWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord16#"--ltInt8HashValName :: Name-ltInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt8#"--ltInt16HashValName :: Name-ltInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt16#"--ltWord8HashValName :: Name-ltWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord8#"--ltWord16HashValName :: Name-ltWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord16#"--word8HashTypeName :: Name-word8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#"--word8ToWordHashValName :: Name-word8ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "word8ToWord#"-# else- "extendWord8#"-# endif--word16HashTypeName :: Name-word16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#"--word16ToWordHashValName :: Name-word16ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "word16ToWord#"-# else- "extendWord16#"-# endif--wordToWord8HashValName :: Name-wordToWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "wordToWord8#"-# else- "narrowWord8#"-# endif--wordToWord16HashValName :: Name-wordToWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim"-# if MIN_VERSION_base(4,16,0)- "wordToWord16#"-# else- "narrowWord16#"-# endif-#endif--#if MIN_VERSION_base(4,16,0)-eqInt32HashValName :: Name-eqInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt32#"--eqWord32HashValName :: Name-eqWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord32#"--geInt32HashValName :: Name-geInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt32#"--geWord32HashValName :: Name-geWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord32#"--gtInt32HashValName :: Name-gtInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt32#"--gtWord32HashValName :: Name-gtWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord32#"--int32HashTypeName :: Name-int32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int32#"--int32ToIntHashValName :: Name-int32ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "int32ToInt#"--intToInt32HashValName :: Name-intToInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "intToInt32#"--leInt32HashValName :: Name-leInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt32#"--leWord32HashValName :: Name-leWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord32#"--ltInt32HashValName :: Name-ltInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt32#"--ltWord32HashValName :: Name-ltWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord32#"--word32HashTypeName :: Name-word32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word32#"--word32ToWordHashValName :: Name-word32ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "word32ToWord#"--wordToWord32HashValName :: Name-wordToWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "wordToWord32#"-#endif+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} + +#if !(MIN_VERSION_base(4,9,0)) +# if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +# else +{-# LANGUAGE TemplateHaskell #-} +# endif +#endif + +{-| +Module: Data.Deriving.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Template Haskell-related utilities. + +Note: this is an internal module, and as such, the API presented here is not +guaranteed to be stable, even between minor releases of this library. +-} +module Data.Deriving.Internal where + +import Control.Applicative (liftA2) +import Control.Monad (when, unless) + +import Data.Foldable (foldr') +#if !(MIN_VERSION_base(4,9,0)) +import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) +# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..)) +# endif +#endif +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Traversable as T + +import Text.ParserCombinators.ReadPrec (ReadPrec) +import qualified Text.Read.Lex as L + +#if MIN_VERSION_base(4,7,0) +import GHC.Read (expectP) +#else +import GHC.Read (lexP) + +import Text.Read (pfail) +import Text.Read.Lex (Lexeme) +#endif + +#if MIN_VERSION_ghc_prim(0,3,1) +import GHC.Prim (Int#, tagToEnum#) +#endif + +#if defined(MIN_VERSION_ghc_boot_th) +import GHC.Lexeme (startsConSym, startsVarSym) +#else +import Data.Char (isSymbol, ord) +#endif + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr (pprint) +import Language.Haskell.TH.Syntax + +-- Ensure, beyond a shadow of a doubt, that the instances are in-scope +import Data.Functor () +import Data.Functor.Classes () +import Data.Foldable () +import Data.Traversable () + +#ifndef CURRENT_PACKAGE_KEY +import Data.Version (showVersion) +import Paths_deriving_compat (version) +#endif + +------------------------------------------------------------------------------- +-- Expanding type synonyms +------------------------------------------------------------------------------- + +applySubstitutionKind :: Map Name Kind -> Type -> Type +#if MIN_VERSION_template_haskell(2,8,0) +applySubstitutionKind = applySubstitution +#else +applySubstitutionKind _ t = t +#endif + +substNameWithKind :: Name -> Kind -> Type -> Type +substNameWithKind n k = applySubstitutionKind (Map.singleton n k) + +substNamesWithKindStar :: [Name] -> Type -> Type +substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns + +------------------------------------------------------------------------------- +-- Via +------------------------------------------------------------------------------- + +-- | A type-level modifier intended to be used in conjunction with 'deriveVia'. +-- Refer to the documentation for 'deriveVia' for more details. +data a `Via` b +infix 0 `Via` + +------------------------------------------------------------------------------- +-- Type-specialized const functions +------------------------------------------------------------------------------- + +fmapConst :: f b -> (a -> b) -> f a -> f b +fmapConst x _ _ = x +{-# INLINE fmapConst #-} + +replaceConst :: f a -> a -> f b -> f a +replaceConst x _ _ = x +{-# INLINE replaceConst #-} + +foldrConst :: b -> (a -> b -> b) -> b -> t a -> b +foldrConst x _ _ _ = x +{-# INLINE foldrConst #-} + +foldMapConst :: m -> (a -> m) -> t a -> m +foldMapConst x _ _ = x +{-# INLINE foldMapConst #-} + +nullConst :: Bool -> t a -> Bool +nullConst x _ = x +{-# INLINE nullConst #-} + +traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b) +traverseConst x _ _ = x +{-# INLINE traverseConst #-} + +eqConst :: Bool + -> a -> a -> Bool +eqConst x _ _ = x +{-# INLINE eqConst #-} + +eq1Const :: Bool + -> f a -> f a-> Bool +eq1Const x _ _ = x +{-# INLINE eq1Const #-} + +liftEqConst :: Bool + -> (a -> b -> Bool) -> f a -> f b -> Bool +liftEqConst x _ _ _ = x +{-# INLINE liftEqConst #-} + +liftEq2Const :: Bool + -> (a -> b -> Bool) -> (c -> d -> Bool) + -> f a c -> f b d -> Bool +liftEq2Const x _ _ _ _ = x +{-# INLINE liftEq2Const #-} + +compareConst :: Ordering -> a -> a -> Ordering +compareConst x _ _ = x +{-# INLINE compareConst #-} + +ltConst :: Bool -> a -> a -> Bool +ltConst x _ _ = x +{-# INLINE ltConst #-} + +compare1Const :: Ordering -> f a -> f a -> Ordering +compare1Const x _ _ = x +{-# INLINE compare1Const #-} + +liftCompareConst :: Ordering + -> (a -> b -> Ordering) -> f a -> f b -> Ordering +liftCompareConst x _ _ _ = x +{-# INLINE liftCompareConst #-} + +liftCompare2Const :: Ordering + -> (a -> b -> Ordering) -> (c -> d -> Ordering) + -> f a c -> f b d -> Ordering +liftCompare2Const x _ _ _ _ = x +{-# INLINE liftCompare2Const #-} + +readsPrecConst :: ReadS a -> Int -> ReadS a +readsPrecConst x _ = x +{-# INLINE readsPrecConst #-} + +-- This isn't really necessary, but it makes for an easier implementation +readPrecConst :: ReadPrec a -> ReadPrec a +readPrecConst x = x +{-# INLINE readPrecConst #-} + +readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a) +readsPrec1Const x _ = x +{-# INLINE readsPrec1Const #-} + +liftReadsPrecConst :: ReadS (f a) + -> (Int -> ReadS a) -> ReadS [a] + -> Int -> ReadS (f a) +liftReadsPrecConst x _ _ _ = x +{-# INLINE liftReadsPrecConst #-} + +liftReadPrecConst :: ReadPrec (f a) + -> ReadPrec a -> ReadPrec [a] + -> ReadPrec (f a) +liftReadPrecConst x _ _ = x +{-# INLINE liftReadPrecConst #-} + +liftReadsPrec2Const :: ReadS (f a b) + -> (Int -> ReadS a) -> ReadS [a] + -> (Int -> ReadS b) -> ReadS [b] + -> Int -> ReadS (f a b) +liftReadsPrec2Const x _ _ _ _ _ = x +{-# INLINE liftReadsPrec2Const #-} + +liftReadPrec2Const :: ReadPrec (f a b) + -> ReadPrec a -> ReadPrec [a] + -> ReadPrec b -> ReadPrec [b] + -> ReadPrec (f a b) +liftReadPrec2Const x _ _ _ _ = x +{-# INLINE liftReadPrec2Const #-} + +showsPrecConst :: ShowS + -> Int -> a -> ShowS +showsPrecConst x _ _ = x +{-# INLINE showsPrecConst #-} + +showsPrec1Const :: ShowS + -> Int -> f a -> ShowS +showsPrec1Const x _ _ = x +{-# INLINE showsPrec1Const #-} + +liftShowsPrecConst :: ShowS + -> (Int -> a -> ShowS) -> ([a] -> ShowS) + -> Int -> f a -> ShowS +liftShowsPrecConst x _ _ _ _ = x +{-# INLINE liftShowsPrecConst #-} + +liftShowsPrec2Const :: ShowS + -> (Int -> a -> ShowS) -> ([a] -> ShowS) + -> (Int -> b -> ShowS) -> ([b] -> ShowS) + -> Int -> f a b -> ShowS +liftShowsPrec2Const x _ _ _ _ _ _ = x +{-# INLINE liftShowsPrec2Const #-} + +------------------------------------------------------------------------------- +-- StarKindStatus +------------------------------------------------------------------------------- + +-- | Whether a type is not of kind *, is of kind *, or is a kind variable. +data StarKindStatus = NotKindStar + | KindStar + | IsKindVar Name + deriving Eq + +-- | Does a Type have kind * or k (for some kind variable k)? +canRealizeKindStar :: Type -> StarKindStatus +canRealizeKindStar t + | hasKindStar t = KindStar + | otherwise = case t of +#if MIN_VERSION_template_haskell(2,8,0) + SigT _ (VarT k) -> IsKindVar k +#endif + _ -> NotKindStar + +-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. +-- Otherwise, returns 'Nothing'. +starKindStatusToName :: StarKindStatus -> Maybe Name +starKindStatusToName (IsKindVar n) = Just n +starKindStatusToName _ = Nothing + +-- | Concat together all of the StarKindStatuses that are IsKindVar and extract +-- the kind variables' Names out. +catKindVarNames :: [StarKindStatus] -> [Name] +catKindVarNames = mapMaybe starKindStatusToName + +------------------------------------------------------------------------------- +-- ClassRep +------------------------------------------------------------------------------- + +class ClassRep a where + arity :: a -> Int + allowExQuant :: a -> Bool + fullClassName :: a -> Name + classConstraint :: a -> Int -> Maybe Name + +------------------------------------------------------------------------------- +-- Template Haskell reifying and AST manipulation +------------------------------------------------------------------------------- + +-- For the given Types, generate an instance context and head. Coming up with +-- the instance type isn't as simple as dropping the last types, as you need to +-- be wary of kinds being instantiated with *. +-- See Note [Type inference in derived instances] +buildTypeInstance :: ClassRep a + => a + -- ^ The typeclass for which an instance should be derived + -> Name + -- ^ The type constructor or data family name + -> Cxt + -- ^ The datatype context + -> [Type] + -- ^ The types to instantiate the instance with + -> DatatypeVariant + -- ^ Are we dealing with a data family instance or not + -> Q (Cxt, Type) +buildTypeInstance cRep tyConName dataCxt varTysOrig variant = do + -- Make sure to expand through type/kind synonyms! Otherwise, the + -- eta-reduction check might get tripped up over type variables in a + -- synonym that are actually dropped. + -- (See GHC Trac #11416 for a scenario where this actually happened.) + varTysExp <- mapM resolveTypeSynonyms varTysOrig + + let remainingLength :: Int + remainingLength = length varTysOrig - arity cRep + + droppedTysExp :: [Type] + droppedTysExp = drop remainingLength varTysExp + + droppedStarKindStati :: [StarKindStatus] + droppedStarKindStati = map canRealizeKindStar droppedTysExp + + -- Check there are enough types to drop and that all of them are either of + -- kind * or kind k (for some kind variable k). If not, throw an error. + when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ + derivingKindError cRep tyConName + + let droppedKindVarNames :: [Name] + droppedKindVarNames = catKindVarNames droppedStarKindStati + + -- Substitute kind * for any dropped kind variables + varTysExpSubst :: [Type] + varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp + + remainingTysExpSubst, droppedTysExpSubst :: [Type] + (remainingTysExpSubst, droppedTysExpSubst) = + splitAt remainingLength varTysExpSubst + + -- All of the type variables mentioned in the dropped types + -- (post-synonym expansion) + droppedTyVarNames :: [Name] + droppedTyVarNames = freeVariables droppedTysExpSubst + + -- If any of the dropped types were polykinded, ensure that they are of kind * + -- after substituting * for the dropped kind variables. If not, throw an error. + unless (all hasKindStar droppedTysExpSubst) $ + derivingKindError cRep tyConName + + let preds :: [Maybe Pred] + kvNames :: [[Name]] + kvNames' :: [Name] + -- Derive instance constraints (and any kind variables which are specialized + -- to * in those constraints) + (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst + kvNames' = concat kvNames + + -- Substitute the kind variables specialized in the constraints with * + remainingTysExpSubst' :: [Type] + remainingTysExpSubst' = + map (substNamesWithKindStar kvNames') remainingTysExpSubst + + -- We now substitute all of the specialized-to-* kind variable names with + -- *, but in the original types, not the synonym-expanded types. The reason + -- we do this is a superficial one: we want the derived instance to resemble + -- the datatype written in source code as closely as possible. For example, + -- for the following data family instance: + -- + -- data family Fam a + -- newtype instance Fam String = Fam String + -- + -- We'd want to generate the instance: + -- + -- instance C (Fam String) + -- + -- Not: + -- + -- instance C (Fam [Char]) + remainingTysOrigSubst :: [Type] + remainingTysOrigSubst = + map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) + $ take remainingLength varTysOrig + + isDataFamily :: Bool + isDataFamily = case variant of + Datatype -> False + Newtype -> False + DataInstance -> True + NewtypeInstance -> True + + remainingTysOrigSubst' :: [Type] + -- See Note [Kind signatures in derived instances] for an explanation + -- of the isDataFamily check. + remainingTysOrigSubst' = + if isDataFamily + then remainingTysOrigSubst + else map unSigT remainingTysOrigSubst + + instanceCxt :: Cxt + instanceCxt = catMaybes preds + + instanceType :: Type + instanceType = AppT (ConT (fullClassName cRep)) + $ applyTyCon tyConName remainingTysOrigSubst' + + -- If the datatype context mentions any of the dropped type variables, + -- we can't derive an instance, so throw an error. + when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ + datatypeContextError tyConName instanceType + -- Also ensure the dropped types can be safely eta-reduced. Otherwise, + -- throw an error. + unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ + etaReductionError instanceType + return (instanceCxt, instanceType) + +-- | Attempt to derive a constraint on a Type. If successful, return +-- Just the constraint and any kind variable names constrained to *. +-- Otherwise, return Nothing and the empty list. +-- +-- See Note [Type inference in derived instances] for the heuristics used to +-- come up with constraints. +deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name]) +deriveConstraint cRep t + | not (isTyVar t) = (Nothing, []) + | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, []) + | otherwise = case hasKindVarChain 1 t of + Just ns | cRepArity >= 1 + -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns) + _ -> case hasKindVarChain 2 t of + Just ns | cRepArity == 2 + -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns) + _ -> (Nothing, []) + where + tName :: Name + tName = varTToName t + + cRepArity :: Int + cRepArity = arity cRep + +{- +Note [Kind signatures in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to put explicit kind signatures into the derived instances, e.g., + + instance C a => C (Data (f :: * -> *)) where ... + +But it is preferable to avoid this if possible. If we come up with an incorrect +kind signature (which is entirely possible, since our type inferencer is pretty +unsophisticated - see Note [Type inference in derived instances]), then GHC will +flat-out reject the instance, which is quite unfortunate. + +Plain old datatypes have the advantage that you can avoid using any kind signatures +at all in their instances. This is because a datatype declaration uses all type +variables, so the types that we use in a derived instance uniquely determine their +kinds. As long as we plug in the right types, the kind inferencer can do the rest +of the work. For this reason, we use unSigT to remove all kind signatures before +splicing in the instance context and head. + +Data family instances are trickier, since a data family can have two instances that +are distinguished by kind alone, e.g., + + data family Fam (a :: k) + data instance Fam (a :: * -> *) + data instance Fam (a :: *) + +If we dropped the kind signatures for C (Fam a), then GHC will have no way of +knowing which instance we are talking about. To avoid this scenario, we always +include explicit kind signatures in data family instances. There is a chance that +the inferred kind signatures will be incorrect, but if so, we can always fall back +on the make- functions. + +Note [Type inference in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Type inference is can be tricky to get right, and we want to avoid recreating the +entirety of GHC's type inferencer in Template Haskell. For this reason, we will +probably never come up with derived instance contexts that are as accurate as +GHC's. But that doesn't mean we can't do anything! There are a couple of simple +things we can do to make instance contexts that work for 80% of use cases: + +1. If one of the last type parameters is polykinded, then its kind will be + specialized to * in the derived instance. We note what kind variable the type + parameter had and substitute it with * in the other types as well. For example, + imagine you had + + data Data (a :: k) (b :: k) + + Then you'd want to derived instance to be: + + instance C (Data (a :: *)) + + Not: + + instance C (Data (a :: k)) + +2. We naïvely come up with instance constraints using the following criteria, using + Show(1)(2) as the example typeclasses: + + (i) If there's a type parameter n of kind *, generate a Show n constraint. + (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind + variables), then generate a Show1 n constraint, and if k1/k2 are kind + variables, then substitute k1/k2 with * elsewhere in the types. We must + consider the case where they are kind variables because you might have a + scenario like this: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) + = Compose (f (g a)) + + Which would have a derived Show1 instance of: + + instance (Show1 f, Show1 g) => Show1 (Compose f g) where ... + (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are + * or kind variables), then generate a Show2 constraint and perform + kind substitution as in the other cases. +-} + +checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name + -> Q c -> Q c +checkExistentialContext cRep tvMap ctxt conName q = + if (any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < arity cRep) + && not (allowExQuant cRep) + then existentialContextError conName + else q + +{- +Note [Matching functions with GADT type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When deriving category-2 classes like Show2, there is a tricky corner case to consider: + + data Both a b where + BothCon :: x -> x -> Both x x + +Which show functions should be applied to which arguments of BothCon? We have a +choice, since both the function of type (Int -> a -> ShowS) and of type +(Int -> b -> ShowS) can be applied to either argument. In such a scenario, the +second show function takes precedence over the first show function, so the +derived Show2 instance would be: + + instance Show2 Both where + liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) = + showsParen (p > appPrec) $ + showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2 + +This is not an arbitrary choice, as this definition ensures that +liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for +Both. +-} + +------------------------------------------------------------------------------- +-- Error messages +------------------------------------------------------------------------------- + +-- | The given datatype has no constructors, and we don't know what to do with it. +noConstructorsError :: Q a +noConstructorsError = fail "Must have at least one data constructor" + +-- | Either the given data type doesn't have enough type variables, or one of +-- the type variables to be eta-reduced cannot realize kind *. +derivingKindError :: ClassRep a => a -> Name -> Q b +derivingKindError cRep tyConName = fail + . showString "Cannot derive well-kinded instance of form ‘" + . showString className + . showChar ' ' + . showParen True + ( showString (nameBase tyConName) + . showString " ..." + ) + . showString "‘\n\tClass " + . showString className + . showString " expects an argument of kind " + . showString (pprint . createKindChain $ arity cRep) + $ "" + where + className :: String + className = nameBase $ fullClassName cRep + +-- | The last type variable appeared in a contravariant position +-- when deriving Functor. +contravarianceError :: Name -> Q a +contravarianceError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not use the last type variable in a function argument" + $ "" + +-- | A constructor has a function argument in a derived Foldable or Traversable +-- instance. +noFunctionsError :: Name -> Q a +noFunctionsError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not contain function types" + $ "" + +-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce +-- function for the criteria it would have to meet). +etaReductionError :: Type -> Q a +etaReductionError instanceType = fail $ + "Cannot eta-reduce to an instance of form \n\tinstance (...) => " + ++ pprint instanceType + +-- | The data type has a DatatypeContext which mentions one of the eta-reduced +-- type variables. +datatypeContextError :: Name -> Type -> Q a +datatypeContextError dataName instanceType = fail + . showString "Can't make a derived instance of ‘" + . showString (pprint instanceType) + . showString "‘:\n\tData type ‘" + . showString (nameBase dataName) + . showString "‘ must not have a class context involving the last type argument(s)" + $ "" + +-- | The data type has an existential constraint which mentions one of the +-- eta-reduced type variables. +existentialContextError :: Name -> Q a +existentialContextError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must be truly polymorphic in the last argument(s) of the data type" + $ "" + +-- | The data type mentions one of the n eta-reduced type variables in a place other +-- than the last nth positions of a data type in a constructor's field. +outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b +outOfPlaceTyVarError cRep conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must only use its last " + . shows n + . showString " type variable(s) within the last " + . shows n + . showString " argument(s) of a data type" + $ "" + where + n :: Int + n = arity cRep + +enumerationError :: String -> Q a +enumerationError = fail . enumerationErrorStr + +enumerationOrProductError :: String -> Q a +enumerationOrProductError nb = fail $ unlines + [ enumerationErrorStr nb + , "\tor a product type (precisely one constructor)" + ] + +enumerationErrorStr :: String -> String +enumerationErrorStr nb = + '\'':nb ++ "’ must be an enumeration type" + ++ " (one or more nullary, non-GADT constructors)" + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +-- | A mapping of type variable Names to their auxiliary function Names. +type TyVarMap a = Map Name (OneOrTwoNames a) +type TyVarMap1 = TyVarMap One +type TyVarMap2 = TyVarMap Two + +data OneOrTwoNames a where + OneName :: Name -> OneOrTwoNames One + TwoNames :: Name -> Name -> OneOrTwoNames Two + +data One +data Two + +interleave :: [a] -> [a] -> [a] +interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s +interleave _ _ = [] + +#if MIN_VERSION_ghc_prim(0,3,1) +isTrue# :: Int# -> Bool +isTrue# x = tagToEnum# x +#else +isTrue# :: Bool -> Bool +isTrue# x = x +#endif +{-# INLINE isTrue# #-} + +-- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +-- | 'filterByLists' takes a list of Bools and two lists as input, and +-- outputs a new list consisting of elements from the last two input lists. For +-- each Bool in the list, if it is 'True', then it takes an element from the +-- former list. If it is 'False', it takes an element from the latter list. +-- The elements taken correspond to the index of the Bool in its list. +-- For example: +-- +-- @ +-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" +-- @ +-- +-- This function does not check whether the lists have equal length. +filterByLists :: [Bool] -> [a] -> [a] -> [a] +filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys +filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys +filterByLists _ _ _ = [] + +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + +integerE :: Int -> Q Exp +integerE = litE . integerL . fromIntegral + +-- | Returns True if a Type has kind *. +hasKindStar :: Type -> Bool +hasKindStar VarT{} = True +#if MIN_VERSION_template_haskell(2,8,0) +hasKindStar (SigT _ StarT) = True +#else +hasKindStar (SigT _ StarK) = True +#endif +hasKindStar _ = False + +-- Returns True is a kind is equal to *, or if it is a kind variable. +isStarOrVar :: Kind -> Bool +#if MIN_VERSION_template_haskell(2,8,0) +isStarOrVar StarT = True +isStarOrVar VarT{} = True +#else +isStarOrVar StarK = True +#endif +isStarOrVar _ = False + +-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form +-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or +-- kind variables. +hasKindVarChain :: Int -> Type -> Maybe [Name] +hasKindVarChain kindArrows t = + let uk = uncurryKind (tyKind t) + in if (length uk - 1 == kindArrows) && all isStarOrVar uk + then Just (freeVariables uk) + else Nothing + +-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. +tyKind :: Type -> Kind +tyKind (SigT _ k) = k +tyKind _ = starK + +zipWithAndUnzipM :: Monad m + => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +zipWithAndUnzipM f (x:xs) (y:ys) = do + (c, d) <- f x y + (cs, ds) <- zipWithAndUnzipM f xs ys + return (c:cs, d:ds) +zipWithAndUnzipM _ _ _ = return ([], []) +{-# INLINE zipWithAndUnzipM #-} + +zipWith3AndUnzipM :: Monad m + => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] + -> m ([d], [e]) +zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do + (d, e) <- f x y z + (ds, es) <- zipWith3AndUnzipM f xs ys zs + return (d:ds, e:es) +zipWith3AndUnzipM _ _ _ _ = return ([], []) +{-# INLINE zipWith3AndUnzipM #-} + +thd3 :: (a, b, c) -> c +thd3 (_, _, c) = c + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = case unsnoc xs of + Nothing -> Just ([], x) + Just (a,b) -> Just (x:a, b) + +isNullaryCon :: ConstructorInfo -> Bool +isNullaryCon (ConstructorInfo { constructorFields = tys }) = null tys + +-- | Returns the number of fields for the constructor. +conArity :: ConstructorInfo -> Int +conArity (ConstructorInfo { constructorFields = tys }) = length tys + +-- | Returns 'True' if it's a datatype with exactly one, non-existential constructor. +isProductType :: [ConstructorInfo] -> Bool +isProductType [con] = null (constructorVars con) +isProductType _ = False + +-- | Returns 'True' if it's a datatype with one or more nullary, non-GADT +-- constructors. +isEnumerationType :: [ConstructorInfo] -> Bool +isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons +isEnumerationType _ = False + +-- | Returns 'False' if we're dealing with existential quantification or GADTs. +isVanillaCon :: ConstructorInfo -> Bool +isVanillaCon (ConstructorInfo { constructorContext = ctxt, constructorVars = vars }) = + null ctxt && null vars + +-- | Generate a list of fresh names with a common prefix, and numbered suffixes. +newNameList :: String -> Int -> Q [Name] +newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] + +-- | Extracts the kind from a TyVarBndr. +tvbKind :: TyVarBndr_ flag -> Kind +tvbKind = elimTV (\_ -> starK) (\_ k -> k) + +-- | Convert a TyVarBndr to a Type. +tvbToType :: TyVarBndr_ flag -> Type +tvbToType = elimTV VarT (\n k -> SigT (VarT n) k) + +-- | Applies a typeclass constraint to a type. +applyClass :: Name -> Name -> Pred +#if MIN_VERSION_template_haskell(2,10,0) +applyClass con t = AppT (ConT con) (VarT t) +#else +applyClass con t = ClassP con [VarT t] +#endif + +createKindChain :: Int -> Kind +createKindChain = go starK + where + go :: Kind -> Int -> Kind + go k !0 = k +#if MIN_VERSION_template_haskell(2,8,0) + go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) +#else + go k !n = go (ArrowK StarK k) (n - 1) +#endif + +-- | Checks to see if the last types in a data family instance can be safely eta- +-- reduced (i.e., dropped), given the other types. This checks for three conditions: +-- +-- (1) All of the dropped types are type variables +-- (2) All of the dropped types are distinct +-- (3) None of the remaining types mention any of the dropped types +canEtaReduce :: [Type] -> [Type] -> Bool +canEtaReduce remaining dropped = + all isTyVar dropped + && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type + -- didn't have an Ord instance until template-haskell-2.10.0.0 + && not (any (`mentionsName` droppedNames) remaining) + where + droppedNames :: [Name] + droppedNames = map varTToName dropped + +-- | Extract the Name from a type constructor. If the argument Type is not a +-- type variable, throw an error. +conTToName :: Type -> Name +conTToName (ConT n) = n +conTToName (SigT t _) = conTToName t +conTToName _ = error "Not a type constructor!" + +-- | Extract Just the Name from a type variable. If the argument Type is not a +-- type variable, return Nothing. +varTToName_maybe :: Type -> Maybe Name +varTToName_maybe (VarT n) = Just n +varTToName_maybe (SigT t _) = varTToName_maybe t +varTToName_maybe _ = Nothing + +-- | Extract the Name from a type variable. If the argument Type is not a +-- type variable, throw an error. +varTToName :: Type -> Name +varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe + +-- | Peel off a kind signature from a Type (if it has one). +unSigT :: Type -> Type +unSigT (SigT t _) = t +unSigT t = t + +-- | Is the given type a variable? +isTyVar :: Type -> Bool +isTyVar (VarT _) = True +isTyVar (SigT t _) = isTyVar t +isTyVar _ = False + +-- | Detect if a Name in a list of provided Names occurs as an argument to some +-- type family. This makes an effort to exclude /oversaturated/ arguments to +-- type families. For instance, if one declared the following type family: +-- +-- @ +-- type family F a :: Type -> Type +-- @ +-- +-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, +-- but not @b@. +isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool +isInTypeFamilyApp names tyFun tyArgs = + case tyFun of + ConT tcName -> go tcName + _ -> return False + where + go :: Name -> Q Bool + go tcName = do + info <- reify tcName + case info of +#if MIN_VERSION_template_haskell(2,11,0) + FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ + -> withinFirstArgs bndrs +#elif MIN_VERSION_template_haskell(2,7,0) + FamilyI (FamilyD TypeFam _ bndrs _) _ + -> withinFirstArgs bndrs +#else + TyConI (FamilyD TypeFam _ bndrs _) + -> withinFirstArgs bndrs +#endif + +#if MIN_VERSION_template_haskell(2,11,0) + FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ + -> withinFirstArgs bndrs +#elif MIN_VERSION_template_haskell(2,9,0) + FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ + -> withinFirstArgs bndrs +#endif + + _ -> return False + where + withinFirstArgs :: [a] -> Q Bool + withinFirstArgs bndrs = + let firstArgs = take (length bndrs) tyArgs + argFVs = freeVariables firstArgs + in return $ any (`elem` argFVs) names + +-- | Are all of the items in a list (which have an ordering) distinct? +-- +-- This uses Set (as opposed to nub) for better asymptotic time complexity. +allDistinct :: Ord a => [a] -> Bool +allDistinct = allDistinct' Set.empty + where + allDistinct' :: Ord a => Set a -> [a] -> Bool + allDistinct' uniqs (x:xs) + | x `Set.member` uniqs = False + | otherwise = allDistinct' (Set.insert x uniqs) xs + allDistinct' _ _ = True + +-- | Does the given type mention any of the Names in the list? +mentionsName :: Type -> [Name] -> Bool +mentionsName = go + where + go :: Type -> [Name] -> Bool + go (AppT t1 t2) names = go t1 names || go t2 names + go (SigT t _k) names = go t names +#if MIN_VERSION_template_haskell(2,8,0) + || go _k names +#endif + go (VarT n) names = n `elem` names + go _ _ = False + +-- | Does an instance predicate mention any of the Names in the list? +predMentionsName :: Pred -> [Name] -> Bool +#if MIN_VERSION_template_haskell(2,10,0) +predMentionsName = mentionsName +#else +predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys +predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names +#endif + +-- | Construct a type via curried application. +applyTy :: Type -> [Type] -> Type +applyTy = List.foldl' AppT + +-- | Fully applies a type constructor to its type variables. +applyTyCon :: Name -> [Type] -> Type +applyTyCon = applyTy . ConT + +-- | Split an applied type into its individual components. For example, this: +-- +-- @ +-- Either Int Char +-- @ +-- +-- would split to this: +-- +-- @ +-- [Either, Int, Char] +-- @ +unapplyTy :: Type -> (Type, [Type]) +unapplyTy ty = go ty ty [] + where + go :: Type -> Type -> [Type] -> (Type, [Type]) + go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) + go origTy (SigT ty' _) args = go origTy ty' args +#if MIN_VERSION_template_haskell(2,11,0) + go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args + go origTy (ParensT ty') args = go origTy ty' args +#endif + go origTy _ args = (origTy, args) + +-- | Split a type signature by the arrows on its spine. For example, this: +-- +-- @ +-- forall a b. (a ~ b) => (a -> b) -> Char -> () +-- @ +-- +-- would split to this: +-- +-- @ +-- (a ~ b, [a -> b, Char, ()]) +-- @ +uncurryTy :: Type -> (Cxt, [Type]) +uncurryTy (AppT (AppT ArrowT t1) t2) = + let (ctxt, tys) = uncurryTy t2 + in (ctxt, t1:tys) +uncurryTy (SigT t _) = uncurryTy t +uncurryTy (ForallT _ ctxt t) = + let (ctxt', tys) = uncurryTy t + in (ctxt ++ ctxt', tys) +uncurryTy t = ([], [t]) + + +-- | Like uncurryType, except on a kind level. +uncurryKind :: Kind -> [Kind] +#if MIN_VERSION_template_haskell(2,8,0) +uncurryKind = snd . uncurryTy +#else +uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 +uncurryKind k = [k] +#endif + +untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp +untagExpr [] e = e +untagExpr ((untagThis, putTagHere) : more) e = + caseE (varE getTagValName `appE` varE untagThis) + [match (varP putTagHere) + (normalB $ untagExpr more e) + []] + +tag2ConExpr :: Type -> Q Exp +tag2ConExpr ty = do + iHash <- newName "i#" + ty' <- freshenType ty + lam1E (conP iHashDataName [varP iHash]) $ + varE tagToEnumHashValName `appE` varE iHash + `sigE` return (quantifyType ty') + -- tagToEnum# is a hack, and won't typecheck unless it's in the + -- immediate presence of a type ascription like so: + -- + -- tagToEnum# x :: Foo + -- + -- We have to be careful when dealing with datatypes with type + -- variables, since Template Haskell might reject the type variables + -- we use for being out-of-scope. To avoid this, we explicitly + -- collect the type variable binders and shove them into a ForallT + -- (using th-abstraction's quantifyType function). Also make sure + -- to freshen the bound type variables to avoid shadowed variable + -- warnings on old versions of GHC when -Wall is enabled. + +primOrdFunTbl :: Map Name (Name, Name, Name, Name, Name) +primOrdFunTbl = Map.fromList + [ (addrHashTypeName, ( ltAddrHashValName + , leAddrHashValName + , eqAddrHashValName + , geAddrHashValName + , gtAddrHashValName + )) + , (charHashTypeName, ( ltCharHashValName + , leCharHashValName + , eqCharHashValName + , geCharHashValName + , gtCharHashValName + )) + , (doubleHashTypeName, ( ltDoubleHashValName + , leDoubleHashValName + , eqDoubleHashValName + , geDoubleHashValName + , gtDoubleHashValName + )) + , (floatHashTypeName, ( ltFloatHashValName + , leFloatHashValName + , eqFloatHashValName + , geFloatHashValName + , gtFloatHashValName + )) + , (intHashTypeName, ( ltIntHashValName + , leIntHashValName + , eqIntHashValName + , geIntHashValName + , gtIntHashValName + )) + , (wordHashTypeName, ( ltWordHashValName + , leWordHashValName + , eqWordHashValName + , geWordHashValName + , gtWordHashValName + )) +#if MIN_VERSION_base(4,13,0) + , (int8HashTypeName, ( ltInt8HashValName + , leInt8HashValName + , eqInt8HashValName + , geInt8HashValName + , gtInt8HashValName + )) + , (int16HashTypeName, ( ltInt16HashValName + , leInt16HashValName + , eqInt16HashValName + , geInt16HashValName + , gtInt16HashValName + )) + , (word8HashTypeName, ( ltWord8HashValName + , leWord8HashValName + , eqWord8HashValName + , geWord8HashValName + , gtWord8HashValName + )) + , (word16HashTypeName, ( ltWord16HashValName + , leWord16HashValName + , eqWord16HashValName + , geWord16HashValName + , gtWord16HashValName + )) +#endif +#if MIN_VERSION_base(4,16,0) + , (int32HashTypeName, ( ltInt32HashValName + , leInt32HashValName + , eqInt32HashValName + , geInt32HashValName + , gtInt32HashValName + )) + , (word32HashTypeName, ( ltWord32HashValName + , leWord32HashValName + , eqWord32HashValName + , geWord32HashValName + , gtWord32HashValName + )) +#endif + ] + +removeClassApp :: Type -> Type +removeClassApp (AppT _ t2) = t2 +removeClassApp t = t + +-- This is an ugly, but unfortunately necessary hack on older versions of GHC which +-- don't have a properly working newName. On those GHCs, even running newName on a +-- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by +-- appending an uncommonly used string to the end of the name. This isn't foolproof, +-- since a user could freshen a variable named x and still have another x_' variable in +-- scope, but at least it's unlikely. +freshen :: Name -> Q Name +freshen n = newName (nameBase n ++ "_'") + +freshenType :: Type -> Q Type +freshenType t = + do let xs = [(n, VarT `fmap` freshen n) | n <- freeVariables t] + subst <- T.sequence (Map.fromList xs) + return (applySubstitution subst t) + +enumFromToExpr :: Q Exp -> Q Exp -> Q Exp +enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t + +primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp +primOpAppExpr e1 op e2 = varE isTrueHashValName `appE` + infixApp e1 (varE op) e2 + +-- | Checks if a 'Name' represents a tuple type constructor (other than '()') +isNonUnitTuple :: Name -> Bool +isNonUnitTuple = isNonUnitTupleString . nameBase + +-- | Checks if a 'String' represents a tuple (other than '()') +isNonUnitTupleString :: String -> Bool +isNonUnitTupleString ('(':',':_) = True +isNonUnitTupleString _ = False + +-- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does +-- it begin with a colon?). +isInfixDataCon :: String -> Bool +isInfixDataCon (':':_) = True +isInfixDataCon _ = False + +isSym :: String -> Bool +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c + +#if !defined(MIN_VERSION_ghc_boot_th) +startsVarSym, startsConSym :: Char -> Bool +startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids +startsConSym c = c == ':' -- Infix data constructors + +startsVarSymASCII :: Char -> Bool +startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" +#endif + +ghc7'8OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 708 +ghc7'8OrLater = True +#else +ghc7'8OrLater = False +#endif + +------------------------------------------------------------------------------- +-- Manually quoted names +------------------------------------------------------------------------------- + +-- By manually generating these names we avoid needing to use the +-- TemplateHaskell language extension when compiling the deriving-compat library. +-- This allows the library to be used in stage1 cross-compilers. + +derivingCompatPackageKey :: String +#ifdef CURRENT_PACKAGE_KEY +derivingCompatPackageKey = CURRENT_PACKAGE_KEY +#else +derivingCompatPackageKey = "deriving-compat-" ++ showVersion version +#endif + +gHC_IX :: String +#if MIN_VERSION_base(4,14,0) +gHC_IX = "GHC.Ix" +#else +gHC_IX = "GHC.Arr" +#endif + +mkDerivingCompatName_v :: String -> Name +mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" + +mkDerivingCompatName_tc :: String -> Name +mkDerivingCompatName_tc = mkNameG_tc derivingCompatPackageKey "Data.Deriving.Internal" + +isTrueHashValName :: Name +isTrueHashValName = mkDerivingCompatName_v "isTrue#" + +fmapConstValName :: Name +fmapConstValName = mkDerivingCompatName_v "fmapConst" + +replaceConstValName :: Name +replaceConstValName = mkDerivingCompatName_v "replaceConst" + +foldrConstValName :: Name +foldrConstValName = mkDerivingCompatName_v "foldrConst" + +foldMapConstValName :: Name +foldMapConstValName = mkDerivingCompatName_v "foldMapConst" + +nullConstValName :: Name +nullConstValName = mkDerivingCompatName_v "nullConst" + +traverseConstValName :: Name +traverseConstValName = mkDerivingCompatName_v "traverseConst" + +eqConstValName :: Name +eqConstValName = mkDerivingCompatName_v "eqConst" + +eq1ConstValName :: Name +eq1ConstValName = mkDerivingCompatName_v "eq1Const" + +liftEqConstValName :: Name +liftEqConstValName = mkDerivingCompatName_v "liftEqConst" + +liftEq2ConstValName :: Name +liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const" + +compareConstValName :: Name +compareConstValName = mkDerivingCompatName_v "compareConst" + +ltConstValName :: Name +ltConstValName = mkDerivingCompatName_v "ltConst" + +compare1ConstValName :: Name +compare1ConstValName = mkDerivingCompatName_v "compare1Const" + +liftCompareConstValName :: Name +liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst" + +liftCompare2ConstValName :: Name +liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const" + +readsPrecConstValName :: Name +readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst" + +readPrecConstValName :: Name +readPrecConstValName = mkDerivingCompatName_v "readPrecConst" + +readsPrec1ConstValName :: Name +readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const" + +liftReadsPrecConstValName :: Name +liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst" + +liftReadPrecConstValName :: Name +liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst" + +liftReadsPrec2ConstValName :: Name +liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const" + +liftReadPrec2ConstValName :: Name +liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const" + +showsPrecConstValName :: Name +showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst" + +showsPrec1ConstValName :: Name +showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const" + +liftShowsPrecConstValName :: Name +liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst" + +liftShowsPrec2ConstValName :: Name +liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" + +viaTypeName :: Name +viaTypeName = mkDerivingCompatName_tc "Via" + +cHashDataName :: Name +cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" + +dHashDataName :: Name +dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#" + +fHashDataName :: Name +fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#" + +identDataName :: Name +identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident" + +iHashDataName :: Name +iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#" + +puncDataName :: Name +puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc" + +symbolDataName :: Name +symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol" + +wrapMonadDataName :: Name +wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" + +addrHashTypeName :: Name +addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#" + +boundedTypeName :: Name +boundedTypeName = mkNameG_tc "base" "GHC.Enum" "Bounded" + +charHashTypeName :: Name +charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#" + +doubleHashTypeName :: Name +doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#" + +enumTypeName :: Name +enumTypeName = mkNameG_tc "base" "GHC.Enum" "Enum" + +floatHashTypeName :: Name +floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#" + +foldableTypeName :: Name +foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" + +functorTypeName :: Name +functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" + +intTypeName :: Name +intTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Int" + +intHashTypeName :: Name +intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#" + +ixTypeName :: Name +ixTypeName = mkNameG_tc "base" gHC_IX "Ix" + +readTypeName :: Name +readTypeName = mkNameG_tc "base" "GHC.Read" "Read" + +showTypeName :: Name +showTypeName = mkNameG_tc "base" "GHC.Show" "Show" + +traversableTypeName :: Name +traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" + +wordHashTypeName :: Name +wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#" + +altValName :: Name +altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++" + +appendValName :: Name +appendValName = mkNameG_v "base" "GHC.Base" "++" + +chooseValName :: Name +chooseValName = mkNameG_v "base" "GHC.Read" "choose" + +coerceValName :: Name +coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" + +composeValName :: Name +composeValName = mkNameG_v "base" "GHC.Base" "." + +constValName :: Name +constValName = mkNameG_v "base" "GHC.Base" "const" + +enumFromValName :: Name +enumFromValName = mkNameG_v "base" "GHC.Enum" "enumFrom" + +enumFromThenValName :: Name +enumFromThenValName = mkNameG_v "base" "GHC.Enum" "enumFromThen" + +enumFromThenToValName :: Name +enumFromThenToValName = mkNameG_v "base" "GHC.Enum" "enumFromThenTo" + +enumFromToValName :: Name +enumFromToValName = mkNameG_v "base" "GHC.Enum" "enumFromTo" + +eqAddrHashValName :: Name +eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#" + +eqCharHashValName :: Name +eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#" + +eqDoubleHashValName :: Name +eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##" + +eqFloatHashValName :: Name +eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#" + +eqIntHashValName :: Name +eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#" + +eqWordHashValName :: Name +eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#" + +errorValName :: Name +errorValName = mkNameG_v "base" "GHC.Err" "error" + +flipValName :: Name +flipValName = mkNameG_v "base" "GHC.Base" "flip" + +fmapValName :: Name +fmapValName = mkNameG_v "base" "GHC.Base" "fmap" + +foldrValName :: Name +foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" + +foldMapValName :: Name +foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" + +fromEnumValName :: Name +fromEnumValName = mkNameG_v "base" "GHC.Enum" "fromEnum" + +geAddrHashValName :: Name +geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#" + +geCharHashValName :: Name +geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#" + +geDoubleHashValName :: Name +geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##" + +geFloatHashValName :: Name +geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#" + +geIntHashValName :: Name +geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#" + +getTagValName :: Name +getTagValName = mkNameG_v "base" "GHC.Base" "getTag" + +geWordHashValName :: Name +geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#" + +gtAddrHashValName :: Name +gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#" + +gtCharHashValName :: Name +gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#" + +gtDoubleHashValName :: Name +gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##" + +gtFloatHashValName :: Name +gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#" + +gtIntHashValName :: Name +gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#" + +gtWordHashValName :: Name +gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#" + +idValName :: Name +idValName = mkNameG_v "base" "GHC.Base" "id" + +indexValName :: Name +indexValName = mkNameG_v "base" gHC_IX "index" + +inRangeValName :: Name +inRangeValName = mkNameG_v "base" gHC_IX "inRange" + +leAddrHashValName :: Name +leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#" + +leCharHashValName :: Name +leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#" + +leDoubleHashValName :: Name +leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##" + +leFloatHashValName :: Name +leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#" + +leIntHashValName :: Name +leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#" + +leWordHashValName :: Name +leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#" + +liftReadListPrecDefaultValName :: Name +liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault" + +liftReadListPrec2DefaultValName :: Name +liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default" + +liftReadListPrecValName :: Name +liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec" + +liftReadListPrec2ValName :: Name +liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2" + +liftReadPrecValName :: Name +liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec" + +liftReadPrec2ValName :: Name +liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2" + +listValName :: Name +listValName = mkNameG_v "base" "GHC.Read" "list" + +ltAddrHashValName :: Name +ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#" + +ltCharHashValName :: Name +ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#" + +ltDoubleHashValName :: Name +ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##" + +ltFloatHashValName :: Name +ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#" + +ltIntHashValName :: Name +ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#" + +ltWordHashValName :: Name +ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#" + +minBoundValName :: Name +minBoundValName = mkNameG_v "base" "GHC.Enum" "minBound" + +mapValName :: Name +mapValName = mkNameG_v "base" "GHC.Base" "map" + +maxBoundValName :: Name +maxBoundValName = mkNameG_v "base" "GHC.Enum" "maxBound" + +minusIntHashValName :: Name +minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#" + +neqIntHashValName :: Name +neqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "/=#" + +parenValName :: Name +parenValName = mkNameG_v "base" "GHC.Read" "paren" + +parensValName :: Name +parensValName = mkNameG_v "base" "GHC.Read" "parens" + +pfailValName :: Name +pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail" + +plusValName :: Name +plusValName = mkNameG_v "base" "GHC.Num" "+" + +precValName :: Name +precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec" + +predValName :: Name +predValName = mkNameG_v "base" "GHC.Enum" "pred" + +rangeSizeValName :: Name +rangeSizeValName = mkNameG_v "base" gHC_IX "rangeSize" + +rangeValName :: Name +rangeValName = mkNameG_v "base" gHC_IX "range" + +readFieldHash :: String -> ReadPrec a -> ReadPrec a +readFieldHash fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Symbol "#") + expectP (L.Punc "=") + readVal +{-# NOINLINE readFieldHash #-} + +readFieldHashValName :: Name +readFieldHashValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readFieldHash" + +readListValName :: Name +readListValName = mkNameG_v "base" "GHC.Read" "readList" + +readListPrecDefaultValName :: Name +readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault" + +readListPrecValName :: Name +readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec" + +readPrec_to_SValName :: Name +readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S" + +readPrecValName :: Name +readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec" + +readS_to_PrecValName :: Name +readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec" + +readsPrecValName :: Name +readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec" + +replaceValName :: Name +replaceValName = mkNameG_v "base" "GHC.Base" "<$" + +resetValName :: Name +resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset" + +returnValName :: Name +returnValName = mkNameG_v "base" "GHC.Base" "return" + +seqValName :: Name +seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" + +showCharValName :: Name +showCharValName = mkNameG_v "base" "GHC.Show" "showChar" + +showListValName :: Name +showListValName = mkNameG_v "base" "GHC.Show" "showList" + +showListWithValName :: Name +showListWithValName = mkNameG_v "base" "Text.Show" "showListWith" + +showParenValName :: Name +showParenValName = mkNameG_v "base" "GHC.Show" "showParen" + +showsPrecValName :: Name +showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec" + +showSpaceValName :: Name +showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace" + +showStringValName :: Name +showStringValName = mkNameG_v "base" "GHC.Show" "showString" + +stepValName :: Name +stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step" + +succValName :: Name +succValName = mkNameG_v "base" "GHC.Enum" "succ" + +tagToEnumHashValName :: Name +tagToEnumHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#" + +timesValName :: Name +timesValName = mkNameG_v "base" "GHC.Num" "*" + +toEnumValName :: Name +toEnumValName = mkNameG_v "base" "GHC.Enum" "toEnum" + +traverseValName :: Name +traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" + +unsafeIndexValName :: Name +unsafeIndexValName = mkNameG_v "base" gHC_IX "unsafeIndex" + +unsafeRangeSizeValName :: Name +unsafeRangeSizeValName = mkNameG_v "base" gHC_IX "unsafeRangeSize" + +unwrapMonadValName :: Name +unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" + +#if MIN_VERSION_base(4,4,0) +boolTypeName :: Name +boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool" + +falseDataName :: Name +falseDataName = mkNameG_d "ghc-prim" "GHC.Types" "False" + +trueDataName :: Name +trueDataName = mkNameG_d "ghc-prim" "GHC.Types" "True" +#else +boolTypeName :: Name +boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool" + +falseDataName :: Name +falseDataName = mkNameG_d "ghc-prim" "GHC.Bool" "False" + +trueDataName :: Name +trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True" +#endif + +#if MIN_VERSION_base(4,5,0) +eqDataName :: Name +eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ" + +gtDataName :: Name +gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT" + +ltDataName :: Name +ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT" + +eqTypeName :: Name +eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq" + +ordTypeName :: Name +ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord" + +andValName :: Name +andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&" + +compareValName :: Name +compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare" + +eqValName :: Name +eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "==" + +geValName :: Name +geValName = mkNameG_v "ghc-prim" "GHC.Classes" ">=" + +gtValName :: Name +gtValName = mkNameG_v "ghc-prim" "GHC.Classes" ">" + +leValName :: Name +leValName = mkNameG_v "ghc-prim" "GHC.Classes" "<=" + +ltValName :: Name +ltValName = mkNameG_v "ghc-prim" "GHC.Classes" "<" + +notValName :: Name +notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not" +#else +eqDataName :: Name +eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ" + +gtDataName :: Name +gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT" + +ltDataName :: Name +ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT" + +eqTypeName :: Name +eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq" + +ordTypeName :: Name +ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord" + +andValName :: Name +andValName = mkNameG_v "base" "GHC.Classes" "&&" + +compareValName :: Name +compareValName = mkNameG_v "base" "GHC.Classes" "compare" + +eqValName :: Name +eqValName = mkNameG_v "base" "GHC.Classes" "==" + +geValName :: Name +geValName = mkNameG_v "base" "GHC.Classes" ">=" + +gtValName :: Name +gtValName = mkNameG_v "base" "GHC.Classes" ">" + +leValName :: Name +leValName = mkNameG_v "base" "GHC.Classes" "<=" + +ltValName :: Name +ltValName = mkNameG_v "base" "GHC.Classes" "<" + +notValName :: Name +notValName = mkNameG_v "base" "GHC.Classes" "not" +#endif + +#if MIN_VERSION_base(4,6,0) +wHashDataName :: Name +wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#" +#else +wHashDataName :: Name +wHashDataName = mkNameG_d "base" "GHC.Word" "W#" +#endif + +#if MIN_VERSION_base(4,7,0) +expectPValName :: Name +expectPValName = mkNameG_v "base" "GHC.Read" "expectP" +#else +expectP :: Lexeme -> ReadPrec () +expectP lexeme = do + thing <- lexP + if thing == lexeme then return () else pfail + +expectPValName :: Name +expectPValName = mkDerivingCompatName_v "expectP" +#endif + +#if MIN_VERSION_base(4,8,0) +allValName :: Name +allValName = mkNameG_v "base" "Data.Foldable" "all" + +apValName :: Name +apValName = mkNameG_v "base" "GHC.Base" "<*>" + +pureValName :: Name +pureValName = mkNameG_v "base" "GHC.Base" "pure" + +liftA2ValName :: Name +liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2" + +mappendValName :: Name +mappendValName = mkNameG_v "base" "GHC.Base" "mappend" + +memptyValName :: Name +memptyValName = mkNameG_v "base" "GHC.Base" "mempty" + +nullValName :: Name +nullValName = mkNameG_v "base" "Data.Foldable" "null" +#else +allValName :: Name +allValName = mkNameG_v "base" "GHC.List" "all" + +apValName :: Name +apValName = mkNameG_v "base" "Control.Applicative" "<*>" + +pureValName :: Name +pureValName = mkNameG_v "base" "Control.Applicative" "pure" + +liftA2ValName :: Name +liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2" + +mappendValName :: Name +mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" + +memptyValName :: Name +memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" + +nullValName :: Name +nullValName = mkNameG_v "base" "GHC.List" "null" +#endif + +#if MIN_VERSION_base(4,9,0) +eq1TypeName :: Name +eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1" + +eq2TypeName :: Name +eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2" + +liftEqValName :: Name +liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq" + +liftEq2ValName :: Name +liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2" + +ord1TypeName :: Name +ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1" + +ord2TypeName :: Name +ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2" + +liftCompareValName :: Name +liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare" + +liftCompare2ValName :: Name +liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2" + +read1TypeName :: Name +read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1" + +read2TypeName :: Name +read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2" + +liftReadsPrecValName :: Name +liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec" + +liftReadListValName :: Name +liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList" + +liftReadsPrec2ValName :: Name +liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2" + +liftReadList2ValName :: Name +liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2" + +show1TypeName :: Name +show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1" + +show2TypeName :: Name +show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2" + +liftShowListValName :: Name +liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList" + +liftShowsPrecValName :: Name +liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec" + +liftShowList2ValName :: Name +liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2" + +liftShowsPrec2ValName :: Name +liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2" +#else +-- If Data.Functor.Classes isn't located in base, then sadly we can't refer to +-- Names from that module without using -XTemplateHaskell. +# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +eq1TypeName :: Name +eq1TypeName = ''Eq1 + +eq2TypeName :: Name +eq2TypeName = ''Eq2 + +liftEqValName :: Name +liftEqValName = 'liftEq + +liftEq2ValName :: Name +liftEq2ValName = 'liftEq2 + +ord1TypeName :: Name +ord1TypeName = ''Ord1 + +ord2TypeName :: Name +ord2TypeName = ''Ord2 + +liftCompareValName :: Name +liftCompareValName = 'liftCompare + +liftCompare2ValName :: Name +liftCompare2ValName = 'liftCompare2 + +read1TypeName :: Name +read1TypeName = ''Read1 + +read2TypeName :: Name +read2TypeName = ''Read2 + +liftReadsPrecValName :: Name +liftReadsPrecValName = 'liftReadsPrec + +liftReadListValName :: Name +liftReadListValName = 'liftReadList + +liftReadsPrec2ValName :: Name +liftReadsPrec2ValName = 'liftReadsPrec2 + +liftReadList2ValName :: Name +liftReadList2ValName = 'liftReadList2 + +show1TypeName :: Name +show1TypeName = ''Show1 + +show2TypeName :: Name +show2TypeName = ''Show2 + +liftShowListValName :: Name +liftShowListValName = 'liftShowList + +liftShowsPrecValName :: Name +liftShowsPrecValName = 'liftShowsPrec + +liftShowList2ValName :: Name +liftShowList2ValName = 'liftShowList2 + +liftShowsPrec2ValName :: Name +liftShowsPrec2ValName = 'liftShowsPrec2 +# else +eq1TypeName :: Name +eq1TypeName = ''Eq1 + +eq1ValName :: Name +eq1ValName = 'eq1 + +ord1TypeName :: Name +ord1TypeName = ''Ord1 + +compare1ValName :: Name +compare1ValName = 'compare1 + +read1TypeName :: Name +read1TypeName = ''Read1 + +readsPrec1ValName :: Name +readsPrec1ValName = 'readsPrec1 + +show1TypeName :: Name +show1TypeName = ''Show1 + +showsPrec1ValName :: Name +showsPrec1ValName = 'showsPrec1 + +newtype Apply f a = Apply { unApply :: f a } + +instance (Eq1 f, Eq a) => Eq (Apply f a) where + Apply x == Apply y = eq1 x y + +instance (Ord1 g, Ord a) => Ord (Apply g a) where + compare (Apply x) (Apply y) = compare1 x y + +instance (Read1 f, Read a) => Read (Apply f a) where + readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s] + +instance (Show1 f, Show a) => Show (Apply f a) where + showsPrec p (Apply x) = showsPrec1 p x + +makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp +makeFmapApplyNeg = makeFmapApply False + +makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp +makeFmapApplyPos = makeFmapApply True + +makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp +makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name +makeFmapApply pos cRep conName t name = do + let tyCon :: Type + tyArgs :: [Type] + (tyCon, tyArgs) = unapplyTy t + + numLastArgs :: Int + numLastArgs = min (arity cRep) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + inspectTy :: Type -> Q Exp + inspectTy (SigT ty _) = inspectTy ty + inspectTy (VarT a) | a == name = varE idValName + inspectTy beta = varE fmapValName `appE` + infixApp (if pos then makeFmapApply pos cRep conName beta name + else conE applyDataName) + (varE composeValName) + (if pos then varE unApplyValName + else makeFmapApply pos cRep conName beta name) + + itf <- isInTypeFamilyApp [name] tyCon tyArgs + if any (`mentionsName` [name]) lhsArgs || itf + then outOfPlaceTyVarError cRep conName + else inspectTy (head rhsArgs) + +applyDataName :: Name +applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply" + +unApplyValName :: Name +unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply" +# endif +#endif + +#if MIN_VERSION_base(4,10,0) +showCommaSpaceValName :: Name +showCommaSpaceValName = mkNameG_v "base" "GHC.Show" "showCommaSpace" +#else +showCommaSpace :: ShowS +showCommaSpace = showString ", " + +showCommaSpaceValName :: Name +showCommaSpaceValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "showCommaSpace" +#endif + +#if MIN_VERSION_base(4,11,0) +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" + +readFieldValName :: Name +readFieldValName = mkNameG_v "base" "GHC.Read" "readField" + +readSymFieldValName :: Name +readSymFieldValName = mkNameG_v "base" "GHC.Read" "readSymField" +#else +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" + +readField :: String -> ReadPrec a -> ReadPrec a +readField fieldName readVal = do + expectP (L.Ident fieldName) + expectP (L.Punc "=") + readVal +{-# NOINLINE readField #-} + +readFieldValName :: Name +readFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readField" + +readSymField :: String -> ReadPrec a -> ReadPrec a +readSymField fieldName readVal = do + expectP (L.Punc "(") + expectP (L.Symbol fieldName) + expectP (L.Punc ")") + expectP (L.Punc "=") + readVal +{-# NOINLINE readSymField #-} + +readSymFieldValName :: Name +readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField" +#endif + +#if MIN_VERSION_base(4,13,0) +eqInt8HashValName :: Name +eqInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt8#" + +eqInt16HashValName :: Name +eqInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt16#" + +eqWord8HashValName :: Name +eqWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord8#" + +eqWord16HashValName :: Name +eqWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#" + +geInt8HashValName :: Name +geInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#" + +geInt16HashValName :: Name +geInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt16#" + +geWord8HashValName :: Name +geWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord8#" + +geWord16HashValName :: Name +geWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord16#" + +gtInt8HashValName :: Name +gtInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt8#" + +gtInt16HashValName :: Name +gtInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt16#" + +gtWord8HashValName :: Name +gtWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord8#" + +gtWord16HashValName :: Name +gtWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord16#" + +int8HashTypeName :: Name +int8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#" + +int8ToIntHashValName :: Name +int8ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "int8ToInt#" +# else + "extendInt8#" +# endif + +int16HashTypeName :: Name +int16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#" + +int16ToIntHashValName :: Name +int16ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "int16ToInt#" +# else + "extendInt16#" +# endif + +intToInt8HashValName :: Name +intToInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "intToInt8#" +# else + "narrowInt8#" +# endif + +intToInt16HashValName :: Name +intToInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "intToInt16#" +# else + "narrowInt16#" +# endif + +leInt8HashValName :: Name +leInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#" + +leInt16HashValName :: Name +leInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt16#" + +leWord8HashValName :: Name +leWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord8#" + +leWord16HashValName :: Name +leWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord16#" + +ltInt8HashValName :: Name +ltInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt8#" + +ltInt16HashValName :: Name +ltInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt16#" + +ltWord8HashValName :: Name +ltWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord8#" + +ltWord16HashValName :: Name +ltWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord16#" + +word8HashTypeName :: Name +word8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#" + +word8ToWordHashValName :: Name +word8ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "word8ToWord#" +# else + "extendWord8#" +# endif + +word16HashTypeName :: Name +word16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#" + +word16ToWordHashValName :: Name +word16ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "word16ToWord#" +# else + "extendWord16#" +# endif + +wordToWord8HashValName :: Name +wordToWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "wordToWord8#" +# else + "narrowWord8#" +# endif + +wordToWord16HashValName :: Name +wordToWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" +# if MIN_VERSION_base(4,16,0) + "wordToWord16#" +# else + "narrowWord16#" +# endif +#endif + +#if MIN_VERSION_base(4,16,0) +eqInt32HashValName :: Name +eqInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt32#" + +eqWord32HashValName :: Name +eqWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord32#" + +geInt32HashValName :: Name +geInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt32#" + +geWord32HashValName :: Name +geWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord32#" + +gtInt32HashValName :: Name +gtInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt32#" + +gtWord32HashValName :: Name +gtWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord32#" + +int32HashTypeName :: Name +int32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int32#" + +int32ToIntHashValName :: Name +int32ToIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "int32ToInt#" + +intToInt32HashValName :: Name +intToInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "intToInt32#" + +leInt32HashValName :: Name +leInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt32#" + +leWord32HashValName :: Name +leWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord32#" + +ltInt32HashValName :: Name +ltInt32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt32#" + +ltWord32HashValName :: Name +ltWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord32#" + +word32HashTypeName :: Name +word32HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word32#" + +word32ToWordHashValName :: Name +word32ToWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "word32ToWord#" + +wordToWord32HashValName :: Name +wordToWord32HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "wordToWord32#" +#endif
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,295 +1,296 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--{-|-Module: Types.EqOrd-Copyright: (C) 2015-2017 Ryan Scott-License: BSD-style (see the file LICENSE)-Maintainer: Ryan Scott-Portability: Template Haskell--Shared datatypes between "EqSpec" and "OrdSpec".--}-module Types.EqOrd where--#if !defined(NEW_FUNCTOR_CLASSES)-import Data.Functor.Classes (Eq1(..), Ord1(..))-#endif-import Data.Deriving--import GHC.Exts ( Addr#, Char#, Double#, Float#, Int#, Word#-#if MIN_VERSION_base(4,13,0)- , Int8#, Int16#, Word8#, Word16#-#endif-#if MIN_VERSION_base(4,16,0)- , Int32#, Word32#-#endif- )---- Plain data types--data TyCon1 a m =- TyCon1A a- | TyCon1B- | TyCon1C- | TyCon1D- | TyCon1E- | TyCon1F- | TyCon1G- | TyCon1H- | TyCon1I- | TyCon1J- | TyCon1K- | TyCon1L- | TyCon1M m--data TyCon# a b = TyCon# {- tcA :: a- , tcB :: b- , tcAddr# :: Addr#- , tcInt# :: Int#- , tcFloat# :: Float#- , tcDouble# :: Double#- , tcChar# :: Char#- , tcWord# :: Word#-#if MIN_VERSION_base(4,13,0)- , tcInt8# :: Int8#- , tcInt16# :: Int16#- , tcWord8# :: Word8#- , tcWord16# :: Word16#-#endif-#if MIN_VERSION_base(4,16,0)- , tcInt32# :: Int32#- , tcWord32# :: Word32#-#endif-}--data TyCon2 a b c d where- TyConClassConstraints :: (Show m, Show n, Show o, Show p)- => m -> n -> o -> p- -> TyCon2 m n o p-- TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f)- => e -> f -> g -> h- -> TyCon2 e f g h-- TyConTypeRefinement1,- TyConTypeRefinement2 :: Int -> z- -> TyCon2 Int Int z z--data TyConWrap f g h a = TyConWrap1 (f a)- | TyConWrap2 (f (g a))- | TyConWrap3 (f (g (h a)))--data Empty a b--data TyConNullary a b- = TyConNullary1- | TyConNullary2- | TyConNullary3---- Data families--data family TyFamily1 y z :: *--data instance TyFamily1 a m =- TyFamily1A a- | TyFamily1B- | TyFamily1C- | TyFamily1D- | TyFamily1E- | TyFamily1F- | TyFamily1G- | TyFamily1H- | TyFamily1I- | TyFamily1J- | TyFamily1K- | TyFamily1L- | TyFamily1M m--data family TyFamily# y z :: *--data instance TyFamily# a b = TyFamily# {- tfA :: a- , tfB :: b- , tfInt# :: Int#- , tfFloat# :: Float#- , tfDouble# :: Double#- , tfChar# :: Char#- , tfWord# :: Word#-#if MIN_VERSION_base(4,13,0)- , tfInt8# :: Int8#- , tfInt16# :: Int16#- , tfWord8# :: Word8#- , tfWord16# :: Word16#-#endif-#if MIN_VERSION_base(4,16,0)- , tfInt32# :: Int32#- , tfWord32# :: Word32#-#endif-}--data family TyFamily2 w x y z :: *--data instance TyFamily2 a b c d where- TyFamilyClassConstraints :: (Show m, Show n, Show o, Show p)- => m -> n -> o -> p- -> TyFamily2 m n o p-- TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f)- => e -> f -> g -> h- -> TyFamily2 e f g h-- TyFamilyTypeRefinement1,- TyFamilyTypeRefinement2 :: Int -> z- -> TyFamily2 Int Int z z--data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: *--data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a)- | TyFamilyWrap2 (f (g a))- | TyFamilyWrap3 (f (g (h a)))--data family TyFamilyNullary x y :: *--data instance TyFamilyNullary a b- = TyFamilyNullary1- | TyFamilyNullary2- | TyFamilyNullary3------------------------------------------------------------------------------------- Plain data types--$(deriveEq ''TyCon1)-$(deriveEq ''TyCon#)-$(deriveEq ''TyCon2)-instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a))))- => Eq (TyConWrap f g h a) where- (==) = $(makeEq ''TyConWrap)- (/=) = $(makeNotEq ''TyConWrap)-$(deriveEq ''Empty)-$(deriveEq ''TyConNullary)--$(deriveEq1 ''TyCon1)-$(deriveEq1 ''TyCon#)-$(deriveEq1 ''TyCon2)-$(deriveEq1 ''Empty)-$(deriveEq1 ''TyConNullary)--$(deriveOrd ''TyCon1)-$(deriveOrd ''TyCon#)-$(deriveOrd ''TyCon2)-instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a))))- => Ord (TyConWrap f g h a) where- compare = $(makeCompare ''TyConWrap)- (>) = $(makeLT ''TyConWrap)- (>=) = $(makeLE ''TyConWrap)- (<) = $(makeGT ''TyConWrap)- (<=) = $(makeGE ''TyConWrap)- max = $(makeMax ''TyConWrap)- min = $(makeMin ''TyConWrap)-$(deriveOrd ''Empty)--$(deriveOrd1 ''TyCon1)-$(deriveOrd1 ''TyCon#)-$(deriveOrd1 ''TyCon2)-$(deriveOrd1 ''Empty)-$(deriveOrd1 ''TyConNullary)--#if defined(NEW_FUNCTOR_CLASSES)-$(deriveEq1 ''TyConWrap)--$(deriveOrd1 ''TyConWrap)-#else-instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h)- => Eq1 (TyConWrap f g h) where- eq1 = $(makeEq1 ''TyConWrap)--instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h)- => Ord1 (TyConWrap f g h) where- compare1 = $(makeCompare1 ''TyConWrap)-#endif--#if defined(NEW_FUNCTOR_CLASSES)-$(deriveEq2 ''TyCon1)-$(deriveEq2 ''TyCon#)-$(deriveEq2 ''TyCon2)-$(deriveEq2 ''Empty)-$(deriveEq2 ''TyConNullary)--$(deriveOrd2 ''TyCon1)-$(deriveOrd2 ''TyCon#)-$(deriveOrd2 ''TyCon2)-$(deriveOrd2 ''Empty)-$(deriveOrd2 ''TyConNullary)-#endif--#if MIN_VERSION_template_haskell(2,7,0)--- Data families--$(deriveEq 'TyFamily1A)-$(deriveEq 'TyFamily#)-$(deriveEq 'TyFamilyClassConstraints)-instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a))))- => Eq (TyFamilyWrap f g h a) where- (==) = $(makeEq 'TyFamilyWrap1)- (/=) = $(makeNotEq 'TyFamilyWrap1)-$(deriveEq 'TyFamilyNullary1)--$(deriveEq1 'TyFamily1B)-$(deriveEq1 'TyFamily#)-$(deriveEq1 'TyFamilyEqualityConstraints)-$(deriveEq1 'TyFamilyNullary1)--$(deriveOrd 'TyFamily1A)-$(deriveOrd 'TyFamily#)-$(deriveOrd 'TyFamilyClassConstraints)-instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a))))- => Ord (TyFamilyWrap f g h a) where- compare = $(makeCompare 'TyFamilyWrap1)- (>) = $(makeLT 'TyFamilyWrap1)- (>=) = $(makeLE 'TyFamilyWrap1)- (<) = $(makeGT 'TyFamilyWrap1)- (<=) = $(makeGE 'TyFamilyWrap1)- max = $(makeMax 'TyFamilyWrap1)- min = $(makeMin 'TyFamilyWrap1)-$(deriveOrd 'TyFamilyNullary1)--$(deriveOrd1 'TyFamily1B)-$(deriveOrd1 'TyFamily#)-$(deriveOrd1 'TyFamilyEqualityConstraints)-$(deriveOrd1 'TyFamilyNullary1)--#if defined(NEW_FUNCTOR_CLASSES)-$(deriveEq1 'TyFamilyWrap2)--$(deriveOrd1 'TyFamilyWrap2)-#else-instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h)- => Eq1 (TyFamilyWrap f g h) where- eq1 = $(makeEq1 'TyFamilyWrap3)--instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h)- => Ord1 (TyFamilyWrap f g h) where- compare1 = $(makeCompare1 'TyFamilyWrap3)-#endif--# if defined(NEW_FUNCTOR_CLASSES)-$(deriveEq2 'TyFamily1C)-$(deriveEq2 'TyFamily#)-$(deriveEq2 'TyFamilyTypeRefinement1)-$(deriveEq2 'TyFamilyNullary1)--$(deriveOrd2 'TyFamily1C)-$(deriveOrd2 'TyFamily#)-$(deriveOrd2 'TyFamilyTypeRefinement1)-$(deriveOrd2 'TyFamilyNullary1)-# endif-#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: Types.EqOrd +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Shared datatypes between "EqSpec" and "OrdSpec". +-} +module Types.EqOrd where + +#if !defined(NEW_FUNCTOR_CLASSES) +import Data.Functor.Classes (Eq1(..), Ord1(..)) +#endif +import Data.Deriving + +import GHC.Exts ( Addr#, Char#, Double#, Float#, Int#, Word# +#if MIN_VERSION_base(4,13,0) + , Int8#, Int16#, Word8#, Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , Int32#, Word32# +#endif + ) + +-- Plain data types + +data TyCon1 a m = + TyCon1A a + | TyCon1B + | TyCon1C + | TyCon1D + | TyCon1E + | TyCon1F + | TyCon1G + | TyCon1H + | TyCon1I + | TyCon1J + | TyCon1K + | TyCon1L + | TyCon1M m + +data TyCon# a b = TyCon# { + tcA :: a + , tcB :: b + , tcAddr# :: Addr# + , tcInt# :: Int# + , tcFloat# :: Float# + , tcDouble# :: Double# + , tcChar# :: Char# + , tcWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tcInt8# :: Int8# + , tcInt16# :: Int16# + , tcWord8# :: Word8# + , tcWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tcInt32# :: Int32# + , tcWord32# :: Word32# +#endif +} + +data TyCon2 a b c d where + TyConClassConstraints :: (Show m, Show n, Show o, Show p) + => m -> n -> o -> p + -> TyCon2 m n o p + + TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyCon2 e f g h + + TyConTypeRefinement1, + TyConTypeRefinement2 :: Int -> z + -> TyCon2 Int Int z z + +data TyConWrap f g h a = TyConWrap1 (f a) + | TyConWrap2 (f (g a)) + | TyConWrap3 (f (g (h a))) + +data Empty a b + +data TyConNullary a b + = TyConNullary1 + | TyConNullary2 + | TyConNullary3 + +-- Data families + +data family TyFamily1 y z :: * + +data instance TyFamily1 a m = + TyFamily1A a + | TyFamily1B + | TyFamily1C + | TyFamily1D + | TyFamily1E + | TyFamily1F + | TyFamily1G + | TyFamily1H + | TyFamily1I + | TyFamily1J + | TyFamily1K + | TyFamily1L + | TyFamily1M m + +data family TyFamily# y z :: * + +data instance TyFamily# a b = TyFamily# { + tfA :: a + , tfB :: b + , tfInt# :: Int# + , tfFloat# :: Float# + , tfDouble# :: Double# + , tfChar# :: Char# + , tfWord# :: Word# +#if MIN_VERSION_base(4,13,0) + , tfInt8# :: Int8# + , tfInt16# :: Int16# + , tfWord8# :: Word8# + , tfWord16# :: Word16# +#endif +#if MIN_VERSION_base(4,16,0) + , tfInt32# :: Int32# + , tfWord32# :: Word32# +#endif +} + +data family TyFamily2 w x y z :: * + +data instance TyFamily2 a b c d where + TyFamilyClassConstraints :: (Show m, Show n, Show o, Show p) + => m -> n -> o -> p + -> TyFamily2 m n o p + + TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyFamily2 e f g h + + TyFamilyTypeRefinement1, + TyFamilyTypeRefinement2 :: Int -> z + -> TyFamily2 Int Int z z + +data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * + +data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) + | TyFamilyWrap2 (f (g a)) + | TyFamilyWrap3 (f (g (h a))) + +data family TyFamilyNullary x y :: * + +data instance TyFamilyNullary a b + = TyFamilyNullary1 + | TyFamilyNullary2 + | TyFamilyNullary3 + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveEq ''TyCon1) +$(deriveEq ''TyCon#) +$(deriveEq ''TyCon2) +instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) + => Eq (TyConWrap f g h a) where + (==) = $(makeEq ''TyConWrap) + (/=) = $(makeNotEq ''TyConWrap) +$(deriveEq ''Empty) +$(deriveEq ''TyConNullary) + +$(deriveEq1 ''TyCon1) +$(deriveEq1 ''TyCon#) +$(deriveEq1 ''TyCon2) +$(deriveEq1 ''Empty) +$(deriveEq1 ''TyConNullary) + +$(deriveOrd ''TyCon1) +$(deriveOrd ''TyCon#) +$(deriveOrd ''TyCon2) +instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) + => Ord (TyConWrap f g h a) where + compare = $(makeCompare ''TyConWrap) + (>) = $(makeLT ''TyConWrap) + (>=) = $(makeLE ''TyConWrap) + (<) = $(makeGT ''TyConWrap) + (<=) = $(makeGE ''TyConWrap) + max = $(makeMax ''TyConWrap) + min = $(makeMin ''TyConWrap) +$(deriveOrd ''Empty) +$(deriveOrd ''TyConNullary) + +$(deriveOrd1 ''TyCon1) +$(deriveOrd1 ''TyCon#) +$(deriveOrd1 ''TyCon2) +$(deriveOrd1 ''Empty) +$(deriveOrd1 ''TyConNullary) + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq1 ''TyConWrap) + +$(deriveOrd1 ''TyConWrap) +#else +instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) + => Eq1 (TyConWrap f g h) where + eq1 = $(makeEq1 ''TyConWrap) + +instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) + => Ord1 (TyConWrap f g h) where + compare1 = $(makeCompare1 ''TyConWrap) +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq2 ''TyCon1) +$(deriveEq2 ''TyCon#) +$(deriveEq2 ''TyCon2) +$(deriveEq2 ''Empty) +$(deriveEq2 ''TyConNullary) + +$(deriveOrd2 ''TyCon1) +$(deriveOrd2 ''TyCon#) +$(deriveOrd2 ''TyCon2) +$(deriveOrd2 ''Empty) +$(deriveOrd2 ''TyConNullary) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveEq 'TyFamily1A) +$(deriveEq 'TyFamily#) +$(deriveEq 'TyFamilyClassConstraints) +instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) + => Eq (TyFamilyWrap f g h a) where + (==) = $(makeEq 'TyFamilyWrap1) + (/=) = $(makeNotEq 'TyFamilyWrap1) +$(deriveEq 'TyFamilyNullary1) + +$(deriveEq1 'TyFamily1B) +$(deriveEq1 'TyFamily#) +$(deriveEq1 'TyFamilyEqualityConstraints) +$(deriveEq1 'TyFamilyNullary1) + +$(deriveOrd 'TyFamily1A) +$(deriveOrd 'TyFamily#) +$(deriveOrd 'TyFamilyClassConstraints) +instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) + => Ord (TyFamilyWrap f g h a) where + compare = $(makeCompare 'TyFamilyWrap1) + (>) = $(makeLT 'TyFamilyWrap1) + (>=) = $(makeLE 'TyFamilyWrap1) + (<) = $(makeGT 'TyFamilyWrap1) + (<=) = $(makeGE 'TyFamilyWrap1) + max = $(makeMax 'TyFamilyWrap1) + min = $(makeMin 'TyFamilyWrap1) +$(deriveOrd 'TyFamilyNullary1) + +$(deriveOrd1 'TyFamily1B) +$(deriveOrd1 'TyFamily#) +$(deriveOrd1 'TyFamilyEqualityConstraints) +$(deriveOrd1 'TyFamilyNullary1) + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq1 'TyFamilyWrap2) + +$(deriveOrd1 'TyFamilyWrap2) +#else +instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) + => Eq1 (TyFamilyWrap f g h) where + eq1 = $(makeEq1 'TyFamilyWrap3) + +instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) + => Ord1 (TyFamilyWrap f g h) where + compare1 = $(makeCompare1 'TyFamilyWrap3) +#endif + +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveEq2 'TyFamily1C) +$(deriveEq2 'TyFamily#) +$(deriveEq2 'TyFamilyTypeRefinement1) +$(deriveEq2 'TyFamilyNullary1) + +$(deriveOrd2 'TyFamily1C) +$(deriveOrd2 'TyFamily#) +$(deriveOrd2 'TyFamilyTypeRefinement1) +$(deriveOrd2 'TyFamilyNullary1) +# endif +#endif
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