deriving-compat 0.1 → 0.2
raw patch · 12 files changed
+2057/−943 lines, 12 filesdep +base-orphansdep +transformersdep +transformers-compatdep ~deriving-compatdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: base-orphans, transformers, transformers-compat
Dependency ranges changed: deriving-compat, template-haskell
API changes (from Hackage documentation)
- Data.Foldable.Deriving: instance Eq FoldFun
+ Data.Foldable.Deriving: makeFold :: Name -> Q Exp
+ Data.Foldable.Deriving: makeFoldl :: Name -> Q Exp
+ Data.Functor.Deriving: deriveFunctor :: Name -> Q [Dec]
+ Data.Functor.Deriving: makeFmap :: Name -> Q Exp
+ Data.Traversable.Deriving: deriveTraversable :: Name -> Q [Dec]
+ Data.Traversable.Deriving: makeMapM :: Name -> Q Exp
+ Data.Traversable.Deriving: makeSequence :: Name -> Q Exp
+ Data.Traversable.Deriving: makeSequenceA :: Name -> Q Exp
+ Data.Traversable.Deriving: makeTraverse :: Name -> Q Exp
Files
- CHANGELOG.md +5/−0
- LICENSE +1/−1
- README.md +32/−2
- deriving-compat.cabal +54/−12
- src/Data/Deriving.hs +194/−0
- src/Data/Deriving/Internal.hs +335/−134
- src/Data/Foldable/Deriving.hs +26/−688
- src/Data/Functor/Deriving.hs +28/−0
- src/Data/Functor/Deriving/Internal.hs +1013/−0
- src/Data/Traversable/Deriving.hs +51/−0
- tests/DerivingSpec.hs +318/−0
- tests/FoldableSpec.hs +0/−106
CHANGELOG.md view
@@ -1,2 +1,7 @@+## 0.2+* Added support for GHC 8.0+* Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH.+* Added `Data.Deriving`, which reexports all other modules+ ## 0.1 * Initial commit
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015, Ryan Scott+Copyright (c) 2015-2016, Ryan Scott All rights reserved.
README.md view
@@ -1,2 +1,32 @@-# deriving-compat-Backports of GHC deriving extensions+# `deriving-compat`+[][Hackage: deriving-compat]+[](http://packdeps.haskellers.com/reverse/deriving-compat)+[][Haskell.org]+[][tl;dr Legal: BSD3]+[](https://travis-ci.org/haskell-compat/deriving-compat)++[Hackage: deriving-compat]:+ http://hackage.haskell.org/package/deriving-compat+ "deriving-compat package on Hackage"+[Haskell.org]:+ http://www.haskell.org+ "The Haskell Programming Language"+[tl;dr Legal: BSD3]:+ https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29+ "BSD 3-Clause License (Revised)"++Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions of GHC. Currently, the following extensions are covered:++* `DeriveFoldable`+* `DeriveFunctor`+* `DeriveTraversable`++The following changes have been backported:++* In GHC 8.0, `DeriveFoldable` was changed to allow folding over data types with existential constraints.+* In GHC 8.0, `DeriveFoldable` and `DeriveTraversable` were changed so as not to generate superfluous `mempty` or `pure` expressions in generated code. As a result, this allows deriving `Traversable` instances for datatypes with unlifted argument types.++Note that some recent GHC extensions are not covered by this package:++* `DeriveGeneric`, which was introducted in GHC 7.2 for deriving `Generic` instances, and modified in GHC 7.6 to allow derivation of `Generic1` instances. Use `Generics.Deriving.TH` from [`generic-deriving`](http://hackage.haskell.org/package/generic-deriving) to derive `Generic(1)` using Template Haskell.+* `DeriveLift`, which was introduced in GHC 8.0 for deriving `Lift` instances. Use `Language.Haskell.TH.Lift` from [`th-lift`](http://hackage.haskell.org/package/th-lift) to derive `Lift` using Template Haskell.
deriving-compat.cabal view
@@ -1,23 +1,57 @@ name: deriving-compat-version: 0.1+version: 0.2 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 extensions are covered: .- * @DeriveFoldable@, which was changed in GHC 7.12 to allow folding+ * @DeriveFoldable@+ .+ * @DeriveFunctor@+ .+ * @DeriveTraversable@+ .+ The following changes have been backported:+ .+ * In GHC 8.0, @DeriveFoldable@ was changed to allow folding over data types with existential constraints.+ .+ * In GHC 8.0, @DeriveFoldable@ and @DeriveTraversable@ were+ changed so as not to generate superfluous @mempty@ or @pure@+ expressions in generated code. As a result, this allows+ deriving @Traversable@ instances for datatypes with unlifted+ argument types.+ .+ Note that some recent GHC extensions are not covered by this package:+ .+ * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving+ @Generic@ instances, and modified in GHC 7.6 to allow derivation+ of @Generic1@ instances. Use @Generics.Deriving.TH@ from+ @<http://hackage.haskell.org/package/generic-deriving generic-deriving>@+ to derive @Generic(1)@ using Template Haskell.+ .+ * @DeriveLift@, which was introduced in GHC 8.0 for deriving+ @Lift@ instances. Use @Language.Haskell.TH.Lift@ from+ @<http://hackage.haskell.org/package/th-lift th-lift>@+ to derive @Lift@ using Template Haskell. homepage: https://github.com/haskell-compat/deriving-compat bug-reports: https://github.com/haskell-compat/deriving-compat/issues license: BSD3 license-file: LICENSE author: Ryan Scott-maintainer: Ryan Scott <ryan.gl.scott@ku.edu>+maintainer: Ryan Scott <ryan.gl.scott@gmail.com> stability: Experimental-copyright: (C) 2015 Ryan Scott+copyright: (C) 2015-2016 Ryan Scott category: Compatibility build-type: Simple extra-source-files: CHANGELOG.md, README.md+tested-with: GHC == 7.0.4+ , GHC == 7.2.2+ , GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.1 cabal-version: >=1.10 source-repository head@@ -25,13 +59,18 @@ location: https://github.com/haskell-compat/deriving-compat library- exposed-modules: Data.Foldable.Deriving+ exposed-modules: Data.Deriving++ Data.Foldable.Deriving+ Data.Functor.Deriving+ Data.Traversable.Deriving other-modules: Data.Deriving.Internal+ Data.Functor.Deriving.Internal Paths_deriving_compat build-depends: base >= 4.3 && < 5 , containers >= 0.1 && < 0.6 , ghc-prim- , template-haskell >= 2.5 && < 2.11+ , template-haskell >= 2.5 && < 2.12 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -39,12 +78,15 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs- other-modules: FoldableSpec- build-depends: base >= 4.3 && < 5- , base-compat >= 0.8.1 && < 1- , deriving-compat == 0.1- , hspec >= 1.8- , QuickCheck >= 2 && < 3+ other-modules: DerivingSpec+ build-depends: base >= 4.3 && < 5+ , base-compat >= 0.8.1 && < 1+ , base-orphans >= 0.5 && < 1+ , deriving-compat == 0.2+ , hspec >= 1.8+ , QuickCheck >= 2 && < 3+ , transformers >= 0.2+ , transformers-compat >= 0.3 hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall
+ src/Data/Deriving.hs view
@@ -0,0 +1,194 @@+{-|+Module: Data.Deriving+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++This module reexports all of the functionality of the other modules in this library.+It also provides a high-level tutorial on @deriving-compat@'s naming conventions and+best practices. Typeclass-specific information can be found in their respective+modules.+-}+module Data.Deriving (+ -- * @derive@- functions+ -- $derive++ -- * @make@- functions+ -- $make+ module Exports+ ) where++import Data.Foldable.Deriving as Exports+import Data.Functor.Deriving as Exports+import Data.Traversable.Deriving as Exports++{- $derive++Functions with the @derive@- prefix can be used to automatically generate an instance+of a typeclass for a given datatype 'Name'. Some examples:++@+{-# LANGUAGE TemplateHaskell #-}+import Data.Deriving++data Pair a = Pair a a+$('deriveFunctor' ''Pair) -- instance Functor Pair where ...++data Product f g a = Product (f a) (g a)+$('deriveFoldable' ''Product)+-- instance (Foldable f, Foldable g) => Foldable (Pair f g) where ...+@++If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),+then @derive@-functions can be used with data family instances (which requires the+@-XTypeFamilies@ extension). To do so, pass the 'Name' of a data or newtype instance+constructor (NOT a data family name!) to @deriveFoldable@. Note that the+generated code may require the @-XFlexibleInstances@ extension. Example:++@+{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}+import Data.Deriving++class AssocClass a b where+ data AssocData a b+instance AssocClass Int b where+ data AssocData Int b = AssocDataInt1 Int+ | AssocDataInt2 b+$('deriveFunctor' 'AssocDataInt1) -- instance Functor (AssocData Int) where ...+-- Alternatively, one could use $(deriveFunctor 'AssocDataInt2)+@++@derive@-functions in @deriving-compat@ fall into one of three categories:++* Category 0: Typeclasses with an argument of kind @*@.+ ('deriveEq', 'deriveOrd', 'deriveRead', 'deriveShow')++* Category 1: Typeclasses with an argument of kind @* -> *@, That is, a datatype+ with such an instance must have at least one type variable, and the last type+ variable must be of kind @*@.+ ('deriveEq1', 'deriveFoldable', 'deriveFunctor', 'deriveOrd1',+ 'deriveRead1', 'deriveShow1', 'deriveTraversable')++* Category 2: Typeclasses with an argument of kind @* -> * -> *@. That is, a datatype+ with such an instance must have at least two type variables, and the last two type+ variables must be of kind @*@.+ ('deriveEq2', 'deriveOrd2', 'deriveRead2', 'deriveShow2')++Note that there are some limitations to @derive@-functions:++* The 'Name' argument must not be of a type synonym.++* Type variables (other than the last ones) are assumed to require typeclass+ constraints. The constraints are different depending on the category. For example,+ for Category 0 functions, other type variables of kind @*@ are assumed to be+ constrained by that typeclass. As an example:++ @+ data Foo a = Foo a+ $(deriveEq ''Foo)+ @++ will result in a generated instance of:++ @+ instance Eq a => Eq (Foo a) where ...+ @++ If you do not want this behavior, use a @make@- function instead.++* For Category 1 and 2 functions, if you are using the @-XDatatypeContexts@ extension,+ a constraint cannot mention the last type variables. For example,+ @data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived 'Functor'+ instance.++* For Category 1 and 2 functions, if one of the last type variables is used within a+ constructor field's type, it must only be used in the last type arguments. For+ example, @data Legal a = Legal (Either Int a)@ can have a derived 'Functor' instance,+ but @data Illegal a = Illegal (Either a Int)@ cannot.++* For Category 1 and 2 functions, data family instances must be able to eta-reduce the+ last type variables. In other words, if you have a instance of the form:++ @+ data family Family a1 ... an t1 ... tn+ data instance Family e1 ... e2 v1 ... vn = ...+ @++ where @t1@, ..., @tn@ are the last type variables, then the following conditions+ must hold:++ 1. @v1@, ..., @vn@ must be type variables.+ 2. @v1@, ..., @vn@ must not be mentioned in any of @e1@, ..., @e2@.++-}++{- $make++Functions prefixed with @make@- are similar to @derive@-functions in that they also+generate code, but @make@-functions in particular generate the expression for a+particular typeclass method. For example:++@+{-# LANGUAGE TemplateHaskell #-}+import Data.Deriving++data Pair a = Pair a a++instance Functor Pair where+ fmap = $('makeFmap' ''Pair)+@++In this example, 'makeFmap' will splice in the appropriate lambda expression which+implements 'fmap' for @Pair@.++@make@-functions are subject to all the restrictions of @derive@-functions listed+above save for one exception: the datatype need not be an instance of a particular+typeclass. There are some scenarios where this might be preferred over using a+@derive@-function. For example, you might want to map over a @Pair@ value+without explicitly having to make it an instance of 'Functor'.++Another use case for @make@-functions is sophisticated data types—that is, an+expression for which a @derive@-function would infer the wrong instance context.+Consider the following example:++@+data Proxy a = Proxy+$('deriveEq' ''Proxy)+@++This would result in a generated instance of:++@+instance Eq a => Eq (Proxy a) where ...+@++This compiles, but is not what we want, since the @Eq a@ constraint is completely+unnecessary. Another scenario in which @derive@-functions fail is when you+have something like this:++@+newtype HigherKinded f a b = HigherKinded (f a b)+$('deriveFunctor' ''HigherKinded)+@++Ideally, this would produce @HigherKinded (f a)@ as its instance context, but sadly,+the Template Haskell type inference machinery used in @deriving-compat@ is not smart+enough to figure that out. Nevertheless, @make@-functions provide a valuable+backdoor for these sorts of scenarios:++@+{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}+import Data.Foldable.Deriving++data Proxy a = Proxy+newtype HigherKinded f a b = HigherKinded (f a b)++instance Eq (Proxy a) where+ (==) = $('makeEq' ''Proxy)++instance Functor (f a) => Functor (HigherKinded f a) where+ fmap = $('makeFmap' ''HigherKinded)+@++-}
src/Data/Deriving/Internal.hs view
@@ -2,7 +2,7 @@ {-| Module: Data.Deriving.Internal-Copyright: (C) 2015 Ryan Scott+Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell@@ -11,13 +11,13 @@ -} module Data.Deriving.Internal where -import Control.Monad (guard)+import Control.Monad (liftM) -import Data.Function (on)+import Data.Foldable (foldr') import Data.List-import qualified Data.Map as Map (fromList, lookup)+import qualified Data.Map as Map (fromList, findWithDefault, singleton) import Data.Map (Map)-import Data.Maybe+import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Set (Set) @@ -39,9 +39,18 @@ expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t expandSyn t@AppT{} = expandSynApp t [] expandSyn t@ConT{} = expandSynApp t []-expandSyn (SigT t _) = expandSyn t -- Ignore kind synonyms+expandSyn (SigT t k) = do t' <- expandSyn t+ k' <- expandSynKind k+ return (SigT t' k') expandSyn t = return t +expandSynKind :: Kind -> Q Kind+#if MIN_VERSION_template_haskell(2,8,0)+expandSynKind = expandSyn+#else+expandSynKind = return -- There are no kind synonyms to deal with+#endif+ expandSynApp :: Type -> [Type] -> Q Type expandSynApp (AppT t1 t2) ts = do t2' <- expandSyn t2@@ -53,33 +62,56 @@ TyConI (TySynD _ tvs rhs) -> let (ts', ts'') = splitAt (length tvs) ts subs = mkSubst tvs ts'- rhs' = subst subs rhs+ rhs' = substType subs rhs in expandSynApp rhs' ts'' _ -> return $ foldl' AppT t ts expandSynApp t ts = do t' <- expandSyn t return $ foldl' AppT t' ts -type Subst = Map Name Type+type TypeSubst = Map Name Type+type KindSubst = Map Name Kind -mkSubst :: [TyVarBndr] -> [Type] -> Subst+mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst mkSubst vs ts = let vs' = map un vs un (PlainTV v) = v un (KindedTV v _) = v in Map.fromList $ zip vs' ts -subst :: Subst -> Type -> Type-subst subs (ForallT v c t) = ForallT v c $ subst subs t-subst subs t@(VarT n) = fromMaybe t $ Map.lookup n subs-subst subs (AppT t1 t2) = AppT (subst subs t1) (subst subs t2)-subst subs (SigT t k) = SigT (subst subs t) k-subst _ t = t+substType :: TypeSubst -> Type -> Type+substType subs (ForallT v c t) = ForallT v c $ substType subs t+substType subs t@(VarT n) = Map.findWithDefault t n subs+substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)+substType subs (SigT t k) = SigT (substType subs t)+#if MIN_VERSION_template_haskell(2,8,0)+ (substType subs k)+#else+ k+#endif+substType _ t = t +substKind :: KindSubst -> Type -> Type+#if MIN_VERSION_template_haskell(2,8,0)+substKind = substType+#else+substKind _ = id -- There are no kind variables!+#endif++substNameWithKind :: Name -> Kind -> Type -> Type+substNameWithKind n k = substKind (Map.singleton n k)++substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns+ ------------------------------------------------------------------------------- -- Type-specialized const functions ------------------------------------------------------------------------------- +fmapConst :: f b -> (a -> b) -> f a -> f b+fmapConst = const . const+{-# INLINE fmapConst #-}+ foldrConst :: b -> (a -> b -> b) -> b -> t a -> b foldrConst = const . const . const {-# INLINE foldrConst #-}@@ -88,40 +120,181 @@ foldMapConst = const . const {-# INLINE foldMapConst #-} +traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b)+traverseConst = const . const+{-# INLINE traverseConst #-}+ ---------------------------------------------------------------------------------- NameBase+-- StarKindStatus ------------------------------------------------------------------------------- --- | A wrapper around Name which only uses the 'nameBase' (not the entire Name)--- to compare for equality. For example, if you had two Names a_123 and a_456,--- they are not equal as Names, but they are equal as NameBases.------ This is useful when inspecting type variables, since a type variable in an--- instance context may have a distinct Name from a type variable within an--- actual constructor declaration, but we'd want to treat them as the same--- if they have the same 'nameBase' (since that's what the programmer uses to--- begin with).-newtype NameBase = NameBase { getName :: Name }--getNameBase :: NameBase -> String-getNameBase = nameBase . getName--instance Eq NameBase where- (==) = (==) `on` getNameBase+-- | Whether a type is not of kind *, is of kind *, or is a kind variable.+data StarKindStatus = NotKindStar+ | KindStar+ | IsKindVar Name+ deriving Eq -instance Ord NameBase where- compare = compare `on` getNameBase+-- | 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 -instance Show NameBase where- showsPrec p = showsPrec p . getNameBase+-- | 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 --- | A NameBase paired with the name of its map function.-type TyVarInfo = (NameBase, Name)+-- | Concat together all of the StarKindStatuses that are IsKindVar and extract+-- the kind variables' Names out.+catKindVarNames :: [StarKindStatus] -> [Name]+catKindVarNames = mapMaybe starKindStatusToName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- +-- isRight and fromEither taken from the extra package (BSD3-licensed)++-- | Test if an 'Either' value is the 'Right' constructor.+-- Provided as standard with GHC 7.8 and above.+isRight :: Either l r -> Bool+isRight Right{} = True; isRight _ = False++-- | Pull the value out of an 'Either' where both alternatives+-- have the same type.+--+-- > \x -> fromEither (Left x ) == x+-- > \x -> fromEither (Right x) == x+fromEither :: Either a a -> a+fromEither = either id id++-- 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)++-- | Apply an @Either Exp Exp@ expression to an 'Exp' expression,+-- preserving the 'Either'-ness.+appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)+appEitherE e1Q e2Q = do+ e2 <- e2Q+ let e2' :: Exp -> Exp+ e2' = (`AppE` e2)+ either (Left . e2') (Right . e2') `fmap` e1Q++-- | 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++-- | Gets all of the type/kind variable names mentioned somewhere in a Type.+tyVarNamesOfType :: Type -> [Name]+tyVarNamesOfType = go+ where+ go :: Type -> [Name]+ go (AppT t1 t2) = go t1 ++ go t2+ go (SigT t _k) = go t+#if MIN_VERSION_template_haskell(2,8,0)+ ++ go _k+#endif+ go (VarT n) = [n]+ go _ = []++-- | Gets all of the type/kind variable names mentioned somewhere in a Kind.+tyVarNamesOfKind :: Kind -> [Name]+#if MIN_VERSION_template_haskell(2,8,0)+tyVarNamesOfKind = tyVarNamesOfType+#else+tyVarNamesOfKind _ = [] -- There are no kind variables+#endif++-- | @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 (concatMap tyVarNamesOfKind uk)+ else Nothing++-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.+tyKind :: Type -> Kind+tyKind (SigT _ k) = k+tyKind _ = starK++-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.+stealKindForType :: TyVarBndr -> Type -> Type+stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)+stealKindForType _ t = t++-- | Monadic version of concatMap+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = liftM concat (mapM f xs)++-- | A mapping of type variable Names to their map function Names. For example, in a+-- Functor declaration, a TyVarMap might look like (a ~> f), where+-- a is the last type variable of the datatype, and f is the function which maps+-- over a.+type TyVarMap = Map Name Name+ thd3 :: (a, b, c) -> c thd3 (_, _, c) = c @@ -131,35 +304,24 @@ constructorName (RecC name _ ) = name constructorName (InfixC _ name _ ) = name constructorName (ForallC _ _ con) = constructorName con+#if MIN_VERSION_template_haskell(2,11,0)+constructorName (GadtC names _ _) = head names+constructorName (RecGadtC names _ _) = head names+#endif -- | 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] --- | Remove any occurrences of a forall-ed type variable from consideration.-removeForalled :: [TyVarBndr] -> Maybe TyVarInfo -> Maybe TyVarInfo-removeForalled _ Nothing = Nothing-removeForalled tvbs (Just tvi) = guard (not (foralled tvbs tvi)) >> Just tvi- where- foralled :: [TyVarBndr] -> TyVarInfo -> Bool- foralled tvbs' tvi' = fst tvi' `elem` map (NameBase . tvbName) tvbs'---- | Extracts the name from a TyVarBndr.-tvbName :: TyVarBndr -> Name-tvbName (PlainTV name) = name-tvbName (KindedTV name _) = name- -- | Extracts the kind from a TyVarBndr. tvbKind :: TyVarBndr -> Kind tvbKind (PlainTV _) = starK tvbKind (KindedTV _ k) = k --- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name).-replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr-replaceTyVarName tvb (SigT t _) = replaceTyVarName tvb t-replaceTyVarName (PlainTV _) (VarT n) = PlainTV n-replaceTyVarName (KindedTV _ k) (VarT n) = KindedTV n k-replaceTyVarName tvb _ = tvb+-- | Convert a TyVarBndr to a Type.+tvbToType :: TyVarBndr -> Type+tvbToType (PlainTV n) = VarT n+tvbToType (KindedTV n k) = SigT (VarT n) k -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred@@ -178,22 +340,24 @@ canEtaReduce :: [Type] -> [Type] -> Bool canEtaReduce remaining dropped = all isTyVar dropped- && allDistinct nbs -- 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 (`mentionsNameBase` nbs) remaining)+ && 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- nbs :: [NameBase]- nbs = map varTToNameBase dropped+ droppedNames :: [Name]+ droppedNames = map varTToName dropped --- | Extract the Name from a type variable.-varTToName :: Type -> Name-varTToName (VarT n) = n-varTToName (SigT t _) = varTToName t-varTToName _ = error "Not a type variable!"+-- | 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 NameBase from a type variable.-varTToNameBase :: Type -> NameBase-varTToNameBase = NameBase . varTToName+-- | 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@@ -211,11 +375,16 @@ isTyFamily (ConT n) = do info <- reify n return $ case info of-#if MIN_VERSION_template_haskell(2,7,0)+#if MIN_VERSION_template_haskell(2,11,0)+ FamilyI OpenTypeFamilyD{} _ -> True+#elif MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD TypeFam _ _ _) _ -> True #else TyConI (FamilyD TypeFam _ _ _) -> True #endif+#if MIN_VERSION_template_haskell(2,9,0)+ FamilyI ClosedTypeFamilyD{} _ -> True+#endif _ -> False isTyFamily _ = return False @@ -231,34 +400,28 @@ | otherwise = allDistinct' (Set.insert x uniqs) xs allDistinct' _ _ = True --- | Does the given type mention any of the NameBases in the list?-mentionsNameBase :: Type -> [NameBase] -> Bool-mentionsNameBase = go Set.empty+-- | Does the given type mention any of the Names in the list?+mentionsName :: Type -> [Name] -> Bool+mentionsName = go where- go :: Set NameBase -> Type -> [NameBase] -> Bool- go foralls (ForallT tvbs _ t) nbs =- go (foralls `Set.union` Set.fromList (map (NameBase . tvbName) tvbs)) t nbs- go foralls (AppT t1 t2) nbs = go foralls t1 nbs || go foralls t2 nbs- go foralls (SigT t _) nbs = go foralls t nbs- go foralls (VarT n) nbs = varNb `elem` nbs && not (varNb `Set.member` foralls)- where- varNb = NameBase n- go _ _ _ = False+ 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 NameBases in the list?-predMentionsNameBase :: Pred -> [NameBase] -> Bool+-- | Does an instance predicate mention any of the Names in the list?+predMentionsName :: Pred -> [Name] -> Bool #if MIN_VERSION_template_haskell(2,10,0)-predMentionsNameBase = mentionsNameBase+predMentionsName = mentionsName #else-predMentionsNameBase (ClassP _ tys) nbs = any (`mentionsNameBase` nbs) tys-predMentionsNameBase (EqualP t1 t2) nbs = mentionsNameBase t1 nbs || mentionsNameBase t2 nbs+predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys+predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names #endif --- | The number of arrows that compose the spine of a kind signature--- (e.g., (* -> *) -> k -> * has two arrows on its spine).-numKindArrows :: Kind -> Int-numKindArrows k = length (uncurryKind k) - 1- -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type applyTy = foldl' AppT@@ -282,66 +445,42 @@ unapplyTy = reverse . go where go :: Type -> [Type]- go (AppT t1 t2) = t2:go t1- go (SigT t _) = go t- go t = [t]+ go (AppT t1 t2) = t2:go t1+ go (SigT t _) = go t+ go (ForallT _ _ t) = go t+ go t = [t] -- | Split a type signature by the arrows on its spine. For example, this: -- -- @--- (Int -> String) -> Char -> ()+-- forall a b. (a ~ b) => (a -> b) -> Char -> () -- @ -- -- would split to this: -- -- @--- [Int -> String, Char, ()]+-- (a ~ b, [a -> b, Char, ()]) -- @-uncurryTy :: Type -> [Type]-uncurryTy (AppT (AppT ArrowT t1) t2) = t1:uncurryTy t2-uncurryTy (SigT t _) = uncurryTy t-uncurryTy t = [t]+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 = uncurryTy+uncurryKind = snd . uncurryTy #else uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 uncurryKind k = [k] #endif -wellKinded :: [Kind] -> Bool-wellKinded = all canRealizeKindStar---- | Of form k1 -> k2 -> ... -> kn, where k is either a single kind variable or *.-canRealizeKindStarChain :: Kind -> Bool-canRealizeKindStarChain = all canRealizeKindStar . uncurryKind--canRealizeKindStar :: Kind -> Bool-canRealizeKindStar k = case uncurryKind k of- [k'] -> case k' of-#if MIN_VERSION_template_haskell(2,8,0)- StarT -> True- (VarT _) -> True -- Kind k can be instantiated with *-#else- StarK -> True-#endif- _ -> False- _ -> False--distinctKindVars :: Kind -> Set Name-#if MIN_VERSION_template_haskell(2,8,0)-distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2-distinctKindVars (SigT k _) = distinctKindVars k-distinctKindVars (VarT k) = Set.singleton k-#endif-distinctKindVars _ = Set.empty--tvbToType :: TyVarBndr -> Type-tvbToType (PlainTV n) = VarT n-tvbToType (KindedTV n k) = SigT (VarT n) k- ------------------------------------------------------------------------------- -- Manually quoted names -------------------------------------------------------------------------------@@ -360,31 +499,93 @@ mkDerivingCompatName_v :: String -> String -> Name mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey +fmapConstValName :: Name+fmapConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "fmapConst"+ foldrConstValName :: Name foldrConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "foldrConst" foldMapConstValName :: Name foldMapConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "foldMapConst" +traverseConstValName :: Name+traverseConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "traverseConst"++dualDataName :: Name+dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"++endoDataName :: Name+endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"++wrapMonadDataName :: Name+wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad"++functorTypeName :: Name+functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"+ foldableTypeName :: Name foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" +traversableTypeName :: Name+traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"++appEndoValName :: Name+appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"++composeValName :: Name+composeValName = mkNameG_v "base" "GHC.Base" "."+ 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" +getDualValName :: Name+getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"++idValName :: Name+idValName = mkNameG_v "base" "GHC.Base" "id"++traverseValName :: Name+traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"++unwrapMonadValName :: Name+unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"++#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0))+starKindName :: Name+starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"+#endif+ #if MIN_VERSION_base(4,8,0)+pureValName :: Name+pureValName = mkNameG_v "base" "GHC.Base" "pure"++apValName :: Name+apValName = mkNameG_v "base" "GHC.Base" "<*>"+ mappendValName :: Name mappendValName = mkNameG_v "base" "GHC.Base" "mappend" memptyValName :: Name memptyValName = mkNameG_v "base" "GHC.Base" "mempty" #else+pureValName :: Name+pureValName = mkNameG_v "base" "Control.Applicative" "pure"++apValName :: Name+apValName = mkNameG_v "base" "Control.Applicative" "<*>"+ mappendValName :: Name mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"
src/Data/Foldable/Deriving.hs view
@@ -1,714 +1,52 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}- {-| Module: Data.Foldable.Deriving-Copyright: (C) 2015 Ryan Scott+Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Foldable' instances in a way that mimics-how the @-XDeriveFoldable@ extension works since GHC 7.12. These changes make it-possible to derive @Foldable@ instances for data types with existential constraints,-e.g.,+how the @-XDeriveFoldable@ extension works since GHC 8.0. -@-{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving, TemplateHaskell #-}+These changes make it possible to derive @Foldable@ instances for data types with+existential constraints, e.g., +@ data WrappedSet a where WrapSet :: Ord a => a -> WrappedSet a-deriving instance Foldable WrappedSet -- On GHC 7.12 on later++deriving instance Foldable WrappedSet -- On GHC 8.0 on later $(deriveFoldable ''WrappedSet) -- On GHC 7.10 and earlier @ +In addition, derived 'Foldable' instances from this module do not generate+superfluous 'mempty' expressions in its implementation of 'foldMap'. One can+verify this by compiling a module that uses 'deriveFoldable' with the+@-ddump-splices@ GHC flag.+ For more info on these changes, see <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>. -} module Data.Foldable.Deriving (- -- * 'deriveFoldable'- -- $derive+ -- * 'deriveFoldable' limitations+ -- $constraints deriveFoldable- -- * @make@- functions- -- $make , makeFoldMap , makeFoldr- ) where--import Control.Monad (guard)--import Data.Deriving.Internal-#if MIN_VERSION_template_haskell(2,7,0)-import Data.List (find)-#endif-import Data.Maybe-#if __GLASGOW_HASKELL__ < 710 && MIN_VERSION_template_haskell(2,8,0)-import qualified Data.Set as Set-#endif--import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Syntax------------------------------------------------------------------------------------ User-facing API----------------------------------------------------------------------------------{- $derive--'deriveFoldable' automatically generates a @Foldable@ instances for a given data-type, newtype, or data family instance that has at least one type variable. Examples:--@-{-# LANGUAGE TemplateHaskell #-}-import Data.Foldable.Deriving--data Pair a = Pair a a-$('deriveFoldable' ''Pair) -- instance Foldable Pair where ...--data Product f g a = Product (f a) (g a)-$('deriveFoldable' ''Product)--- instance (Foldable f, Foldable g) => Foldable (Pair f g) where ...-@--If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),-then @deriveFoldable@ can be used with data family instances (which requires the-@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance-constructor (NOT a data family name!) to @deriveFoldable@. Note that the-generated code may require the @-XFlexibleInstances@ extension. Example:--@-{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}-import Data.Foldable.Deriving--class AssocClass a b where- data AssocData a b-instance AssocClass Int b where- data AssocData Int b = AssocDataInt1 Int | AssocDataInt2 b-$('deriveFoldable' 'AssocDataInt1) -- instance Foldable (AssocData Int) where ...--- Alternatively, one could use $(deriveFoldable 'AssocDataInt2)-@--Note that there are some limitations:--* The 'Name' argument must not be a type synonym.--* The last type variable must be of kind @*@. Other type variables of kind @* -> *@- are assumed to require a 'Foldable' constraint. If your data type doesn't meet- this assumption, use a @make@ function.--* If using the @-XDatatypeContexts@ extension, a constraint cannot mention the last- type variable. For example, @data Illegal a where I :: Ord a => a -> Illegal a@- cannot have a derived 'Foldable' instance.--* If the last type variable is used within a constructor argument's type, it must- only be used in the last type argument. For example,- @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Foldable' instance,- but @data Illegal a b = Illegal (a, b, a, b)@ cannot.--* Data family instances must be able to eta-reduce the last type variable. In other- words, if you have a instance of the form:-- @- data family Family a1 ... an t- data instance Family e1 ... e2 v = ...- @-- Then the following conditions must hold:-- 1. @v@ must be a type variable.- 2. @v@ must not be mentioned in any of @e1@, ..., @e2@.--* In GHC 7.8, a bug exists that can cause problems when a data family declaration and- one of its data instances use different type variables, e.g.,-- @- data family Foo a b- data instance Foo Int z = Foo Int z- $(deriveFoldable 'Foo)- @-- To avoid this issue, it is recommened that you use the same type variables in the- same positions in which they appeared in the data family declaration:-- @- data family Foo a b- data instance Foo Int b = Foo Int b- $(deriveFoldable 'Foo)- @---}--{- $make--There may be scenarios in which you want to, say, fold over an arbitrary data type-or data family instance without having to make the type an instance of 'Foldable'. For-these cases, this module provides several functions (all prefixed with @make@-) that-splice the appropriate lambda expression into your source code.--This is particularly useful for creating instances for sophisticated data types. For-example, 'deriveFoldable' cannot infer the correct type context for-@newtype HigherKinded f a b = HigherKinded (f a b)@, since @f@ is of kind-@* -> * -> *@. However, it is still possible to create a 'Foldable' instance for-@HigherKinded@ without too much trouble using 'makeFoldr':+ , makeFold+ , makeFoldl+ ) where -@-{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}-import Data.Foldable.Deriving+import Data.Functor.Deriving.Internal -newtype HigherKinded f a b = HigherKinded (f a b)+{- $constraints -instance Foldable (f a) => Foldable (HigherKinded f a) where- foldr = $(makeFoldr ''HigherKinded)-@+Be aware of the following potential gotchas: +* If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an+ existential constraint cannot mention the last type variable. For example,+ @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived+ 'Functor' instance.+* Type variables of kind @* -> *@ are assumed to have 'Foldable' constraints.+ If this is not desirable, use @makeFoldr@ or @makeFoldMap@. -}------------------------------------------------------------------------------------ Code generation------------------------------------------------------------------------------------ | Generates a 'Foldable' instance declaration for the given data type or data--- family instance. This mimics how the @-XDeriveFoldable@ extension works since--- GHC 7.12.-deriveFoldable :: Name -> Q [Dec]-deriveFoldable tyConName = do- info <- reify tyConName- case info of- TyConI{} -> deriveFoldablePlainTy tyConName-#if MIN_VERSION_template_haskell(2,7,0)- DataConI{} -> deriveFoldableDataFamInst tyConName- FamilyI (FamilyD DataFam _ _ _) _ ->- error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."- FamilyI (FamilyD TypeFam _ _ _) _ ->- error $ ns ++ "Cannot use a type family name."- _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."-#else- DataConI{} -> dataConIError- _ -> error $ ns ++ "The name must be of a plain type constructor."-#endif- where- ns :: String- ns = "Data.Foldable.Deriving.deriveFoldable: "---- | Generates a Foldable instance declaration for a plain type constructor.-deriveFoldablePlainTy :: Name -> Q [Dec]-deriveFoldablePlainTy tyConName = withTyCon tyConName fromCons where- fromCons :: Cxt -> [TyVarBndr] -> [Con] -> Q [Dec]- fromCons ctxt tvbs cons = (:[]) `fmap`- instanceD (return instanceCxt)- (return $ AppT (ConT foldableTypeName) instanceType)- (foldFunDecs droppedNb cons)- where- (instanceCxt, instanceType, droppedNb:_) =- cxtAndTypePlainTy tyConName ctxt tvbs--#if MIN_VERSION_template_haskell(2,7,0)--- | Generates a Foldable instance declaration for a data family instance constructor.-deriveFoldableDataFamInst :: Name -> Q [Dec]-deriveFoldableDataFamInst dataFamInstName = withDataFamInstCon dataFamInstName fromDec where- fromDec :: [TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q [Dec]- fromDec famTvbs ctxt parentName instTys cons = (:[]) `fmap`- instanceD (return instanceCxt)- (return $ AppT (ConT foldableTypeName) instanceType)- (foldFunDecs droppedNb cons)- where- (instanceCxt, instanceType, droppedNb:_) =- cxtAndTypeDataFamInstCon parentName ctxt famTvbs instTys-#endif---- | Generates a the function declarations for foldr and foldMap.------ For why both foldr and foldMap are derived for Foldable, see Trac #7436.-foldFunDecs :: NameBase -> [Con] -> [Q Dec]-foldFunDecs nb cons = map makeFunD [Foldr, FoldMap] where- makeFunD :: FoldFun -> Q Dec- makeFunD fun =- funD (foldFunName fun)- [ clause []- (normalB $ makeFoldFunForCons fun nb cons)- []- ]---- | Generates a lambda expression which behaves like 'foldMap' (without requiring a--- 'Foldable' instance). This mimics how the @-XDeriveFoldable@ extension works since--- GHC 7.12.-makeFoldMap :: Name -> Q Exp-makeFoldMap = makeFoldFun FoldMap---- | Generates a lambda expression which behaves like 'foldr' (without requiring a--- 'Foldable' instance). This mimics how the @-XDeriveFoldable@ extension works since--- GHC 7.12.-makeFoldr :: Name -> Q Exp-makeFoldr = makeFoldFun Foldr---- | Generates a lambda expression which behaves like the FoldFun argument.-makeFoldFun :: FoldFun -> Name -> Q Exp-makeFoldFun fun tyConName = do- info <- reify tyConName- case info of- TyConI{} -> withTyCon tyConName $ \ctxt tvbs decs ->- let !nbs = thd3 $ cxtAndTypePlainTy tyConName ctxt tvbs- in makeFoldFunForCons fun (head nbs) decs-#if MIN_VERSION_template_haskell(2,7,0)- DataConI{} -> withDataFamInstCon tyConName $ \famTvbs ctxt parentName instTys cons ->- let !nbs = thd3 $ cxtAndTypeDataFamInstCon parentName ctxt famTvbs instTys- in makeFoldFunForCons fun (head nbs) cons- FamilyI (FamilyD DataFam _ _ _) _ ->- error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."- FamilyI (FamilyD TypeFam _ _ _) _ ->- error $ ns ++ "Cannot use a type family name."- _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."-#else- DataConI{} -> dataConIError- _ -> error $ ns ++ "The name must be of a plain type constructor."-#endif- where- ns :: String- ns = "Data.Foldable.Deriving.makeFoldFun: "---- | Generates a lambda expression for the given constructors.--- All constructors must be from the same type.-makeFoldFunForCons :: FoldFun -> NameBase -> [Con] -> Q Exp-makeFoldFunForCons fun nb cons = do- argNames <- mapM newName $ catMaybes [ Just "f"- , guard (fun == Foldr) >> Just "z"- , Just "value"- ]- let f:others = argNames- z = head others -- If we're deriving foldr, this will be well defined- -- and useful. Otherwise, it'll be ignored.- value = last others- mbTvi = Just (nb, f)- lamE (map varP argNames)- . appsE- $ [ varE $ foldFunConstName fun- , if null cons- then appE (varE errorValName)- (stringE $ "Void " ++ nameBase (foldFunName fun))- else caseE (varE value)- (map (makeFoldFunForCon fun z mbTvi) cons)- ] ++ map varE argNames---- | Generates a lambda expression for a single constructor.-makeFoldFunForCon :: FoldFun -> Name -> Maybe TyVarInfo -> Con -> Q Match-makeFoldFunForCon fun z mbTvi (NormalC conName tys) = do- args <- newNameList "arg" $ length tys- let argTys = map snd tys- makeFoldFunForArgs fun z mbTvi conName argTys args-makeFoldFunForCon fun z mbTvi (RecC conName tys) = do- args <- newNameList "arg" $ length tys- let argTys = map thd3 tys- makeFoldFunForArgs fun z mbTvi conName argTys args-makeFoldFunForCon fun z mbTvi (InfixC (_, argTyL) conName (_, argTyR)) = do- argL <- newName "argL"- argR <- newName "argR"- makeFoldFunForArgs fun z mbTvi conName [argTyL, argTyR] [argL, argR]-makeFoldFunForCon fun z mbTvi (ForallC tvbs _ con)- = makeFoldFunForCon fun z (removeForalled tvbs mbTvi) con---- | Generates a lambda expression for a single constructor's arguments.-makeFoldFunForArgs :: FoldFun- -> Name- -> Maybe TyVarInfo- -> Name- -> [Type]- -> [Name]- -> Q Match-makeFoldFunForArgs fun z mbTvi conName tys args =- match (conP conName $ map varP args)- (normalB $ foldFunCombine fun z mappedArgs)- []- where- mappedArgs :: [Q Exp]- mappedArgs = zipWith (makeFoldFunForArg fun mbTvi conName) tys args---- | Generates a lambda expression for a single argument of a constructor.-makeFoldFunForArg :: FoldFun- -> Maybe TyVarInfo- -> Name- -> Type- -> Name- -> Q Exp-makeFoldFunForArg fun mbTvi conName ty tyExpName = do- ty' <- expandSyn ty- makeFoldFunForType fun mbTvi conName ty' `appE` varE tyExpName---- | Generates a lambda expression for a specific type.-makeFoldFunForType :: FoldFun- -> Maybe TyVarInfo- -> Name- -> Type- -> Q Exp-makeFoldFunForType fun mbTvi _ (VarT tyName) =- maybe (foldFunTriv fun) (\(nb, mapName) ->- if NameBase tyName == nb- then varE mapName- else foldFunTriv fun) mbTvi-makeFoldFunForType fun mbTvi conName (SigT ty _) =- makeFoldFunForType fun mbTvi conName ty-makeFoldFunForType fun mbTvi conName (ForallT tvbs _ ty) =- makeFoldFunForType fun (removeForalled tvbs mbTvi) conName ty-makeFoldFunForType fun mbTvi conName ty =- let tyCon :: Type- tyArgs :: [Type]- tyCon:tyArgs = unapplyTy ty-- numLastArgs :: Int- numLastArgs = min 1 $ length tyArgs-- lhsArgs, rhsArgs :: [Type]- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- tyVarNameBase :: [NameBase]- tyVarNameBase = maybeToList $ fmap fst mbTvi-- mentionsTyArgs :: Bool- mentionsTyArgs = any (`mentionsNameBase` tyVarNameBase) tyArgs-- makeFoldFunTuple :: Type -> Name -> Q Exp- makeFoldFunTuple fieldTy fieldName =- makeFoldFunForType fun mbTvi conName fieldTy `appE` varE fieldName-- in case tyCon of- ArrowT -> noFunctionsError conName- TupleT n- | n > 0 && mentionsTyArgs -> do- args <- mapM newName $ catMaybes [ Just "x"- , guard (fun == Foldr) >> Just "z"- ]- xs <- newNameList "tup" n-- let x = head args- z = last args- lamE (map varP args) $ caseE (varE x)- [ match (tupP $ map varP xs)- (normalB $ foldFunCombine fun- z- (zipWith makeFoldFunTuple tyArgs xs)- )- []- ]- _ -> do- itf <- isTyFamily tyCon- if any (`mentionsNameBase` tyVarNameBase) lhsArgs || (itf && mentionsTyArgs)- then outOfPlaceTyVarError conName (head tyVarNameBase)- else if any (`mentionsNameBase` tyVarNameBase) rhsArgs- then foldFunApp fun . appsE $- ( varE (foldFunName fun)- : map (makeFoldFunForType fun mbTvi conName) rhsArgs- )- else foldFunTriv fun------------------------------------------------------------------------------------ Template Haskell reifying and AST manipulation------------------------------------------------------------------------------------ | Extracts a plain type constructor's information.-withTyCon :: Name- -> (Cxt -> [TyVarBndr] -> [Con] -> Q a)- -> Q a-withTyCon name f = do- info <- reify name- case info of- TyConI dec ->- case dec of- DataD ctxt _ tvbs cons _ -> f ctxt tvbs cons- NewtypeD ctxt _ tvbs con _ -> f ctxt tvbs [con]- _ -> error $ ns ++ "Unsupported type " ++ show dec ++ ". Must be a data type or newtype."- _ -> error $ ns ++ "The name must be of a plain type constructor."- where- ns :: String- ns = "Data.Foldable.Deriving.withTyCon: "--#if MIN_VERSION_template_haskell(2,7,0)--- | Extracts a data family name's information.-withDataFam :: Name- -> ([TyVarBndr] -> [Dec] -> Q a)- -> Q a-withDataFam name f = do- info <- reify name- case info of- FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs- FamilyI (FamilyD TypeFam _ _ _) _ -> error $ ns ++ "Cannot use a type family name."- _ -> error $ ns ++ "Unsupported type " ++ show info ++ ". Must be a data family name."- where- ns :: String- ns = "Data.Foldable.Deriving.withDataFam: "---- | Extracts a data family instance constructor's information.-withDataFamInstCon :: Name- -> ([TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q a)- -> Q a-withDataFamInstCon dficName f = do- dficInfo <- reify dficName- case dficInfo of- DataConI _ _ parentName _ -> do- parentInfo <- reify parentName- case parentInfo of- FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \famTvbs decs ->- let sameDefDec = flip find decs $ \dec ->- case dec of- DataInstD _ _ _ cons' _ -> any ((dficName ==) . constructorName) cons'- NewtypeInstD _ _ _ con _ -> dficName == constructorName con- _ -> error $ ns ++ "Must be a data or newtype instance."-- (ctxt, instTys, cons) = case sameDefDec of- Just (DataInstD ctxt' _ instTys' cons' _) -> (ctxt', instTys', cons')- Just (NewtypeInstD ctxt' _ instTys' con _) -> (ctxt', instTys', [con])- _ -> error $ ns ++ "Could not find data or newtype instance constructor."-- in f famTvbs ctxt parentName instTys cons- _ -> error $ ns ++ "Data constructor " ++ show dficName ++ " is not from a data family instance."- _ -> error $ ns ++ "Unsupported type " ++ show dficInfo ++ ". Must be a data family instance constructor."- where- ns :: String- ns = "Data.Foldable.Deriving.withDataFamInstCon: "-#endif---- | Deduces the instance context, instance head, and eta-reduced type variables--- for a plain data type constructor.-cxtAndTypePlainTy :: Name -- The datatype's name- -> Cxt -- The datatype context- -> [TyVarBndr] -- The type variables- -> (Cxt, Type, [NameBase])-cxtAndTypePlainTy tyConName dataCxt tvbs- | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have a well-kinded type variable- = derivingKindError tyConName- | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable is mentioned in a datatype context- = datatypeContextError tyConName instanceType- | otherwise = (instanceCxt, instanceType, droppedNbs)- where- instanceCxt :: Cxt- instanceCxt = mapMaybe applyConstraint remaining-- instanceType :: Type- instanceType = applyTyCon tyConName $ map (VarT . tvbName) remaining-- remainingLength :: Int- remainingLength = length tvbs - 1-- remaining, dropped :: [TyVarBndr]- (remaining, dropped) = splitAt remainingLength tvbs-- droppedKinds :: [Kind]- droppedKinds = map tvbKind dropped-- droppedNbs :: [NameBase]- droppedNbs = map (NameBase . tvbName) dropped--#if MIN_VERSION_template_haskell(2,7,0)--- | Deduces the instance context, instance head, and eta-reduced type variable--- for a data family instance constructor.-cxtAndTypeDataFamInstCon :: Name -- The data family name- -> Cxt -- The datatype context- -> [TyVarBndr] -- The data family declaration's type variables- -> [Type] -- The data family instance types- -> (Cxt, Type, [NameBase])-cxtAndTypeDataFamInstCon parentName dataCxt famTvbs instTysAndKinds- | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have a well-kinded type variable- = derivingKindError parentName- | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable is mentioned in a datatype context- = datatypeContextError parentName instanceType- | canEtaReduce remaining dropped -- If it is safe to drop the type variable- = (instanceCxt, instanceType, droppedNbs)- | otherwise = etaReductionError instanceType- where- instanceCxt :: Cxt- instanceCxt = mapMaybe applyConstraint lhsTvbs-- -- We need to make sure that type variables in the instance head which have- -- constraints aren't poly-kinded, e.g.,- --- -- @- -- instance Foldable f => Foldable (Foo (f :: k)) where- -- @- --- -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').- instanceType :: Type- instanceType = applyTyCon parentName- $ map unSigT remaining-- remainingLength :: Int- remainingLength = length famTvbs - 1-- remaining, dropped :: [Type]- (remaining, dropped) = splitAt remainingLength rhsTypes-- droppedKinds :: [Kind]- droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs-- droppedNbs :: [NameBase]- droppedNbs = map varTToNameBase dropped-- -- We need to be mindful of an old GHC bug which causes kind variables to appear in- -- @instTysAndKinds@ (as the name suggests) if- --- -- (1) @PolyKinds@ is enabled- -- (2) either GHC 7.6 or 7.8 is being used (for more info, see Trac #9692).- --- -- Since Template Haskell doesn't seem to have a mechanism for detecting which- -- language extensions are enabled, we do the next-best thing by counting- -- the number of distinct kind variables in the data family declaration, and- -- then dropping that number of entries from @instTysAndKinds@.- instTypes :: [Type]- instTypes =-# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))- instTysAndKinds-# else- drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs)- instTysAndKinds-# endif-- lhsTvbs :: [TyVarBndr]- lhsTvbs = map (uncurry replaceTyVarName)- . filter (isTyVar . snd)- . take remainingLength- $ zip famTvbs rhsTypes-- -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable- -- in @instTypes@ are provided (as a result of a bug reported in Trac #9692). This- -- is pretty inconvenient, as it makes it impossible to come up with the correct- -- instance types in some cases. For example, consider the following code:- --- -- @- -- data family Foo a b- -- data instance Foo Int z = Foo Int z- -- $(deriveFoldable 'Foo)- -- @- --- -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of- -- the type variable in the data instance (@z@). As a result, we won't know to which- -- fields of the 'Foo' constructor to apply the map functions, which will result- -- in an incorrect instance. Urgh.- --- -- A workaround is to ensure that you use the exact same type variables, in the- -- exact same order, in the data family declaration and any data or newtype- -- instances:- --- -- @- -- data family Foo a b- -- data instance Foo Int b = Foo Int b- -- $(deriveFoldable 'Foo)- -- @- --- -- Thankfully, other versions of GHC don't seem to have this bug.- rhsTypes :: [Type]- rhsTypes =-# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710- instTypes ++ map tvbToType (drop (length instTypes) famTvbs)-# else- instTypes-# endif-#endif---- | Given a TyVarBndr, apply a Foldable constraint to it if it has the right kind.-applyConstraint :: TyVarBndr -> Maybe Pred-applyConstraint (PlainTV _) = Nothing-applyConstraint (KindedTV name kind) = do- guard $ numKindArrows kind == 1 && canRealizeKindStarChain kind- Just $ applyClass foldableTypeName name------------------------------------------------------------------------------------ Error messages------------------------------------------------------------------------------------ | Either the given data type doesn't have a type variable, or the type variable--- to be eta-reduced cannot realize kind *.-derivingKindError :: Name -> a-derivingKindError tyConName = error- . showString "Cannot derive well-kinded instance of form ‘Foldable "- . showParen True- ( showString (nameBase tyConName)- . showString " ..."- )- . showString "‘\n\tClass Foldable expects an argument of kind * -> *"- $ ""---- | A constructor has a function argument.-noFunctionsError :: Name -> a-noFunctionsError conName = error- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must not contain function types"- $ ""---- | The data type has a DatatypeContext which mentions the eta-reduced type variable.-datatypeContextError :: Name -> Type -> a-datatypeContextError dataName instanceType = error- . 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"- $ ""---- | The data type mentions the eta-reduced type variable in a place other--- than the last position of a data type in a constructor's field.-outOfPlaceTyVarError :: Name -> NameBase -> a-outOfPlaceTyVarError conName tyVarName = error- . showString "Constructor ‘"- . showString (nameBase conName)- . showString "‘ must use the type variable "- . shows tyVarName- . showString " only in the last argument of a data type"- $ ""--#if MIN_VERSION_template_haskell(2,7,0)--- | The last type variable cannot be eta-reduced (see the canEtaReduce--- function for the criteria it would have to meet).-etaReductionError :: Type -> a-etaReductionError instanceType = error $- "Cannot eta-reduce to an instance of form \n\tinstance (...) => "- ++ pprint instanceType-#else--- | Template Haskell didn't list all of a data family's instances upon reification--- until template-haskell-2.7.0.0, which is necessary for a derived instance to work.-dataConIError :: a-dataConIError = error- . showString "Cannot use a data constructor."- . showString "\n\t(Note: if you are trying to derive for a data family instance,"- . showString "\n\tuse GHC >= 7.4 instead.)"- $ ""-#endif------------------------------------------------------------------------------------ Class-specific constants------------------------------------------------------------------------------------ | A representation of which function is being generated.-data FoldFun = Foldr | FoldMap- deriving Eq--foldFunConstName :: FoldFun -> Name-foldFunConstName Foldr = foldrConstValName-foldFunConstName FoldMap = foldMapConstValName--foldFunName :: FoldFun -> Name-foldFunName Foldr = foldrValName-foldFunName FoldMap = foldMapValName---- See Trac #7436 for why explicit lambdas are used-foldFunTriv :: FoldFun -> Q Exp-foldFunTriv Foldr = do- z <- newName "z"- lamE [wildP, varP z] $ varE z-foldFunTriv FoldMap = lamE [wildP] $ varE memptyValName--foldFunApp :: FoldFun -> Q Exp -> Q Exp-foldFunApp Foldr e = do- x <- newName "x"- z <- newName "z"- lamE [varP x, varP z] $ appsE [e, varE z, varE x]-foldFunApp FoldMap e = e--foldFunCombine :: FoldFun -> Name -> [Q Exp] -> Q Exp-foldFunCombine Foldr = foldrCombine-foldFunCombine FoldMap = foldMapCombine--foldrCombine :: Name -> [Q Exp] -> Q Exp-foldrCombine zName = foldr appE (varE zName)--foldMapCombine :: Name -> [Q Exp] -> Q Exp-foldMapCombine _ [] = varE memptyValName-foldMapCombine _ es = foldr1 (appE . appE (varE mappendValName)) es
+ src/Data/Functor/Deriving.hs view
@@ -0,0 +1,28 @@+{-|+Module: Data.Functor.Deriving+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Functor' instances.++For more info on how deriving @Functor@ works, see+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.+-}+module Data.Functor.Deriving (+ -- * 'deriveFunctor' limitations+ -- $constraints+ deriveFunctor+ , makeFmap+ ) where++import Data.Functor.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* Type variables of kind @* -> *@ are assumed to have 'Functor' constraints.+ If this is not desirable, use @makeFmap@'.+-}
+ src/Data/Functor/Deriving/Internal.hs view
@@ -0,0 +1,1013 @@+{-# LANGUAGE CPP #-}+{-|+Module: Data.Functor.Deriving.Internal+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances.++For more info on how deriving @Functor@ works, see+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.+-}+module Data.Functor.Deriving.Internal (+ -- * 'Foldable'+ deriveFoldable+ , makeFoldMap+ , makeFoldr+ , makeFold+ , makeFoldl+ -- * 'Functor'+ , deriveFunctor+ , makeFmap+ -- * 'Traversable'+ , deriveTraversable+ , makeTraverse+ , makeSequenceA+ , makeMapM+ , makeSequence+ ) where++import Control.Monad (guard, unless, when, zipWithM)++import Data.Deriving.Internal+import Data.Either (rights)+#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))+import Data.Foldable (foldr')+#endif+import Data.List+import qualified Data.Map as Map (fromList, keys, lookup, size)+import Data.Maybe++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Syntax++-- | Generates a 'Foldable' instance declaration for the given data type or data+-- family instance.+deriveFoldable :: Name -> Q [Dec]+deriveFoldable = deriveFunctorClass Foldable++-- | Generates a lambda expression which behaves like 'foldMap' (without requiring a+-- 'Foldable' instance).+makeFoldMap :: Name -> Q Exp+makeFoldMap = makeFunctorFun FoldMap++-- | Generates a lambda expression which behaves like 'foldr' (without requiring a+-- 'Foldable' instance).+makeFoldr :: Name -> Q Exp+makeFoldr = makeFunctorFun Foldr++-- | Generates a lambda expression which behaves like 'fold' (without requiring a+-- 'Foldable' instance).+makeFold :: Name -> Q Exp+makeFold name = makeFoldMap name `appE` varE idValName++-- | Generates a lambda expression which behaves like 'foldl' (without requiring a+-- 'Foldable' instance).+makeFoldl :: Name -> Q Exp+makeFoldl name = do+ f <- newName "f"+ z <- newName "z"+ t <- newName "t"+ lamE [varP f, varP z, varP t] $+ appsE [ varE appEndoValName+ , appsE [ varE getDualValName+ , appsE [ makeFoldMap name, foldFun f, varE t]+ ]+ , varE z+ ]+ where+ foldFun :: Name -> Q Exp+ foldFun n = infixApp (conE dualDataName)+ (varE composeValName)+ (infixApp (conE endoDataName)+ (varE composeValName)+ (varE flipValName `appE` varE n)+ )++-- | Generates a 'Functor' instance declaration for the given data type or data+-- family instance.+deriveFunctor :: Name -> Q [Dec]+deriveFunctor = deriveFunctorClass Functor++-- | Generates a lambda expression which behaves like 'fmap' (without requiring a+-- 'Functor' instance).+makeFmap :: Name -> Q Exp+makeFmap = makeFunctorFun Fmap++-- | Generates a 'Traversable' instance declaration for the given data type or data+-- family instance.+deriveTraversable :: Name -> Q [Dec]+deriveTraversable = deriveFunctorClass Traversable++-- | Generates a lambda expression which behaves like 'traverse' (without requiring a+-- 'Traversable' instance).+makeTraverse :: Name -> Q Exp+makeTraverse = makeFunctorFun Traverse++-- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a+-- 'Traversable' instance).+makeSequenceA :: Name -> Q Exp+makeSequenceA name = makeTraverse name `appE` varE idValName++-- | Generates a lambda expression which behaves like 'mapM' (without requiring a+-- 'Traversable' instance).+makeMapM :: Name -> Q Exp+makeMapM name = do+ f <- newName "f"+ lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $+ makeTraverse name `appE` wrapMonadExp f+ where+ wrapMonadExp :: Name -> Q Exp+ wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n)++-- | Generates a lambda expression which behaves like 'sequence' (without requiring a+-- 'Traversable' instance).+makeSequence :: Name -> Q Exp+makeSequence name = makeMapM name `appE` varE idValName++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | Derive a class instance declaration (depending on the FunctorClass argument's value).+deriveFunctorClass :: FunctorClass -> Name -> Q [Dec]+deriveFunctorClass fc name = withType name fromCons where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]+ fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do+ (instanceCxt, instanceType)+ <- buildTypeInstance fc name' ctxt tvbs mbTys+ instanceD (return instanceCxt)+ (return instanceType)+ (functorFunDecs fc cons)++-- | Generates a declaration defining the primary function(s) corresponding to a+-- particular class (fmap for Functor, foldr and foldMap for Foldable, and+-- traverse for Traversable).+--+-- For why both foldr and foldMap are derived for Foldable, see Trac #7436.+functorFunDecs :: FunctorClass -> [Con] -> [Q Dec]+functorFunDecs fc cons = map makeFunD $ functorClassToFuns fc where+ makeFunD :: FunctorFun -> Q Dec+ makeFunD ff =+ funD (functorFunName ff)+ [ clause []+ (normalB $ makeFunctorFunForCons ff cons)+ []+ ]++-- | Generates a lambda expression which behaves like the FunctorFun argument.+makeFunctorFun :: FunctorFun -> Name -> Q Exp+makeFunctorFun ff name = withType name fromCons where+ fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp+ fromCons name' ctxt tvbs cons mbTys =+ -- We force buildTypeInstance here since it performs some checks for whether+ -- or not the provided datatype can actually have fmap/foldr/traverse/etc.+ -- implemented for it, and produces errors if it can't.+ buildTypeInstance (functorFunToClass ff) name' ctxt tvbs mbTys+ `seq` makeFunctorFunForCons ff cons++-- | Generates a lambda expression for the given constructors.+-- All constructors must be from the same type.+makeFunctorFunForCons :: FunctorFun -> [Con] -> Q Exp+makeFunctorFunForCons ff cons = do+ argNames <- mapM newName $ catMaybes [ Just "f"+ , guard (ff == Foldr) >> Just "z"+ , Just "value"+ ]+ let mapFun:others = argNames+ z = head others -- If we're deriving foldr, this will be well defined+ -- and useful. Otherwise, it'll be ignored.+ value = last others+ lamE (map varP argNames)+ . appsE+ $ [ varE $ functorFunConstName ff+ , if null cons+ then appE (varE errorValName)+ (stringE $ "Void " ++ nameBase (functorFunName ff))+ else caseE (varE value)+ (map (makeFunctorFunForCon ff z mapFun) cons)+ ] ++ map varE argNames++-- | Generates a lambda expression for a single constructor.+makeFunctorFunForCon :: FunctorFun -> Name -> Name -> Con -> Q Match+makeFunctorFunForCon ff z mapFun con = do+ let conName = constructorName con+ (ts, tvMap) <- reifyConTys ff conName mapFun+ argNames <- newNameList "_arg" $ length ts+ makeFunctorFunForArgs ff z tvMap conName ts argNames++-- | Generates a lambda expression for a single constructor's arguments.+makeFunctorFunForArgs :: FunctorFun+ -> Name+ -> TyVarMap+ -> Name+ -> [Type]+ -> [Name]+ -> Q Match+makeFunctorFunForArgs ff z tvMap conName tys args =+ match (conP conName $ map varP args)+ (normalB $ functorFunCombine ff conName z args mappedArgs)+ []+ where+ mappedArgs :: Q [Either Exp Exp]+ mappedArgs = zipWithM (makeFunctorFunForArg ff tvMap conName) tys args++-- | Generates a lambda expression for a single argument of a constructor.+-- The returned value is 'Right' if its type mentions the last type+-- parameter. Otherwise, it is 'Left'.+makeFunctorFunForArg :: FunctorFun+ -> TyVarMap+ -> Name+ -> Type+ -> Name+ -> Q (Either Exp Exp)+makeFunctorFunForArg ff tvMap conName ty tyExpName =+ makeFunctorFunForType ff tvMap conName True ty `appEitherE` varE tyExpName++-- | Generates a lambda expression for a specific type. The returned value is+-- 'Right' if its type mentions the last type parameter. Otherwise,+-- it is 'Left'.+makeFunctorFunForType :: FunctorFun+ -> TyVarMap+ -> Name+ -> Bool+ -> Type+ -> Q (Either Exp Exp)+makeFunctorFunForType ff tvMap conName covariant (VarT tyName) =+ case Map.lookup tyName tvMap of+ Just mapName -> fmap Right $+ if covariant+ then varE mapName+ else contravarianceError conName+ -- Invariant: this should only happen when deriving fmap+ Nothing -> fmap Left $ functorFunTriv ff+makeFunctorFunForType ff tvMap conName covariant (SigT ty _) =+ makeFunctorFunForType ff tvMap conName covariant ty+makeFunctorFunForType ff tvMap conName covariant (ForallT _ _ ty) =+ makeFunctorFunForType ff tvMap conName covariant ty+makeFunctorFunForType ff tvMap conName covariant ty =+ let tyCon :: Type+ tyArgs :: [Type]+ tyCon:tyArgs = unapplyTy ty++ numLastArgs :: Int+ numLastArgs = min 1 $ length tyArgs++ lhsArgs, rhsArgs :: [Type]+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++ tyVarNames :: [Name]+ tyVarNames = Map.keys tvMap++ mentionsTyArgs :: Bool+ mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs++ makeFunctorFunTuple :: Type -> Name -> Q (Either Exp Exp)+ makeFunctorFunTuple fieldTy fieldName =+ makeFunctorFunForType ff tvMap conName covariant fieldTy+ `appEitherE` varE fieldName++ in case tyCon of+ ArrowT+ | not (allowFunTys (functorFunToClass ff)) -> noFunctionsError conName+ | mentionsTyArgs, [argTy, resTy] <- tyArgs ->+ do x <- newName "x"+ b <- newName "b"+ fmap Right . lamE [varP x, varP b] $+ covFunctorFun covariant resTy `appE` (varE x `appE`+ (covFunctorFun (not covariant) argTy `appE` varE b))+ where+ covFunctorFun :: Bool -> Type -> Q Exp+ covFunctorFun cov = fmap fromEither . makeFunctorFunForType ff tvMap conName cov+ TupleT n+ | n > 0 && mentionsTyArgs -> do+ args <- mapM newName $ catMaybes [ Just "x"+ , guard (ff == Foldr) >> Just "z"+ ]+ xs <- newNameList "_tup" n++ let x = head args+ z = last args+ fmap Right $ lamE (map varP args) $ caseE (varE x)+ [ match (tupP $ map varP xs)+ (normalB $ functorFunCombine ff+ (tupleDataName n)+ z+ xs+ (zipWithM makeFunctorFunTuple tyArgs xs)+ )+ []+ ]+ _ -> do+ itf <- isTyFamily tyCon+ if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)+ then outOfPlaceTyVarError conName+ else if any (`mentionsName` tyVarNames) rhsArgs+ then fmap Right . functorFunApp ff . appsE $+ ( varE (functorFunName ff)+ : map (fmap fromEither . makeFunctorFunForType ff tvMap conName covariant)+ rhsArgs+ )+ else fmap Left $ functorFunTriv ff++-------------------------------------------------------------------------------+-- Template Haskell reifying and AST manipulation+-------------------------------------------------------------------------------++-- | Boilerplate for top level splices.+--+-- The given Name must meet one of two criteria:+--+-- 1. It must be the name of a type constructor of a plain data type or newtype.+-- 2. It must be the name of a data family instance or newtype instance constructor.+--+-- Any other value will result in an exception.+withType :: Name+ -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)+ -> Q a+withType name f = do+ info <- reify name+ case info of+ TyConI dec ->+ case dec of+ DataD ctxt _ tvbs+#if MIN_VERSION_template_haskell(2,11,0)+ _+#endif+ cons _ -> f name ctxt tvbs cons Nothing+ NewtypeD ctxt _ tvbs+#if MIN_VERSION_template_haskell(2,11,0)+ _+#endif+ con _ -> f name ctxt tvbs [con] Nothing+ _ -> fail $ ns ++ "Unsupported type: " ++ show dec+#if MIN_VERSION_template_haskell(2,7,0)+# if MIN_VERSION_template_haskell(2,11,0)+ DataConI _ _ parentName -> do+# else+ DataConI _ _ parentName _ -> do+# endif+ parentInfo <- reify parentName+ case parentInfo of+# if MIN_VERSION_template_haskell(2,11,0)+ FamilyI (DataFamilyD _ tvbs _) decs ->+# else+ FamilyI (FamilyD DataFam _ tvbs _) decs ->+# endif+ let instDec = flip find decs $ \dec -> case dec of+ DataInstD _ _ _+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ cons _ -> any ((name ==) . constructorName) cons+ NewtypeInstD _ _ _+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ con _ -> name == constructorName con+ _ -> error $ ns ++ "Must be a data or newtype instance."+ in case instDec of+ Just (DataInstD ctxt _ instTys+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ cons _)+ -> f parentName ctxt tvbs cons $ Just instTys+ Just (NewtypeInstD ctxt _ instTys+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ con _)+ -> f parentName ctxt tvbs [con] $ Just instTys+ _ -> fail $ ns +++ "Could not find data or newtype instance constructor."+ _ -> fail $ ns ++ "Data constructor " ++ show name +++ " is not from a data family instance constructor."+# if MIN_VERSION_template_haskell(2,11,0)+ FamilyI DataFamilyD{} _ ->+# else+ FamilyI (FamilyD DataFam _ _ _) _ ->+# endif+ fail $ ns +++ "Cannot use a data family name. Use a data family instance constructor instead."+ _ -> fail $ ns ++ "The name must be of a plain data type constructor, "+ ++ "or a data family instance constructor."+#else+ DataConI{} -> dataConIError+ _ -> fail $ ns ++ "The name must be of a plain type constructor."+#endif+ where+ ns :: String+ ns = "Data.Functor.Deriving.Internal.withType: "++-- | Deduces the instance context and head for an instance.+buildTypeInstance :: FunctorClass+ -- ^ Functor, Foldable, or Traversable+ -> Name+ -- ^ The type constructor or data family name+ -> Cxt+ -- ^ The datatype context+ -> [TyVarBndr]+ -- ^ The type variables from the data type/data family declaration+ -> Maybe [Type]+ -- ^ 'Just' the types used to instantiate a data family instance,+ -- or 'Nothing' if it's a plain data type+ -> Q (Cxt, Type)+-- Plain data type/newtype case+buildTypeInstance fc tyConName dataCxt tvbs Nothing =+ let varTys :: [Type]+ varTys = map tvbToType tvbs+ in buildTypeInstanceFromTys fc tyConName dataCxt varTys False+-- Data family instance case+--+-- The CPP is present to work around a couple of annoying old GHC bugs.+-- See Note [Polykinded data families in Template Haskell]+buildTypeInstance fc parentName dataCxt tvbs (Just instTysAndKinds) = do+#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)+ let instTys :: [Type]+ instTys = zipWith stealKindForType tvbs instTysAndKinds+#else+ let kindVarNames :: [Name]+ kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs++ numKindVars :: Int+ numKindVars = length kindVarNames++ givenKinds, givenKinds' :: [Kind]+ givenTys :: [Type]+ (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds+ givenKinds' = map sanitizeStars givenKinds++ -- A GHC 7.6-specific bug requires us to replace all occurrences of+ -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.+ -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.+ sanitizeStars :: Kind -> Kind+ sanitizeStars = go+ where+ go :: Kind -> Kind+ go (AppT t1 t2) = AppT (go t1) (go t2)+ go (SigT t k) = SigT (go t) (go k)+ go (ConT n) | n == starKindName = StarT+ go t = t++ -- If we run this code with GHC 7.8, we might have to generate extra type+ -- variables to compensate for any type variables that Template Haskell+ -- eta-reduced away.+ -- See Note [Polykinded data families in Template Haskell]+ xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)++ let xTys :: [Type]+ xTys = map VarT xTypeNames+ -- ^ Because these type variables were eta-reduced away, we can only+ -- determine their kind by using stealKindForType. Therefore, we mark+ -- them as VarT to ensure they will be given an explicit kind annotation+ -- (and so the kind inference machinery has the right information).++ substNamesWithKinds :: [(Name, Kind)] -> Type -> Type+ substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks++ -- The types from the data family instance might not have explicit kind+ -- annotations, which the kind machinery needs to work correctly. To+ -- compensate, we use stealKindForType to explicitly annotate any+ -- types without kind annotations.+ instTys :: [Type]+ instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))+ -- ^ Note that due to a GHC 7.8-specific bug+ -- (see Note [Polykinded data families in Template Haskell]),+ -- there may be more kind variable names than there are kinds+ -- to substitute. But this is OK! If a kind is eta-reduced, it+ -- means that is was not instantiated to something more specific,+ -- so we need not substitute it. Using stealKindForType will+ -- grab the correct kind.+ $ zipWith stealKindForType tvbs (givenTys ++ xTys)+#endif+ buildTypeInstanceFromTys fc parentName dataCxt instTys True++-- For the given Types, generate an instance context and head. Coming up with+-- the instance type isn't as simple as dropping the last type, as you need to+-- be wary of kinds being instantiated with *.+-- See Note [Type inference in derived instances]+buildTypeInstanceFromTys :: FunctorClass+ -- ^ Functor, Foldable, or Traversable+ -> Name+ -- ^ The type constructor or data family name+ -> Cxt+ -- ^ The datatype context+ -> [Type]+ -- ^ The types to instantiate the instance with+ -> Bool+ -- ^ True if it's a data family, False otherwise+ -> Q (Cxt, Type)+buildTypeInstanceFromTys fc tyConName dataCxt varTysOrig isDataFamily = 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 expandSyn varTysOrig++ let remainingLength :: Int+ remainingLength = length varTysOrig - 1++ 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 fc 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 = concatMap tyVarNamesOfType 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 fc 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 fc) 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++ 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 $ functorClassName fc)+ $ 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 :: FunctorClass -> Type -> (Maybe Pred, [Name])+deriveConstraint fc t+ | not (isTyVar t) = (Nothing, [])+ | otherwise = case hasKindVarChain 1 t of+ Just ns -> (Just (applyClass (functorClassName fc) tName), ns)+ Nothing -> (Nothing, [])+ where+ tName :: Name+ tName = varTToName t++{-+Note [Polykinded data families in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In order to come up with the correct instance context and head for an instance, e.g.,++ instance C a => C (Data a) where ...++We need to know the exact types and kinds used to instantiate the instance. For+plain old datatypes, this is simple: every type must be a type variable, and+Template Haskell reliably tells us the type variables and their kinds.++Doing the same for data families proves to be much harder for three reasons:++1. On any version of Template Haskell, it may not tell you what an instantiated+ type's kind is. For instance, in the following data family instance:++ data family Fam (f :: * -> *) (a :: *)+ data instance Fam f a++ Then if we use TH's reify function, it would tell us the TyVarBndrs of the+ data family declaration are:++ [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]++ and the instantiated types of the data family instance are:++ [VarT f1,VarT a1]++ We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we+ have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the+ kind is in case an instantiated type isn't a SigT, so we use the stealKindForType+ function to ensure all of the instantiated types are SigTs before passing them+ to buildTypeInstanceFromTys.+2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of+ the specified kinds of a data family instance efore any of the instantiated+ types. Fortunately, this is easy to deal with: you simply count the number of+ distinct kind variables in the data family declaration, take that many elements+ from the front of the Types list of the data family instance, substitute the+ kind variables with their respective instantiated kinds (which you took earlier),+ and proceed as normal.+3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template+ Haskell might not even list all of the Types of a data family instance, since+ they are eta-reduced away! And yes, kinds can be eta-reduced too.++ The simplest workaround is to count how many instantiated types are missing from+ the list and generate extra type variables to use in their place. Luckily, we+ needn't worry much if its kind was eta-reduced away, since using stealKindForType+ will get it back.++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) (c :: 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 criterion:++ (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind+ variables), then generate a Functor 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 Functor instance of:++ instance (Functor f, Functor g) => Functor (Compose f g) where ...+-}++-- Determines the types of a constructor's arguments as well as the last type+-- parameters (along with their map functions), expanding through any type synonyms.+-- The type parameters are determined on a constructor-by-constructor basis since+-- they may be refined to be particular types in a GADT.+reifyConTys :: FunctorFun+ -> Name+ -> Name+ -> Q ([Type], TyVarMap)+reifyConTys ff conName mapFun = do+ info <- reify conName+ (ctxt, uncTy) <- case info of+ DataConI _ ty _+#if !(MIN_VERSION_template_haskell(2,11,0))+ _+#endif+ -> fmap uncurryTy (expandSyn ty)+ _ -> fail "Must be a data constructor"+ let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy+ unapResTy = unapplyTy resTy+ -- If one of the last type variables is refined to a particular type+ -- (i.e., not truly polymorphic), we mark it with Nothing and filter+ -- it out later, since we only apply map functions to arguments of+ -- a type that it (1) one of the last type variables, and (2)+ -- of a truly polymorphic type.+ mbTvNames = map varTToName_maybe $+ drop (length unapResTy - 1) unapResTy+ tvMap = Map.fromList+ . catMaybes -- Drop refined types+ $ zipWith (\mbTvName sp ->+ fmap (\tvName -> (tvName, sp)) mbTvName)+ mbTvNames [mapFun]+ if (any (`predMentionsName` Map.keys tvMap) ctxt+ || Map.size tvMap < 1)+ && not (allowExQuant (functorFunToClass ff))+ then existentialContextError conName+ else return (argTys, tvMap)++-------------------------------------------------------------------------------+-- Error messages+-------------------------------------------------------------------------------++-- | 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 :: FunctorClass -> Name -> Q a+derivingKindError fc 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 * -> *"+ $ ""+ where+ className :: String+ className = nameBase $ functorClassName fc++-- | 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"+ $ ""++-- | 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 :: Name -> Q a+outOfPlaceTyVarError conName = fail+ . showString "Constructor ‘"+ . showString (nameBase conName)+ . showString "‘ must only use its last two type variable(s) within"+ . showString " the last two argument(s) of a data type"+ $ ""++-- | 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++#if !(MIN_VERSION_template_haskell(2,7,0))+-- | Template Haskell didn't list all of a data family's instances upon reification+-- until template-haskell-2.7.0.0, which is necessary for a derived instance to work.+dataConIError :: Q a+dataConIError = fail+ . showString "Cannot use a data constructor."+ . showString "\n\t(Note: if you are trying to derive for a data family instance,"+ . showString "\n\tuse GHC >= 7.4 instead.)"+ $ ""+#endif++-------------------------------------------------------------------------------+-- Class-specific constants+-------------------------------------------------------------------------------++-- | A representation of which class is being derived.+data FunctorClass = Functor | Foldable | Traversable++-- | A representation of which function is being generated.+data FunctorFun = Fmap | Foldr | FoldMap | Traverse+ deriving Eq++instance Show FunctorFun where+ showsPrec _ Fmap = showString "fmap"+ showsPrec _ Foldr = showString "foldr"+ showsPrec _ FoldMap = showString "foldMap"+ showsPrec _ Traverse = showString "traverse"++functorFunConstName :: FunctorFun -> Name+functorFunConstName Fmap = fmapConstValName+functorFunConstName Foldr = foldrConstValName+functorFunConstName FoldMap = foldMapConstValName+functorFunConstName Traverse = traverseConstValName++functorClassName :: FunctorClass -> Name+functorClassName Functor = functorTypeName+functorClassName Foldable = foldableTypeName+functorClassName Traversable = traversableTypeName++functorFunName :: FunctorFun -> Name+functorFunName Fmap = fmapValName+functorFunName Foldr = foldrValName+functorFunName FoldMap = foldMapValName+functorFunName Traverse = traverseValName++functorClassToFuns :: FunctorClass -> [FunctorFun]+functorClassToFuns Functor = [Fmap]+functorClassToFuns Foldable = [Foldr, FoldMap]+functorClassToFuns Traversable = [Traverse]++functorFunToClass :: FunctorFun -> FunctorClass+functorFunToClass Fmap = Functor+functorFunToClass Foldr = Foldable+functorFunToClass FoldMap = Foldable+functorFunToClass Traverse = Traversable++allowFunTys :: FunctorClass -> Bool+allowFunTys Functor = True+allowFunTys _ = False++allowExQuant :: FunctorClass -> Bool+allowExQuant Foldable = True+allowExQuant _ = False++-- See Trac #7436 for why explicit lambdas are used+functorFunTriv :: FunctorFun -> Q Exp+functorFunTriv Fmap = do+ x <- newName "x"+ lam1E (varP x) $ varE x+-- We filter out trivial expressions from derived foldr, foldMap, and traverse+-- implementations, so if we attempt to call functorFunTriv on one of those+-- methods, we've done something wrong.+functorFunTriv ff = return . error $ "functorFunTriv: " ++ show ff++functorFunApp :: FunctorFun -> Q Exp -> Q Exp+functorFunApp Foldr e = do+ x <- newName "x"+ z <- newName "z"+ lamE [varP x, varP z] $ appsE [e, varE z, varE x]+functorFunApp _ e = e++functorFunCombine :: FunctorFun+ -> Name+ -> Name+ -> [Name]+ -> Q [Either Exp Exp]+ -> Q Exp+functorFunCombine Fmap = fmapCombine+functorFunCombine Foldr = foldrCombine+functorFunCombine FoldMap = foldMapCombine+functorFunCombine Traverse = traverseCombine++fmapCombine :: Name+ -> Name+ -> [Name]+ -> Q [Either Exp Exp]+ -> Q Exp+fmapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither)++-- foldr, foldMap, and traverse are handled differently from fmap, since+-- they filter out subexpressions whose types do not mention the last+-- type parameter. See+-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable+-- for further discussion.++foldrCombine :: Name+ -> Name+ -> [Name]+ -> Q [Either Exp Exp]+ -> Q Exp+foldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights)++foldMapCombine :: Name+ -> Name+ -> [Name]+ -> Q [Either Exp Exp]+ -> Q Exp+foldMapCombine _ _ _ = fmap (go . rights)+ where+ go :: [Exp] -> Exp+ go [] = VarE memptyValName+ go es = foldr1 (AppE . AppE (VarE mappendValName)) es++traverseCombine :: Name+ -> Name+ -> [Name]+ -> Q [Either Exp Exp]+ -> Q Exp+traverseCombine conName _ args essQ = do+ ess <- essQ++ let argTysTyVarInfo :: [Bool]+ argTysTyVarInfo = map isRight ess++ argsWithTyVar, argsWithoutTyVar :: [Name]+ (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args++ conExpQ :: Q Exp+ conExpQ+ | null argsWithTyVar+ = appsE (conE conName:map varE argsWithoutTyVar)+ | otherwise = do+ bs <- newNameList "b" $ length args+ let bs' = filterByList argTysTyVarInfo bs+ vars = filterByLists argTysTyVarInfo+ (map varE bs) (map varE args)+ lamE (map varP bs') (appsE (conE conName:vars))++ conExp <- conExpQ++ let go :: [Exp] -> Exp+ go [] = VarE pureValName `AppE` conExp+ go (e:es) = foldl' (\e1 e2 -> InfixE (Just e1) (VarE apValName) (Just e2))+ (VarE fmapValName `AppE` conExp `AppE` e) es++ return . go . rights $ ess
+ src/Data/Traversable/Deriving.hs view
@@ -0,0 +1,51 @@+{-|+Module: Data.Traversable.Deriving+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++Exports functions to mechanically derive 'Traversable' instances in a way that mimics+how the @-XDeriveTraversable@ extension works since GHC 8.0.++Derived 'Traversable' instances from this module do not generate+superfluous 'pure' expressions in its implementation of 'traverse'. One can+verify this by compiling a module that uses 'deriveTraversable' with the+@-ddump-splices@ GHC flag.++These changes make it possible to derive @Traversable@ instances for data types with+unlifted argument types, e.g.,++@+data IntHash a = IntHash Int# a++deriving instance Traversable IntHash -- On GHC 8.0 on later+$(deriveTraversable ''IntHash) -- On GHC 7.10 and earlier+@++For more info on these changes, see+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.+-}+module Data.Traversable.Deriving (+ -- * 'deriveTraversable' limitations+ -- $constraints+ deriveTraversable+ , makeTraverse+ , makeSequenceA+ , makeMapM+ , makeSequence+ ) where++import Data.Functor.Deriving.Internal++{- $constraints++Be aware of the following potential gotchas:++* If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an+ existential constraint cannot mention the last type variable. For example,+ @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived+ 'Traversable' instance.+* Type variables of kind @* -> *@ are assumed to have 'Traversable' constraints.+ If this is not desirable, use @makeTraverse@.+-}
+ tests/DerivingSpec.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-unused-foralls #-}+#endif++{-|+Module: DerivingSpec+Copyright: (C) 2015-2016 Ryan Scott+License: BSD-style (see the file LICENSE)+Maintainer: Ryan Scott+Portability: Template Haskell++@hspec@ tests for @deriving-compat@.+-}+module DerivingSpec where++import Data.Char (chr)+import Data.Deriving+import Data.Foldable (fold)+import Data.Functor.Classes (Eq1)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Monoid+import Data.Orphans ()++import GHC.Exts (Int#)++import Prelude ()+import Prelude.Compat++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary)++-------------------------------------------------------------------------------++-- Adapted from the test cases from+-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch++-- Plain data types++data Strange a b c+ = T1 a b c+ | T2 [a] [b] [c] -- lists+ | T3 [[a]] [[b]] [[c]] -- nested lists+ | T4 (c,(b,b),(c,c)) -- tuples+ | T5 ([c],Strange a b c) -- tycons++type IntFun a b = (b -> Int) -> a+data StrangeFunctions a b c+ = T6 (a -> c) -- function types+ | T7 (a -> (c,a)) -- functions and tuples+ | T8 ((b -> a) -> c) -- continuation+ | T9 (IntFun b c) -- type synonyms++data StrangeGADT a b where+ T10 :: Ord d => d -> StrangeGADT c d+ T11 :: Int -> StrangeGADT e Int+ T12 :: c ~ Int => c -> StrangeGADT f Int+ T13 :: i ~ Int => Int -> StrangeGADT h i+ T14 :: k ~ Int => k -> StrangeGADT j k+ T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n++data NotPrimitivelyRecursive a b+ = S1 (NotPrimitivelyRecursive (a,a) (b, a))+ | S2 a+ | S3 b++newtype OneTwoCompose f g a b = OneTwoCompose (Either (f (g a)) (f (g b)))+ deriving (Arbitrary, Eq, Show)++newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b))++data Universal a b+ = Universal (forall b. (b,[a]))+ | Universal2 (forall f. Functor (f a) => f a b)+ | Universal3 (forall a. Maybe a) -- reuse a+ | NotReallyUniversal (forall b. a)++data Existential a b+ = forall a. ExistentialList [a]+ | forall f. Traversable (f a) => ExistentialFunctor (f a b)+ | forall b. SneakyUseSameName (Maybe b)++data IntHash a b+ = IntHash Int# Int#+ | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int))++data IntHashFun a b+ = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a)++-- Data families++data family StrangeFam x y z+data instance StrangeFam a b c+ = T1Fam a b c+ | T2Fam [a] [b] [c] -- lists+ | T3Fam [[a]] [[b]] [[c]] -- nested lists+ | T4Fam (c,(b,b),(c,c)) -- tuples+ | T5Fam ([c],Strange a b c) -- tycons++data family StrangeFunctionsFam x y z+data instance StrangeFunctionsFam a b c+ = T6Fam (a -> c) -- function types+ | T7Fam (a -> (c,a)) -- functions and tuples+ | T8Fam ((b -> a) -> c) -- continuation+ | T9Fam (IntFun b c) -- type synonyms++data family StrangeGADTFam x y+data instance StrangeGADTFam a b where+ T10Fam :: Ord d => d -> StrangeGADTFam c d+ T11Fam :: Int -> StrangeGADTFam e Int+ T12Fam :: c ~ Int => c -> StrangeGADTFam f Int+ T13Fam :: i ~ Int => Int -> StrangeGADTFam h i+ T14Fam :: k ~ Int => k -> StrangeGADTFam j k+ T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n++data family NotPrimitivelyRecursiveFam x y+data instance NotPrimitivelyRecursiveFam a b+ = S1Fam (NotPrimitivelyRecursive (a,a) (b, a))+ | S2Fam a+ | S3Fam b++data family OneTwoComposeFam (j :: * -> *) (k :: * -> *) x y+newtype instance OneTwoComposeFam f g a b =+ OneTwoComposeFam (Either (f (g a)) (f (g b)))+ deriving (Arbitrary, Eq, Show)++data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y+newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b))++data family UniversalFam x y+data instance UniversalFam a b+ = UniversalFam (forall b. (b,[a]))+ | Universal2Fam (forall f. Functor (f a) => f a b)+ | Universal3Fam (forall a. Maybe a) -- reuse a+ | NotReallyUniversalFam (forall b. a)++data family ExistentialFam x y+data instance ExistentialFam a b+ = forall a. ExistentialListFam [a]+ | forall f. Traversable (f a) => ExistentialFunctorFam (f a b)+ | forall b. SneakyUseSameNameFam (Maybe b)++data family IntHashFam x y+data instance IntHashFam a b+ = IntHashFam Int# Int#+ | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int))++data family IntHashFunFam x y+data instance IntHashFunFam a b+ = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a)++-------------------------------------------------------------------------------++-- Plain data types++$(deriveFunctor ''Strange)+$(deriveFoldable ''Strange)+$(deriveTraversable ''Strange)++$(deriveFunctor ''StrangeFunctions)+$(deriveFoldable ''StrangeGADT)++$(deriveFunctor ''NotPrimitivelyRecursive)+$(deriveFoldable ''NotPrimitivelyRecursive)+$(deriveTraversable ''NotPrimitivelyRecursive)++$(deriveFunctor ''OneTwoCompose)+$(deriveFoldable ''OneTwoCompose)+$(deriveTraversable ''OneTwoCompose)++instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where+ fmap = $(makeFmap ''ComplexConstraint)+instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where+ foldr = $(makeFoldr ''ComplexConstraint)+ foldMap = $(makeFoldMap ''ComplexConstraint)+instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where+ traverse = $(makeTraverse ''ComplexConstraint)++$(deriveFunctor ''Universal)++$(deriveFunctor ''Existential)+$(deriveFoldable ''Existential)+$(deriveTraversable ''Existential)++$(deriveFunctor ''IntHash)+$(deriveFoldable ''IntHash)+$(deriveTraversable ''IntHash)++$(deriveFunctor ''IntHashFun)++#if MIN_VERSION_template_haskell(2,7,0)+-- Data families++$(deriveFunctor 'T1Fam)+$(deriveFoldable 'T2Fam)+$(deriveTraversable 'T3Fam)++$(deriveFunctor 'T6Fam)+$(deriveFoldable 'T10Fam)++$(deriveFunctor 'S1Fam)+$(deriveFoldable 'S2Fam)+$(deriveTraversable 'S3Fam)++$(deriveFunctor 'OneTwoComposeFam)+$(deriveFoldable 'OneTwoComposeFam)+$(deriveTraversable 'OneTwoComposeFam)++instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where+ fmap = $(makeFmap 'ComplexConstraintFam)+instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where+ foldr = $(makeFoldr 'ComplexConstraintFam)+ foldMap = $(makeFoldMap 'ComplexConstraintFam)+instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where+ traverse = $(makeTraverse 'ComplexConstraintFam)++$(deriveFunctor 'UniversalFam)++$(deriveFunctor 'ExistentialListFam)+$(deriveFoldable 'ExistentialFunctorFam)+$(deriveTraversable 'SneakyUseSameNameFam)++$(deriveFunctor 'IntHashFam)+$(deriveFoldable 'IntHashTupleFam)+$(deriveTraversable 'IntHashFam)++$(deriveFunctor 'IntHashFunFam)+#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_FunctorEx :: (Functor f, Eq (f [Int])) => f [Int] -> Bool+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_FoldableEx :: Foldable f => f [Int] -> Bool+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)+ => (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++ && (t . sequenceA) y == (sequenceA . fmap t) y+ && (sequenceA . fmap Identity) y == Identity y+ && (sequenceA . fmap Compose) z+ == (Compose . fmap sequenceA . sequenceA) z+ where+ y :: t (f a)+ y = fmap pure x++ z :: t (f (g a))+ z = fmap (fmap pure) y++prop_TraversableEx :: (Traversable t, Eq (t [[Int]]),+ Eq (t [Int]), Eq (t String), Eq (t Char))+ => t [Int] -> Bool+prop_TraversableEx = prop_TraversableLaws+ (replicate 2 . map (chr . abs))+ (++ "Hello")+ reverse++-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do+ prop "satisfies the Functor laws"+ (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)+ prop "satisfies the Foldable laws"+ (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)+ prop "satisfies the Traversable laws"+ (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool)+#if MIN_VERSION_template_haskell(2,7,0)+ describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do+ prop "satisfies the Functor laws"+ (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)+ prop "satisfies the Foldable laws"+ (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)+ prop "satisfies the Traversable laws"+ (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool)+#endif
− tests/FoldableSpec.hs
@@ -1,106 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-unused-matches #-}--{-|-Module: FoldableSpec-Copyright: (C) 2015 Ryan Scott-License: BSD-style (see the file LICENSE)-Maintainer: Ryan Scott-Portability: Template Haskell--@hspec@ tests for the "Data.Foldable.Deriving" module.--}-module FoldableSpec where--import Data.Foldable (fold)-import Data.Foldable.Deriving-import Data.Monoid--import Prelude.Compat--import Test.Hspec-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Arbitrary)------------------------------------------------------------------------------------- Adapted from the test cases from--- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch--data Strange a b c- = T1 a b c- | T2 [a] [b] [c] -- lists- | T3 [[a]] [[b]] [[c]] -- nested lists- | T4 (c,(b,b),(c,c)) -- tuples- | T5 ([c],Strange a b c) -- tycons--data StrangeGADT a b where- T10 :: Ord b => b -> StrangeGADT a b- T11 :: Int -> StrangeGADT a Int- T12 :: c ~ Int => c -> StrangeGADT a Int- T13 :: b ~ Int => Int -> StrangeGADT a b- T14 :: b ~ Int => b -> StrangeGADT a b- T15 :: (b ~ c, c ~ Int) => Int -> c -> StrangeGADT a b--data NotPrimitivelyRecursive a b- = S1 (NotPrimitivelyRecursive (a,a) (b, a))- | S2 a- | S3 b--newtype Compose f g a = Compose (f (g a))- deriving (Arbitrary, Eq, Show)--newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g b, a, b))--type Flip f a b = f b a-data Existential a b- = forall a. ExistentialList [a]- | forall f. Foldable (f a) => ExistentialFoldable (Flip f b a)- | forall b. SneakyUseSameName (Maybe b)-----------------------------------------------------------------------------------$(deriveFoldable ''Strange)-$(deriveFoldable ''StrangeGADT)-$(deriveFoldable ''NotPrimitivelyRecursive)-$(deriveFoldable ''Compose)--instance (Foldable (f Int Int), Foldable g) =>- Foldable (ComplexConstraint f g a) where- foldr = $(makeFoldr ''ComplexConstraint)- foldMap = $(makeFoldMap ''ComplexConstraint)--$(deriveFoldable ''Existential)-----------------------------------------------------------------------------------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-----------------------------------------------------------------------------------main :: IO ()-main = hspec spec--spec :: Spec-spec =- describe "Compose Maybe Maybe [Int]" $- prop "satisfies the Foldable laws"- (prop_FoldableLaws- reverse- ((+) . length)- 0- :: Compose Maybe Maybe [Int] -> Bool)