deriving-compat 0.5.10 → 0.6.8
raw patch · 33 files changed
Files
- CHANGELOG.md +53/−1
- README.md +8/−6
- deriving-compat.cabal +44/−73
- src/Data/Bounded/Deriving/Internal.hs +9/−4
- src/Data/Deriving.hs +7/−1
- src/Data/Deriving/Internal.hs +2008/−2214
- src/Data/Deriving/Via/Internal.hs +22/−11
- src/Data/Enum/Deriving.hs +3/−0
- src/Data/Enum/Deriving/Internal.hs +6/−2
- src/Data/Eq/Deriving.hs +4/−5
- src/Data/Eq/Deriving/Internal.hs +65/−79
- src/Data/Functor/Deriving/Internal.hs +19/−40
- src/Data/Ix/Deriving.hs +3/−0
- src/Data/Ix/Deriving/Internal.hs +6/−5
- src/Data/Ord/Deriving.hs +4/−5
- src/Data/Ord/Deriving/Internal.hs +21/−108
- src/Text/Read/Deriving.hs +7/−7
- src/Text/Read/Deriving/Internal.hs +10/−82
- src/Text/Show/Deriving.hs +4/−5
- src/Text/Show/Deriving/Internal.hs +80/−78
- tests/BoundedEnumIxSpec.hs +8/−23
- tests/DerivingViaSpec.hs +0/−3
- tests/EqSpec.hs +0/−3
- tests/FunctorSpec.hs +44/−58
- tests/GH24Spec.hs +2/−8
- tests/GH27Spec.hs +0/−8
- tests/GH31Spec.hs +0/−3
- tests/GH6Spec.hs +0/−3
- tests/OrdSpec.hs +3/−6
- tests/ReadSpec.hs +3/−17
- tests/ShowSpec.hs +13/−14
- tests/Types/EqOrd.hs +39/−36
- tests/Types/ReadShow.hs +4/−38
CHANGELOG.md view
@@ -1,3 +1,55 @@+### 0.6.8 [2026.01.08]+* Allow building with `template-haskell-2.24.*` (GHC 9.14).+* Remove unused `ghc-prim`, `transformers`, and `transformers-compat`+ dependencies.++### 0.6.7 [2024.12.05]+* Drop support for pre-8.0 versions of GHC.++### 0.6.6 [2024.03.19]+* Support building with `template-haskell-2.22.*` (GHC 9.10).++### 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). @@ -45,7 +97,7 @@ * Have `deriveGND`/`deriveVia` throw an error if an incorrect number of arguments are supplied to the type class. -### 0.5 [2018.07.01]+## 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).
README.md view
@@ -3,7 +3,7 @@ [](http://packdeps.haskellers.com/reverse/deriving-compat) [][Haskell.org] [][tl;dr Legal: BSD3]-[](https://travis-ci.org/haskell-compat/deriving-compat)+[](https://github.com/haskell-compat/deriving-compat/actions?query=workflow%3AHaskell-CI) [Hackage: deriving-compat]: http://hackage.haskell.org/package/deriving-compat@@ -15,15 +15,15 @@ https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" -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-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`, `Eq1`, and `Eq2`-* Deriving `Ord`, `Ord1`, and `Ord2`-* Deriving `Read`, `Read1`, and `Read2`-* Deriving `Show`, `Show1`, and `Show2`+* Deriving `Eq`+* Deriving `Ord`+* Deriving `Read`+* Deriving `Show` * `DeriveFoldable` * `DeriveFunctor` * `DeriveTraversable`@@ -31,6 +31,8 @@ * `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:
deriving-compat.cabal view
@@ -1,9 +1,10 @@ name: deriving-compat-version: 0.5.10+version: 0.6.8 synopsis: Backports of GHC deriving extensions-description: 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:+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@ .@@ -11,13 +12,13 @@ . * Deriving @Ix@ .- * Deriving @Eq@, @Eq1@, and @Eq2@+ * Deriving @Eq@ .- * Deriving @Ord@, @Ord1@, and @Ord2@+ * Deriving @Ord@ .- * Deriving @Read@, @Read1@, and @Read2@+ * Deriving @Read@ .- * Deriving @Show@, @Show1@, and @Show2@+ * Deriving @Show@ . * @DeriveFoldable@ .@@ -31,6 +32,21 @@ . 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@@@ -62,39 +78,26 @@ 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+tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.3- , GHC == 8.10.1+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 cabal-version: >=1.10 source-repository head type: git location: https://github.com/haskell-compat/deriving-compat -flag base-4-9- description: Use base-4.9 or later.- default: True--flag template-haskell-2-11- description: Use template-haskell-2.11.0.0 or later.- default: True--flag new-functor-classes- description: Use a version of transformers or transformers-compat with a- modern-style Data.Functor.Classes module. This flag cannot be- used when building with transformers-0.4, since it comes with- a different version of Data.Functor.Classes.- default: True- library exposed-modules: Data.Deriving Data.Deriving.Internal@@ -119,29 +122,11 @@ Text.Read.Deriving.Internal Text.Show.Deriving Text.Show.Deriving.Internal- other-modules: Paths_deriving_compat- build-depends: containers >= 0.1 && < 0.7- , ghc-prim- , th-abstraction >= 0.4 && < 0.5-- if flag(base-4-9)- build-depends: base >= 4.9 && < 5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: base >= 4.3 && < 4.9-- if flag(template-haskell-2-11)- build-depends: template-haskell >= 2.11 && < 2.18+ build-depends: base >= 4.9 && < 5+ , containers >= 0.1 && < 0.9 , 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- , transformers-compat >= 0.5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: transformers == 0.4.*+ , template-haskell >= 2.11 && < 2.25+ , th-abstraction >= 0.5 && < 0.8 hs-source-dirs: src default-language: Haskell2010@@ -164,31 +149,17 @@ Types.EqOrd Types.ReadShow- build-depends: base-compat >= 0.8.1 && < 1- , base-orphans >= 0.5 && < 1+ build-depends: base >= 4.9 && < 5 , deriving-compat , hspec >= 1.8- , QuickCheck >= 2 && < 3- , tagged >= 0.7 && < 1- , template-haskell >= 2.5 && < 2.18- , void >= 0.5.10 && < 1+ , QuickCheck >= 2 && < 3+ , template-haskell 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.6)- , transformers-compat >= 0.5- cpp-options: "-DNEW_FUNCTOR_CLASSES"- else- build-depends: transformers == 0.4.*- hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type+ if impl(ghc >= 9.0)+ ghc-options: -fenable-th-splice-warnings
src/Data/Bounded/Deriving/Internal.hs view
@@ -20,6 +20,8 @@ ) 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@@ -90,7 +92,7 @@ -- given constructors. All constructors must be from the same type. makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp makeBoundedFunForCons _ _ [] = noConstructorsError-makeBoundedFunForCons bf tyName cons+makeBoundedFunForCons bf tyName (con:cons') | not (isProduct || isEnumeration) = enumerationOrProductError $ nameBase tyName | isEnumeration@@ -102,9 +104,12 @@ isProduct = isProductType cons isEnumeration = isEnumerationType cons + cons :: NonEmpty ConstructorInfo+ cons = con :| cons'+ con1, conN :: Q Exp- con1 = conE $ constructorName $ head cons- conN = conE $ constructorName $ last cons+ con1 = conE $ constructorName con+ conN = conE $ constructorName $ NE.last cons pickCon :: Q Exp pickCon = case bf of@@ -114,7 +119,7 @@ pickConApp :: Q Exp pickConApp = appsE $ pickCon- : map varE (replicate (conArity $ head cons) (boundedFunName bf))+ : map varE (replicate (conArity con) (boundedFunName bf)) ------------------------------------------------------------------------------- -- Class-specific constants
src/Data/Deriving.hs view
@@ -118,9 +118,15 @@ * 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 8.12, @DeriveFunctor@ was changed so that it works on more+* 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
src/Data/Deriving/Internal.hs view
@@ -2,2218 +2,2012 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-}--#if !(MIN_VERSION_base(4,9,0))-# if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE TemplateHaskellQuotes #-}-# else-{-# LANGUAGE TemplateHaskell #-}-# endif-#endif--{-|-Module: Data.Deriving.Internal-Copyright: (C) 2015-2017 Ryan Scott-License: BSD-style (see the file LICENSE)-Maintainer: Ryan Scott-Portability: Template Haskell--Template Haskell-related utilities.--Note: this is an internal module, and as such, the API presented here is not-guaranteed to be stable, even between minor releases of this library.--}-module Data.Deriving.Internal where--import Control.Applicative (liftA2)-import Control.Monad (when, unless)--import Data.Foldable (foldr')-#if !(MIN_VERSION_base(4,9,0))-import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..))-# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)-import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..))-# endif-#endif-import Data.List-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Traversable as T--import Text.ParserCombinators.ReadPrec (ReadPrec)-import qualified Text.Read.Lex as L--#if MIN_VERSION_base(4,7,0)-import GHC.Read (expectP)-#else-import GHC.Read (lexP)--import Text.Read (pfail)-import Text.Read.Lex (Lexeme)-#endif--#if MIN_VERSION_ghc_prim(0,3,1)-import GHC.Prim (Int#, tagToEnum#)-#endif--#if defined(MIN_VERSION_ghc_boot_th)-import GHC.Lexeme (startsConSym, startsVarSym)-#else-import Data.Char (isSymbol, ord)-#endif--import Language.Haskell.TH.Datatype-import Language.Haskell.TH.Datatype.TyVarBndr-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr (pprint)-import Language.Haskell.TH.Syntax---- Ensure, beyond a shadow of a doubt, that the instances are in-scope-import Data.Functor ()-import Data.Functor.Classes ()-import Data.Foldable ()-import Data.Traversable ()--#ifndef CURRENT_PACKAGE_KEY-import Data.Version (showVersion)-import Paths_deriving_compat (version)-#endif------------------------------------------------------------------------------------ Expanding type synonyms----------------------------------------------------------------------------------applySubstitutionKind :: Map Name Kind -> Type -> Type-#if MIN_VERSION_template_haskell(2,8,0)-applySubstitutionKind = applySubstitution-#else-applySubstitutionKind _ t = t-#endif--substNameWithKind :: Name -> Kind -> Type -> Type-substNameWithKind n k = applySubstitutionKind (Map.singleton n k)--substNamesWithKindStar :: [Name] -> Type -> Type-substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns------------------------------------------------------------------------------------ Via------------------------------------------------------------------------------------ | A type-level modifier intended to be used in conjunction with 'deriveVia'.--- Refer to the documentation for 'deriveVia' for more details.-data a `Via` b-infix 0 `Via`------------------------------------------------------------------------------------ Type-specialized const functions----------------------------------------------------------------------------------fmapConst :: f b -> (a -> b) -> f a -> f b-fmapConst x _ _ = x-{-# INLINE fmapConst #-}--replaceConst :: f a -> a -> f b -> f a-replaceConst x _ _ = x-{-# INLINE replaceConst #-}--foldrConst :: b -> (a -> b -> b) -> b -> t a -> b-foldrConst x _ _ _ = x-{-# INLINE foldrConst #-}--foldMapConst :: m -> (a -> m) -> t a -> m-foldMapConst x _ _ = x-{-# INLINE foldMapConst #-}--nullConst :: Bool -> t a -> Bool-nullConst x _ = x-{-# INLINE nullConst #-}--traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b)-traverseConst x _ _ = x-{-# INLINE traverseConst #-}--eqConst :: Bool- -> a -> a -> Bool-eqConst x _ _ = x-{-# INLINE eqConst #-}--eq1Const :: Bool- -> f a -> f a-> Bool-eq1Const x _ _ = x-{-# INLINE eq1Const #-}--liftEqConst :: Bool- -> (a -> b -> Bool) -> f a -> f b -> Bool-liftEqConst x _ _ _ = x-{-# INLINE liftEqConst #-}--liftEq2Const :: Bool- -> (a -> b -> Bool) -> (c -> d -> Bool)- -> f a c -> f b d -> Bool-liftEq2Const x _ _ _ _ = x-{-# INLINE liftEq2Const #-}--compareConst :: Ordering -> a -> a -> Ordering-compareConst x _ _ = x-{-# INLINE compareConst #-}--ltConst :: Bool -> a -> a -> Bool-ltConst x _ _ = x-{-# INLINE ltConst #-}--compare1Const :: Ordering -> f a -> f a -> Ordering-compare1Const x _ _ = x-{-# INLINE compare1Const #-}--liftCompareConst :: Ordering- -> (a -> b -> Ordering) -> f a -> f b -> Ordering-liftCompareConst x _ _ _ = x-{-# INLINE liftCompareConst #-}--liftCompare2Const :: Ordering- -> (a -> b -> Ordering) -> (c -> d -> Ordering)- -> f a c -> f b d -> Ordering-liftCompare2Const x _ _ _ _ = x-{-# INLINE liftCompare2Const #-}--readsPrecConst :: ReadS a -> Int -> ReadS a-readsPrecConst x _ = x-{-# INLINE readsPrecConst #-}---- This isn't really necessary, but it makes for an easier implementation-readPrecConst :: ReadPrec a -> ReadPrec a-readPrecConst x = x-{-# INLINE readPrecConst #-}--readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a)-readsPrec1Const x _ = x-{-# INLINE readsPrec1Const #-}--liftReadsPrecConst :: ReadS (f a)- -> (Int -> ReadS a) -> ReadS [a]- -> Int -> ReadS (f a)-liftReadsPrecConst x _ _ _ = x-{-# INLINE liftReadsPrecConst #-}--liftReadPrecConst :: ReadPrec (f a)- -> ReadPrec a -> ReadPrec [a]- -> ReadPrec (f a)-liftReadPrecConst x _ _ = x-{-# INLINE liftReadPrecConst #-}--liftReadsPrec2Const :: ReadS (f a b)- -> (Int -> ReadS a) -> ReadS [a]- -> (Int -> ReadS b) -> ReadS [b]- -> Int -> ReadS (f a b)-liftReadsPrec2Const x _ _ _ _ _ = x-{-# INLINE liftReadsPrec2Const #-}--liftReadPrec2Const :: ReadPrec (f a b)- -> ReadPrec a -> ReadPrec [a]- -> ReadPrec b -> ReadPrec [b]- -> ReadPrec (f a b)-liftReadPrec2Const x _ _ _ _ = x-{-# INLINE liftReadPrec2Const #-}--showsPrecConst :: ShowS- -> Int -> a -> ShowS-showsPrecConst x _ _ = x-{-# INLINE showsPrecConst #-}--showsPrec1Const :: ShowS- -> Int -> f a -> ShowS-showsPrec1Const x _ _ = x-{-# INLINE showsPrec1Const #-}--liftShowsPrecConst :: ShowS- -> (Int -> a -> ShowS) -> ([a] -> ShowS)- -> Int -> f a -> ShowS-liftShowsPrecConst x _ _ _ _ = x-{-# INLINE liftShowsPrecConst #-}--liftShowsPrec2Const :: ShowS- -> (Int -> a -> ShowS) -> ([a] -> ShowS)- -> (Int -> b -> ShowS) -> ([b] -> ShowS)- -> Int -> f a b -> ShowS-liftShowsPrec2Const x _ _ _ _ _ _ = x-{-# INLINE liftShowsPrec2Const #-}------------------------------------------------------------------------------------ StarKindStatus------------------------------------------------------------------------------------ | Whether a type is not of kind *, is of kind *, or is a kind variable.-data StarKindStatus = NotKindStar- | KindStar- | IsKindVar Name- deriving Eq---- | Does a Type have kind * or k (for some kind variable k)?-canRealizeKindStar :: Type -> StarKindStatus-canRealizeKindStar t- | hasKindStar t = KindStar- | otherwise = case t of-#if MIN_VERSION_template_haskell(2,8,0)- SigT _ (VarT k) -> IsKindVar k-#endif- _ -> NotKindStar---- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.--- Otherwise, returns 'Nothing'.-starKindStatusToName :: StarKindStatus -> Maybe Name-starKindStatusToName (IsKindVar n) = Just n-starKindStatusToName _ = Nothing---- | Concat together all of the StarKindStatuses that are IsKindVar and extract--- the kind variables' Names out.-catKindVarNames :: [StarKindStatus] -> [Name]-catKindVarNames = mapMaybe starKindStatusToName------------------------------------------------------------------------------------ ClassRep----------------------------------------------------------------------------------class ClassRep a where- arity :: a -> Int- allowExQuant :: a -> Bool- fullClassName :: a -> Name- classConstraint :: a -> Int -> Maybe Name------------------------------------------------------------------------------------ Template Haskell reifying and AST manipulation------------------------------------------------------------------------------------ For the given Types, generate an instance context and head. Coming up with--- the instance type isn't as simple as dropping the last types, as you need to--- be wary of kinds being instantiated with *.--- See Note [Type inference in derived instances]-buildTypeInstance :: ClassRep a- => a- -- ^ The typeclass for which an instance should be derived- -> Name- -- ^ The type constructor or data family name- -> Cxt- -- ^ The datatype context- -> [Type]- -- ^ The types to instantiate the instance with- -> DatatypeVariant- -- ^ Are we dealing with a data family instance or not- -> Q (Cxt, Type)-buildTypeInstance cRep tyConName dataCxt varTysOrig variant = do- -- Make sure to expand through type/kind synonyms! Otherwise, the- -- eta-reduction check might get tripped up over type variables in a- -- synonym that are actually dropped.- -- (See GHC Trac #11416 for a scenario where this actually happened.)- varTysExp <- mapM resolveTypeSynonyms varTysOrig-- let remainingLength :: Int- remainingLength = length varTysOrig - arity cRep-- droppedTysExp :: [Type]- droppedTysExp = drop remainingLength varTysExp-- droppedStarKindStati :: [StarKindStatus]- droppedStarKindStati = map canRealizeKindStar droppedTysExp-- -- Check there are enough types to drop and that all of them are either of- -- kind * or kind k (for some kind variable k). If not, throw an error.- when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $- derivingKindError cRep tyConName-- let droppedKindVarNames :: [Name]- droppedKindVarNames = catKindVarNames droppedStarKindStati-- -- Substitute kind * for any dropped kind variables- varTysExpSubst :: [Type]- varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp-- remainingTysExpSubst, droppedTysExpSubst :: [Type]- (remainingTysExpSubst, droppedTysExpSubst) =- splitAt remainingLength varTysExpSubst-- -- All of the type variables mentioned in the dropped types- -- (post-synonym expansion)- droppedTyVarNames :: [Name]- droppedTyVarNames = freeVariables droppedTysExpSubst-- -- If any of the dropped types were polykinded, ensure that they are of kind *- -- after substituting * for the dropped kind variables. If not, throw an error.- unless (all hasKindStar droppedTysExpSubst) $- derivingKindError cRep tyConName-- let preds :: [Maybe Pred]- kvNames :: [[Name]]- kvNames' :: [Name]- -- Derive instance constraints (and any kind variables which are specialized- -- to * in those constraints)- (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst- kvNames' = concat kvNames-- -- Substitute the kind variables specialized in the constraints with *- remainingTysExpSubst' :: [Type]- remainingTysExpSubst' =- map (substNamesWithKindStar kvNames') remainingTysExpSubst-- -- We now substitute all of the specialized-to-* kind variable names with- -- *, but in the original types, not the synonym-expanded types. The reason- -- we do this is a superficial one: we want the derived instance to resemble- -- the datatype written in source code as closely as possible. For example,- -- for the following data family instance:- --- -- data family Fam a- -- newtype instance Fam String = Fam String- --- -- We'd want to generate the instance:- --- -- instance C (Fam String)- --- -- Not:- --- -- instance C (Fam [Char])- remainingTysOrigSubst :: [Type]- remainingTysOrigSubst =- map (substNamesWithKindStar (union droppedKindVarNames kvNames'))- $ take remainingLength varTysOrig-- isDataFamily :: Bool- isDataFamily = case variant of- Datatype -> False- Newtype -> False- DataInstance -> True- NewtypeInstance -> True-- remainingTysOrigSubst' :: [Type]- -- See Note [Kind signatures in derived instances] for an explanation- -- of the isDataFamily check.- remainingTysOrigSubst' =- if isDataFamily- then remainingTysOrigSubst- else map unSigT remainingTysOrigSubst-- instanceCxt :: Cxt- instanceCxt = catMaybes preds-- instanceType :: Type- instanceType = AppT (ConT (fullClassName cRep))- $ applyTyCon tyConName remainingTysOrigSubst'-- -- If the datatype context mentions any of the dropped type variables,- -- we can't derive an instance, so throw an error.- when (any (`predMentionsName` droppedTyVarNames) dataCxt) $- datatypeContextError tyConName instanceType- -- Also ensure the dropped types can be safely eta-reduced. Otherwise,- -- throw an error.- unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $- etaReductionError instanceType- return (instanceCxt, instanceType)---- | Attempt to derive a constraint on a Type. If successful, return--- Just the constraint and any kind variable names constrained to *.--- Otherwise, return Nothing and the empty list.------ See Note [Type inference in derived instances] for the heuristics used to--- come up with constraints.-deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name])-deriveConstraint cRep t- | not (isTyVar t) = (Nothing, [])- | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, [])- | otherwise = case hasKindVarChain 1 t of- Just ns | cRepArity >= 1- -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns)- _ -> case hasKindVarChain 2 t of- Just ns | cRepArity == 2- -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns)- _ -> (Nothing, [])- where- tName :: Name- tName = varTToName t-- cRepArity :: Int- cRepArity = arity cRep--{--Note [Kind signatures in derived instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is possible to put explicit kind signatures into the derived instances, e.g.,-- instance C a => C (Data (f :: * -> *)) where ...--But it is preferable to avoid this if possible. If we come up with an incorrect-kind signature (which is entirely possible, since our type inferencer is pretty-unsophisticated - see Note [Type inference in derived instances]), then GHC will-flat-out reject the instance, which is quite unfortunate.--Plain old datatypes have the advantage that you can avoid using any kind signatures-at all in their instances. This is because a datatype declaration uses all type-variables, so the types that we use in a derived instance uniquely determine their-kinds. As long as we plug in the right types, the kind inferencer can do the rest-of the work. For this reason, we use unSigT to remove all kind signatures before-splicing in the instance context and head.--Data family instances are trickier, since a data family can have two instances that-are distinguished by kind alone, e.g.,-- data family Fam (a :: k)- data instance Fam (a :: * -> *)- data instance Fam (a :: *)--If we dropped the kind signatures for C (Fam a), then GHC will have no way of-knowing which instance we are talking about. To avoid this scenario, we always-include explicit kind signatures in data family instances. There is a chance that-the inferred kind signatures will be incorrect, but if so, we can always fall back-on the make- functions.--Note [Type inference in derived instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Type inference is can be tricky to get right, and we want to avoid recreating the-entirety of GHC's type inferencer in Template Haskell. For this reason, we will-probably never come up with derived instance contexts that are as accurate as-GHC's. But that doesn't mean we can't do anything! There are a couple of simple-things we can do to make instance contexts that work for 80% of use cases:--1. If one of the last type parameters is polykinded, then its kind will be- specialized to * in the derived instance. We note what kind variable the type- parameter had and substitute it with * in the other types as well. For example,- imagine you had-- data Data (a :: k) (b :: k)-- Then you'd want to derived instance to be:-- instance C (Data (a :: *))-- Not:-- instance C (Data (a :: k))--2. We naïvely come up with instance constraints using the following criteria, using- Show(1)(2) as the example typeclasses:-- (i) If there's a type parameter n of kind *, generate a Show n constraint.- (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind- variables), then generate a Show1 n constraint, and if k1/k2 are kind- variables, then substitute k1/k2 with * elsewhere in the types. We must- consider the case where they are kind variables because you might have a- scenario like this:-- newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)- = Compose (f (g a))-- Which would have a derived Show1 instance of:-- instance (Show1 f, Show1 g) => Show1 (Compose f g) where ...- (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are- * or kind variables), then generate a Show2 constraint and perform- kind substitution as in the other cases.--}--checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name- -> Q c -> Q c-checkExistentialContext cRep tvMap ctxt conName q =- if (any (`predMentionsName` Map.keys tvMap) ctxt- || Map.size tvMap < arity cRep)- && not (allowExQuant cRep)- then existentialContextError conName- else q--{--Note [Matching functions with GADT type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When deriving category-2 classes like Show2, there is a tricky corner case to consider:-- data Both a b where- BothCon :: x -> x -> Both x x--Which show functions should be applied to which arguments of BothCon? We have a-choice, since both the function of type (Int -> a -> ShowS) and of type-(Int -> b -> ShowS) can be applied to either argument. In such a scenario, the-second show function takes precedence over the first show function, so the-derived Show2 instance would be:-- instance Show2 Both where- liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) =- showsParen (p > appPrec) $- showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2--This is not an arbitrary choice, as this definition ensures that-liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for-Both.--}------------------------------------------------------------------------------------ Error messages------------------------------------------------------------------------------------ | The given datatype has no constructors, and we don't know what to do with it.-noConstructorsError :: Q a-noConstructorsError = fail "Must have at least one data constructor"---- | Either the given data type doesn't have enough type variables, or one of--- the type variables to be eta-reduced cannot realize kind *.-derivingKindError :: ClassRep a => a -> Name -> Q b-derivingKindError cRep tyConName = fail- . showString "Cannot derive well-kinded instance of form ‘"- . showString className- . showChar ' '- . showParen True- ( showString (nameBase tyConName)- . showString " ..."- )- . showString "‘\n\tClass "- . showString className- . showString " expects an argument of kind "- . showString (pprint . createKindChain $ arity cRep)- $ ""- where- className :: String- className = nameBase $ fullClassName cRep---- | The last type variable appeared in a contravariant position--- when deriving Functor.-contravarianceError :: Name -> Q a-contravarianceError conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must not use the last type variable in a function argument"- $ ""---- | A constructor has a function argument in a derived Foldable or Traversable--- instance.-noFunctionsError :: Name -> Q a-noFunctionsError conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must not contain function types"- $ ""---- | One of the last type variables cannot be eta-reduced (see the canEtaReduce--- function for the criteria it would have to meet).-etaReductionError :: Type -> Q a-etaReductionError instanceType = fail $- "Cannot eta-reduce to an instance of form \n\tinstance (...) => "- ++ pprint instanceType---- | The data type has a DatatypeContext which mentions one of the eta-reduced--- type variables.-datatypeContextError :: Name -> Type -> Q a-datatypeContextError dataName instanceType = fail- . showString "Can't make a derived instance of ‘"- . showString (pprint instanceType)- . showString "‘:\n\tData type ‘"- . showString (nameBase dataName)- . showString "‘ must not have a class context involving the last type argument(s)"- $ ""---- | The data type has an existential constraint which mentions one of the--- eta-reduced type variables.-existentialContextError :: Name -> Q a-existentialContextError conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must be truly polymorphic in the last argument(s) of the data type"- $ ""---- | The data type mentions one of the n eta-reduced type variables in a place other--- than the last nth positions of a data type in a constructor's field.-outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b-outOfPlaceTyVarError cRep conName = fail- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must only use its last "- . shows n- . showString " type variable(s) within the last "- . shows n- . showString " argument(s) of a data type"- $ ""- where- n :: Int- n = arity cRep--enumerationError :: String -> Q a-enumerationError = fail . enumerationErrorStr--enumerationOrProductError :: String -> Q a-enumerationOrProductError nb = fail $ unlines- [ enumerationErrorStr nb- , "\tor a product type (precisely one constructor)"- ]--enumerationErrorStr :: String -> String-enumerationErrorStr nb =- '\'':nb ++ "’ must be an enumeration type"- ++ " (one or more nullary, non-GADT constructors)"------------------------------------------------------------------------------------ Assorted utilities------------------------------------------------------------------------------------ | A mapping of type variable Names to their auxiliary function Names.-type TyVarMap a = Map Name (OneOrTwoNames a)-type TyVarMap1 = TyVarMap One-type TyVarMap2 = TyVarMap Two--data OneOrTwoNames a where- OneName :: Name -> OneOrTwoNames One- TwoNames :: Name -> Name -> OneOrTwoNames Two--data One-data Two--interleave :: [a] -> [a] -> [a]-interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s-interleave _ _ = []--#if MIN_VERSION_ghc_prim(0,3,1)-isTrue# :: Int# -> Bool-isTrue# x = tagToEnum# x-#else-isTrue# :: Bool -> Bool-isTrue# x = x-#endif-{-# INLINE isTrue# #-}---- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed)---- | 'filterByList' takes a list of Bools and a list of some elements and--- filters out these elements for which the corresponding value in the list of--- Bools is False. This function does not check whether the lists have equal--- length.-filterByList :: [Bool] -> [a] -> [a]-filterByList (True:bs) (x:xs) = x : filterByList bs xs-filterByList (False:bs) (_:xs) = filterByList bs xs-filterByList _ _ = []---- | 'filterByLists' takes a list of Bools and two lists as input, and--- outputs a new list consisting of elements from the last two input lists. For--- each Bool in the list, if it is 'True', then it takes an element from the--- former list. If it is 'False', it takes an element from the latter list.--- The elements taken correspond to the index of the Bool in its list.--- For example:------ @--- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"--- @------ This function does not check whether the lists have equal length.-filterByLists :: [Bool] -> [a] -> [a] -> [a]-filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys-filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys-filterByLists _ _ _ = []---- | 'partitionByList' takes a list of Bools and a list of some elements and--- partitions the list according to the list of Bools. Elements corresponding--- to 'True' go to the left; elements corresponding to 'False' go to the right.--- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@--- This function does not check whether the lists have equal--- length.-partitionByList :: [Bool] -> [a] -> ([a], [a])-partitionByList = go [] []- where- go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs- go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs- go trues falses _ _ = (reverse trues, reverse falses)--integerE :: Int -> Q Exp-integerE = litE . integerL . fromIntegral---- | Returns True if a Type has kind *.-hasKindStar :: Type -> Bool-hasKindStar VarT{} = True-#if MIN_VERSION_template_haskell(2,8,0)-hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif-hasKindStar _ = False---- Returns True is a kind is equal to *, or if it is a kind variable.-isStarOrVar :: Kind -> Bool-#if MIN_VERSION_template_haskell(2,8,0)-isStarOrVar StarT = True-isStarOrVar VarT{} = True-#else-isStarOrVar StarK = True-#endif-isStarOrVar _ = False---- | @hasKindVarChain n kind@ Checks if @kind@ is of the form--- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or--- kind variables.-hasKindVarChain :: Int -> Type -> Maybe [Name]-hasKindVarChain kindArrows t =- let uk = uncurryKind (tyKind t)- in if (length uk - 1 == kindArrows) && all isStarOrVar uk- then Just (freeVariables uk)- else Nothing---- | If a Type is a SigT, returns its kind signature. Otherwise, return *.-tyKind :: Type -> Kind-tyKind (SigT _ k) = k-tyKind _ = starK--zipWithAndUnzipM :: Monad m- => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])-zipWithAndUnzipM f (x:xs) (y:ys) = do- (c, d) <- f x y- (cs, ds) <- zipWithAndUnzipM f xs ys- return (c:cs, d:ds)-zipWithAndUnzipM _ _ _ = return ([], [])-{-# INLINE zipWithAndUnzipM #-}--zipWith3AndUnzipM :: Monad m- => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c]- -> m ([d], [e])-zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do- (d, e) <- f x y z- (ds, es) <- zipWith3AndUnzipM f xs ys zs- return (d:ds, e:es)-zipWith3AndUnzipM _ _ _ _ = return ([], [])-{-# INLINE zipWith3AndUnzipM #-}--thd3 :: (a, b, c) -> c-thd3 (_, _, c) = c--unsnoc :: [a] -> Maybe ([a], a)-unsnoc [] = Nothing-unsnoc (x:xs) = case unsnoc xs of- Nothing -> Just ([], x)- Just (a,b) -> Just (x:a, b)--isNullaryCon :: ConstructorInfo -> Bool-isNullaryCon (ConstructorInfo { constructorFields = tys }) = null tys---- | Returns the number of fields for the constructor.-conArity :: ConstructorInfo -> Int-conArity (ConstructorInfo { constructorFields = tys }) = length tys---- | Returns 'True' if it's a datatype with exactly one, non-existential constructor.-isProductType :: [ConstructorInfo] -> Bool-isProductType [con] = null (constructorVars con)-isProductType _ = False---- | Returns 'True' if it's a datatype with one or more nullary, non-GADT--- constructors.-isEnumerationType :: [ConstructorInfo] -> Bool-isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons-isEnumerationType _ = False---- | Returns 'False' if we're dealing with existential quantification or GADTs.-isVanillaCon :: ConstructorInfo -> Bool-isVanillaCon (ConstructorInfo { constructorContext = ctxt, constructorVars = vars }) =- null ctxt && null vars---- | Generate a list of fresh names with a common prefix, and numbered suffixes.-newNameList :: String -> Int -> Q [Name]-newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]---- | Extracts the kind from a TyVarBndr.-tvbKind :: TyVarBndr_ flag -> Kind-tvbKind = elimTV (\_ -> starK) (\_ k -> k)---- | Convert a TyVarBndr to a Type.-tvbToType :: TyVarBndr_ flag -> Type-tvbToType = elimTV VarT (\n k -> SigT (VarT n) k)---- | Applies a typeclass constraint to a type.-applyClass :: Name -> Name -> Pred-#if MIN_VERSION_template_haskell(2,10,0)-applyClass con t = AppT (ConT con) (VarT t)-#else-applyClass con t = ClassP con [VarT t]-#endif--createKindChain :: Int -> Kind-createKindChain = go starK- where- go :: Kind -> Int -> Kind- go k !0 = k-#if MIN_VERSION_template_haskell(2,8,0)- go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)-#else- go k !n = go (ArrowK StarK k) (n - 1)-#endif---- | Checks to see if the last types in a data family instance can be safely eta---- reduced (i.e., dropped), given the other types. This checks for three conditions:------ (1) All of the dropped types are type variables--- (2) All of the dropped types are distinct--- (3) None of the remaining types mention any of the dropped types-canEtaReduce :: [Type] -> [Type] -> Bool-canEtaReduce remaining dropped =- all isTyVar dropped- && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type- -- didn't have an Ord instance until template-haskell-2.10.0.0- && not (any (`mentionsName` droppedNames) remaining)- where- droppedNames :: [Name]- droppedNames = map varTToName dropped---- | Extract the Name from a type constructor. If the argument Type is not a--- type variable, throw an error.-conTToName :: Type -> Name-conTToName (ConT n) = n-conTToName (SigT t _) = conTToName t-conTToName _ = error "Not a type constructor!"---- | Extract Just the Name from a type variable. If the argument Type is not a--- type variable, return Nothing.-varTToName_maybe :: Type -> Maybe Name-varTToName_maybe (VarT n) = Just n-varTToName_maybe (SigT t _) = varTToName_maybe t-varTToName_maybe _ = Nothing---- | Extract the Name from a type variable. If the argument Type is not a--- type variable, throw an error.-varTToName :: Type -> Name-varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe---- | Peel off a kind signature from a Type (if it has one).-unSigT :: Type -> Type-unSigT (SigT t _) = t-unSigT t = t---- | Is the given type a variable?-isTyVar :: Type -> Bool-isTyVar (VarT _) = True-isTyVar (SigT t _) = isTyVar t-isTyVar _ = False---- | Detect if a Name in a list of provided Names occurs as an argument to some--- type family. This makes an effort to exclude /oversaturated/ arguments to--- type families. For instance, if one declared the following type family:------ @--- type family F a :: Type -> Type--- @------ Then in the type @F a b@, we would consider @a@ to be an argument to @F@,--- but not @b@.-isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool-isInTypeFamilyApp names tyFun tyArgs =- case tyFun of- ConT tcName -> go tcName- _ -> return False- where- go :: Name -> Q Bool- go tcName = do- info <- reify tcName- case info of-#if MIN_VERSION_template_haskell(2,11,0)- FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _- -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ bndrs _) _- -> withinFirstArgs bndrs-#else- TyConI (FamilyD TypeFam _ bndrs _)- -> withinFirstArgs bndrs-#endif--#if MIN_VERSION_template_haskell(2,11,0)- FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _- -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,9,0)- FamilyI (ClosedTypeFamilyD _ bndrs _ _) _- -> withinFirstArgs bndrs-#endif-- _ -> return False- where- withinFirstArgs :: [a] -> Q Bool- withinFirstArgs bndrs =- let firstArgs = take (length bndrs) tyArgs- argFVs = freeVariables firstArgs- in return $ any (`elem` argFVs) names---- | Are all of the items in a list (which have an ordering) distinct?------ This uses Set (as opposed to nub) for better asymptotic time complexity.-allDistinct :: Ord a => [a] -> Bool-allDistinct = allDistinct' Set.empty- where- allDistinct' :: Ord a => Set a -> [a] -> Bool- allDistinct' uniqs (x:xs)- | x `Set.member` uniqs = False- | otherwise = allDistinct' (Set.insert x uniqs) xs- allDistinct' _ _ = True---- | Does the given type mention any of the Names in the list?-mentionsName :: Type -> [Name] -> Bool-mentionsName = go- where- go :: Type -> [Name] -> Bool- go (AppT t1 t2) names = go t1 names || go t2 names- go (SigT t _k) names = go t names-#if MIN_VERSION_template_haskell(2,8,0)- || go _k names-#endif- go (VarT n) names = n `elem` names- go _ _ = False---- | Does an instance predicate mention any of the Names in the list?-predMentionsName :: Pred -> [Name] -> Bool-#if MIN_VERSION_template_haskell(2,10,0)-predMentionsName = mentionsName-#else-predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys-predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names-#endif---- | Construct a type via curried application.-applyTy :: Type -> [Type] -> Type-applyTy = 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- let tvbs = avoidTypeInType $ freeVariablesWellScoped [ty']- lam1E (conP iHashDataName [varP iHash]) $- varE tagToEnumHashValName `appE` varE iHash- `sigE` return (ForallT (changeTVFlags SpecifiedSpec tvbs) [] 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.- where- -- Somewhat annoyingly, it's possible to generate code that requires- -- TypeInType (on old versions of GHC) for data types which didn't require- -- TypeInType to define. To avoid users having to turn on more language- -- extensions than is necessary, we filter out all kind variable binders.- -- Fortunately, old versions of GHC are quite alright with implicitly- -- quantifying kind variables, even in the type of a SigE.- --- -- This is rather tiresome, and while writing this function, I debated- -- whether to just forget about this nonsense and require users to- -- enable TypeInType to use the generated code. Alas, that would entail- -- a breaking change, so I decided against it at the time. If we ever make- -- some breaking change in the future, however, this would be at the top- -- of the list of things that I'd rip out.- avoidTypeInType :: [TyVarBndrUnit] -> [TyVarBndrUnit]-#if __GLASGOW_HASKELL__ >= 806- avoidTypeInType = id-#else- avoidTypeInType = go . map attachFreeKindVars- where- attachFreeKindVars :: TyVarBndrUnit -> (TyVarBndrUnit, [Name])- attachFreeKindVars tvb = (tvb, freeVariables (tvKind tvb))-- go :: [(TyVarBndrUnit, [Name])] -> [TyVarBndrUnit]- go [] = []- go ((tvb, _):tvbsAndFVs)- | any (\(_, kindVars) -> tvName tvb `elem` kindVars) tvbsAndFVs- = tvbs'- | otherwise- = tvb:tvbs'- where- tvbs' = go tvbsAndFVs-#endif--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- ]--removeClassApp :: Type -> Type-removeClassApp (AppT _ t2) = t2-removeClassApp t = t---- This is an ugly, but unfortunately necessary hack on older versions of GHC which--- don't have a properly working newName. On those GHCs, even running newName on a--- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by--- appending an uncommonly used string to the end of the name. This isn't foolproof,--- since a user could freshen a variable named x and still have another x_' variable in--- scope, but at least it's unlikely.-freshen :: Name -> Q Name-freshen n = newName (nameBase n ++ "_'")--freshenType :: Type -> Q Type-freshenType t =- do let xs = [(n, VarT `fmap` freshen n) | n <- freeVariables t]- subst <- T.sequence (Map.fromList xs)- return (applySubstitution subst t)--enumFromToExpr :: Q Exp -> Q Exp -> Q Exp-enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t--primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp-primOpAppExpr e1 op e2 = varE isTrueHashValName `appE`- infixApp e1 (varE op) e2---- | Checks if a 'Name' represents a tuple type constructor (other than '()')-isNonUnitTuple :: Name -> Bool-isNonUnitTuple = isNonUnitTupleString . nameBase---- | Checks if a 'String' represents a tuple (other than '()')-isNonUnitTupleString :: String -> Bool-isNonUnitTupleString ('(':',':_) = True-isNonUnitTupleString _ = False---- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does--- it begin with a colon?).-isInfixDataCon :: String -> Bool-isInfixDataCon (':':_) = True-isInfixDataCon _ = False--isSym :: String -> Bool-isSym "" = False-isSym (c : _) = startsVarSym c || startsConSym c--#if !defined(MIN_VERSION_ghc_boot_th)-startsVarSym, startsConSym :: Char -> Bool-startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids-startsConSym c = c == ':' -- Infix data constructors--startsVarSymASCII :: Char -> Bool-startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"-#endif--ghc7'8OrLater :: Bool-#if __GLASGOW_HASKELL__ >= 708-ghc7'8OrLater = True-#else-ghc7'8OrLater = False-#endif------------------------------------------------------------------------------------ Manually quoted names------------------------------------------------------------------------------------ By manually generating these names we avoid needing to use the--- TemplateHaskell language extension when compiling the deriving-compat library.--- This allows the library to be used in stage1 cross-compilers.--derivingCompatPackageKey :: String-#ifdef CURRENT_PACKAGE_KEY-derivingCompatPackageKey = CURRENT_PACKAGE_KEY-#else-derivingCompatPackageKey = "deriving-compat-" ++ showVersion version-#endif--gHC_IX :: String-#if MIN_VERSION_base(4,14,0)-gHC_IX = "GHC.Ix"-#else-gHC_IX = "GHC.Arr"-#endif--mkDerivingCompatName_v :: String -> Name-mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal"--mkDerivingCompatName_tc :: String -> Name-mkDerivingCompatName_tc = mkNameG_tc derivingCompatPackageKey "Data.Deriving.Internal"--isTrueHashValName :: Name-isTrueHashValName = mkDerivingCompatName_v "isTrue#"--fmapConstValName :: Name-fmapConstValName = mkDerivingCompatName_v "fmapConst"--replaceConstValName :: Name-replaceConstValName = mkDerivingCompatName_v "replaceConst"--foldrConstValName :: Name-foldrConstValName = mkDerivingCompatName_v "foldrConst"--foldMapConstValName :: Name-foldMapConstValName = mkDerivingCompatName_v "foldMapConst"--nullConstValName :: Name-nullConstValName = mkDerivingCompatName_v "nullConst"--traverseConstValName :: Name-traverseConstValName = mkDerivingCompatName_v "traverseConst"--eqConstValName :: Name-eqConstValName = mkDerivingCompatName_v "eqConst"--eq1ConstValName :: Name-eq1ConstValName = mkDerivingCompatName_v "eq1Const"--liftEqConstValName :: Name-liftEqConstValName = mkDerivingCompatName_v "liftEqConst"--liftEq2ConstValName :: Name-liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const"--compareConstValName :: Name-compareConstValName = mkDerivingCompatName_v "compareConst"--ltConstValName :: Name-ltConstValName = mkDerivingCompatName_v "ltConst"--compare1ConstValName :: Name-compare1ConstValName = mkDerivingCompatName_v "compare1Const"--liftCompareConstValName :: Name-liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst"--liftCompare2ConstValName :: Name-liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const"--readsPrecConstValName :: Name-readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst"--readPrecConstValName :: Name-readPrecConstValName = mkDerivingCompatName_v "readPrecConst"--readsPrec1ConstValName :: Name-readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const"--liftReadsPrecConstValName :: Name-liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst"--liftReadPrecConstValName :: Name-liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst"--liftReadsPrec2ConstValName :: Name-liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const"--liftReadPrec2ConstValName :: Name-liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const"--showsPrecConstValName :: Name-showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst"--showsPrec1ConstValName :: Name-showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const"--liftShowsPrecConstValName :: Name-liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst"--liftShowsPrec2ConstValName :: Name-liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const"--viaTypeName :: Name-viaTypeName = mkDerivingCompatName_tc "Via"--cHashDataName :: Name-cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#"--dHashDataName :: Name-dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#"--fHashDataName :: Name-fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#"--identDataName :: Name-identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident"--iHashDataName :: Name-iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#"--puncDataName :: Name-puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc"--symbolDataName :: Name-symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol"--wrapMonadDataName :: Name-wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad"--addrHashTypeName :: Name-addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#"--boundedTypeName :: Name-boundedTypeName = mkNameG_tc "base" "GHC.Enum" "Bounded"--charHashTypeName :: Name-charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#"--doubleHashTypeName :: Name-doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#"--enumTypeName :: Name-enumTypeName = mkNameG_tc "base" "GHC.Enum" "Enum"--floatHashTypeName :: Name-floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#"--foldableTypeName :: Name-foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable"--functorTypeName :: Name-functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"--intTypeName :: Name-intTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Int"--intHashTypeName :: Name-intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#"--ixTypeName :: Name-ixTypeName = mkNameG_tc "base" gHC_IX "Ix"--readTypeName :: Name-readTypeName = mkNameG_tc "base" "GHC.Read" "Read"--showTypeName :: Name-showTypeName = mkNameG_tc "base" "GHC.Show" "Show"--traversableTypeName :: Name-traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"--wordHashTypeName :: Name-wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#"--altValName :: Name-altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++"--appendValName :: Name-appendValName = mkNameG_v "base" "GHC.Base" "++"--chooseValName :: Name-chooseValName = mkNameG_v "base" "GHC.Read" "choose"--coerceValName :: Name-coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"--composeValName :: Name-composeValName = mkNameG_v "base" "GHC.Base" "."--constValName :: Name-constValName = mkNameG_v "base" "GHC.Base" "const"--enumFromValName :: Name-enumFromValName = mkNameG_v "base" "GHC.Enum" "enumFrom"--enumFromThenValName :: Name-enumFromThenValName = mkNameG_v "base" "GHC.Enum" "enumFromThen"--enumFromThenToValName :: Name-enumFromThenToValName = mkNameG_v "base" "GHC.Enum" "enumFromThenTo"--enumFromToValName :: Name-enumFromToValName = mkNameG_v "base" "GHC.Enum" "enumFromTo"--eqAddrHashValName :: Name-eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#"--eqCharHashValName :: Name-eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#"--eqDoubleHashValName :: Name-eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##"--eqFloatHashValName :: Name-eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#"--eqIntHashValName :: Name-eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#"--eqWordHashValName :: Name-eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#"--errorValName :: Name-errorValName = mkNameG_v "base" "GHC.Err" "error"--flipValName :: Name-flipValName = mkNameG_v "base" "GHC.Base" "flip"--fmapValName :: Name-fmapValName = mkNameG_v "base" "GHC.Base" "fmap"--foldrValName :: Name-foldrValName = mkNameG_v "base" "Data.Foldable" "foldr"--foldMapValName :: Name-foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap"--fromEnumValName :: Name-fromEnumValName = mkNameG_v "base" "GHC.Enum" "fromEnum"--geAddrHashValName :: Name-geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#"--geCharHashValName :: Name-geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#"--geDoubleHashValName :: Name-geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##"--geFloatHashValName :: Name-geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#"--geIntHashValName :: Name-geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#"--getTagValName :: Name-getTagValName = mkNameG_v "base" "GHC.Base" "getTag"--geWordHashValName :: Name-geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#"--gtAddrHashValName :: Name-gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#"--gtCharHashValName :: Name-gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#"--gtDoubleHashValName :: Name-gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##"--gtFloatHashValName :: Name-gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#"--gtIntHashValName :: Name-gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#"--gtWordHashValName :: Name-gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#"--idValName :: Name-idValName = mkNameG_v "base" "GHC.Base" "id"--indexValName :: Name-indexValName = mkNameG_v "base" gHC_IX "index"--inRangeValName :: Name-inRangeValName = mkNameG_v "base" gHC_IX "inRange"--leAddrHashValName :: Name-leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#"--leCharHashValName :: Name-leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#"--leDoubleHashValName :: Name-leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##"--leFloatHashValName :: Name-leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#"--leIntHashValName :: Name-leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#"--leWordHashValName :: Name-leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#"--liftReadListPrecDefaultValName :: Name-liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault"--liftReadListPrec2DefaultValName :: Name-liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default"--liftReadListPrecValName :: Name-liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec"--liftReadListPrec2ValName :: Name-liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2"--liftReadPrecValName :: Name-liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec"--liftReadPrec2ValName :: Name-liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2"--listValName :: Name-listValName = mkNameG_v "base" "GHC.Read" "list"--ltAddrHashValName :: Name-ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#"--ltCharHashValName :: Name-ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#"--ltDoubleHashValName :: Name-ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##"--ltFloatHashValName :: Name-ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#"--ltIntHashValName :: Name-ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#"--ltWordHashValName :: Name-ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#"--minBoundValName :: Name-minBoundValName = mkNameG_v "base" "GHC.Enum" "minBound"--mapValName :: Name-mapValName = mkNameG_v "base" "GHC.Base" "map"--maxBoundValName :: Name-maxBoundValName = mkNameG_v "base" "GHC.Enum" "maxBound"--minusIntHashValName :: Name-minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#"--parenValName :: Name-parenValName = mkNameG_v "base" "GHC.Read" "paren"--parensValName :: Name-parensValName = mkNameG_v "base" "GHC.Read" "parens"--pfailValName :: Name-pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail"--plusValName :: Name-plusValName = mkNameG_v "base" "GHC.Num" "+"--precValName :: Name-precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec"--predValName :: Name-predValName = mkNameG_v "base" "GHC.Enum" "pred"--rangeSizeValName :: Name-rangeSizeValName = mkNameG_v "base" gHC_IX "rangeSize"--rangeValName :: Name-rangeValName = mkNameG_v "base" gHC_IX "range"--readFieldHash :: String -> ReadPrec a -> ReadPrec a-readFieldHash fieldName readVal = do- expectP (L.Ident fieldName)- expectP (L.Symbol "#")- expectP (L.Punc "=")- readVal-{-# NOINLINE readFieldHash #-}--readFieldHashValName :: Name-readFieldHashValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readFieldHash"--readListValName :: Name-readListValName = mkNameG_v "base" "GHC.Read" "readList"--readListPrecDefaultValName :: Name-readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault"--readListPrecValName :: Name-readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec"--readPrec_to_SValName :: Name-readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S"--readPrecValName :: Name-readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec"--readS_to_PrecValName :: Name-readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec"--readsPrecValName :: Name-readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec"--replaceValName :: Name-replaceValName = mkNameG_v "base" "GHC.Base" "<$"--resetValName :: Name-resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset"--returnValName :: Name-returnValName = mkNameG_v "base" "GHC.Base" "return"--seqValName :: Name-seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"--showCharValName :: Name-showCharValName = mkNameG_v "base" "GHC.Show" "showChar"--showListValName :: Name-showListValName = mkNameG_v "base" "GHC.Show" "showList"--showListWithValName :: Name-showListWithValName = mkNameG_v "base" "Text.Show" "showListWith"--showParenValName :: Name-showParenValName = mkNameG_v "base" "GHC.Show" "showParen"--showsPrecValName :: Name-showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec"--showSpaceValName :: Name-showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace"--showStringValName :: Name-showStringValName = mkNameG_v "base" "GHC.Show" "showString"--stepValName :: Name-stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step"--succValName :: Name-succValName = mkNameG_v "base" "GHC.Enum" "succ"--tagToEnumHashValName :: Name-tagToEnumHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#"--timesValName :: Name-timesValName = mkNameG_v "base" "GHC.Num" "*"--toEnumValName :: Name-toEnumValName = mkNameG_v "base" "GHC.Enum" "toEnum"--traverseValName :: Name-traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"--unsafeIndexValName :: Name-unsafeIndexValName = mkNameG_v "base" gHC_IX "unsafeIndex"--unsafeRangeSizeValName :: Name-unsafeRangeSizeValName = mkNameG_v "base" gHC_IX "unsafeRangeSize"--unwrapMonadValName :: Name-unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"--#if MIN_VERSION_base(4,4,0)-boolTypeName :: Name-boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool"--falseDataName :: Name-falseDataName = mkNameG_d "ghc-prim" "GHC.Types" "False"--trueDataName :: Name-trueDataName = mkNameG_d "ghc-prim" "GHC.Types" "True"-#else-boolTypeName :: Name-boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool"--falseDataName :: Name-falseDataName = mkNameG_d "ghc-prim" "GHC.Bool" "False"--trueDataName :: Name-trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True"-#endif--#if MIN_VERSION_base(4,5,0)-eqDataName :: Name-eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ"--gtDataName :: Name-gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT"--ltDataName :: Name-ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT"--eqTypeName :: Name-eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq"--ordTypeName :: Name-ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord"--andValName :: Name-andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&"--compareValName :: Name-compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare"--eqValName :: Name-eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "=="--geValName :: Name-geValName = mkNameG_v "ghc-prim" "GHC.Classes" ">="--gtValName :: Name-gtValName = mkNameG_v "ghc-prim" "GHC.Classes" ">"--leValName :: Name-leValName = mkNameG_v "ghc-prim" "GHC.Classes" "<="--ltValName :: Name-ltValName = mkNameG_v "ghc-prim" "GHC.Classes" "<"--notValName :: Name-notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not"-#else-eqDataName :: Name-eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ"--gtDataName :: Name-gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT"--ltDataName :: Name-ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT"--eqTypeName :: Name-eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq"--ordTypeName :: Name-ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord"--andValName :: Name-andValName = mkNameG_v "base" "GHC.Classes" "&&"--compareValName :: Name-compareValName = mkNameG_v "base" "GHC.Classes" "compare"--eqValName :: Name-eqValName = mkNameG_v "base" "GHC.Classes" "=="--geValName :: Name-geValName = mkNameG_v "base" "GHC.Classes" ">="--gtValName :: Name-gtValName = mkNameG_v "base" "GHC.Classes" ">"--leValName :: Name-leValName = mkNameG_v "base" "GHC.Classes" "<="--ltValName :: Name-ltValName = mkNameG_v "base" "GHC.Classes" "<"--notValName :: Name-notValName = mkNameG_v "base" "GHC.Classes" "not"-#endif--#if MIN_VERSION_base(4,6,0)-wHashDataName :: Name-wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#"-#else-wHashDataName :: Name-wHashDataName = mkNameG_d "base" "GHC.Word" "W#"-#endif--#if MIN_VERSION_base(4,7,0)-expectPValName :: Name-expectPValName = mkNameG_v "base" "GHC.Read" "expectP"-#else-expectP :: Lexeme -> ReadPrec ()-expectP lexeme = do- thing <- lexP- if thing == lexeme then return () else pfail--expectPValName :: Name-expectPValName = mkDerivingCompatName_v "expectP"-#endif--#if MIN_VERSION_base(4,8,0)-allValName :: Name-allValName = mkNameG_v "base" "Data.Foldable" "all"--apValName :: Name-apValName = mkNameG_v "base" "GHC.Base" "<*>"--pureValName :: Name-pureValName = mkNameG_v "base" "GHC.Base" "pure"--liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2"--mappendValName :: Name-mappendValName = mkNameG_v "base" "GHC.Base" "mappend"--memptyValName :: Name-memptyValName = mkNameG_v "base" "GHC.Base" "mempty"--nullValName :: Name-nullValName = mkNameG_v "base" "Data.Foldable" "null"-#else-allValName :: Name-allValName = mkNameG_v "base" "GHC.List" "all"--apValName :: Name-apValName = mkNameG_v "base" "Control.Applicative" "<*>"--pureValName :: Name-pureValName = mkNameG_v "base" "Control.Applicative" "pure"--liftA2ValName :: Name-liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2"--mappendValName :: Name-mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"--memptyValName :: Name-memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"--nullValName :: Name-nullValName = mkNameG_v "base" "GHC.List" "null"-#endif--#if MIN_VERSION_base(4,9,0)-eq1TypeName :: Name-eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1"--eq2TypeName :: Name-eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2"--liftEqValName :: Name-liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq"--liftEq2ValName :: Name-liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2"--ord1TypeName :: Name-ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1"--ord2TypeName :: Name-ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2"--liftCompareValName :: Name-liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare"--liftCompare2ValName :: Name-liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2"--read1TypeName :: Name-read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1"--read2TypeName :: Name-read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2"--liftReadsPrecValName :: Name-liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec"--liftReadListValName :: Name-liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList"--liftReadsPrec2ValName :: Name-liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2"--liftReadList2ValName :: Name-liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2"--show1TypeName :: Name-show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1"--show2TypeName :: Name-show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2"--liftShowListValName :: Name-liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList"--liftShowsPrecValName :: Name-liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec"--liftShowList2ValName :: Name-liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2"--liftShowsPrec2ValName :: Name-liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2"-#else--- If Data.Functor.Classes isn't located in base, then sadly we can't refer to--- Names from that module without using -XTemplateHaskell.-# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)-eq1TypeName :: Name-eq1TypeName = ''Eq1--eq2TypeName :: Name-eq2TypeName = ''Eq2--liftEqValName :: Name-liftEqValName = 'liftEq--liftEq2ValName :: Name-liftEq2ValName = 'liftEq2--ord1TypeName :: Name-ord1TypeName = ''Ord1--ord2TypeName :: Name-ord2TypeName = ''Ord2--liftCompareValName :: Name-liftCompareValName = 'liftCompare--liftCompare2ValName :: Name-liftCompare2ValName = 'liftCompare2--read1TypeName :: Name-read1TypeName = ''Read1--read2TypeName :: Name-read2TypeName = ''Read2--liftReadsPrecValName :: Name-liftReadsPrecValName = 'liftReadsPrec--liftReadListValName :: Name-liftReadListValName = 'liftReadList--liftReadsPrec2ValName :: Name-liftReadsPrec2ValName = 'liftReadsPrec2--liftReadList2ValName :: Name-liftReadList2ValName = 'liftReadList2--show1TypeName :: Name-show1TypeName = ''Show1--show2TypeName :: Name-show2TypeName = ''Show2--liftShowListValName :: Name-liftShowListValName = 'liftShowList--liftShowsPrecValName :: Name-liftShowsPrecValName = 'liftShowsPrec--liftShowList2ValName :: Name-liftShowList2ValName = 'liftShowList2--liftShowsPrec2ValName :: Name-liftShowsPrec2ValName = 'liftShowsPrec2-# else-eq1TypeName :: Name-eq1TypeName = ''Eq1--eq1ValName :: Name-eq1ValName = 'eq1--ord1TypeName :: Name-ord1TypeName = ''Ord1--compare1ValName :: Name-compare1ValName = 'compare1--read1TypeName :: Name-read1TypeName = ''Read1--readsPrec1ValName :: Name-readsPrec1ValName = 'readsPrec1--show1TypeName :: Name-show1TypeName = ''Show1--showsPrec1ValName :: Name-showsPrec1ValName = 'showsPrec1--newtype Apply f a = Apply { unApply :: f a }--instance (Eq1 f, Eq a) => Eq (Apply f a) where- Apply x == Apply y = eq1 x y--instance (Ord1 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = compare1 x y--instance (Read1 f, Read a) => Read (Apply f a) where- readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s]--instance (Show1 f, Show a) => Show (Apply f a) where- showsPrec p (Apply x) = showsPrec1 p x--makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp-makeFmapApplyNeg = makeFmapApply False--makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp-makeFmapApplyPos = makeFmapApply True--makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp-makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name-makeFmapApply pos cRep conName t name = do- let tyCon :: Type- tyArgs :: [Type]- (tyCon, tyArgs) = unapplyTy t-- numLastArgs :: Int- numLastArgs = min (arity cRep) (length tyArgs)-- lhsArgs, rhsArgs :: [Type]- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- inspectTy :: Type -> Q Exp- inspectTy (SigT ty _) = inspectTy ty- inspectTy (VarT a) | a == name = varE idValName- inspectTy beta = varE fmapValName `appE`- infixApp (if pos then makeFmapApply pos cRep conName beta name- else conE applyDataName)- (varE composeValName)- (if pos then varE unApplyValName- else makeFmapApply pos cRep conName beta name)-- itf <- isInTypeFamilyApp [name] tyCon tyArgs- if any (`mentionsName` [name]) lhsArgs || itf- then outOfPlaceTyVarError cRep conName- else inspectTy (head rhsArgs)--applyDataName :: Name-applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply"--unApplyValName :: Name-unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply"-# endif-#endif--#if MIN_VERSION_base(4,10,0)-showCommaSpaceValName :: Name-showCommaSpaceValName = mkNameG_v "base" "GHC.Show" "showCommaSpace"-#else-showCommaSpace :: ShowS-showCommaSpace = showString ", "--showCommaSpaceValName :: Name-showCommaSpaceValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "showCommaSpace"-#endif--#if MIN_VERSION_base(4,11,0)-appEndoValName :: Name-appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo"--dualDataName :: Name-dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual"--endoDataName :: Name-endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo"--getDualValName :: Name-getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual"--readFieldValName :: Name-readFieldValName = mkNameG_v "base" "GHC.Read" "readField"--readSymFieldValName :: Name-readSymFieldValName = mkNameG_v "base" "GHC.Read" "readSymField"-#else-appEndoValName :: Name-appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"--dualDataName :: Name-dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"--endoDataName :: Name-endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"--getDualValName :: Name-getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"--readField :: String -> ReadPrec a -> ReadPrec a-readField fieldName readVal = do- expectP (L.Ident fieldName)- expectP (L.Punc "=")- readVal-{-# NOINLINE readField #-}--readFieldValName :: Name-readFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readField"--readSymField :: String -> ReadPrec a -> ReadPrec a-readSymField fieldName readVal = do- expectP (L.Punc "(")- expectP (L.Symbol fieldName)- expectP (L.Punc ")")- expectP (L.Punc "=")- readVal-{-# NOINLINE readSymField #-}--readSymFieldValName :: Name-readSymFieldValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "readSymField"-#endif--#if MIN_VERSION_base(4,13,0)-eqInt8HashValName :: Name-eqInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt8#"--eqInt16HashValName :: Name-eqInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqInt16#"--eqWord8HashValName :: Name-eqWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord8#"--eqWord16HashValName :: Name-eqWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord16#"--extendInt8HashValName :: Name-extendInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendInt8#"--extendInt16HashValName :: Name-extendInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendInt16#"--extendWord8HashValName :: Name-extendWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendWord8#"--extendWord16HashValName :: Name-extendWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "extendWord16#"--geInt8HashValName :: Name-geInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt8#"--geInt16HashValName :: Name-geInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geInt16#"--geWord8HashValName :: Name-geWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord8#"--geWord16HashValName :: Name-geWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord16#"--gtInt8HashValName :: Name-gtInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt8#"--gtInt16HashValName :: Name-gtInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtInt16#"--gtWord8HashValName :: Name-gtWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord8#"--gtWord16HashValName :: Name-gtWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord16#"--int8HashTypeName :: Name-int8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int8#"--int16HashTypeName :: Name-int16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int16#"--leInt8HashValName :: Name-leInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt8#"--leInt16HashValName :: Name-leInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leInt16#"--leWord8HashValName :: Name-leWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord8#"--leWord16HashValName :: Name-leWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord16#"--ltInt8HashValName :: Name-ltInt8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt8#"--ltInt16HashValName :: Name-ltInt16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltInt16#"--ltWord8HashValName :: Name-ltWord8HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord8#"--ltWord16HashValName :: Name-ltWord16HashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord16#"--word8HashTypeName :: Name-word8HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word8#"--word16HashTypeName :: Name-word16HashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word16#"+{-# LANGUAGE TemplateHaskellQuotes #-}++{-|+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(..)+ , Eq2(..), Ord2(..), Read2(..), Show2(..)+#if MIN_VERSION_base(4,10,0)+ , liftReadListPrecDefault, liftReadListPrec2Default+#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.Lexeme (startsConSym, startsVarSym)+import GHC.Read (choose, expectP, 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,10,0)+import GHC.Show (showCommaSpace)+#endif++#if MIN_VERSION_base(4,11,0)+import GHC.Read (readField, readSymField)+#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+applySubstitutionKind = applySubstitution++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+ SigT _ (VarT k) -> IsKindVar k+ _ -> 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+ Datatype.TypeData -> typeDataError tyConName++ 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 (`mentionsName` 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 (`mentionsName` 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 _ _ = []++-- 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+hasKindStar (SigT _ StarT) = True+hasKindStar _ = False++-- Returns True is a kind is equal to *, or if it is a kind variable.+isStarOrVar :: Kind -> Bool+isStarOrVar StarT = True+isStarOrVar VarT{} = True+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+applyClass con t = AppT (ConT con) (VarT t)++createKindChain :: Int -> Kind+createKindChain = go starK+ where+ go :: Kind -> Int -> Kind+ go k !0 = k+ go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)++-- | 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+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> withinFirstArgs bndrs+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> withinFirstArgs bndrs+ _ -> 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 || go k names+ go (VarT n) names = n `elem` names+ go _ _ = False++-- | 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+ 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+ 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]+uncurryKind = snd . uncurryTy++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++-------------------------------------------------------------------------------+-- 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#++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++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++coerceValName :: Name+coerceValName = 'coerce++#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
src/Data/Deriving/Via/Internal.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TupleSections #-} {-| Module: Data.Deriving.Via.Internal@@ -23,10 +25,13 @@ 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@@ -46,12 +51,11 @@ deriveGND :: Q Type -> Q [Dec] deriveGND qty = do ty <- qty- let (instanceTvbs, instanceCxt, instanceTy) = decomposeType ty+ let (_instanceTvbs, instanceCxt, instanceTy) = decomposeType ty instanceTy' <- (resolveTypeSynonyms <=< resolveInfixT) instanceTy decs <- deriveViaDecs instanceTy' Nothing- let instanceHeader = ForallT instanceTvbs instanceCxt instanceTy- (:[]) `fmap` instanceD (return [])- (return instanceHeader)+ (:[]) `fmap` instanceD (return instanceCxt)+ (return instanceTy) (map return decs) {- | Generates an instance for a type class by emulating the behavior of the@@ -71,7 +75,7 @@ deriveVia :: Q Type -> Q [Dec] deriveVia qty = do ty <- qty- let (instanceTvbs, instanceCxt, viaApp) = decomposeType ty+ let (_instanceTvbs, instanceCxt, viaApp) = decomposeType ty viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp (instanceTy, viaTy) <- case unapplyTy viaApp' of@@ -83,10 +87,17 @@ , "\tThe ‘Via‘ type must be used, e.g." , "\t[t| forall a. C (T a) `Via` V a |]" ]- decs <- deriveViaDecs instanceTy (Just viaTy)- let instanceHeader = ForallT instanceTvbs instanceCxt instanceTy- (:[]) `fmap` instanceD (return [])- (return instanceHeader)+ -- 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)@)@@ -134,7 +145,7 @@ _ -> fail $ "Not a type class: " ++ pprint clsTy _ -> fail $ "Malformed instance: " ++ pprint instanceTy -deriveViaDecs' :: Name -> [TyVarBndrUnit] -> [Type] -> Type -> Dec -> Q (Maybe [Dec])+deriveViaDecs' :: Name -> [TyVarBndr_ flag] -> [Type] -> Type -> Dec -> Q (Maybe [Dec]) deriveViaDecs' clsName clsTvbs clsArgs repTy dec = do let numExpectedArgs = length clsTvbs numActualArgs = length clsArgs@@ -173,7 +184,7 @@ go _ = return Nothing -mkCoerceClassMethEqn :: [TyVarBndrUnit] -> [Type] -> Type -> Type -> (Type, Type)+mkCoerceClassMethEqn :: [TyVarBndr_ flag] -> [Type] -> Type -> Type -> (Type, Type) mkCoerceClassMethEqn clsTvbs clsArgs repTy methTy = ( applySubstitution rhsSubst methTy , applySubstitution lhsSubst methTy
src/Data/Enum/Deriving.hs view
@@ -28,4 +28,7 @@ * Type variables of kind @*@ are assumed to have 'Enum' constraints. If this is not desirable, use 'makeToEnum' or one of its cousins.++* Generated 'Enum' instances for poly-kinded data family instances are likely+ to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. -}
src/Data/Enum/Deriving/Internal.hs view
@@ -22,6 +22,7 @@ ) where import Data.Deriving.Internal+import Data.List.NonEmpty (NonEmpty(..)) import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib@@ -116,7 +117,7 @@ -- given constructors. All constructors must be from the same type. makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp makeEnumFunForCons _ _ _ [] = noConstructorsError-makeEnumFunForCons ef tyName ty cons+makeEnumFunForCons ef tyName ty (con:cons') | not $ isEnumerationType cons = enumerationError tyNameBase | otherwise = case ef of@@ -173,8 +174,11 @@ tyNameBase :: String tyNameBase = nameBase tyName + cons :: NonEmpty ConstructorInfo+ cons = con :| cons'+ maxTagExpr :: Q Exp- maxTagExpr = integerE (length cons - 1) `sigE` conT intTypeName+ maxTagExpr = integerE (length cons') `sigE` conT intTypeName lamOne :: (Name -> Q Exp) -> Q Exp lamOne f = do
src/Data/Eq/Deriving.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-| Module: Data.Eq.Deriving Copyright: (C) 2015-2017 Ryan Scott@@ -7,6 +6,10 @@ 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'@@ -15,16 +18,12 @@ , 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
src/Data/Eq/Deriving/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-|@@ -20,20 +19,16 @@ , 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', partition)+import Data.List (foldl1') import qualified Data.Map as Map import Language.Haskell.TH.Datatype@@ -64,7 +59,6 @@ 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). --@@ -76,14 +70,7 @@ -- 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. --@@ -104,7 +91,6 @@ -- 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@@ -170,56 +156,72 @@ 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]+ lamE (map varP $ eqs ++ [value1, value2] ) . appsE $ [ varE $ eqConstName eClass- , letE [ funD eqDefn $ map (makeCaseForCon eClass tvMap) patMatchCons- ++ fallThroughCase+ , letE [ funD eqDefn [eqClause tvMap] ] $ varE eqDefn `appE` varE value1 `appE` varE value2- ]-#if defined(NEW_FUNCTOR_CLASSES)- ++ map varE eqs-#endif+ ] ++ map varE eqs ++ [varE value1, varE value2] where- nullaryCons, nonNullaryCons :: [ConstructorInfo]- (nullaryCons, nonNullaryCons) = partition isNullaryCon cons+ nonNullaryCons :: [ConstructorInfo]+ nonNullaryCons = filter (not . isNullaryCon) cons - tagMatchCons, patMatchCons :: [ConstructorInfo]- (tagMatchCons, patMatchCons)- | length nullaryCons > 10 = (nullaryCons, nonNullaryCons)- | otherwise = ([], cons)+ numNonNullaryCons :: Int+ numNonNullaryCons = length nonNullaryCons - fallThroughCase :: [Q Clause]- fallThroughCase- | null tagMatchCons = case patMatchCons of- [] -> [makeFallThroughCaseTrue] -- No constructors: _ == _ = True- [_] -> [] -- One constructor: no fall-through case- _ -> [makeFallThroughCaseFalse] -- Two or more constructors:- -- _ == _ = False- | otherwise = [makeTagCase]+ 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)+ [] -makeTagCase :: Q Clause-makeTagCase = do+ 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)) [] -makeFallThroughCaseFalse, makeFallThroughCaseTrue :: Q Clause-makeFallThroughCaseFalse = makeFallThroughCase falseDataName-makeFallThroughCaseTrue = makeFallThroughCase trueDataName+makeFallThroughCaseTrue :: Q Clause+makeFallThroughCaseTrue = clause [wildP, wildP] (normalB $ conE trueDataName) [] -makeFallThroughCase :: Name -> Q Clause-makeFallThroughCase dataName = clause [wildP, wildP] (normalB $ conE dataName) []+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@@ -231,6 +233,22 @@ (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@@ -272,17 +290,12 @@ -> 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]@@ -305,22 +318,7 @@ 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 -------------------------------------------------------------------------------@@ -328,9 +326,7 @@ -- | 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@@ -340,9 +336,7 @@ 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)@@ -354,18 +348,10 @@ eqConstName :: EqClass -> Name eqConstName Eq = eqConstValName-#if defined(NEW_FUNCTOR_CLASSES) eqConstName Eq1 = liftEqConstValName eqConstName Eq2 = liftEq2ConstValName-#else-eqConstName Eq1 = eq1ConstValName-#endif eqName :: EqClass -> Name eqName Eq = eqValName-#if defined(NEW_FUNCTOR_CLASSES) eqName Eq1 = liftEqValName eqName Eq2 = liftEq2ValName-#else-eqName Eq1 = eq1ValName-#endif
src/Data/Functor/Deriving/Internal.hs view
@@ -56,7 +56,7 @@ import Control.Monad (guard) import Data.Deriving.Internal-import Data.List+import qualified Data.List as List import qualified Data.Map as Map ((!), keys, lookup, member, singleton) import Data.Maybe @@ -311,18 +311,12 @@ 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+ _ | Just (_, PhantomR) <- unsnoc roles -> functorFunPhantom z value-#endif - | null cons && fftEmptyCaseBehavior opts && ghc7'8OrLater+ | null cons && fftEmptyCaseBehavior opts -> functorFunEmptyCase ff z value | null cons@@ -332,7 +326,6 @@ -> 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@@ -341,7 +334,6 @@ 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@@ -590,7 +582,7 @@ mkApCon :: Exp -> [Exp] -> Exp mkApCon conExp [] = VarE pureValName `AppE` conExp mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e- mkApCon conExp (e1:e2:es) = foldl' appAp+ 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) @@ -650,11 +642,7 @@ functorClassToFuns :: FunctorClass -> [FunctorFun] functorClassToFuns Functor = [ Fmap, Replace ]-functorClassToFuns Foldable = [ Foldr, FoldMap-#if MIN_VERSION_base(4,8,0)- , Null-#endif- ]+functorClassToFuns Foldable = [ Foldr, FoldMap, Null ] functorClassToFuns Traversable = [ Traverse ] functorFunToClass :: FunctorFun -> FunctorClass@@ -703,7 +691,7 @@ conWildPat :: ConstructorInfo -> Pat conWildPat (ConstructorInfo { constructorName = conName , constructorFields = ts }) =- ConP conName $ replicate (length ts) WildP+ conPCompat conName $ replicate (length ts) WildP ------------------------------------------------------------------------------- -- Generic traversal for functor-like deriving@@ -779,10 +767,8 @@ -- 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@@ -792,7 +778,7 @@ then wrongArg else return (caseTyApp (last args) (last xrs), True) go co (SigT t k) = do- (_, kc) <- go_kind co k+ (_, kc) <- go co k if kc then return (caseWrongArg, True) else go co t@@ -809,15 +795,6 @@ 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) @@ -837,16 +814,14 @@ mkSimpleLam :: (Exp -> Q Exp) -> Q Exp mkSimpleLam lam = do n <- newName "n"- body <- lam (VarE n)- return $ LamE [VarP n] body+ lamE [varP n] $ lam (VarE n) -- 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+ lamE [varP n1, varP n2] $ lam (VarE n1) (VarE n2) -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --@@ -861,7 +836,7 @@ -> Q Match mkSimpleConMatch fold conName insides = do varsNeeded <- newNameList "_arg" $ length insides- let pat = ConP conName (map VarP varsNeeded)+ let pat = conPCompat conName (map VarP varsNeeded) rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) return $ Match pat (NormalB rhs) [] @@ -885,7 +860,7 @@ -> Q Match mkSimpleConMatch2 fold conName insides = do varsNeeded <- newNameList "_arg" lengthInsides- let pat = ConP conName (map VarP varsNeeded)+ 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).@@ -918,9 +893,7 @@ -- 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)@@ -928,8 +901,14 @@ mkSimpleTupleCase matchForCon tupSort insides x = do let tupDataName = case tupSort of Boxed len -> tupleDataName len-#if MIN_VERSION_template_haskell(2,6,0) Unboxed len -> unboxedTupleDataName len-#endif m <- matchForCon tupDataName insides return $ CaseE x [m]++-- Adapt to the type of ConP changing in template-haskell-2.18.0.0.+conPCompat :: Name -> [Pat] -> Pat+conPCompat n pats = ConP n+#if MIN_VERSION_template_haskell(2,18,0)+ []+#endif+ pats
src/Data/Ix/Deriving.hs view
@@ -25,4 +25,7 @@ * Type variables of kind @*@ are assumed to have 'Ix' constraints. If this is not desirable, use 'makeRange' or one of its cousins.++* Generated 'Ix' instances for poly-kinded data family instances are likely+ to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. -}
src/Data/Ix/Deriving/Internal.hs view
@@ -19,6 +19,7 @@ ) where import Data.Deriving.Internal+import Data.List.NonEmpty (NonEmpty(..)) import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib@@ -95,7 +96,7 @@ -- given constructors. All constructors must be from the same type. makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp makeIxFunForCons _ _ _ [] = noConstructorsError-makeIxFunForCons ixf tyName ty cons+makeIxFunForCons ixf tyName ty (con:cons') | not (isProduct || isEnumeration) = enumerationOrProductError $ nameBase tyName | isEnumeration@@ -144,10 +145,7 @@ ] | otherwise -- It's a product type- = do let con :: ConstructorInfo- con = head cons-- conName :: Name+ = do let conName :: Name conName = constructorName con conFields :: Int@@ -204,6 +202,9 @@ 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
src/Data/Ord/Deriving.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-| Module: Data.Ord.Deriving Copyright: (C) 2015-2017 Ryan Scott@@ -7,6 +6,10 @@ 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'@@ -20,16 +23,12 @@ , 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
src/Data/Ord/Deriving/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-|@@ -25,20 +24,18 @@ , 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) @@ -109,7 +106,6 @@ 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). --@@ -121,14 +117,7 @@ -- 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. --@@ -151,7 +140,6 @@ makeCompare2 name = makeLiftCompare name `appE` varE compareValName `appE` varE compareValName-#endif ------------------------------------------------------------------------------- -- Code generation@@ -203,11 +191,7 @@ 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@@ -246,12 +230,8 @@ where compareFuns :: [OrdFun] compareFuns = [ OrdCompare-#if defined(NEW_FUNCTOR_CLASSES) , Ord1LiftCompare , Ord2LiftCompare2-#else- , Ord1Compare1-#endif ] -- | Generates a lambda expression for the given constructors.@@ -277,10 +257,6 @@ singleConType :: Bool singleConType = isSingleton cons - firstConName, lastConName :: Name- firstConName = constructorName $ head cons- lastConName = constructorName $ last cons- -- Alternatively, we could look these up from dataConTagMap, but this -- is slightly faster due to the lack of Map lookups. firstTag, lastTag :: Int@@ -290,39 +266,40 @@ dataConTagMap :: Map Name Int dataConTagMap = Map.fromList $ zip (map constructorName cons) [0..] - ordMatches :: ConstructorInfo -> Q Match- ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType- firstTag firstConName lastTag lastConName- dataConTagMap- ordFunRhs :: Q Exp- ordFunRhs- | null cons- = conE eqDataName+ 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 cons+ = 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])+ lamE (map varP $ ords ++ [v1, v2]) . appsE $ [ varE $ compareConstName oFun , ordFunRhs- ]-#if defined(NEW_FUNCTOR_CLASSES)- ++ map varE ords-#endif+ ] ++ map varE ords ++ [varE v1, varE v2] makeOrdFunForCon :: OrdFun@@ -432,17 +409,12 @@ -> 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@@ -468,23 +440,7 @@ 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 -------------------------------------------------------------------------------@@ -492,9 +448,7 @@ -- | 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@@ -504,9 +458,7 @@ 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)@@ -522,28 +474,16 @@ 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@@ -552,16 +492,11 @@ 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@@ -570,12 +505,8 @@ 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@@ -583,12 +514,8 @@ 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@@ -596,12 +523,8 @@ 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@@ -609,12 +532,8 @@ 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@@ -632,9 +551,7 @@ 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@@ -654,12 +571,8 @@ 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
src/Text/Read/Deriving.hs view
@@ -7,6 +7,10 @@ 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'@@ -23,23 +27,20 @@ -- * 'Read1' , deriveRead1 , deriveRead1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftReadsPrec -- , makeLiftReadsPrecOptions -- , makeLiftReadList -- , makeLiftReadListOptions-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec -- , makeLiftReadPrecOptions -- , makeLiftReadListPrec -- , makeLiftReadListPrecOptions , makeReadPrec1 -- , makeReadPrec1Options-# endif #endif , makeReadsPrec1 -- , makeReadsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Read2' , deriveRead2 , deriveRead2Options@@ -47,17 +48,16 @@ -- , makeLiftReadsPrec2Options -- , makeLiftReadList2 -- , makeLiftReadList2Options-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec2 -- , makeLiftReadPrec2Options -- , makeLiftReadListPrec2 -- , makeLiftReadListPrec2Options , makeReadPrec2 -- , makeReadPrec2Options-# endif+#endif , makeReadsPrec2 -- , makeReadsPrec2Options-#endif -- * 'ReadOptions' , ReadOptions(..) , defaultReadOptions
src/Text/Read/Deriving/Internal.hs view
@@ -27,23 +27,20 @@ -- * 'Read1' , deriveRead1 , deriveRead1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftReadsPrec -- , makeLiftReadsPrecOptions -- , makeLiftReadList -- , makeLiftReadListOptions-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec -- , makeLiftReadPrecOptions -- , makeLiftReadListPrec -- , makeLiftReadListPrecOptions , makeReadPrec1 -- , makeReadPrec1Options-# endif #endif , makeReadsPrec1 -- , makeReadsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Read2' , deriveRead2 , deriveRead2Options@@ -51,17 +48,16 @@ -- , makeLiftReadsPrec2Options -- , makeLiftReadList2 -- , makeLiftReadList2Options-# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec2 -- , makeLiftReadPrec2Options -- , makeLiftReadListPrec2 -- , makeLiftReadListPrec2Options , makeReadPrec2 -- , makeReadPrec2Options-# endif+#endif , makeReadsPrec2 -- , makeReadsPrec2Options-#endif -- * 'ReadOptions' , ReadOptions(..) , defaultReadOptions@@ -185,7 +181,6 @@ -- 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). --@@ -212,7 +207,7 @@ -- makeLiftReadListOptions :: ReadOptions -> Name -> Q Exp -- makeLiftReadListOptions = undefined -# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 -- | Generates a lambda expression which behaves like 'liftReadPrec' (without -- requiring a 'Read1' instance). --@@ -255,7 +250,7 @@ -- makeReadPrec1Options opts name = makeLiftReadPrecOptions opts name -- `appE` varE readPrecValName -- `appE` varE readListPrecValName-# endif+#endif -- | Generates a lambda expression which behaves like 'readsPrec1' (without -- requiring a 'Read1' instance). makeReadsPrec1 :: Name -> Q Exp@@ -268,18 +263,7 @@ -- 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. --@@ -341,7 +325,7 @@ -- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr)))) -- `appE` integerE 0 -# if __GLASGOW_HASKELL__ >= 801+#if __GLASGOW_HASKELL__ >= 801 -- | Generates a lambda expression which behaves like 'liftReadPrec2' (without -- requiring a 'Read2' instance). --@@ -388,7 +372,7 @@ -- `appE` varE readListPrecValName -- `appE` varE readPrecValName -- `appE` varE readListPrecValName-# endif+#endif -- | Generates a lambda expression which behaves like 'readsPrec2' (without -- requiring a 'Read2' instance).@@ -410,7 +394,6 @@ -- `appE` varE readListValName -- `appE` varE readsPrecValName -- `appE` varE readListValName-#endif ------------------------------------------------------------------------------- -- Code generation@@ -483,7 +466,7 @@ rps <- newNameList "rp" $ arity rClass rls <- newNameList "rl" $ arity rClass let rpls = zip rps rls- _rpsAndRls = interleave 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 @@ -527,20 +510,13 @@ | null cons = varE pfailValName | otherwise = varE parensValName `appE` readConsExpr - lamE (map varP $-#if defined(NEW_FUNCTOR_CLASSES)- _rpsAndRls ++-#endif- if urp then [] else [p]+ lamE (map varP $ rpsAndRls ++ 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+ ] ++ map varE rpsAndRls ++ if urp then [] else [varE p] makeReadForCon :: ReadClass@@ -658,21 +634,15 @@ -> 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]@@ -700,23 +670,7 @@ (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 -------------------------------------------------------------------------------@@ -724,9 +678,7 @@ -- | 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@@ -736,9 +688,7 @@ 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)@@ -750,58 +700,38 @@ 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@@ -891,6 +821,4 @@ baseCompatible = case rClass of Read -> True Read1 -> base4'10OrLater-#if defined(NEW_FUNCTOR_CLASSES) Read2 -> base4'10OrLater-#endif
src/Text/Show/Deriving.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-| Module: Text.Show.Deriving Copyright: (C) 2015-2017 Ryan Scott@@ -7,6 +6,10 @@ 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'@@ -21,15 +24,12 @@ -- * 'Show1' , deriveShow1 , deriveShow1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftShowsPrec , makeLiftShowsPrecOptions , makeLiftShowList , makeLiftShowListOptions-#endif , makeShowsPrec1 , makeShowsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Show2' , deriveShow2 , deriveShow2Options@@ -39,7 +39,6 @@ , makeLiftShowList2Options , makeShowsPrec2 , makeShowsPrec2Options-#endif -- * 'ShowOptions' , ShowOptions(..) , defaultShowOptions
src/Text/Show/Deriving/Internal.hs view
@@ -26,15 +26,12 @@ -- * 'Show1' , deriveShow1 , deriveShow1Options-#if defined(NEW_FUNCTOR_CLASSES) , makeLiftShowsPrec , makeLiftShowsPrecOptions , makeLiftShowList , makeLiftShowListOptions-#endif , makeShowsPrec1 , makeShowsPrec1Options-#if defined(NEW_FUNCTOR_CLASSES) -- * 'Show2' , deriveShow2 , deriveShow2Options@@ -44,7 +41,6 @@ , makeLiftShowList2Options , makeShowsPrec2 , makeShowsPrec2Options-#endif -- * 'ShowOptions' , ShowOptions(..) , defaultShowOptions@@ -52,7 +48,7 @@ ) where import Data.Deriving.Internal-import Data.List+import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (fromMaybe)@@ -88,12 +84,7 @@ -- | 'ShowOptions' that match the behavior of the installed version of GHC. legacyShowOptions :: ShowOptions legacyShowOptions = ShowOptions- { ghc8ShowBehavior =-#if __GLASGOW_HASKELL__ >= 711- True-#else- False-#endif+ { ghc8ShowBehavior = True , showEmptyCaseBehavior = False } @@ -153,7 +144,6 @@ 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). --@@ -190,13 +180,7 @@ 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. --@@ -261,7 +245,6 @@ `appE` varE showListValName `appE` varE showsPrecValName `appE` varE showListValName-#endif ------------------------------------------------------------------------------- -- Code generation@@ -324,12 +307,12 @@ sps <- newNameList "sp" $ arity sClass sls <- newNameList "sl" $ arity sClass let spls = zip sps sls- _spsAndSls = interleave 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+ | null cons && showEmptyCaseBehavior opts = caseE (varE value) [] | null cons@@ -341,18 +324,11 @@ = caseE (varE value) (map (makeShowForCon p sClass opts splMap) cons) - lamE (map varP $-#if defined(NEW_FUNCTOR_CLASSES)- _spsAndSls ++-#endif- [p, value])+ lamE (map varP $ spsAndSls ++ [p, value]) . appsE $ [ varE $ showsPrecConstName sClass , makeFun- ]-#if defined(NEW_FUNCTOR_CLASSES)- ++ map varE _spsAndSls-#endif+ ] ++ map varE spsAndSls ++ [varE p, varE value] -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a@@ -398,7 +374,7 @@ then do let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys' args parenCommaArgs = (varE showCharValName `appE` charE '(')- : intersperse (varE showCharValName `appE` charE ',') showArgs+ : List.intersperse (varE showCharValName `appE` charE ',') showArgs mappendArgs = foldr (`infixApp` varE composeValName) (varE showCharValName `appE` charE ')') parenCommaArgs@@ -530,17 +506,12 @@ -- 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]@@ -565,22 +536,7 @@ (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 -------------------------------------------------------------------------------@@ -588,9 +544,7 @@ -- | 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@@ -600,9 +554,7 @@ 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)@@ -614,23 +566,14 @@ 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@@ -641,7 +584,6 @@ -> Name showsPrecOrListName False = showsPrecName showsPrecOrListName True = showListName-#endif ------------------------------------------------------------------------------- -- Assorted utilities@@ -690,36 +632,91 @@ , primShowPostfixMod = twoHashE , primShowConv = id })-#if MIN_VERSION_base(4,13,0)+#if MIN_VERSION_base(4,19,0) , (int8HashTypeName, PrimShow- { primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt8HashValName)+ { 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 "narrowInt8#"+ , primShowConv = mkNarrowE intToInt8HashValName }) , (int16HashTypeName, PrimShow- { primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt16HashValName)+ { primShowBoxer = appE (conE iHashDataName) . appE (varE int16ToIntHashValName) , primShowPostfixMod = oneHashE- , primShowConv = mkNarrowE "narrowInt16#"+ , primShowConv = mkNarrowE intToInt16HashValName }) , (word8HashTypeName, PrimShow- { primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord8HashValName)+ { primShowBoxer = appE (conE wHashDataName) . appE (varE word8ToWordHashValName) , primShowPostfixMod = twoHashE- , primShowConv = mkNarrowE "narrowWord8#"+ , primShowConv = mkNarrowE wordToWord8HashValName }) , (word16HashTypeName, PrimShow- { primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord16HashValName)+ { primShowBoxer = appE (conE wHashDataName) . appE (varE word16ToWordHashValName) , primShowPostfixMod = twoHashE- , primShowConv = mkNarrowE "narrowWord16#"+ , 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)-mkNarrowE :: String -> Q Exp -> Q Exp-mkNarrowE narrowStr e =+#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 ('(':narrowStr ++ " ")+ [ varE showStringValName `appE` stringE ('(':nameBase narrowName ++ " ") , e ] #endif@@ -727,3 +724,8 @@ 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
tests/BoundedEnumIxSpec.hs view
@@ -2,12 +2,13 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-} #endif {-|@@ -22,12 +23,12 @@ module BoundedEnumIxSpec where import Data.Deriving+#if __GLASGOW_HASKELL__ < 806+import Data.Kind+#endif import GHC.Arr (Ix(..)) -import Prelude ()-import Prelude.Compat- import Test.Hspec -------------------------------------------------------------------------------@@ -40,13 +41,7 @@ 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+data TyConUnit (f :: k -> *) (a :: k) = TyConUnit deriving (Eq, Ord, Show) data TyConExQuant a = Show a => TyConExQuant@@ -70,13 +65,7 @@ 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 family TyFamilyUnit (f :: k -> *) (a :: k) :: * data instance TyFamilyUnit f a = TyFamilyUnit deriving (Eq, Ord, Show) @@ -129,7 +118,6 @@ unsafeIndex = $(makeUnsafeIndex ''TyConGADT) inRange = $(makeInRange ''TyConGADT) -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveBounded 'TyFamilyEnum1)@@ -163,7 +151,6 @@ range = $(makeRange 'TyFamilyGADT) unsafeIndex = $(makeUnsafeIndex 'TyFamilyGADT) inRange = $(makeInRange 'TyFamilyGADT)-#endif ------------------------------------------------------------------------------- @@ -223,7 +210,6 @@ 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@@ -265,4 +251,3 @@ it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyFamilyGADT False)-#endif
tests/DerivingViaSpec.hs view
@@ -24,9 +24,6 @@ -} module DerivingViaSpec where -import Prelude ()-import Prelude.Compat- import Test.Hspec #if MIN_VERSION_template_haskell(2,12,0)
tests/EqSpec.hs view
@@ -9,9 +9,6 @@ -} module EqSpec where -import Prelude ()-import Prelude.Compat- import Test.Hspec import Types.EqOrd ()
tests/FunctorSpec.hs view
@@ -1,24 +1,20 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-} {-# 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-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-unused-foralls #-}-#endif {-| Module: FunctorSpec@@ -34,17 +30,13 @@ import Data.Char (chr) import Data.Foldable (fold) import Data.Deriving-import Data.Functor.Classes (Eq1)+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)@@ -108,9 +100,7 @@ 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)@@ -218,9 +208,7 @@ 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)@@ -254,7 +242,6 @@ $(deriveFoldable ''TyCon30) $(deriveTraversable ''TyCon30) -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveFunctor 'T1Fam)@@ -280,9 +267,7 @@ 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)@@ -306,45 +291,47 @@ $(deriveFunctor 'TyFamily30) $(deriveFoldable 'TyFamily30) $(deriveTraversable 'TyFamily30)-#endif ------------------------------------------------------------------------------- -prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c))- => (b -> c) -> (a -> b) -> f a -> Bool-prop_FunctorLaws f g x =- fmap id x == x- && fmap (f . g) x == (fmap f . fmap g) x+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])) => f [Int] -> Bool+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, Monoid a, Monoid b, Foldable f)- => (a -> b) -> (a -> z -> z) -> z -> f a -> Bool-prop_FoldableLaws f h z x =- fold x == foldMap id x- && foldMap f x == foldr (mappend . f) mempty x- && foldr h z x == appEndo (foldMap (Endo . h) x) z+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] -> Bool+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)+ 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 -> Bool-prop_TraversableLaws f g t x =- (t . traverse f) x == traverse (t . f) x- && traverse Identity x == Identity x- && traverse (Compose . fmap g . f) x- == (Compose . fmap (traverse g) . traverse f) x+ -> (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 == (sequenceA . fmap t) y- && (sequenceA . fmap Identity) y == Identity y- && (sequenceA . fmap Compose) z- == (Compose . fmap sequenceA . sequenceA) z+ (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@@ -352,9 +339,10 @@ 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))- => t [Int] -> Bool+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")@@ -369,17 +357,15 @@ spec = parallel $ do describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do prop "satisfies the Functor laws"- (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)+ (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Foldable laws"- (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)+ (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Traversable laws"- (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)-#if MIN_VERSION_template_haskell(2,7,0)+ (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do prop "satisfies the Functor laws"- (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)+ (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Foldable laws"- (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)+ (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) prop "satisfies the Traversable laws"- (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)-#endif+ (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation)
tests/GH24Spec.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif @@ -18,22 +19,15 @@ -} 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
tests/GH27Spec.hs view
@@ -6,7 +6,6 @@ #if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-unused-foralls #-} -- Due to GHC #13512. Sigh. #endif {-|@@ -18,15 +17,8 @@ A regression test for https://github.com/haskell-compat/deriving-compat/issues/27.-We isolate this test case from the rest of "DerivingViaSpec" because-we have to disable @-Wunused-foralls@ due to-https://gitlab.haskell.org/ghc/ghc/issues/13512, and we would prefer not to-contaminate the rest of "DerivingViaSpec" with this hack. -} module GH27Spec where--import Prelude ()-import Prelude.Compat import Test.Hspec
tests/GH31Spec.hs view
@@ -19,9 +19,6 @@ import OrdSpec (ordSpec) -import Prelude ()-import Prelude.Compat- import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) import Test.QuickCheck (Arbitrary(..), oneof)
tests/GH6Spec.hs view
@@ -17,9 +17,6 @@ import OrdSpec (ordSpec) -import Prelude ()-import Prelude.Compat- import Test.Hspec (Spec, describe, hspec, parallel) import Test.QuickCheck (Arbitrary(..), oneof)
tests/OrdSpec.hs view
@@ -13,9 +13,6 @@ import Data.Functor.Classes -import Prelude ()-import Prelude.Compat- import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary)@@ -24,13 +21,13 @@ ------------------------------------------------------------------------------- -prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Bool-prop_Ord x y = compare x y == compare1 x y+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 -> Bool)+ordSpec _ = prop "has a valid Ord1 instance" (prop_Ord :: f a -> f a -> Expectation) -------------------------------------------------------------------------------
tests/ReadSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -20,9 +19,6 @@ 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(..))@@ -57,38 +53,30 @@ $(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 -> Bool-prop_Read x = readArb readsPrec == readArb readsPrec1+ => f a -> Expectation+prop_Read x = readArb readsPrec `shouldBe` readArb readsPrec1 where readArb :: (Int -> ReadS (f a)) -> f a readArb = read' (show x)@@ -96,7 +84,7 @@ 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 -> Bool)+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@@ -118,7 +106,5 @@ spec = parallel $ do describe "TyCon#" $ readSpec (Proxy :: Proxy (TyCon# Char Int))-#if MIN_VERSION_template_haskell(2,7,0) describe "TyFamily#" $ readSpec (Proxy :: Proxy (TyFamily# Char Int))-#endif
tests/ShowSpec.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE EmptyCase #-}-#endif+{-# LANGUAGE TypeOperators #-} {-| Module: ShowSpec@@ -26,11 +25,11 @@ #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 ()@@ -53,6 +52,10 @@ , tcWord8# :: Word8# , tcWord16# :: Word16# #endif+#if MIN_VERSION_base(4,16,0)+ , tcInt32# :: Int32#+ , tcWord32# :: Word32#+#endif } data TyCon2 a b c d where@@ -94,6 +97,10 @@ , tfWord8# :: Word8# , tfWord16# :: Word16# #endif+#if MIN_VERSION_base(4,16,0)+ , tfInt32# :: Int32#+ , tfWord32# :: Word32#+#endif } data family TyFamily2 w x y z :: *@@ -128,20 +135,15 @@ $(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#)@@ -150,11 +152,8 @@ $(deriveShow1 'TyFamily#) $(deriveShow1 'TyFamilyEqualityConstraints) -# if defined(NEW_FUNCTOR_CLASSES) $(deriveShow2 'TyFamily#) $(deriveShow2 'TyFamilyTypeRefinement1)-# endif-#endif -------------------------------------------------------------------------------
tests/Types/EqOrd.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-| Module: Types.EqOrd@@ -17,15 +18,15 @@ -} 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@@ -60,6 +61,10 @@ , tcWord8# :: Word8# , tcWord16# :: Word16# #endif+#if MIN_VERSION_base(4,16,0)+ , tcInt32# :: Int32#+ , tcWord32# :: Word32#+#endif } data TyCon2 a b c d where@@ -81,6 +86,11 @@ data Empty a b +data TyConNullary a b+ = TyConNullary1+ | TyConNullary2+ | TyConNullary3+ -- Data families data family TyFamily1 y z :: *@@ -116,6 +126,10 @@ , tfWord8# :: Word8# , tfWord16# :: Word16# #endif+#if MIN_VERSION_base(4,16,0)+ , tfInt32# :: Int32#+ , tfWord32# :: Word32#+#endif } data family TyFamily2 w x y z :: *@@ -139,6 +153,13 @@ | 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@@ -151,11 +172,14 @@ (==) = $(makeEq ''TyConWrap) (/=) = $(makeNotEq ''TyConWrap) $(deriveEq ''Empty)+$(deriveEq ''TyConNullary) $(deriveEq1 ''TyCon1) $(deriveEq1 ''TyCon#) $(deriveEq1 ''TyCon2)+$(deriveEq1 ''TyConWrap) $(deriveEq1 ''Empty)+$(deriveEq1 ''TyConNullary) $(deriveOrd ''TyCon1) $(deriveOrd ''TyCon#)@@ -170,39 +194,27 @@ max = $(makeMax ''TyConWrap) min = $(makeMin ''TyConWrap) $(deriveOrd ''Empty)+$(deriveOrd ''TyConNullary) $(deriveOrd1 ''TyCon1) $(deriveOrd1 ''TyCon#) $(deriveOrd1 ''TyCon2)-$(deriveOrd1 ''Empty)--#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+$(deriveOrd1 ''Empty)+$(deriveOrd1 ''TyConNullary) -#if defined(NEW_FUNCTOR_CLASSES) $(deriveEq2 ''TyCon1) $(deriveEq2 ''TyCon#) $(deriveEq2 ''TyCon2) $(deriveEq2 ''Empty)+$(deriveEq2 ''TyConNullary) $(deriveOrd2 ''TyCon1) $(deriveOrd2 ''TyCon#) $(deriveOrd2 ''TyCon2) $(deriveOrd2 ''Empty)-#endif+$(deriveOrd2 ''TyConNullary) -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveEq 'TyFamily1A)@@ -212,14 +224,17 @@ => 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)+$(deriveEq1 'TyFamilyWrap2) instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) => Ord (TyFamilyWrap f g h a) where compare = $(makeCompare 'TyFamilyWrap1)@@ -229,32 +244,20 @@ (<=) = $(makeGE 'TyFamilyWrap1) max = $(makeMax 'TyFamilyWrap1) min = $(makeMin 'TyFamilyWrap1)+$(deriveOrd 'TyFamilyNullary1) $(deriveOrd1 'TyFamily1B) $(deriveOrd1 'TyFamily#) $(deriveOrd1 'TyFamilyEqualityConstraints)--#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+$(deriveOrd1 'TyFamilyNullary1) -# if defined(NEW_FUNCTOR_CLASSES) $(deriveEq2 'TyFamily1C) $(deriveEq2 'TyFamily#) $(deriveEq2 'TyFamilyTypeRefinement1)+$(deriveEq2 'TyFamilyNullary1) $(deriveOrd2 'TyFamily1C) $(deriveOrd2 'TyFamily#) $(deriveOrd2 'TyFamilyTypeRefinement1)-# endif-#endif+$(deriveOrd2 'TyFamilyNullary1)
tests/Types/ReadShow.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}@@ -17,9 +16,6 @@ -} module Types.ReadShow where -#if !defined(NEW_FUNCTOR_CLASSES)-import Data.Functor.Classes (Read1(..), Show1(..))-#endif import Data.Deriving import Text.Read (Read(..), readListPrecDefault)@@ -112,6 +108,7 @@ $(deriveRead1 ''TyCon1) $(deriveRead1 ''TyConPlain) $(deriveRead1 ''TyConGADT)+$(deriveRead1 ''TyConWrap) $(deriveRead1 ''TC#) $(deriveShow ''TyCon1)@@ -127,23 +124,9 @@ $(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+$(deriveShow1 ''TC#) -#if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 ''TyCon1) $(deriveRead2 ''TyConPlain) $(deriveRead2 ''TyConGADT)@@ -153,9 +136,7 @@ $(deriveShow2 ''TyConPlain) $(deriveShow2 ''TyConGADT) $(deriveShow2 ''TC#)-#endif -#if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveRead 'TyFamilyPrefix)@@ -169,6 +150,7 @@ $(deriveRead1 '(:!:)) $(deriveRead1 '(:$:)) $(deriveRead1 '(:**))+$(deriveRead1 'TyFamilyWrap2) $(deriveRead1 'MkTF2#) $(deriveShow 'TyFamilyPrefix)@@ -184,23 +166,9 @@ $(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+$(deriveShow1 'MkTF1#) -# if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 'TyFamilyPrefix) $(deriveRead2 'TyFamilyPlain) $(deriveRead2 '(:***))@@ -210,5 +178,3 @@ $(deriveShow2 'TyFamilyPlain) $(deriveShow2 '(:***)) $(deriveShow2 'MkTF3#)-# endif-#endif