deriving-compat-0.6.5/0000755000000000000000000000000007346545000013003 5ustar0000000000000000deriving-compat-0.6.5/CHANGELOG.md0000644000000000000000000002111507346545000014614 0ustar0000000000000000### 0.6.5 [2023.08.06] * When generating `Show(1)(2)` instances with `Text.Show.Deriving` using GHC 9.8 or later, data types that have fields of type `Int{8,16,32,64}#` or `Word{8,16,32,64}#` will be printed using extended literal syntax, mirroring corresponding changes introduced in GHC 9.8 (see https://github.com/ghc-proposals/ghc-proposals/pull/596). ### 0.6.4 [2023.08.06] * Support building with `template-haskell-2.21.*` (GHC 9.8). * The Template Haskell machinery now uses `TemplateHaskellQuotes` when building with GHC 8.0+ instead of manually constructing each Template Haskell `Name`. A consequence of this is that `deriving-compat` will now build with GHC 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template Haskell changes introduced in 9.8. ### 0.6.3 [2023.02.27] * Support `th-abstraction-0.5.*`. ### 0.6.2 [2022.12.07] * Make the test suite build with GHC 9.6 or later. ### 0.6.1 [2022.05.07] * Backport [GHC!6955](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6955), which makes derived `Eq` instances check data constructor tags, which can improve runtime performance for data types with nullary constructors. * Allow building the test suite with `transformers-0.6.*`. ## 0.6 [2021.08.29] * Allow building with `template-haskell-2.18.0.0` (GHC 9.2). * Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may now require the use of the `TypeInType` extension if using GHC 8.0, 8.2, or 8.4. (On later versions of GHC, `TypeInType`'s functionality has been folded into `PolyKinds`.) * Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields of type `Int32#` or `Word32#` on GHC 9.2 or later. * `deriveVia` now instantiates "floating" `via` type variables (i.e., type variables mentioned in the `via` type that are not mentioned in the instance context or the first argument to `Via`) to `Any` in the generated code. As a result, `deriveVia` no longer generates code that produces `-Wunused-foralls` warnings. ### 0.5.10 [2020.09.30] * Allow building with `template-haskell-2.17.0.0` (GHC 9.0). ### 0.5.9 [2019.06.08] * Have `deriveFunctor` and `deriveFoldable` derive implementations of `(<$)` and `null`, which GHC starting doing in 8.2 and 8.4, respectively. * Fix a bug in which `deriveOrd{,1,2}` could generate incorrect code for data types with a combination of nullary and non-nullary constructors. * Fix a bug in which `deriveFunctor` would fail on sufficiently complex uses of rank-n types in constructor fields. * Fix a bug in which `deriveFunctor` and related functions would needlessly reject data types whose last type parameters appear as oversaturated arguments to a type family. ### 0.5.8 [2019.11.26] * Allow building with GHC 8.10. ### 0.5.7 [2019.08.27] * Permit `deriveVia` to use "floating" `via` type variables, such as the `a` in: ```hs deriveVia [t| forall a. Show MyInt `Via` Const Int a |] ``` ### 0.5.6 [2019.05.02] * Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later. ### 0.5.5 [2019.04.26] * Support `th-abstraction-0.3` or later. ### 0.5.4 [2019.01.21] * Expose `Internal` modules. ### 0.5.3 [2019.01.20] * Fix a bug in which `deriveEnum`/`deriveIx` would generate ill-scoped code for certain poly-kinded data types. ### 0.5.2 [2018.09.13] * Fix a bug (on GHC 8.7 and above) in which `deriveGND`/`deriveVia` would generate ill-scoped code. ### 0.5.1 [2018.07.11] * Have `deriveGND`/`deriveVia` throw an error if an incorrect number of arguments are supplied to the type class. ## 0.5 [2018.07.01] * Backport the changes to `GeneralizedNewtypeDeriving` and `DerivingVia` code generation from [Trac #15290](https://ghc.haskell.org/trac/ghc/ticket/15290). As a result, code generated by `deriveGND` or `deriveVia` now requires the `InstanceSigs` and `ScopedTypeVariables` language extensions. On the other hand, the generated code no longer requires the `ImpredicativeTypes` extension (unless any class methods use higher-rank types). * Allow building with `containers-0.6` and `template-haskell-2.14`. ### 0.4.3 [2018.06.16] * Fix a bug that caused debug-enabled GHC builds to panic when generating code from this library (see [Trac #15270](https://ghc.haskell.org/trac/ghc/ticket/15270)). The fix only affects the library's internals, so no changes are user-facing. ### 0.4.2 [2018.05.14] * Backport the fixes for GHC Trac [#14364](https://ghc.haskell.org/trac/ghc/ticket/14364) and [#14918](https://ghc.haskell.org/trac/ghc/ticket/14918), which significantly improve the compliation times of derived `Read` instances. ### 0.4.1 [2018.02.04] * Add `Data.Deriving.Via`, which allows emulating the behavior of the `GeneralizedNewtypeDeriving` and `DerivingVia` extensions. * Test suite fixes for GHC 8.4. ## 0.4 [2017.12.07] * Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC as of 8.4): * For derived `Eq` and `Ord` instances for empty data types, simply return `True` and `EQ`, respectively, without inspecting the arguments. * For derived `Read` instances for empty data types, simply return `pfail` (without `parens`). * For derived `Show` instances for empty data types, inspect the argument (instead of `error`ing). In addition, add `showEmptyCaseBehavior` to `ShowOptions`, which configures whether derived instances for empty data types should use the `EmptyCase` extension (this is disabled by default). * For derived `Functor` and `Traversable` instances for empty data types, make `fmap` and `traverse` strict in its argument. * For derived `Foldable` instances, do not error on empty data types. Instead, simply return the folded state (for `foldr`) or `mempty` (for `foldMap`), without inspecting the arguments. * Add `FFTOptions` (`Functor`/`Foldable`/`Traversable` options) to `Data.Functor.Deriving`, along with variants of existing functions that take `FFTOptions` as an argument. For now, the only configurable option is whether derived instances for empty data types should use the `EmptyCase` extension (this is disabled by default). * Backport the fix to #13328. That is, when deriving `Functor` or `Traversable` instances for data types where the last type variable is at phantom role, generated `fmap`/`traverse` implementations now use `coerce` for efficiency. * Rename `emptyCaseBehavior` from `Data.Functor.Deriving` to `fftEmptyCaseBehavior`. ### 0.3.6 [2017.04.10] * Make `deriveTraversable` use `liftA2` in derived implementations of `traverse` when possible, now that `liftA2` is a class method of `Applicative` (as of GHC 8.2) * Make `deriveShow` use `showCommaSpace`, a change introduced in GHC 8.2 ### 0.3.5 [2016.12.12] * Fix bug in which derived `Ord` instances for datatypes with many constructors would fail to typecheck ### 0.3.4 [2016.10.20] * Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances * Fix bug in which record selectors weren't parsed correctly in derived `Read` instances ### 0.3.3 [2016.09.11] * Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH. * Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH. * Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH. * Fix bug in which derived `Show` instance would parenthesize the output too eagerly ### 0.3.2 * Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2 * Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods * Fix GHC HEAD build ### 0.3.1 * Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples * Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show` ## 0.3 * Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH. * Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH. * Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH. * Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules. ### 0.2.2 * Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types ### 0.2.1 * Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH. ## 0.2 * Added support for GHC 8.0 * Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH. * Added `Data.Deriving`, which reexports all other modules ## 0.1 * Initial commit deriving-compat-0.6.5/LICENSE0000644000000000000000000000276307346545000014020 0ustar0000000000000000Copyright (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. deriving-compat-0.6.5/README.md0000644000000000000000000000615607346545000014272 0ustar0000000000000000# `deriving-compat` [![Hackage](https://img.shields.io/hackage/v/deriving-compat.svg)][Hackage: deriving-compat] [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] [![Build Status](https://github.com/haskell-compat/deriving-compat/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-compat/deriving-compat/actions?query=workflow%3AHaskell-CI) [Hackage: deriving-compat]: http://hackage.haskell.org/package/deriving-compat "deriving-compat package on Hackage" [Haskell.org]: http://www.haskell.org "The Haskell Programming Language" [tl;dr Legal: BSD3]: https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" `deriving-compat` provides Template Haskell functions that mimic `deriving` extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: * Deriving `Bounded` * Deriving `Enum` * Deriving `Ix` * Deriving `Eq` * Deriving `Ord` * Deriving `Read` * Deriving `Show` * `DeriveFoldable` * `DeriveFunctor` * `DeriveTraversable` * `GeneralizedNewtypeDeriving` (with GHC 8.2 or later) * `DerivingVia` (with GHC 8.2 or later) See the `Data.Deriving` module for a full list of backported changes. In addition, `deriving-compat` also provides some additional `deriving` functionality that has not yet been merged into upstream GHC. Aside from the GHC `deriving` extensions mentioned above, `deriving-compat` also permits deriving instances of classes in the `Data.Functor.Classes` module, covering the `Eq1`, `Eq2`, `Ord1`, `Ord2`, `Read1`, `Read2`, `Show1`, and `Show2` classes. This extra functionality is outside of the main scope of `deriving-compat`, as it does not backport extensions that exist in today's GHC. Nevertheless, the underlying Template Haskell machinery needed to derive `Eq` and friends extends very naturally to `Eq1` and friends, so this extra functionality is included in `deriving-compat` as a convenience. Note that some recent GHC typeclasses/extensions are not covered by this package: * `DeriveDataTypeable` * `DeriveGeneric`, which was introducted in GHC 7.2 for deriving `Generic` instances, and modified in GHC 7.6 to allow derivation of `Generic1` instances. Use `Generics.Deriving.TH` from [`generic-deriving`](http://hackage.haskell.org/package/generic-deriving) to derive `Generic(1)` using Template Haskell. * `DeriveLift`, which was introduced in GHC 8.0 for deriving `Lift` instances. Use `Language.Haskell.TH.Lift` from [`th-lift`](http://hackage.haskell.org/package/th-lift) to derive `Lift` using Template Haskell. * The `Bifunctor` typeclass, which was introduced in GHC 7.10, as well as the `Bifoldable` and `Bitraversable` typeclasses, which were introduced in GHC 8.2. Use `Data.Bifunctor.TH` from [`bifunctors`](http://hackage.haskell.org/package/bifunctors) to derive these typeclasses using Template Haskell. deriving-compat-0.6.5/Setup.hs0000644000000000000000000000005607346545000014440 0ustar0000000000000000import Distribution.Simple main = defaultMain deriving-compat-0.6.5/deriving-compat.cabal0000644000000000000000000002212007346545000017054 0ustar0000000000000000name: deriving-compat version: 0.6.5 synopsis: Backports of GHC deriving extensions description: @deriving-compat@ provides Template Haskell functions that mimic @deriving@ extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: . * Deriving @Bounded@ . * Deriving @Enum@ . * Deriving @Ix@ . * Deriving @Eq@ . * Deriving @Ord@ . * Deriving @Read@ . * Deriving @Show@ . * @DeriveFoldable@ . * @DeriveFunctor@ . * @DeriveTraversable@ . * @GeneralizedNewtypeDeriving@ (with GHC 8.2 or later) . * @DerivingVia@ (with GHC 8.2 or later) . See the "Data.Deriving" module for a full list of backported changes. . In addition, @deriving-compat@ also provides some additional @deriving@ functionality that has not yet been merged into upstream GHC. Aside from the GHC @deriving@ extensions mentioned above, @deriving-compat@ also permits deriving instances of classes in the @Data.Functor.Classes@ module, covering the @Eq1@, @Eq2@, @Ord1@, @Ord2@, @Read1@, @Read2@, @Show1@, and @Show2@ classes. This extra functionality is outside of the main scope of @deriving-compat@, as it does not backport extensions that exist in today's GHC. Nevertheless, the underlying Template Haskell machinery needed to derive @Eq@ and friends extends very naturally to @Eq1@ and friends, so this extra functionality is included in @deriving-compat@ as a convenience. . Note that some recent GHC typeclasses/extensions are not covered by this package: . * @DeriveDataTypeable@ . * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving @Generic@ instances, and modified in GHC 7.6 to allow derivation of @Generic1@ instances. Use @Generics.Deriving.TH@ from @@ to derive @Generic(1)@ using Template Haskell. . * @DeriveLift@, which was introduced in GHC 8.0 for deriving @Lift@ instances. Use @Language.Haskell.TH.Lift@ from @@ to derive @Lift@ using Template Haskell. . * The @Bifunctor@ typeclass, which was introduced in GHC 7.10, as well as the @Bifoldable@ and @Bitraversable@ typeclasses, which were introduced in GHC 8.2. Use @Data.Bifunctor.TH@ from @@ to derive these typeclasses using Template Haskell. homepage: https://github.com/haskell-compat/deriving-compat bug-reports: https://github.com/haskell-compat/deriving-compat/issues license: BSD3 license-file: LICENSE author: Ryan Scott maintainer: Ryan Scott stability: Experimental copyright: (C) 2015-2017 Ryan Scott category: Compatibility build-type: Simple extra-source-files: CHANGELOG.md, README.md tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.5 , GHC == 9.6.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 build-depends: containers >= 0.1 && < 0.7 , ghc-prim , th-abstraction >= 0.4 && < 0.7 if flag(base-4-9) build-depends: base >= 4.9 && < 5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else build-depends: base >= 4.3 && < 4.9 , semigroups >= 0.6 && < 0.21 if flag(template-haskell-2-11) build-depends: template-haskell >= 2.11 && < 2.22 , 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.22 , 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 deriving-compat-0.6.5/src/Data/Bounded/0000755000000000000000000000000007346545000016023 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Bounded/Deriving.hs0000644000000000000000000000124207346545000020125 0ustar0000000000000000{-| 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. -} deriving-compat-0.6.5/src/Data/Bounded/Deriving/0000755000000000000000000000000007346545000017572 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Bounded/Deriving/Internal.hs0000644000000000000000000001155307346545000021707 0ustar0000000000000000{-# 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 qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) 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 (con: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 cons :: NonEmpty ConstructorInfo cons = con :| cons' con1, conN :: Q Exp con1 = conE $ constructorName con conN = conE $ constructorName $ NE.last cons pickCon :: Q Exp pickCon = case bf of MinBound -> con1 MaxBound -> conN pickConApp :: Q Exp pickConApp = appsE $ pickCon : map varE (replicate (conArity con) (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 deriving-compat-0.6.5/src/Data/0000755000000000000000000000000007346545000014443 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Deriving.hs0000644000000000000000000002631107346545000016551 0ustar0000000000000000{-| 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) @ -} deriving-compat-0.6.5/src/Data/Deriving/0000755000000000000000000000000007346545000016212 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Deriving/Internal.hs0000644000000000000000000017522207346545000020333 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} #else {-# LANGUAGE TemplateHaskell #-} #endif {-| Module: Data.Deriving.Internal Copyright: (C) 2015-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Template Haskell-related utilities. Note: this is an internal module, and as such, the API presented here is not guaranteed to be stable, even between minor releases of this library. -} module Data.Deriving.Internal where import qualified Control.Applicative as App import Control.Monad (when, unless) import qualified Data.Foldable as F import Data.Functor.Classes ( Eq1(..), Ord1(..), Read1(..), Show1(..) #if MIN_VERSION_base(4,10,0) , liftReadListPrecDefault #endif ) #if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) import Data.Functor.Classes ( Eq2(..), Ord2(..), Read2(..), Show2(..) #if MIN_VERSION_base(4,10,0) , liftReadListPrec2Default #endif ) #endif import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import Data.Monoid (Dual(..), Endo(..)) import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Traversable as T import GHC.Arr (Ix(..)) import GHC.Base (getTag) import GHC.Exts import GHC.Read (choose, list, paren) import GHC.Show (showSpace) #if MIN_VERSION_base(4,19,0) import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..)) import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..)) #endif import Text.ParserCombinators.ReadPrec ( ReadPrec, (+++), pfail, prec, readPrec_to_S, readS_to_Prec , reset, step ) import Text.Read (Read(..), parens, readListPrecDefault) import qualified Text.Read.Lex as L import Text.Show (showListWith) #if MIN_VERSION_base(4,7,0) import GHC.Read (expectP) #else import GHC.Read (lexP) import Text.Read.Lex (Lexeme) #endif #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative(..)) import Data.Foldable (Foldable(..)) import Data.Functor (Functor(..)) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(..)) #endif #if MIN_VERSION_base(4,10,0) import GHC.Show (showCommaSpace) #endif #if MIN_VERSION_base(4,11,0) import GHC.Read (readField, readSymField) #endif #if defined(MIN_VERSION_ghc_boot_th) import GHC.Lexeme (startsConSym, startsVarSym) #else import Data.Char (isSymbol, ord) #endif import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax -- Ensure, beyond a shadow of a doubt, that the instances are in-scope import Data.Functor () import Data.Functor.Classes () import Data.Foldable () import Data.Traversable () ------------------------------------------------------------------------------- -- 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 = F.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 <- T.mapM resolveTypeSynonyms varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - arity cRep droppedTysExp :: [Type] droppedTysExp = drop remainingLength varTysExp droppedStarKindStati :: [StarKindStatus] droppedStarKindStati = map canRealizeKindStar droppedTysExp -- Check there are enough types to drop and that all of them are either of -- kind * or kind k (for some kind variable k). If not, throw an error. when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ derivingKindError cRep tyConName let droppedKindVarNames :: [Name] droppedKindVarNames = catKindVarNames droppedStarKindStati -- Substitute kind * for any dropped kind variables varTysExpSubst :: [Type] varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp remainingTysExpSubst, droppedTysExpSubst :: [Type] (remainingTysExpSubst, droppedTysExpSubst) = splitAt remainingLength varTysExpSubst -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name] droppedTyVarNames = freeVariables droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that they are of kind * -- after substituting * for the dropped kind variables. If not, throw an error. unless (all hasKindStar droppedTysExpSubst) $ derivingKindError cRep tyConName let preds :: [Maybe Pred] kvNames :: [[Name]] kvNames' :: [Name] -- Derive instance constraints (and any kind variables which are specialized -- to * in those constraints) (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst kvNames' = concat kvNames -- Substitute the kind variables specialized in the constraints with * remainingTysExpSubst' :: [Type] remainingTysExpSubst' = map (substNamesWithKindStar kvNames') remainingTysExpSubst -- We now substitute all of the specialized-to-* kind variable names with -- *, but in the original types, not the synonym-expanded types. The reason -- we do this is a superficial one: we want the derived instance to resemble -- the datatype written in source code as closely as possible. For example, -- for the following data family instance: -- -- data family Fam a -- newtype instance Fam String = Fam String -- -- We'd want to generate the instance: -- -- instance C (Fam String) -- -- Not: -- -- instance C (Fam [Char]) remainingTysOrigSubst :: [Type] remainingTysOrigSubst = map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig isDataFamily <- case variant of Datatype -> return False Newtype -> return False DataInstance -> return True NewtypeInstance -> return True #if MIN_VERSION_th_abstraction(0,5,0) Datatype.TypeData -> typeDataError tyConName #endif let remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. remainingTysOrigSubst' = if isDataFamily then remainingTysOrigSubst else map unSigT remainingTysOrigSubst instanceCxt :: Cxt instanceCxt = catMaybes preds instanceType :: Type instanceType = AppT (ConT (fullClassName cRep)) $ applyTyCon tyConName remainingTysOrigSubst' -- If the datatype context mentions any of the dropped type variables, -- we can't derive an instance, so throw an error. when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ datatypeContextError tyConName instanceType -- Also ensure the dropped types can be safely eta-reduced. Otherwise, -- throw an error. unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ etaReductionError instanceType return (instanceCxt, instanceType) -- | Attempt to derive a constraint on a Type. If successful, return -- Just the constraint and any kind variable names constrained to *. -- Otherwise, return Nothing and the empty list. -- -- See Note [Type inference in derived instances] for the heuristics used to -- come up with constraints. deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name]) deriveConstraint cRep t | not (isTyVar t) = (Nothing, []) | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, []) | otherwise = case hasKindVarChain 1 t of Just ns | cRepArity >= 1 -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns) _ -> case hasKindVarChain 2 t of Just ns | cRepArity == 2 -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns) _ -> (Nothing, []) where tName :: Name tName = varTToName t cRepArity :: Int cRepArity = arity cRep {- Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is possible to put explicit kind signatures into the derived instances, e.g., instance C a => C (Data (f :: * -> *)) where ... But it is preferable to avoid this if possible. If we come up with an incorrect kind signature (which is entirely possible, since our type inferencer is pretty unsophisticated - see Note [Type inference in derived instances]), then GHC will flat-out reject the instance, which is quite unfortunate. Plain old datatypes have the advantage that you can avoid using any kind signatures at all in their instances. This is because a datatype declaration uses all type variables, so the types that we use in a derived instance uniquely determine their kinds. As long as we plug in the right types, the kind inferencer can do the rest of the work. For this reason, we use unSigT to remove all kind signatures before splicing in the instance context and head. Data family instances are trickier, since a data family can have two instances that are distinguished by kind alone, e.g., data family Fam (a :: k) data instance Fam (a :: * -> *) data instance Fam (a :: *) If we dropped the kind signatures for C (Fam a), then GHC will have no way of knowing which instance we are talking about. To avoid this scenario, we always include explicit kind signatures in data family instances. There is a chance that the inferred kind signatures will be incorrect, but if so, we can always fall back on the make- functions. Note [Type inference in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Type inference is can be tricky to get right, and we want to avoid recreating the entirety of GHC's type inferencer in Template Haskell. For this reason, we will probably never come up with derived instance contexts that are as accurate as GHC's. But that doesn't mean we can't do anything! There are a couple of simple things we can do to make instance contexts that work for 80% of use cases: 1. If one of the last type parameters is polykinded, then its kind will be specialized to * in the derived instance. We note what kind variable the type parameter had and substitute it with * in the other types as well. For example, imagine you had data Data (a :: k) (b :: k) Then you'd want to derived instance to be: instance C (Data (a :: *)) Not: instance C (Data (a :: k)) 2. We naïvely come up with instance constraints using the following criteria, using Show(1)(2) as the example typeclasses: (i) If there's a type parameter n of kind *, generate a Show n constraint. (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind variables), then generate a Show1 n constraint, and if k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the types. We must consider the case where they are kind variables because you might have a scenario like this: newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a)) Which would have a derived Show1 instance of: instance (Show1 f, Show1 g) => Show1 (Compose f g) where ... (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are * or kind variables), then generate a Show2 constraint and perform kind substitution as in the other cases. -} checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c checkExistentialContext cRep tvMap ctxt conName q = if (any (`predMentionsName` Map.keys tvMap) ctxt || Map.size tvMap < arity cRep) && not (allowExQuant cRep) then existentialContextError conName else q {- Note [Matching functions with GADT type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When deriving category-2 classes like Show2, there is a tricky corner case to consider: data Both a b where BothCon :: x -> x -> Both x x Which show functions should be applied to which arguments of BothCon? We have a choice, since both the function of type (Int -> a -> ShowS) and of type (Int -> b -> ShowS) can be applied to either argument. In such a scenario, the second show function takes precedence over the first show function, so the derived Show2 instance would be: instance Show2 Both where liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) = showsParen (p > appPrec) $ showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2 This is not an arbitrary choice, as this definition ensures that liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for Both. -} ------------------------------------------------------------------------------- -- Error messages ------------------------------------------------------------------------------- -- | The given datatype has no constructors, and we don't know what to do with it. noConstructorsError :: Q a noConstructorsError = fail "Must have at least one data constructor" -- | Either the given data type doesn't have enough type variables, or one of -- the type variables to be eta-reduced cannot realize kind *. derivingKindError :: ClassRep a => a -> Name -> Q b derivingKindError cRep tyConName = fail . showString "Cannot derive well-kinded instance of form ‘" . showString className . showChar ' ' . showParen True ( showString (nameBase tyConName) . showString " ..." ) . showString "‘\n\tClass " . showString className . showString " expects an argument of kind " . showString (pprint . createKindChain $ arity cRep) $ "" where className :: String className = nameBase $ fullClassName cRep -- | The last type variable appeared in a contravariant position -- when deriving Functor. contravarianceError :: Name -> Q a contravarianceError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must not use the last type variable in a function argument" $ "" -- | A constructor has a function argument in a derived Foldable or Traversable -- instance. noFunctionsError :: Name -> Q a noFunctionsError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must not contain function types" $ "" -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet). etaReductionError :: Type -> Q a etaReductionError instanceType = fail $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -- | The data type has a DatatypeContext which mentions one of the eta-reduced -- type variables. datatypeContextError :: Name -> Type -> Q a datatypeContextError dataName instanceType = fail . showString "Can't make a derived instance of ‘" . showString (pprint instanceType) . showString "‘:\n\tData type ‘" . showString (nameBase dataName) . showString "‘ must not have a class context involving the last type argument(s)" $ "" -- | The data type has an existential constraint which mentions one of the -- eta-reduced type variables. existentialContextError :: Name -> Q a existentialContextError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must be truly polymorphic in the last argument(s) of the data type" $ "" -- | The data type mentions one of the n eta-reduced type variables in a place other -- than the last nth positions of a data type in a constructor's field. outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b outOfPlaceTyVarError cRep conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must only use its last " . shows n . showString " type variable(s) within the last " . shows n . showString " argument(s) of a data type" $ "" where n :: Int n = arity cRep enumerationError :: String -> Q a enumerationError = fail . enumerationErrorStr enumerationOrProductError :: String -> Q a enumerationOrProductError nb = fail $ unlines [ enumerationErrorStr nb , "\tor a product type (precisely one constructor)" ] enumerationErrorStr :: String -> String enumerationErrorStr nb = '\'':nb ++ "’ must be an enumeration type" ++ " (one or more nullary, non-GADT constructors)" typeDataError :: Name -> Q a typeDataError dataName = fail . showString "Cannot derive instance for ‘" . showString (nameBase dataName) . showString "‘, which is a ‘type data‘ declaration" $ "" ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- | A mapping of type variable Names to their auxiliary function Names. type TyVarMap a = Map Name (OneOrTwoNames a) type TyVarMap1 = TyVarMap One type TyVarMap2 = TyVarMap Two data OneOrTwoNames a where OneName :: Name -> OneOrTwoNames One TwoNames :: Name -> Name -> OneOrTwoNames Two data One data Two interleave :: [a] -> [a] -> [a] interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s interleave _ _ = [] #if !(MIN_VERSION_ghc_prim(0,3,1)) isTrue# :: Bool -> Bool isTrue# x = x {-# INLINE isTrue# #-} #endif -- 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 :: NonEmpty 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 :: NonEmpty ConstructorInfo -> Bool isEnumerationType cons = F.all (App.liftA2 (&&) isNullaryCon isVanillaCon) cons -- | 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 = T.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 ------------------------------------------------------------------------------- -- Quoted names ------------------------------------------------------------------------------- -- With GHC 8.0 or later, we can simply use TemplateHaskellQuotes to quote each -- name, which allows deriving-compat to be built with compilers that do not -- support Template Haskell (e.g., stage-1 cross compilers). Unfortunately, -- older versions of GHC must fall back on full-blown Template Haskell. isTrueHashValName :: Name isTrueHashValName = 'isTrue# fmapConstValName :: Name fmapConstValName = 'fmapConst replaceConstValName :: Name replaceConstValName = 'replaceConst foldrConstValName :: Name foldrConstValName = 'foldrConst foldMapConstValName :: Name foldMapConstValName = 'foldMapConst nullConstValName :: Name nullConstValName = 'nullConst traverseConstValName :: Name traverseConstValName = 'traverseConst eqConstValName :: Name eqConstValName = 'eqConst eq1ConstValName :: Name eq1ConstValName = 'eq1Const liftEqConstValName :: Name liftEqConstValName = 'liftEqConst liftEq2ConstValName :: Name liftEq2ConstValName = 'liftEq2Const compareConstValName :: Name compareConstValName = 'compareConst ltConstValName :: Name ltConstValName = 'ltConst compare1ConstValName :: Name compare1ConstValName = 'compare1Const liftCompareConstValName :: Name liftCompareConstValName = 'liftCompareConst liftCompare2ConstValName :: Name liftCompare2ConstValName = 'liftCompare2Const readsPrecConstValName :: Name readsPrecConstValName = 'readsPrecConst readPrecConstValName :: Name readPrecConstValName = 'readPrecConst readsPrec1ConstValName :: Name readsPrec1ConstValName = 'readsPrec1Const liftReadsPrecConstValName :: Name liftReadsPrecConstValName = 'liftReadsPrecConst liftReadPrecConstValName :: Name liftReadPrecConstValName = 'liftReadPrecConst liftReadsPrec2ConstValName :: Name liftReadsPrec2ConstValName = 'liftReadsPrec2Const liftReadPrec2ConstValName :: Name liftReadPrec2ConstValName = 'liftReadPrec2Const showsPrecConstValName :: Name showsPrecConstValName = 'showsPrecConst showsPrec1ConstValName :: Name showsPrec1ConstValName = 'showsPrec1Const liftShowsPrecConstValName :: Name liftShowsPrecConstValName = 'liftShowsPrecConst liftShowsPrec2ConstValName :: Name liftShowsPrec2ConstValName = 'liftShowsPrec2Const viaTypeName :: Name viaTypeName = ''Via cHashDataName :: Name cHashDataName = 'C# dHashDataName :: Name dHashDataName = 'D# fHashDataName :: Name fHashDataName = 'F# identDataName :: Name identDataName = 'L.Ident iHashDataName :: Name iHashDataName = 'I# puncDataName :: Name puncDataName = 'L.Punc symbolDataName :: Name symbolDataName = 'L.Symbol wrapMonadDataName :: Name wrapMonadDataName = 'App.WrapMonad addrHashTypeName :: Name addrHashTypeName = ''Addr# boundedTypeName :: Name boundedTypeName = ''Bounded charHashTypeName :: Name charHashTypeName = ''Char# doubleHashTypeName :: Name doubleHashTypeName = ''Double# enumTypeName :: Name enumTypeName = ''Enum floatHashTypeName :: Name floatHashTypeName = ''Float# foldableTypeName :: Name foldableTypeName = ''Foldable functorTypeName :: Name functorTypeName = ''Functor intTypeName :: Name intTypeName = ''Int intHashTypeName :: Name intHashTypeName = ''Int# ixTypeName :: Name ixTypeName = ''Ix readTypeName :: Name readTypeName = ''Read showTypeName :: Name showTypeName = ''Show traversableTypeName :: Name traversableTypeName = ''Traversable wordHashTypeName :: Name wordHashTypeName = ''Word# altValName :: Name altValName = '(+++) appendValName :: Name appendValName = '(++) chooseValName :: Name chooseValName = 'choose composeValName :: Name composeValName = '(.) constValName :: Name constValName = 'const enumFromValName :: Name enumFromValName = 'enumFrom enumFromThenValName :: Name enumFromThenValName = 'enumFromThen enumFromThenToValName :: Name enumFromThenToValName = 'enumFromThenTo enumFromToValName :: Name enumFromToValName = 'enumFromTo eqAddrHashValName :: Name eqAddrHashValName = 'eqAddr# eqCharHashValName :: Name eqCharHashValName = 'eqChar# eqDoubleHashValName :: Name eqDoubleHashValName = '(==##) eqFloatHashValName :: Name eqFloatHashValName = 'eqFloat# eqIntHashValName :: Name eqIntHashValName = '(==#) eqWordHashValName :: Name eqWordHashValName = 'eqWord# errorValName :: Name errorValName = 'error flipValName :: Name flipValName = 'flip fmapValName :: Name fmapValName = 'fmap foldrValName :: Name foldrValName = 'F.foldr foldMapValName :: Name foldMapValName = 'foldMap fromEnumValName :: Name fromEnumValName = 'fromEnum geAddrHashValName :: Name geAddrHashValName = 'geAddr# geCharHashValName :: Name geCharHashValName = 'geChar# geDoubleHashValName :: Name geDoubleHashValName = '(>=##) geFloatHashValName :: Name geFloatHashValName = 'geFloat# geIntHashValName :: Name geIntHashValName = '(>=#) getTagValName :: Name getTagValName = 'getTag geWordHashValName :: Name geWordHashValName = 'geWord# gtAddrHashValName :: Name gtAddrHashValName = 'gtAddr# gtCharHashValName :: Name gtCharHashValName = 'gtChar# gtDoubleHashValName :: Name gtDoubleHashValName = '(>##) gtFloatHashValName :: Name gtFloatHashValName = 'gtFloat# gtIntHashValName :: Name gtIntHashValName = '(>#) gtWordHashValName :: Name gtWordHashValName = 'gtWord# idValName :: Name idValName = 'id indexValName :: Name indexValName = 'index inRangeValName :: Name inRangeValName = 'inRange leAddrHashValName :: Name leAddrHashValName = 'leAddr# leCharHashValName :: Name leCharHashValName = 'leChar# leDoubleHashValName :: Name leDoubleHashValName = '(<=##) leFloatHashValName :: Name leFloatHashValName = 'leFloat# leIntHashValName :: Name leIntHashValName = '(<=#) leWordHashValName :: Name leWordHashValName = 'leWord# listValName :: Name listValName = 'list ltAddrHashValName :: Name ltAddrHashValName = 'ltAddr# ltCharHashValName :: Name ltCharHashValName = 'ltChar# ltDoubleHashValName :: Name ltDoubleHashValName = '(<##) ltFloatHashValName :: Name ltFloatHashValName = 'ltFloat# ltIntHashValName :: Name ltIntHashValName = '(<#) ltWordHashValName :: Name ltWordHashValName = 'ltWord# minBoundValName :: Name minBoundValName = 'minBound mapValName :: Name mapValName = 'map maxBoundValName :: Name maxBoundValName = 'maxBound minusIntHashValName :: Name minusIntHashValName = '(-#) neqIntHashValName :: Name neqIntHashValName = '(/=#) parenValName :: Name parenValName = 'paren parensValName :: Name parensValName = 'parens pfailValName :: Name pfailValName = 'pfail plusValName :: Name plusValName = '(+) precValName :: Name precValName = 'prec predValName :: Name predValName = 'pred rangeSizeValName :: Name rangeSizeValName = 'rangeSize rangeValName :: Name rangeValName = '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 = 'readFieldHash readListValName :: Name readListValName = 'readList readListPrecDefaultValName :: Name readListPrecDefaultValName = 'readListPrecDefault readListPrecValName :: Name readListPrecValName = 'readListPrec readPrec_to_SValName :: Name readPrec_to_SValName = 'readPrec_to_S readPrecValName :: Name readPrecValName = 'readPrec readS_to_PrecValName :: Name readS_to_PrecValName = 'readS_to_Prec readsPrecValName :: Name readsPrecValName = 'readsPrec replaceValName :: Name replaceValName = '(<$) resetValName :: Name resetValName = 'reset returnValName :: Name returnValName = 'return seqValName :: Name seqValName = 'seq showCharValName :: Name showCharValName = 'showChar showListValName :: Name showListValName = 'showList showListWithValName :: Name showListWithValName = 'showListWith showParenValName :: Name showParenValName = 'showParen showsPrecValName :: Name showsPrecValName = 'showsPrec showSpaceValName :: Name showSpaceValName = 'showSpace showStringValName :: Name showStringValName = 'showString stepValName :: Name stepValName = 'step succValName :: Name succValName = 'succ tagToEnumHashValName :: Name tagToEnumHashValName = 'tagToEnum# timesValName :: Name timesValName = '(*) toEnumValName :: Name toEnumValName = 'toEnum traverseValName :: Name traverseValName = 'traverse unsafeIndexValName :: Name unsafeIndexValName = 'unsafeIndex unsafeRangeSizeValName :: Name unsafeRangeSizeValName = 'unsafeRangeSize unwrapMonadValName :: Name unwrapMonadValName = 'App.unwrapMonad boolTypeName :: Name boolTypeName = ''Bool falseDataName :: Name falseDataName = 'False trueDataName :: Name trueDataName = 'True eqDataName :: Name eqDataName = 'EQ gtDataName :: Name gtDataName = 'GT ltDataName :: Name ltDataName = 'LT eqTypeName :: Name eqTypeName = ''Eq ordTypeName :: Name ordTypeName = ''Ord andValName :: Name andValName = '(&&) compareValName :: Name compareValName = 'compare eqValName :: Name eqValName = '(==) geValName :: Name geValName = '(>=) gtValName :: Name gtValName = '(>) leValName :: Name leValName = '(<=) ltValName :: Name ltValName = '(<) notValName :: Name notValName = 'not wHashDataName :: Name wHashDataName = 'W# #if !(MIN_VERSION_base(4,7,0)) expectP :: Lexeme -> ReadPrec () expectP lexeme = do thing <- lexP if thing == lexeme then return () else pfail #endif expectPValName :: Name expectPValName = 'expectP allValName :: Name allValName = 'all apValName :: Name apValName = '(<*>) pureValName :: Name pureValName = 'pure liftA2ValName :: Name liftA2ValName = 'App.liftA2 mappendValName :: Name mappendValName = 'mappend memptyValName :: Name memptyValName = 'mempty nullValName :: Name nullValName = 'null eq1TypeName :: Name eq1TypeName = ''Eq1 ord1TypeName :: Name ord1TypeName = ''Ord1 read1TypeName :: Name read1TypeName = ''Read1 show1TypeName :: Name show1TypeName = ''Show1 #if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) eq2TypeName :: Name eq2TypeName = ''Eq2 ord2TypeName :: Name ord2TypeName = ''Ord2 read2TypeName :: Name read2TypeName = ''Read2 show2TypeName :: Name show2TypeName = ''Show2 liftEqValName :: Name liftEqValName = 'liftEq liftEq2ValName :: Name liftEq2ValName = 'liftEq2 liftCompareValName :: Name liftCompareValName = 'liftCompare liftCompare2ValName :: Name liftCompare2ValName = 'liftCompare2 liftReadsPrecValName :: Name liftReadsPrecValName = 'liftReadsPrec liftReadListValName :: Name liftReadListValName = 'liftReadList liftReadsPrec2ValName :: Name liftReadsPrec2ValName = 'liftReadsPrec2 liftReadList2ValName :: Name liftReadList2ValName = 'liftReadList2 liftShowListValName :: Name liftShowListValName = 'liftShowList liftShowsPrecValName :: Name liftShowsPrecValName = 'liftShowsPrec liftShowList2ValName :: Name liftShowList2ValName = 'liftShowList2 liftShowsPrec2ValName :: Name liftShowsPrec2ValName = 'liftShowsPrec2 #else eq1ValName :: Name eq1ValName = 'eq1 compare1ValName :: Name compare1ValName = 'compare1 readsPrec1ValName :: Name readsPrec1ValName = 'readsPrec1 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 = 'Apply unApplyValName :: Name unApplyValName = 'unApply #endif #if MIN_VERSION_base(4,7,0) coerceValName :: Name coerceValName = 'coerce #endif #if MIN_VERSION_base(4,10,0) liftReadListPrecDefaultValName :: Name liftReadListPrecDefaultValName = 'liftReadListPrecDefault liftReadListPrec2DefaultValName :: Name liftReadListPrec2DefaultValName = 'liftReadListPrec2Default liftReadListPrecValName :: Name liftReadListPrecValName = 'liftReadListPrec liftReadListPrec2ValName :: Name liftReadListPrec2ValName = 'liftReadListPrec2 liftReadPrecValName :: Name liftReadPrecValName = 'liftReadPrec liftReadPrec2ValName :: Name liftReadPrec2ValName = 'liftReadPrec2 #else -- This is a gross hack to avoid needing to guard some uses of these two Names -- in Text.Read.Deriving.Internal with even grosser CPP. liftReadListPrecDefaultValName :: Name liftReadListPrecDefaultValName = error "using liftReadListPrecDefault before base-4.10.*" liftReadListPrec2DefaultValName :: Name liftReadListPrec2DefaultValName = error "using liftReadListPrec2Default before base-4.10.*" liftReadListPrecValName :: Name liftReadListPrecValName = error "using liftReadListPrec before base-4.10.*" liftReadListPrec2ValName :: Name liftReadListPrec2ValName = error "using liftReadListPrec2 before base-4.10.*" liftReadPrecValName :: Name liftReadPrecValName = error "using liftReadPrec before base-4.10.*" liftReadPrec2ValName :: Name liftReadPrec2ValName = error "using liftReadPrec2 before base-4.10.*" #endif #if !(MIN_VERSION_base(4,10,0)) showCommaSpace :: ShowS showCommaSpace = showString ", " #endif showCommaSpaceValName :: Name showCommaSpaceValName = 'showCommaSpace appEndoValName :: Name appEndoValName = 'appEndo dualDataName :: Name dualDataName = 'Dual endoDataName :: Name endoDataName = 'Endo getDualValName :: Name getDualValName = 'getDual #if !(MIN_VERSION_base(4,11,0)) readField :: String -> ReadPrec a -> ReadPrec a readField fieldName readVal = do expectP (L.Ident fieldName) expectP (L.Punc "=") readVal {-# NOINLINE 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 #-} #endif readFieldValName :: Name readFieldValName = 'readField readSymFieldValName :: Name readSymFieldValName = 'readSymField #if MIN_VERSION_base(4,13,0) eqInt8HashValName :: Name eqInt8HashValName = 'eqInt8# eqInt16HashValName :: Name eqInt16HashValName = 'eqInt16# eqWord8HashValName :: Name eqWord8HashValName = 'eqWord8# eqWord16HashValName :: Name eqWord16HashValName = 'eqWord16# geInt8HashValName :: Name geInt8HashValName = 'geInt8# geInt16HashValName :: Name geInt16HashValName = 'geInt16# geWord8HashValName :: Name geWord8HashValName = 'geWord8# geWord16HashValName :: Name geWord16HashValName = 'geWord16# gtInt8HashValName :: Name gtInt8HashValName = 'gtInt8# gtInt16HashValName :: Name gtInt16HashValName = 'gtInt16# gtWord8HashValName :: Name gtWord8HashValName = 'gtWord8# gtWord16HashValName :: Name gtWord16HashValName = 'gtWord16# int8HashTypeName :: Name int8HashTypeName = ''Int8# int8ToIntHashValName :: Name int8ToIntHashValName = # if MIN_VERSION_base(4,16,0) 'int8ToInt# # else 'extendInt8# # endif int16HashTypeName :: Name int16HashTypeName = ''Int16# int16ToIntHashValName :: Name int16ToIntHashValName = # if MIN_VERSION_base(4,16,0) 'int16ToInt# # else 'extendInt16# # endif intToInt8HashValName :: Name intToInt8HashValName = # if MIN_VERSION_base(4,16,0) 'intToInt8# # else 'narrowInt8# # endif intToInt16HashValName :: Name intToInt16HashValName = # if MIN_VERSION_base(4,16,0) 'intToInt16# # else 'narrowInt16# # endif leInt8HashValName :: Name leInt8HashValName = 'leInt8# leInt16HashValName :: Name leInt16HashValName = 'leInt16# leWord8HashValName :: Name leWord8HashValName = 'leWord8# leWord16HashValName :: Name leWord16HashValName = 'leWord16# ltInt8HashValName :: Name ltInt8HashValName = 'ltInt8# ltInt16HashValName :: Name ltInt16HashValName = 'ltInt16# ltWord8HashValName :: Name ltWord8HashValName = 'ltWord8# ltWord16HashValName :: Name ltWord16HashValName = 'ltWord16# word8HashTypeName :: Name word8HashTypeName = ''Word8# word8ToWordHashValName :: Name word8ToWordHashValName = # if MIN_VERSION_base(4,16,0) 'word8ToWord# # else 'extendWord8# # endif word16HashTypeName :: Name word16HashTypeName = ''Word16# word16ToWordHashValName :: Name word16ToWordHashValName = # if MIN_VERSION_base(4,16,0) 'word16ToWord# # else 'extendWord16# # endif wordToWord8HashValName :: Name wordToWord8HashValName = # if MIN_VERSION_base(4,16,0) 'wordToWord8# # else 'narrowWord8# # endif wordToWord16HashValName :: Name wordToWord16HashValName = # if MIN_VERSION_base(4,16,0) 'wordToWord16# # else 'narrowWord16# # endif #endif #if MIN_VERSION_base(4,16,0) eqInt32HashValName :: Name eqInt32HashValName = 'eqInt32# eqWord32HashValName :: Name eqWord32HashValName = 'eqWord32# geInt32HashValName :: Name geInt32HashValName = 'geInt32# geWord32HashValName :: Name geWord32HashValName = 'geWord32# gtInt32HashValName :: Name gtInt32HashValName = 'gtInt32# gtWord32HashValName :: Name gtWord32HashValName = 'gtWord32# int32HashTypeName :: Name int32HashTypeName = ''Int32# int32ToIntHashValName :: Name int32ToIntHashValName = 'int32ToInt# intToInt32HashValName :: Name intToInt32HashValName = 'intToInt32# leInt32HashValName :: Name leInt32HashValName = 'leInt32# leWord32HashValName :: Name leWord32HashValName = 'leWord32# ltInt32HashValName :: Name ltInt32HashValName = 'ltInt32# ltWord32HashValName :: Name ltWord32HashValName = 'ltWord32# word32HashTypeName :: Name word32HashTypeName = ''Word32# word32ToWordHashValName :: Name word32ToWordHashValName = 'word32ToWord# wordToWord32HashValName :: Name wordToWord32HashValName = 'wordToWord32# #endif #if MIN_VERSION_base(4,19,0) i8HashDataName :: Name i8HashDataName = 'I8# i16HashDataName :: Name i16HashDataName = 'I16# i32HashDataName :: Name i32HashDataName = 'I32# i64HashDataName :: Name i64HashDataName = 'I64# int64HashTypeName :: Name int64HashTypeName = ''Int64# w8HashDataName :: Name w8HashDataName = 'W8# w16HashDataName :: Name w16HashDataName = 'W16# w32HashDataName :: Name w32HashDataName = 'W32# w64HashDataName :: Name w64HashDataName = 'W64# word64HashTypeName :: Name word64HashTypeName = ''Word64# #endif deriving-compat-0.6.5/src/Data/Deriving/Via.hs0000644000000000000000000000407707346545000017275 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Module: Data.Deriving.Via Copyright: (C) 2015-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module exports functionality which emulates the @GeneralizedNewtypeDeriving@ and @DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6). On older versions of @template-haskell@/GHC, this module does not export anything. -} module Data.Deriving.Via ( #if !(MIN_VERSION_template_haskell(2,12,0)) ) where #else -- * @GeneralizedNewtypeDeriving@ deriveGND -- * @DerivingVia@ , deriveVia , Via -- * Limitations -- $constraints ) where import Data.Deriving.Internal (Via) import Data.Deriving.Via.Internal {- $constraints Be aware of the following potential gotchas: * Unlike every other module in this library, the functions exported by "Data.Deriving.Via" only support GHC 8.2 and later, as they require Template Haskell functionality not present in earlier GHCs. * Additionally, using the functions in "Data.Deriving.Via" will likely require you to enable some language extensions (besides @TemplateHaskell@). These may include: * @ImpredicativeTypes@ (if any class methods contain higher-rank types) * @InstanceSigs@ * @KindSignatures@ * @RankNTypes@ * @ScopedTypeVariables@ * @TypeApplications@ * @TypeOperators@ * @UndecidableInstances@ (if deriving an instance of a type class with associated type families) * The functions in "Data.Deriving.Via" are not terribly robust in the presence of @PolyKinds@. Alas, Template Haskell does not make this easy to fix. * The functions in "Data.Deriving.Via" make a best-effort attempt to derive instances for classes with associated type families. This is known not to work in all scenarios, however, especially when the last parameter to a type class appears as a kind variable in an associated type family. (See .) -} #endif deriving-compat-0.6.5/src/Data/Deriving/Via/0000755000000000000000000000000007346545000016731 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Deriving/Via/Internal.hs0000644000000000000000000002346507346545000021053 0ustar0000000000000000{-# 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 -> [TyVarBndr_ flag] -> [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 :: [TyVarBndr_ flag] -> [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 deriving-compat-0.6.5/src/Data/Enum/0000755000000000000000000000000007346545000015347 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Enum/Deriving.hs0000644000000000000000000000155107346545000017454 0ustar0000000000000000{-| 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. -} deriving-compat-0.6.5/src/Data/Enum/Deriving/0000755000000000000000000000000007346545000017116 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Enum/Deriving/Internal.hs0000644000000000000000000002163707346545000021237 0ustar0000000000000000{-| 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 Data.List.NonEmpty (NonEmpty(..)) 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 (con: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 cons :: NonEmpty ConstructorInfo cons = con :| cons' maxTagExpr :: Q Exp maxTagExpr = integerE (length cons') `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 ")"))))) deriving-compat-0.6.5/src/Data/Eq/0000755000000000000000000000000007346545000015010 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Eq/Deriving.hs0000644000000000000000000000333207346545000017114 0ustar0000000000000000{-# 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@. -} deriving-compat-0.6.5/src/Data/Eq/Deriving/0000755000000000000000000000000007346545000016557 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Eq/Deriving/Internal.hs0000644000000000000000000003305107346545000020671 0ustar0000000000000000{-# 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 deriving-compat-0.6.5/src/Data/Foldable/0000755000000000000000000000000007346545000016153 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Foldable/Deriving.hs0000644000000000000000000000364607346545000020267 0ustar0000000000000000{-| Module: Data.Foldable.Deriving Copyright: (C) 2015-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Foldable' instances in a way that mimics how the @-XDeriveFoldable@ extension works since GHC 8.0. These changes make it possible to derive @Foldable@ instances for data types with existential constraints, e.g., @ data WrappedSet a where WrapSet :: Ord a => a -> WrappedSet a deriving instance Foldable WrappedSet -- On GHC 8.0 on later $(deriveFoldable ''WrappedSet) -- On GHC 7.10 and earlier @ In addition, derived 'Foldable' instances from this module do not generate superfluous 'mempty' expressions in its implementation of 'foldMap'. One can verify this by compiling a module that uses 'deriveFoldable' with the @-ddump-splices@ GHC flag. For more info on these changes, see . -} module Data.Foldable.Deriving ( -- * 'Foldable' deriveFoldable , deriveFoldableOptions , makeFoldMap , makeFoldMapOptions , makeFoldr , makeFoldrOptions , makeFold , makeFoldOptions , makeFoldl , makeFoldlOptions , makeNull , makeNullOptions -- * 'FFTOptions' , FFTOptions(..) , defaultFFTOptions -- * 'deriveFoldable' limitations -- $constraints ) where import Data.Functor.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an existential constraint cannot mention the last type variable. For example, @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 'Functor' instance. * Type variables of kind @* -> *@ are assumed to have 'Foldable' constraints. If this is not desirable, use 'makeFoldr' or 'makeFoldMap'. -} deriving-compat-0.6.5/src/Data/Functor/0000755000000000000000000000000007346545000016063 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Functor/Deriving.hs0000644000000000000000000000165107346545000020171 0ustar0000000000000000{-| Module: Data.Functor.Deriving Copyright: (C) 2015-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Functor' instances. For more info on how deriving @Functor@ works, see . -} module Data.Functor.Deriving ( -- * 'Functor' deriveFunctor , deriveFunctorOptions , makeFmap , makeFmapOptions , makeReplace , makeReplaceOptions -- * 'FFTOptions' , FFTOptions(..) , defaultFFTOptions -- * 'deriveFunctor' limitations -- $constraints ) where import Data.Functor.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @* -> *@ are assumed to have 'Functor' constraints. If this is not desirable, use 'makeFmap'. -} deriving-compat-0.6.5/src/Data/Functor/Deriving/0000755000000000000000000000000007346545000017632 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Functor/Deriving/Internal.hs0000644000000000000000000011273607346545000021754 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-| Module: Data.Functor.Deriving.Internal Copyright: (C) 2015-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances. For more info on how deriving @Functor@ works, see . Note: this is an internal module, and as such, the API presented here is not guaranteed to be stable, even between minor releases of this library. -} module Data.Functor.Deriving.Internal ( -- * 'Foldable' deriveFoldable , deriveFoldableOptions , makeFoldMap , makeFoldMapOptions , makeFoldr , makeFoldrOptions , makeFold , makeFoldOptions , makeFoldl , makeFoldlOptions , makeNull , makeNullOptions -- * 'Functor' , deriveFunctor , deriveFunctorOptions , makeFmap , makeFmapOptions , makeReplace , makeReplaceOptions -- * 'Traversable' , deriveTraversable , deriveTraversableOptions , makeTraverse , makeTraverseOptions , makeSequenceA , makeSequenceAOptions , makeMapM , makeMapMOptions , makeSequence , makeSequenceOptions -- * 'FFTOptions' , FFTOptions(..) , defaultFFTOptions ) where import Control.Monad (guard) import Data.Deriving.Internal import qualified Data.List as List import qualified Data.Map as Map ((!), keys, lookup, member, singleton) import Data.Maybe import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Options that further configure how the functions in "Data.Functor.Deriving" -- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.) newtype FFTOptions = FFTOptions { fftEmptyCaseBehavior :: Bool -- ^ If 'True', derived instances for empty data types (i.e., ones with -- no data constructors) will use the @EmptyCase@ language extension. -- If 'False', derived instances will simply use 'seq' instead. -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only -- available in 7.8 or later.) } deriving (Eq, Ord, Read, Show) -- | Conservative 'FFTOptions' that doesn't attempt to use @EmptyCase@ (to -- prevent users from having to enable that extension at use sites.) defaultFFTOptions :: FFTOptions defaultFFTOptions = FFTOptions { fftEmptyCaseBehavior = False } -- | Generates a 'Foldable' instance declaration for the given data type or data -- family instance. deriveFoldable :: Name -> Q [Dec] deriveFoldable = deriveFoldableOptions defaultFFTOptions -- | Like 'deriveFoldable', but takes an 'FFTOptions' argument. deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec] deriveFoldableOptions = deriveFunctorClass Foldable -- | Generates a lambda expression which behaves like 'foldMap' (without requiring a -- 'Foldable' instance). makeFoldMap :: Name -> Q Exp makeFoldMap = makeFoldMapOptions defaultFFTOptions -- | Like 'makeFoldMap', but takes an 'FFTOptions' argument. makeFoldMapOptions :: FFTOptions -> Name -> Q Exp makeFoldMapOptions = makeFunctorFun FoldMap -- | Generates a lambda expression which behaves like 'null' (without requiring a -- 'Foldable' instance). makeNull :: Name -> Q Exp makeNull = makeNullOptions defaultFFTOptions -- | Like 'makeNull', but takes an 'FFTOptions' argument. makeNullOptions :: FFTOptions -> Name -> Q Exp makeNullOptions = makeFunctorFun Null -- | Generates a lambda expression which behaves like 'foldr' (without requiring a -- 'Foldable' instance). makeFoldr :: Name -> Q Exp makeFoldr = makeFoldrOptions defaultFFTOptions -- | Like 'makeFoldr', but takes an 'FFTOptions' argument. makeFoldrOptions :: FFTOptions -> Name -> Q Exp makeFoldrOptions = makeFunctorFun Foldr -- | Generates a lambda expression which behaves like 'fold' (without requiring a -- 'Foldable' instance). makeFold :: Name -> Q Exp makeFold = makeFoldOptions defaultFFTOptions -- | Like 'makeFold', but takes an 'FFTOptions' argument. makeFoldOptions :: FFTOptions -> Name -> Q Exp makeFoldOptions opts name = makeFoldMapOptions opts name `appE` varE idValName -- | Generates a lambda expression which behaves like 'foldl' (without requiring a -- 'Foldable' instance). makeFoldl :: Name -> Q Exp makeFoldl = makeFoldlOptions defaultFFTOptions -- | Like 'makeFoldl', but takes an 'FFTOptions' argument. makeFoldlOptions :: FFTOptions -> Name -> Q Exp makeFoldlOptions opts name = do f <- newName "f" z <- newName "z" t <- newName "t" lamE [varP f, varP z, varP t] $ appsE [ varE appEndoValName , appsE [ varE getDualValName , appsE [ makeFoldMapOptions opts name, foldFun f, varE t] ] , varE z ] where foldFun :: Name -> Q Exp foldFun n = infixApp (conE dualDataName) (varE composeValName) (infixApp (conE endoDataName) (varE composeValName) (varE flipValName `appE` varE n) ) -- | Generates a 'Functor' instance declaration for the given data type or data -- family instance. deriveFunctor :: Name -> Q [Dec] deriveFunctor = deriveFunctorOptions defaultFFTOptions -- | Like 'deriveFunctor', but takes an 'FFTOptions' argument. deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec] deriveFunctorOptions = deriveFunctorClass Functor -- | Generates a lambda expression which behaves like 'fmap' (without requiring a -- 'Functor' instance). makeFmap :: Name -> Q Exp makeFmap = makeFmapOptions defaultFFTOptions -- | Like 'makeFmap', but takes an 'FFTOptions' argument. makeFmapOptions :: FFTOptions -> Name -> Q Exp makeFmapOptions = makeFunctorFun Fmap -- | Generates a lambda expression which behaves like ('<$') (without requiring a -- 'Functor' instance). makeReplace :: Name -> Q Exp makeReplace = makeReplaceOptions defaultFFTOptions -- | Like 'makeReplace', but takes an 'FFTOptions' argument. makeReplaceOptions :: FFTOptions -> Name -> Q Exp makeReplaceOptions = makeFunctorFun Replace -- | Generates a 'Traversable' instance declaration for the given data type or data -- family instance. deriveTraversable :: Name -> Q [Dec] deriveTraversable = deriveTraversableOptions defaultFFTOptions -- | Like 'deriveTraverse', but takes an 'FFTOptions' argument. deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec] deriveTraversableOptions = deriveFunctorClass Traversable -- | Generates a lambda expression which behaves like 'traverse' (without requiring a -- 'Traversable' instance). makeTraverse :: Name -> Q Exp makeTraverse = makeTraverseOptions defaultFFTOptions -- | Like 'makeTraverse', but takes an 'FFTOptions' argument. makeTraverseOptions :: FFTOptions -> Name -> Q Exp makeTraverseOptions = makeFunctorFun Traverse -- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a -- 'Traversable' instance). makeSequenceA :: Name -> Q Exp makeSequenceA = makeSequenceAOptions defaultFFTOptions -- | Like 'makeSequenceA', but takes an 'FFTOptions' argument. makeSequenceAOptions :: FFTOptions -> Name -> Q Exp makeSequenceAOptions opts name = makeTraverseOptions opts name `appE` varE idValName -- | Generates a lambda expression which behaves like 'mapM' (without requiring a -- 'Traversable' instance). makeMapM :: Name -> Q Exp makeMapM = makeMapMOptions defaultFFTOptions -- | Like 'makeMapM', but takes an 'FFTOptions' argument. makeMapMOptions :: FFTOptions -> Name -> Q Exp makeMapMOptions opts name = do f <- newName "f" lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $ makeTraverseOptions opts name `appE` wrapMonadExp f where wrapMonadExp :: Name -> Q Exp wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) -- | Generates a lambda expression which behaves like 'sequence' (without requiring a -- 'Traversable' instance). makeSequence :: Name -> Q Exp makeSequence = makeSequenceOptions defaultFFTOptions -- | Like 'makeSequence', but takes an 'FFTOptions' argument. makeSequenceOptions :: FFTOptions -> Name -> Q Exp makeSequenceOptions opts name = makeMapMOptions opts name `appE` varE idValName ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a class instance declaration (depending on the FunctorClass argument's value). deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec] deriveFunctorClass fc opts name = do info <- reifyDatatype name case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName , datatypeInstTypes = instTypes , datatypeVariant = variant , datatypeCons = cons } -> do (instanceCxt, instanceType) <- buildTypeInstance fc parentName ctxt instTypes variant (:[]) `fmap` instanceD (return instanceCxt) (return instanceType) (functorFunDecs fc opts parentName instTypes cons) -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (fmap for Functor, foldr and foldMap for Foldable, and -- traverse for Traversable). -- -- For why both foldr and foldMap are derived for Foldable, see Trac #7436. functorFunDecs :: FunctorClass -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec] functorFunDecs fc opts parentName instTypes cons = map makeFunD $ functorClassToFuns fc where makeFunD :: FunctorFun -> Q Dec makeFunD ff = funD (functorFunName ff) [ clause [] (normalB $ makeFunctorFunForCons ff opts parentName instTypes cons) [] ] -- | Generates a lambda expression which behaves like the FunctorFun argument. makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp makeFunctorFun ff opts name = do info <- reifyDatatype name case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName , datatypeInstTypes = instTypes , datatypeVariant = variant , datatypeCons = cons } -> do -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have fmap/foldr/traverse/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance (functorFunToClass ff) parentName ctxt instTypes variant >> makeFunctorFunForCons ff opts parentName instTypes cons -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. makeFunctorFunForCons :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] -> Q Exp makeFunctorFunForCons ff opts _parentName instTypes cons = do mapFun <- newName "f" z <- newName "z" -- Only used for deriving foldr value <- newName "value" let argNames = catMaybes [ guard (ff /= Null) >> Just mapFun , guard (ff == Foldr) >> Just z , Just value ] lastTyVar = varTToName $ last instTypes tvMap = Map.singleton lastTyVar $ OneName mapFun lamE (map varP argNames) . appsE $ [ varE $ functorFunConstName ff , makeFun z value tvMap ] ++ map varE argNames where makeFun :: Name -> Name -> TyVarMap1 -> Q Exp makeFun z value tvMap = do #if MIN_VERSION_template_haskell(2,9,0) roles <- reifyRoles _parentName #endif case () of _ #if MIN_VERSION_template_haskell(2,9,0) | Just (_, PhantomR) <- unsnoc roles -> functorFunPhantom z value #endif | null cons && fftEmptyCaseBehavior opts && ghc7'8OrLater -> functorFunEmptyCase ff z value | null cons -> functorFunNoCons ff z value | otherwise -> caseE (varE value) (map (makeFunctorFunForCon ff z tvMap) cons) #if MIN_VERSION_template_haskell(2,9,0) functorFunPhantom :: Name -> Name -> Q Exp functorFunPhantom z value = functorFunTrivial coerce (varE pureValName `appE` coerce) ff z where coerce :: Q Exp coerce = varE coerceValName `appE` varE value #endif -- | Generates a match for a single constructor. makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match makeFunctorFunForCon ff z tvMap con@(ConstructorInfo { constructorName = conName , constructorContext = ctxt }) = do checkExistentialContext (functorFunToClass ff) tvMap ctxt conName $ case ff of Fmap -> makeFmapMatch tvMap con Replace -> makeReplaceMatch tvMap con Foldr -> makeFoldrMatch z tvMap con FoldMap -> makeFoldMapMatch tvMap con Null -> makeNullMatch tvMap con Traverse -> makeTraverseMatch tvMap con -- | Generates a match whose right-hand side implements @fmap@. makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match makeFmapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_fmap con match_for_con_functor conName parts where ft_fmap :: FFoldType (Exp -> Q Exp) ft_fmap = FT { ft_triv = return , ft_var = \v x -> case tvMap Map.! v of OneName f -> return $ VarE f `AppE` x , ft_fun = \g h x -> mkSimpleLam $ \b -> do gg <- g b h $ x `AppE` gg , ft_tup = mkSimpleTupleCase match_for_con_functor , ft_ty_app = \argTy g x -> do case varTToName_maybe argTy of -- If the argument type is a bare occurrence of the -- data type's last type variable, then we can -- generate more efficient code. -- This was inspired by GHC#17880. Just argVar | Just (OneName f) <- Map.lookup argVar tvMap -> return $ VarE fmapValName `AppE` VarE f `AppE` x _ -> do gg <- mkSimpleLam g return $ VarE fmapValName `AppE` gg `AppE` x , ft_forall = \_ g x -> g x , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName , ft_co_var = \_ _ -> contravarianceError conName } -- | Generates a match whose right-hand side implements @(<$)@. makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match makeReplaceMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_replace con match_for_con_functor conName parts where ft_replace :: FFoldType (Exp -> Q Exp) ft_replace = FT { ft_triv = return , ft_var = \v _ -> case tvMap Map.! v of OneName z -> return $ VarE z , ft_fun = \g h x -> mkSimpleLam $ \b -> do gg <- g b h $ x `AppE` gg , ft_tup = mkSimpleTupleCase match_for_con_functor , ft_ty_app = \argTy g x -> do case varTToName_maybe argTy of -- If the argument type is a bare occurrence of the -- data type's last type variable, then we can -- generate more efficient code. -- This was inspired by GHC#17880. Just argVar | Just (OneName z) <- Map.lookup argVar tvMap -> return $ VarE replaceValName `AppE` VarE z `AppE` x _ -> do gg <- mkSimpleLam g return $ VarE fmapValName `AppE` gg `AppE` x , ft_forall = \_ g x -> g x , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName , ft_co_var = \_ _ -> contravarianceError conName } match_for_con_functor :: Name -> [Exp -> Q Exp] -> Q Match match_for_con_functor = mkSimpleConMatch $ \conName' xs -> appsE (conE conName':xs) -- Con x1 x2 .. -- | Generates a match whose right-hand side implements @foldr@. makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match makeFoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_foldr con parts' <- sequence parts match_for_con (VarE z) conName parts' where -- The Bool is True if the type mentions the last type parameter, False -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out -- expressions that do not mention the last parameter by checking for False. ft_foldr :: FFoldType (Q (Bool, Exp)) ft_foldr = FT { ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z' return (False, lam) , ft_var = \v -> case tvMap Map.! v of OneName f -> return (True, VarE f) , ft_tup = \t gs -> do gg <- sequence gs lam <- mkSimpleLam2 $ \x z' -> mkSimpleTupleCase (match_for_con z') t gg x return (True, lam) , ft_ty_app = \_ g -> do (b, gg) <- g e <- mkSimpleLam2 $ \x z' -> return $ VarE foldrValName `AppE` gg `AppE` z' `AppE` x return (b, e) , ft_forall = \_ g -> g , ft_co_var = \_ -> contravarianceError conName , ft_fun = \_ _ -> noFunctionsError conName , ft_bad_app = outOfPlaceTyVarError Foldable conName } match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldr xs where -- g1 v1 (g2 v2 (.. z)) mkFoldr :: [Exp] -> Exp mkFoldr = foldr AppE zExp -- | Generates a match whose right-hand side implements @foldMap@. makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match makeFoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_foldMap con parts' <- sequence parts match_for_con conName parts' where -- The Bool is True if the type mentions the last type parameter, False -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out -- expressions that do not mention the last parameter by checking for False. ft_foldMap :: FFoldType (Q (Bool, Exp)) ft_foldMap = FT { ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName return (False, lam) , ft_var = \v -> case tvMap Map.! v of OneName f -> return (True, VarE f) , ft_tup = \t gs -> do gg <- sequence gs lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg return (True, lam) , ft_ty_app = \_ g -> do fmap (\(b, e) -> (b, VarE foldMapValName `AppE` e)) g , ft_forall = \_ g -> g , ft_co_var = \_ -> contravarianceError conName , ft_fun = \_ _ -> noFunctionsError conName , ft_bad_app = outOfPlaceTyVarError Foldable conName } match_for_con :: Name -> [(Bool, Exp)] -> Q Match match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldMap xs where -- mappend v1 (mappend v2 ..) mkFoldMap :: [Exp] -> Exp mkFoldMap [] = VarE memptyValName mkFoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es -- | Generates a match whose right-hand side implements @null@. makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match makeNullMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_null con parts' <- sequence parts case convert parts' of Nothing -> return $ Match (conWildPat con) (NormalB $ ConE falseDataName) [] Just cp -> match_for_con conName cp where ft_null :: FFoldType (Q (NullM Exp)) ft_null = FT { ft_triv = return $ IsNull $ ConE trueDataName , ft_var = \_ -> return NotNull , ft_tup = \t g -> do gg <- sequence g case convert gg of Nothing -> return NotNull Just ggg -> fmap NullM $ mkSimpleLam $ mkSimpleTupleCase match_for_con t ggg , ft_ty_app = \_ g -> flip fmap g $ \nestedResult -> case nestedResult of -- If e definitely contains the parameter, then we can -- test if (G e) contains it by simply checking if (G e) -- is null NotNull -> NullM $ VarE nullValName -- This case is unreachable--it will actually be caught -- by ft_triv r@IsNull{} -> r -- The general case uses (all null), (all (all null)), -- etc. NullM nestedTest -> NullM $ VarE allValName `AppE` nestedTest , ft_forall = \_ g -> g , ft_co_var = \_ -> contravarianceError conName , ft_fun = \_ _ -> noFunctionsError conName , ft_bad_app = outOfPlaceTyVarError Foldable conName } match_for_con :: Name -> [(Bool, Exp)] -> Q Match match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkNull xs where -- v1 && v2 && .. mkNull :: [Exp] -> Exp mkNull [] = ConE trueDataName mkNull xs = foldr1 (\x y -> VarE andValName `AppE` x `AppE` y) xs -- Given a list of NullM results, produce Nothing if any of them is NotNull, -- and otherwise produce a list of (Bool, a) with True entries representing -- unknowns and False entries representing things that are definitely null. convert :: [NullM a] -> Maybe [(Bool, a)] convert = mapM go where go (IsNull a) = Just (False, a) go NotNull = Nothing go (NullM a) = Just (True, a) data NullM a = IsNull a -- Definitely null | NotNull -- Definitely not null | NullM a -- Unknown -- | Generates a match whose right-hand side implements @traverse@. makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match makeTraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_trav con parts' <- sequence parts match_for_con conName parts' where -- The Bool is True if the type mentions the last type parameter, False -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out -- expressions that do not mention the last parameter by checking for False. ft_trav :: FFoldType (Q (Bool, Exp)) ft_trav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] ft_triv = return (False, VarE pureValName) , ft_var = \v -> case tvMap Map.! v of OneName f -> return (True, VarE f) , ft_tup = \t gs -> do gg <- sequence gs lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg return (True, lam) , ft_ty_app = \_ g -> fmap (\(b, e) -> (b, VarE traverseValName `AppE` e)) g , ft_forall = \_ g -> g , ft_co_var = \_ -> contravarianceError conName , ft_fun = \_ _ -> noFunctionsError conName , ft_bad_app = outOfPlaceTyVarError Traversable conName } -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) -- (g2 a2) <*> ... match_for_con :: Name -> [(Bool, Exp)] -> Q Match match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs where -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. mkApCon :: Exp -> [Exp] -> Exp mkApCon conExp [] = VarE pureValName `AppE` conExp mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e mkApCon conExp (e1:e2:es) = List.foldl' appAp (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- | A representation of which class is being derived. data FunctorClass = Functor | Foldable | Traversable instance ClassRep FunctorClass where arity _ = 1 allowExQuant Foldable = True allowExQuant _ = False fullClassName Functor = functorTypeName fullClassName Foldable = foldableTypeName fullClassName Traversable = traversableTypeName classConstraint fClass 1 = Just $ fullClassName fClass classConstraint _ _ = Nothing -- | A representation of which function is being generated. data FunctorFun = Fmap | Replace -- (<$) | Foldr | FoldMap | Null | Traverse deriving Eq instance Show FunctorFun where showsPrec _ Fmap = showString "fmap" showsPrec _ Replace = showString "(<$)" showsPrec _ Foldr = showString "foldr" showsPrec _ FoldMap = showString "foldMap" showsPrec _ Null = showString "null" showsPrec _ Traverse = showString "traverse" functorFunConstName :: FunctorFun -> Name functorFunConstName Fmap = fmapConstValName functorFunConstName Replace = replaceConstValName functorFunConstName Foldr = foldrConstValName functorFunConstName FoldMap = foldMapConstValName functorFunConstName Null = nullConstValName functorFunConstName Traverse = traverseConstValName functorFunName :: FunctorFun -> Name functorFunName Fmap = fmapValName functorFunName Replace = replaceValName functorFunName Foldr = foldrValName functorFunName FoldMap = foldMapValName functorFunName Null = nullValName functorFunName Traverse = traverseValName functorClassToFuns :: FunctorClass -> [FunctorFun] functorClassToFuns Functor = [ Fmap, Replace ] functorClassToFuns Foldable = [ Foldr, FoldMap #if MIN_VERSION_base(4,8,0) , Null #endif ] functorClassToFuns Traversable = [ Traverse ] functorFunToClass :: FunctorFun -> FunctorClass functorFunToClass Fmap = Functor functorFunToClass Replace = Functor functorFunToClass Foldr = Foldable functorFunToClass FoldMap = Foldable functorFunToClass Null = Foldable functorFunToClass Traverse = Traversable ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp functorFunEmptyCase ff z value = functorFunTrivial emptyCase (varE pureValName `appE` emptyCase) ff z where emptyCase :: Q Exp emptyCase = caseE (varE value) [] functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp functorFunNoCons ff z value = functorFunTrivial seqAndError (varE pureValName `appE` seqAndError) ff z where seqAndError :: Q Exp seqAndError = appE (varE seqValName) (varE value) `appE` appE (varE errorValName) (stringE $ "Void " ++ nameBase (functorFunName ff)) functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp functorFunTrivial fmapE traverseE ff z = go ff where go :: FunctorFun -> Q Exp go Fmap = fmapE go Replace = fmapE go Foldr = varE z go FoldMap = varE memptyValName go Null = conE trueDataName go Traverse = traverseE conWildPat :: ConstructorInfo -> Pat conWildPat (ConstructorInfo { constructorName = conName , constructorFields = ts }) = conPCompat conName $ replicate (length ts) WildP ------------------------------------------------------------------------------- -- Generic traversal for functor-like deriving ------------------------------------------------------------------------------- -- Much of the code below is cargo-culted from the TcGenFunctor module in GHC. data FFoldType a -- Describes how to fold over a Type in a functor like way = FT { ft_triv :: a -- ^ Does not contain variable , ft_var :: Name -> a -- ^ The variable itself , ft_co_var :: Name -> a -- ^ The variable itself, contravariantly , ft_fun :: a -> a -> a -- ^ Function type , ft_tup :: TupleSort -> [a] -> a -- ^ Tuple type. The @[a]@ is the result of folding over the -- arguments of the tuple. , ft_ty_app :: Type -> a -> a -- ^ Type app, variable only in last argument. The 'Type' is the -- @arg_ty@ in @fun_ty arg_ty@. , ft_bad_app :: a -- ^ Type app, variable other than in last argument , ft_forall :: [TyVarBndrSpec] -> a -> a -- ^ Forall type } -- Note that in GHC, this function is pure. It must be monadic here since we: -- -- (1) Expand type synonyms -- (2) Detect type family applications -- -- Which require reification in Template Haskell, but are pure in Core. functorLikeTraverse :: forall a. TyVarMap1 -- ^ Variable to look for -> FFoldType a -- ^ How to fold -> Type -- ^ Type to process -> Q a functorLikeTraverse tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar , ft_co_var = caseCoVar, ft_fun = caseFun , ft_tup = caseTuple, ft_ty_app = caseTyApp , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) ty = do ty' <- resolveTypeSynonyms ty (res, _) <- go False ty' return res where go :: Bool -- Covariant or contravariant context -> Type -> Q (a, Bool) -- (result of type a, does type contain var) go co t@AppT{} | (ArrowT, [funArg, funRes]) <- unapplyTy t = do (funArgR, funArgC) <- go (not co) funArg (funResR, funResC) <- go co funRes if funArgC || funResC then return (caseFun funArgR funResR, True) else trivial go co t@AppT{} = do let (f, args) = unapplyTy t (_, fc) <- go co f (xrs, xcs) <- fmap unzip $ mapM (go co) args let tuple :: TupleSort -> Q (a, Bool) tuple tupSort = return (caseTuple tupSort xrs, True) wrongArg :: Q (a, Bool) wrongArg = return (caseWrongArg, True) case () of _ | not (or xcs) -> trivial -- Variable does not occur -- At this point we know that xrs, xcs is not empty, -- and at least one xr is True | TupleT len <- f -> tuple $ Boxed len #if MIN_VERSION_template_haskell(2,6,0) | UnboxedTupleT len <- f -> tuple $ Unboxed len #endif | fc || or (init xcs) -> wrongArg -- T (..var..) ty | otherwise -- T (..no var..) ty -> do itf <- isInTypeFamilyApp tyVarNames f args if itf -- We can't decompose type families, so -- error if we encounter one here. then wrongArg else return (caseTyApp (last args) (last xrs), True) go co (SigT t k) = do (_, kc) <- go_kind co k if kc then return (caseWrongArg, True) else go co t go co (VarT v) | Map.member v tvMap = return (if co then caseCoVar v else caseVar v, True) | otherwise = trivial go co (ForallT tvbs _ t) = do (tr, tc) <- go co t let tvbNames = map tvName tvbs if not tc || any (`elem` tvbNames) tyVarNames then trivial else return (caseForAll tvbs tr, True) go _ _ = trivial go_kind :: Bool -> Kind -> Q (a, Bool) #if MIN_VERSION_template_haskell(2,9,0) go_kind = go #else go_kind _ _ = trivial #endif trivial :: Q (a, Bool) trivial = return (caseTrivial, False) tyVarNames :: [Name] tyVarNames = Map.keys tvMap -- Fold over the arguments of a data constructor in a Functor-like way. foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a] foldDataConArgs tvMap ft con = do fieldTys <- mapM resolveTypeSynonyms $ constructorFields con mapM foldArg fieldTys where foldArg :: Type -> Q a foldArg = functorLikeTraverse tvMap ft -- Make a 'LamE' using a fresh variable. mkSimpleLam :: (Exp -> Q Exp) -> Q Exp mkSimpleLam lam = do n <- newName "n" body <- lam (VarE n) return $ LamE [VarP n] body -- Make a 'LamE' using two fresh variables. mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp mkSimpleLam2 lam = do n1 <- newName "n1" n2 <- newName "n2" body <- lam (VarE n1) (VarE n2) return $ LamE [VarP n1, VarP n2] body -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" -- -- @mkSimpleConMatch fold conName insides@ produces a match clause in -- which the LHS pattern-matches on @extraPats@, followed by a match on the -- constructor @conName@ and its arguments. The RHS folds (with @fold@) over -- @conName@ and its arguments, applying an expression (from @insides@) to each -- of the respective arguments of @conName@. mkSimpleConMatch :: (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match mkSimpleConMatch fold conName insides = do varsNeeded <- newNameList "_arg" $ length insides let pat = conPCompat conName (map VarP varsNeeded) rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) return $ Match pat (NormalB rhs) [] -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" -- -- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to -- 'mkSimpleConMatch', with two key differences: -- -- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it -- filters out the expressions corresponding to arguments whose types do not -- mention the last type variable in a derived 'Foldable' or 'Traversable' -- instance (i.e., those elements of @insides@ containing @False@). -- -- 2. @fold@ takes an expression as its first argument instead of a -- constructor name. This is because it uses a specialized -- constructor function expression that only takes as many parameters as -- there are argument types that mention the last type variable. mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match mkSimpleConMatch2 fold conName insides = do varsNeeded <- newNameList "_arg" lengthInsides let pat = conPCompat conName (map VarP varsNeeded) -- Make sure to zip BEFORE invoking catMaybes. We want the variable -- indicies in each expression to match up with the argument indices -- in conExpr (defined below). exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v) else Nothing) insides varsNeeded -- An element of argTysTyVarInfo is True if the constructor argument -- with the same index has a type which mentions the last type -- variable. argTysTyVarInfo = map (\(m, _) -> m) insides (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded conExpQ | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar) | otherwise = do bs <- newNameList "b" lengthInsides let bs' = filterByList argTysTyVarInfo bs vars = filterByLists argTysTyVarInfo (map varE bs) (map varE varsNeeded) lamE (map varP bs') (appsE (conE conName:vars)) conExp <- conExpQ rhs <- fold conExp exps return $ Match pat (NormalB rhs) [] where lengthInsides = length insides -- Indicates whether a tuple is boxed or unboxed, as well as its number of -- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #) -- corresponds to @Unboxed 3@. data TupleSort = Boxed Int #if MIN_VERSION_template_haskell(2,6,0) | Unboxed Int #endif -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp mkSimpleTupleCase matchForCon tupSort insides x = do let tupDataName = case tupSort of Boxed len -> tupleDataName len #if MIN_VERSION_template_haskell(2,6,0) Unboxed len -> unboxedTupleDataName len #endif m <- matchForCon tupDataName insides return $ CaseE x [m] -- Adapt to the type of ConP changing in template-haskell-2.18.0.0. conPCompat :: Name -> [Pat] -> Pat conPCompat n pats = ConP n #if MIN_VERSION_template_haskell(2,18,0) [] #endif pats deriving-compat-0.6.5/src/Data/Ix/0000755000000000000000000000000007346545000015023 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Ix/Deriving.hs0000644000000000000000000000144207346545000017127 0ustar0000000000000000{-| 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. -} deriving-compat-0.6.5/src/Data/Ix/Deriving/0000755000000000000000000000000007346545000016572 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Ix/Deriving/Internal.hs0000644000000000000000000002045607346545000020711 0ustar0000000000000000{-| 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 Data.List.NonEmpty (NonEmpty(..)) 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 (con: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 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 cons :: NonEmpty ConstructorInfo cons = con :| cons' 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 deriving-compat-0.6.5/src/Data/Ord/0000755000000000000000000000000007346545000015167 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Ord/Deriving.hs0000644000000000000000000000353407346545000017277 0ustar0000000000000000{-# 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@. -} deriving-compat-0.6.5/src/Data/Ord/Deriving/0000755000000000000000000000000007346545000016736 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Ord/Deriving/Internal.hs0000644000000000000000000006105107346545000021051 0ustar0000000000000000{-# 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.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) 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 -- 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..] ordFunRhs :: Q Exp ordFunRhs = case cons of [] -> conE eqDataName c:cs -> ordFunRhsNonEmptyCons (c :| cs) ordFunRhsNonEmptyCons :: NonEmpty ConstructorInfo -> Q Exp ordFunRhsNonEmptyCons cs@(c :| _) | length nullaryCons <= 2 = caseE (varE v1) $ map ordMatches $ NE.toList cs | null nonNullaryCons = mkTagCmp | otherwise = caseE (varE v1) $ map ordMatches nonNullaryCons ++ [match wildP (normalB mkTagCmp) []] where firstConName, lastConName :: Name firstConName = constructorName c lastConName = constructorName $ NE.last cs ordMatches :: ConstructorInfo -> Q Match ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType firstTag firstConName lastTag lastConName dataConTagMap 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 deriving-compat-0.6.5/src/Data/Traversable/0000755000000000000000000000000007346545000016715 5ustar0000000000000000deriving-compat-0.6.5/src/Data/Traversable/Deriving.hs0000644000000000000000000000357307346545000021030 0ustar0000000000000000{-| Module: Data.Traversable.Deriving Copyright: (C) 2015-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Traversable' instances in a way that mimics how the @-XDeriveTraversable@ extension works since GHC 8.0. Derived 'Traversable' instances from this module do not generate superfluous 'pure' expressions in its implementation of 'traverse'. One can verify this by compiling a module that uses 'deriveTraversable' with the @-ddump-splices@ GHC flag. These changes make it possible to derive @Traversable@ instances for data types with unlifted argument types, e.g., @ data IntHash a = IntHash Int# a deriving instance Traversable IntHash -- On GHC 8.0 on later $(deriveTraversable ''IntHash) -- On GHC 7.10 and earlier @ For more info on these changes, see . -} module Data.Traversable.Deriving ( -- * 'Traversable' deriveTraversable , deriveTraversableOptions , makeTraverse , makeTraverseOptions , makeSequenceA , makeSequenceAOptions , makeMapM , makeMapMOptions , makeSequence , makeSequenceOptions -- * 'FFTOptions' , FFTOptions(..) , defaultFFTOptions -- * 'deriveTraversable' limitations -- $constraints ) where import Data.Functor.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an existential constraint cannot mention the last type variable. For example, @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 'Traversable' instance. * Type variables of kind @* -> *@ are assumed to have 'Traversable' constraints. If this is not desirable, use 'makeTraverse'. -} deriving-compat-0.6.5/src/Text/Read/0000755000000000000000000000000007346545000015371 5ustar0000000000000000deriving-compat-0.6.5/src/Text/Read/Deriving.hs0000644000000000000000000000635707346545000017507 0ustar0000000000000000{-# 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@. -} deriving-compat-0.6.5/src/Text/Read/Deriving/0000755000000000000000000000000007346545000017140 5ustar0000000000000000deriving-compat-0.6.5/src/Text/Read/Deriving/Internal.hs0000644000000000000000000010352307346545000021254 0ustar0000000000000000{-# 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 deriving-compat-0.6.5/src/Text/Show/0000755000000000000000000000000007346545000015436 5ustar0000000000000000deriving-compat-0.6.5/src/Text/Show/Deriving.hs0000644000000000000000000000451007346545000017541 0ustar0000000000000000{-# 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@. -} deriving-compat-0.6.5/src/Text/Show/Deriving/0000755000000000000000000000000007346545000017205 5ustar0000000000000000deriving-compat-0.6.5/src/Text/Show/Deriving/Internal.hs0000644000000000000000000007731407346545000021331 0ustar0000000000000000{-# 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,19,0) , (int8HashTypeName, PrimShow { primShowBoxer = appE (conE i8HashDataName) , primShowPostfixMod = extendedLitE "Int8" , primShowConv = id }) , (int16HashTypeName, PrimShow { primShowBoxer = appE (conE i16HashDataName) , primShowPostfixMod = extendedLitE "Int16" , primShowConv = id }) , (int32HashTypeName, PrimShow { primShowBoxer = appE (conE i32HashDataName) , primShowPostfixMod = extendedLitE "Int32" , primShowConv = id }) , (int64HashTypeName, PrimShow { primShowBoxer = appE (conE i64HashDataName) , primShowPostfixMod = extendedLitE "Int64" , primShowConv = id }) , (word8HashTypeName, PrimShow { primShowBoxer = appE (conE w8HashDataName) , primShowPostfixMod = extendedLitE "Word8" , primShowConv = id }) , (word16HashTypeName, PrimShow { primShowBoxer = appE (conE w16HashDataName) , primShowPostfixMod = extendedLitE "Word16" , primShowConv = id }) , (word32HashTypeName, PrimShow { primShowBoxer = appE (conE w32HashDataName) , primShowPostfixMod = extendedLitE "Word32" , primShowConv = id }) , (word64HashTypeName, PrimShow { primShowBoxer = appE (conE w64HashDataName) , primShowPostfixMod = extendedLitE "Word64" , primShowConv = id }) #else # 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 #endif ] #if MIN_VERSION_base(4,13,0) && !(MIN_VERSION_base(4,19,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 "##" #if MIN_VERSION_base(4,19,0) extendedLitE :: String -> Q Exp extendedLitE suffix = varE showStringValName `appE` stringE ("#" ++ suffix) #endif deriving-compat-0.6.5/tests/0000755000000000000000000000000007346545000014145 5ustar0000000000000000deriving-compat-0.6.5/tests/BoundedEnumIxSpec.hs0000644000000000000000000002237207346545000020030 0ustar0000000000000000{-# 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 deriving-compat-0.6.5/tests/DerivingViaSpec.hs0000644000000000000000000000453707346545000017534 0ustar0000000000000000{-# 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 () deriving-compat-0.6.5/tests/EqSpec.hs0000644000000000000000000000073007346545000015661 0ustar0000000000000000{-| 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 () deriving-compat-0.6.5/tests/FunctorSpec.hs0000644000000000000000000003231207346545000016735 0ustar0000000000000000{-# 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 deriving-compat-0.6.5/tests/GH24Spec.hs0000644000000000000000000000155007346545000015761 0ustar0000000000000000{-# 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 () deriving-compat-0.6.5/tests/GH27Spec.hs0000644000000000000000000000145007346545000015763 0ustar0000000000000000{-# 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 () deriving-compat-0.6.5/tests/GH31Spec.hs0000644000000000000000000000232307346545000015756 0ustar0000000000000000{-# 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 deriving-compat-0.6.5/tests/GH6Spec.hs0000644000000000000000000000163607346545000015706 0ustar0000000000000000{-# 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)) deriving-compat-0.6.5/tests/OrdSpec.hs0000644000000000000000000000203007346545000016033 0ustar0000000000000000{-# 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 () deriving-compat-0.6.5/tests/ReadSpec.hs0000644000000000000000000000603207346545000016170 0ustar0000000000000000{-# 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 deriving-compat-0.6.5/tests/ShowSpec.hs0000644000000000000000000001050307346545000016233 0ustar0000000000000000{-# 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 () deriving-compat-0.6.5/tests/Spec.hs0000644000000000000000000000005407346545000015372 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} deriving-compat-0.6.5/tests/Types/0000755000000000000000000000000007346545000015251 5ustar0000000000000000deriving-compat-0.6.5/tests/Types/EqOrd.hs0000644000000000000000000001623407346545000016625 0ustar0000000000000000{-# 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 deriving-compat-0.6.5/tests/Types/ReadShow.hs0000644000000000000000000001343207346545000017324 0ustar0000000000000000{-# 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