deriving-compat (empty) → 0.1
raw patch · 9 files changed
+1300/−0 lines, 9 filesdep +QuickCheckdep +basedep +base-compatsetup-changed
Dependencies added: QuickCheck, base, base-compat, containers, deriving-compat, ghc-prim, hspec, template-haskell
Files
- CHANGELOG.md +2/−0
- LICENSE +30/−0
- README.md +2/−0
- Setup.hs +2/−0
- deriving-compat.cabal +50/−0
- src/Data/Deriving/Internal.hs +393/−0
- src/Data/Foldable/Deriving.hs +714/−0
- tests/FoldableSpec.hs +106/−0
- tests/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+## 0.1+* Initial commit
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,2 @@+# deriving-compat+Backports of GHC deriving extensions
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ deriving-compat.cabal view
@@ -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 <ryan.gl.scott@ku.edu>+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
+ src/Data/Deriving/Internal.hs view
@@ -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
+ src/Data/Foldable/Deriving.hs view
@@ -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+<https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.+-}+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
+ tests/FoldableSpec.hs view
@@ -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)
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}