diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +## 0.1 +* Initial commit diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Ryan Scott + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Scott nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# deriving-compat +Backports of GHC deriving extensions diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deriving-compat.cabal b/deriving-compat.cabal new file mode 100644 --- /dev/null +++ b/deriving-compat.cabal @@ -0,0 +1,50 @@ +name: deriving-compat +version: 0.1 +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 + over data types with existential constraints. +homepage: https://github.com/haskell-compat/deriving-compat +bug-reports: https://github.com/haskell-compat/deriving-compat/issues +license: BSD3 +license-file: LICENSE +author: Ryan Scott +maintainer: Ryan Scott +stability: Experimental +copyright: (C) 2015 Ryan Scott +category: Compatibility +build-type: Simple +extra-source-files: CHANGELOG.md, README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/haskell-compat/deriving-compat + +library + exposed-modules: Data.Foldable.Deriving + other-modules: Data.Deriving.Internal + Paths_deriving_compat + build-depends: base >= 4.3 && < 5 + , containers >= 0.1 && < 0.6 + , ghc-prim + , template-haskell >= 2.5 && < 2.11 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +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 + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Deriving/Internal.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE CPP #-} + +{-| +Module: Data.Deriving.Internal +Copyright: (C) 2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Template Haskell-related utilities. +-} +module Data.Deriving.Internal where + +import Control.Monad (guard) + +import Data.Function (on) +import Data.List +import qualified Data.Map as Map (fromList, lookup) +import Data.Map (Map) +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) + +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +#ifndef CURRENT_PACKAGE_KEY +import Data.Version (showVersion) +import Paths_deriving_compat (version) +#endif + +------------------------------------------------------------------------------- +-- Expanding type synonyms +------------------------------------------------------------------------------- + +-- | Expands all type synonyms in a type. Written by Dan Rosén in the +-- @genifunctors@ package (licensed under BSD3). +expandSyn :: Type -> Q Type +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 t = return t + +expandSynApp :: Type -> [Type] -> Q Type +expandSynApp (AppT t1 t2) ts = do + t2' <- expandSyn t2 + expandSynApp t1 (t2':ts) +expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts +expandSynApp t@(ConT n) ts = do + info <- reify n + case info of + TyConI (TySynD _ tvs rhs) -> + let (ts', ts'') = splitAt (length tvs) ts + subs = mkSubst tvs ts' + rhs' = subst 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 + +mkSubst :: [TyVarBndr] -> [Type] -> Subst +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 + +------------------------------------------------------------------------------- +-- Type-specialized const functions +------------------------------------------------------------------------------- + +foldrConst :: b -> (a -> b -> b) -> b -> t a -> b +foldrConst = const . const . const +{-# INLINE foldrConst #-} + +foldMapConst :: m -> (a -> m) -> t a -> m +foldMapConst = const . const +{-# INLINE foldMapConst #-} + +------------------------------------------------------------------------------- +-- NameBase +------------------------------------------------------------------------------- + +-- | 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 + +instance Ord NameBase where + compare = compare `on` getNameBase + +instance Show NameBase where + showsPrec p = showsPrec p . getNameBase + +-- | A NameBase paired with the name of its map function. +type TyVarInfo = (NameBase, Name) + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +thd3 :: (a, b, c) -> c +thd3 (_, _, c) = c + +-- | Extracts the name of a constructor. +constructorName :: Con -> Name +constructorName (NormalC name _ ) = name +constructorName (RecC name _ ) = name +constructorName (InfixC _ name _ ) = name +constructorName (ForallC _ _ con) = constructorName con + +-- | 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 + +-- | Applies a typeclass constraint to a type. +applyClass :: Name -> Name -> Pred +#if MIN_VERSION_template_haskell(2,10,0) +applyClass con t = AppT (ConT con) (VarT t) +#else +applyClass con t = ClassP con [VarT t] +#endif + +-- | Checks to see if the last types in a data family instance can be safely eta- +-- reduced (i.e., dropped), given the other types. This checks for three conditions: +-- +-- (1) All of the dropped types are type variables +-- (2) All of the dropped types are distinct +-- (3) None of the remaining types mention any of the dropped types +canEtaReduce :: [Type] -> [Type] -> Bool +canEtaReduce remaining dropped = + all isTyVar dropped + && allDistinct 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) + where + nbs :: [NameBase] + nbs = map varTToNameBase 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 the NameBase from a type variable. +varTToNameBase :: Type -> NameBase +varTToNameBase = NameBase . varTToName + +-- | Peel off a kind signature from a Type (if it has one). +unSigT :: Type -> Type +unSigT (SigT t _) = t +unSigT t = t + +-- | Is the given type a variable? +isTyVar :: Type -> Bool +isTyVar (VarT _) = True +isTyVar (SigT t _) = isTyVar t +isTyVar _ = False + +-- | Is the given type a type family constructor (and not a data family constructor)? +isTyFamily :: Type -> Q Bool +isTyFamily (ConT n) = do + info <- reify n + return $ case info of +#if MIN_VERSION_template_haskell(2,7,0) + FamilyI (FamilyD TypeFam _ _ _) _ -> True +#else + TyConI (FamilyD TypeFam _ _ _) -> True +#endif + _ -> False +isTyFamily _ = return False + +-- | Are all of the items in a list (which have an ordering) distinct? +-- +-- This uses Set (as opposed to nub) for better asymptotic time complexity. +allDistinct :: Ord a => [a] -> Bool +allDistinct = allDistinct' Set.empty + where + allDistinct' :: Ord a => Set a -> [a] -> Bool + allDistinct' uniqs (x:xs) + | x `Set.member` uniqs = False + | otherwise = allDistinct' (Set.insert x uniqs) xs + allDistinct' _ _ = True + +-- | Does the given type mention any of the NameBases in the list? +mentionsNameBase :: Type -> [NameBase] -> Bool +mentionsNameBase = go Set.empty + 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 + +-- | Does an instance predicate mention any of the NameBases in the list? +predMentionsNameBase :: Pred -> [NameBase] -> Bool +#if MIN_VERSION_template_haskell(2,10,0) +predMentionsNameBase = mentionsNameBase +#else +predMentionsNameBase (ClassP _ tys) nbs = any (`mentionsNameBase` nbs) tys +predMentionsNameBase (EqualP t1 t2) nbs = mentionsNameBase t1 nbs || mentionsNameBase t2 nbs +#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 + +-- | Fully applies a type constructor to its type variables. +applyTyCon :: Name -> [Type] -> Type +applyTyCon = applyTy . ConT + +-- | Split an applied type into its individual components. For example, this: +-- +-- @ +-- Either Int Char +-- @ +-- +-- would split to this: +-- +-- @ +-- [Either, Int, Char] +-- @ +unapplyTy :: Type -> [Type] +unapplyTy = reverse . go + where + go :: Type -> [Type] + go (AppT t1 t2) = t2:go t1 + go (SigT t _) = go t + go t = [t] + +-- | Split a type signature by the arrows on its spine. For example, this: +-- +-- @ +-- (Int -> String) -> Char -> () +-- @ +-- +-- would split to this: +-- +-- @ +-- [Int -> String, Char, ()] +-- @ +uncurryTy :: Type -> [Type] +uncurryTy (AppT (AppT ArrowT t1) t2) = t1:uncurryTy t2 +uncurryTy (SigT t _) = uncurryTy t +uncurryTy t = [t] + +-- | Like uncurryType, except on a kind level. +uncurryKind :: Kind -> [Kind] +#if MIN_VERSION_template_haskell(2,8,0) +uncurryKind = 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 +------------------------------------------------------------------------------- + +-- By manually generating these names we avoid needing to use the +-- TemplateHaskell language extension when compiling the deriving-compat library. +-- This allows the library to be used in stage1 cross-compilers. + +derivingCompatPackageKey :: String +#ifdef CURRENT_PACKAGE_KEY +derivingCompatPackageKey = CURRENT_PACKAGE_KEY +#else +derivingCompatPackageKey = "deriving-compat-" ++ showVersion version +#endif + +mkDerivingCompatName_v :: String -> String -> Name +mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey + +foldrConstValName :: Name +foldrConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "foldrConst" + +foldMapConstValName :: Name +foldMapConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "foldMapConst" + +foldableTypeName :: Name +foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" + +errorValName :: Name +errorValName = mkNameG_v "base" "GHC.Err" "error" + +foldrValName :: Name +foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" + +foldMapValName :: Name +foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" + +#if MIN_VERSION_base(4,8,0) +mappendValName :: Name +mappendValName = mkNameG_v "base" "GHC.Base" "mappend" + +memptyValName :: Name +memptyValName = mkNameG_v "base" "GHC.Base" "mempty" +#else +mappendValName :: Name +mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" + +memptyValName :: Name +memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" +#endif diff --git a/src/Data/Foldable/Deriving.hs b/src/Data/Foldable/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foldable/Deriving.hs @@ -0,0 +1,714 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +{-| +Module: Data.Foldable.Deriving +Copyright: (C) 2015 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., + +@ +{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving, TemplateHaskell #-} + +data WrappedSet a where + WrapSet :: Ord a => a -> WrappedSet a +deriving instance Foldable WrappedSet -- On GHC 7.12 on later +$(deriveFoldable ''WrappedSet) -- On GHC 7.10 and earlier +@ + +For more info on these changes, see +. +-} +module Data.Foldable.Deriving ( + -- * 'deriveFoldable' + -- $derive + 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': + +@ +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +import Data.Foldable.Deriving + +newtype HigherKinded f a b = HigherKinded (f a b) + +instance Foldable (f a) => Foldable (HigherKinded f a) where + foldr = $(makeFoldr ''HigherKinded) +@ + +-} + +------------------------------------------------------------------------------- +-- 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/tests/FoldableSpec.hs b/tests/FoldableSpec.hs new file mode 100644 --- /dev/null +++ b/tests/FoldableSpec.hs @@ -0,0 +1,106 @@ +{-# 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) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}