diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Ryan Scott +Copyright (c) 2015-2016, Ryan Scott All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,2 +1,32 @@ -# deriving-compat -Backports of GHC deriving extensions +# `deriving-compat` +[![Hackage](https://img.shields.io/hackage/v/deriving-compat.svg)][Hackage: deriving-compat] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] +[![Build](https://img.shields.io/travis/haskell-compat/deriving-compat.svg)](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. diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -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 + @@ + to derive @Generic(1)@ using Template Haskell. + . + * @DeriveLift@, which was introduced in GHC 8.0 for deriving + @Lift@ instances. Use @Language.Haskell.TH.Lift@ from + @@ + to derive @Lift@ using Template Haskell. 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 +maintainer: Ryan Scott 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 diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Data/Deriving.hs @@ -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) +@ + +-} diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -2,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" diff --git a/src/Data/Foldable/Deriving.hs b/src/Data/Foldable/Deriving.hs --- a/src/Data/Foldable/Deriving.hs +++ b/src/Data/Foldable/Deriving.hs @@ -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 . -} 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 diff --git a/src/Data/Functor/Deriving.hs b/src/Data/Functor/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Deriving.hs @@ -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 +. +-} +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@'. +-} diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Deriving/Internal.hs @@ -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 +. +-} +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 diff --git a/src/Data/Traversable/Deriving.hs b/src/Data/Traversable/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Data/Traversable/Deriving.hs @@ -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 +. +-} +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@. +-} diff --git a/tests/DerivingSpec.hs b/tests/DerivingSpec.hs new file mode 100644 --- /dev/null +++ b/tests/DerivingSpec.hs @@ -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 diff --git a/tests/FoldableSpec.hs b/tests/FoldableSpec.hs deleted file mode 100644 --- a/tests/FoldableSpec.hs +++ /dev/null @@ -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)