diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] -[![Build](https://img.shields.io/travis/haskell-compat/deriving-compat.svg)](https://travis-ci.org/haskell-compat/deriving-compat) +[![Build Status](https://github.com/haskell-compat/deriving-compat/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-compat/deriving-compat/actions?query=workflow%3AHaskell-CI) [Hackage: deriving-compat]: http://hackage.haskell.org/package/deriving-compat @@ -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: diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -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 diff --git a/src/Data/Bounded/Deriving/Internal.hs b/src/Data/Bounded/Deriving/Internal.hs --- a/src/Data/Bounded/Deriving/Internal.hs +++ b/src/Data/Bounded/Deriving/Internal.hs @@ -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 diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -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 diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -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 diff --git a/src/Data/Deriving/Via/Internal.hs b/src/Data/Deriving/Via/Internal.hs --- a/src/Data/Deriving/Via/Internal.hs +++ b/src/Data/Deriving/Via/Internal.hs @@ -1,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 diff --git a/src/Data/Enum/Deriving.hs b/src/Data/Enum/Deriving.hs --- a/src/Data/Enum/Deriving.hs +++ b/src/Data/Enum/Deriving.hs @@ -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. -} diff --git a/src/Data/Enum/Deriving/Internal.hs b/src/Data/Enum/Deriving/Internal.hs --- a/src/Data/Enum/Deriving/Internal.hs +++ b/src/Data/Enum/Deriving/Internal.hs @@ -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 diff --git a/src/Data/Eq/Deriving.hs b/src/Data/Eq/Deriving.hs --- a/src/Data/Eq/Deriving.hs +++ b/src/Data/Eq/Deriving.hs @@ -1,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 diff --git a/src/Data/Eq/Deriving/Internal.hs b/src/Data/Eq/Deriving/Internal.hs --- a/src/Data/Eq/Deriving/Internal.hs +++ b/src/Data/Eq/Deriving/Internal.hs @@ -1,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 diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -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 diff --git a/src/Data/Ix/Deriving.hs b/src/Data/Ix/Deriving.hs --- a/src/Data/Ix/Deriving.hs +++ b/src/Data/Ix/Deriving.hs @@ -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. -} diff --git a/src/Data/Ix/Deriving/Internal.hs b/src/Data/Ix/Deriving/Internal.hs --- a/src/Data/Ix/Deriving/Internal.hs +++ b/src/Data/Ix/Deriving/Internal.hs @@ -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 diff --git a/src/Data/Ord/Deriving.hs b/src/Data/Ord/Deriving.hs --- a/src/Data/Ord/Deriving.hs +++ b/src/Data/Ord/Deriving.hs @@ -1,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 diff --git a/src/Data/Ord/Deriving/Internal.hs b/src/Data/Ord/Deriving/Internal.hs --- a/src/Data/Ord/Deriving/Internal.hs +++ b/src/Data/Ord/Deriving/Internal.hs @@ -1,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 diff --git a/src/Text/Read/Deriving.hs b/src/Text/Read/Deriving.hs --- a/src/Text/Read/Deriving.hs +++ b/src/Text/Read/Deriving.hs @@ -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 diff --git a/src/Text/Read/Deriving/Internal.hs b/src/Text/Read/Deriving/Internal.hs --- a/src/Text/Read/Deriving/Internal.hs +++ b/src/Text/Read/Deriving/Internal.hs @@ -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 diff --git a/src/Text/Show/Deriving.hs b/src/Text/Show/Deriving.hs --- a/src/Text/Show/Deriving.hs +++ b/src/Text/Show/Deriving.hs @@ -1,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 diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -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 diff --git a/tests/BoundedEnumIxSpec.hs b/tests/BoundedEnumIxSpec.hs --- a/tests/BoundedEnumIxSpec.hs +++ b/tests/BoundedEnumIxSpec.hs @@ -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 diff --git a/tests/DerivingViaSpec.hs b/tests/DerivingViaSpec.hs --- a/tests/DerivingViaSpec.hs +++ b/tests/DerivingViaSpec.hs @@ -24,9 +24,6 @@ -} module DerivingViaSpec where -import Prelude () -import Prelude.Compat - import Test.Hspec #if MIN_VERSION_template_haskell(2,12,0) diff --git a/tests/EqSpec.hs b/tests/EqSpec.hs --- a/tests/EqSpec.hs +++ b/tests/EqSpec.hs @@ -9,9 +9,6 @@ -} module EqSpec where -import Prelude () -import Prelude.Compat - import Test.Hspec import Types.EqOrd () diff --git a/tests/FunctorSpec.hs b/tests/FunctorSpec.hs --- a/tests/FunctorSpec.hs +++ b/tests/FunctorSpec.hs @@ -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) diff --git a/tests/GH24Spec.hs b/tests/GH24Spec.hs --- a/tests/GH24Spec.hs +++ b/tests/GH24Spec.hs @@ -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 diff --git a/tests/GH27Spec.hs b/tests/GH27Spec.hs --- a/tests/GH27Spec.hs +++ b/tests/GH27Spec.hs @@ -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 diff --git a/tests/GH31Spec.hs b/tests/GH31Spec.hs --- a/tests/GH31Spec.hs +++ b/tests/GH31Spec.hs @@ -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) diff --git a/tests/GH6Spec.hs b/tests/GH6Spec.hs --- a/tests/GH6Spec.hs +++ b/tests/GH6Spec.hs @@ -17,9 +17,6 @@ import OrdSpec (ordSpec) -import Prelude () -import Prelude.Compat - import Test.Hspec (Spec, describe, hspec, parallel) import Test.QuickCheck (Arbitrary(..), oneof) diff --git a/tests/OrdSpec.hs b/tests/OrdSpec.hs --- a/tests/OrdSpec.hs +++ b/tests/OrdSpec.hs @@ -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) ------------------------------------------------------------------------------- diff --git a/tests/ReadSpec.hs b/tests/ReadSpec.hs --- a/tests/ReadSpec.hs +++ b/tests/ReadSpec.hs @@ -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 diff --git a/tests/ShowSpec.hs b/tests/ShowSpec.hs --- a/tests/ShowSpec.hs +++ b/tests/ShowSpec.hs @@ -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 ------------------------------------------------------------------------------- diff --git a/tests/Types/EqOrd.hs b/tests/Types/EqOrd.hs --- a/tests/Types/EqOrd.hs +++ b/tests/Types/EqOrd.hs @@ -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) diff --git a/tests/Types/ReadShow.hs b/tests/Types/ReadShow.hs --- a/tests/Types/ReadShow.hs +++ b/tests/Types/ReadShow.hs @@ -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