recursion-schemes 5 → 5.0.1
raw patch · 7 files changed
+687/−12 lines, 7 filesdep +HUnitdep +base-orphansdep +recursion-schemesdep ~base
Dependencies added: HUnit, base-orphans, recursion-schemes, semigroups, template-haskell
Dependency ranges changed: base
Files
- .travis.yml +3/−3
- CHANGELOG.markdown +3/−0
- Data/Functor/Base.hs +120/−0
- Data/Functor/Foldable.hs +74/−0
- Data/Functor/Foldable/TH.hs +393/−0
- examples/Expr.hs +60/−0
- recursion-schemes.cabal +34/−9
.travis.yml view
@@ -25,9 +25,9 @@ - env: CABALVER=1.22 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.0.1- compiler: ": #GHC 8.0.1b"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=8.0.2+ compiler: ": #GHC 8.0.2"+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} before_install: - unset CC
CHANGELOG.markdown view
@@ -1,3 +1,6 @@+## 5.0.1+* Add `Data.Functor.Foldable.TH` module, which provides derivation of base functors via Template Haskell.+ ## 5 * Renamed `Foldable` to `Recursive` and `Unfoldable` to `Corecursive`. With `Foldable` in `Prelude` in GHC 7.10+, having a needlessly conflicting name seemed silly. * Add support for GHC-8.0.1
+ Data/Functor/Base.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}++#define EXPLICIT_DICT_FUNCTOR_CLASSES (MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) || (MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)))++#define HAS_GENERIC (__GLASGOW_HASKELL__ >= 702)+#define HAS_GENERIC1 (__GLASGOW_HASKELL__ >= 706)++#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+#if HAS_GENERIC+{-# LANGUAGE DeriveGeneric #-}+#endif+#endif++-- | Base Functors for standard types not already expressed as a fixed point.+module Data.Functor.Base+ ( NonEmptyF(..)+ ) where++#ifdef __GLASGOW_HASKELL__+import Data.Data (Typeable)+#if HAS_GENERIC+import GHC.Generics (Generic)+#endif+#if HAS_GENERIC1+import GHC.Generics (Generic1)+#endif+#endif++import Control.Applicative+import Data.Monoid++import Data.Functor.Classes+ ( Eq1(..), Ord1(..), Show1(..), Read1(..)+#if EXPLICIT_DICT_FUNCTOR_CLASSES+ , Eq2(..), Ord2(..), Show2(..), Read2(..)+#endif+ )++import qualified Data.Foldable as F+import qualified Data.Traversable as T++import qualified Data.Bifunctor as Bi+import qualified Data.Bifoldable as Bi+import qualified Data.Bitraversable as Bi++import Prelude hiding (head, tail)++-- | Base Functor for 'Data.List.NonEmpty'+data NonEmptyF a b = NonEmptyF { head :: a, tail :: Maybe b }+ deriving (Eq,Ord,Show,Read,Typeable+#if HAS_GENERIC+ , Generic+#endif+#if HAS_GENERIC1+ , Generic1+#endif+ )++#if EXPLICIT_DICT_FUNCTOR_CLASSES+instance Eq2 NonEmptyF where+ liftEq2 f g (NonEmptyF a mb) (NonEmptyF a' mb') = f a a' && liftEq g mb mb'++instance Eq a => Eq1 (NonEmptyF a) where+ liftEq = liftEq2 (==)++instance Ord2 NonEmptyF where+ liftCompare2 f g (NonEmptyF a mb) (NonEmptyF a' mb') = f a a' `mappend` liftCompare g mb mb'++instance Ord a => Ord1 (NonEmptyF a) where+ liftCompare = liftCompare2 compare++instance Show a => Show1 (NonEmptyF a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 NonEmptyF where+ liftShowsPrec2 sa _ sb slb d (NonEmptyF a b) = showParen (d > 10)+ $ showString "NonEmptyF "+ . sa 11 a+ . showString " "+ . liftShowsPrec sb slb 11 b++instance Read2 NonEmptyF where+ liftReadsPrec2 ra _ rb rlb d = readParen (d > 10) $ \s -> cons s+ where+ cons s0 = do+ ("NonEmptyF", s1) <- lex s0+ (a, s2) <- ra 11 s1+ (mb, s3) <- liftReadsPrec rb rlb 11 s2+ return (NonEmptyF a mb, s3)++instance Read a => Read1 (NonEmptyF a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++#else+instance Eq a => Eq1 (NonEmptyF a) where eq1 = (==)+instance Ord a => Ord1 (NonEmptyF a) where compare1 = compare+instance Show a => Show1 (NonEmptyF a) where showsPrec1 = showsPrec+instance Read a => Read1 (NonEmptyF a) where readsPrec1 = readsPrec+#endif++-- These instances cannot be auto-derived on with GHC <= 7.6+instance Functor (NonEmptyF a) where+ fmap f = NonEmptyF <$> head <*> (fmap f . tail)++instance F.Foldable (NonEmptyF a) where+ foldMap f = F.foldMap f . tail++instance T.Traversable (NonEmptyF a) where+ traverse f = fmap <$> (NonEmptyF . head) <*> (T.traverse f . tail)++instance Bi.Bifunctor NonEmptyF where+ bimap f g = NonEmptyF <$> (f . head) <*> (fmap g . tail)++instance Bi.Bifoldable NonEmptyF where+ bifoldMap f g = merge <$> (f . head) <*> (fmap g . tail)+ where merge x my = maybe x (mappend x) my++instance Bi.Bitraversable NonEmptyF where+ bitraverse f g = liftA2 NonEmptyF <$> (f . head) <*> (T.traverse g . tail)
Data/Functor/Foldable.hs view
@@ -99,13 +99,20 @@ import Control.Comonad.Trans.Env import qualified Control.Comonad.Cofree as Cofree import Control.Comonad.Cofree (Cofree(..))+import Control.Comonad.Trans.Cofree (CofreeF, CofreeT(..))+import qualified Control.Comonad.Trans.Cofree as CCTC import Control.Monad (liftM, join) import Control.Monad.Free (Free(..))+import qualified Control.Monad.Free.Church as CMFC import Control.Monad.Trans.Except (ExceptT(..), runExceptT)+import Control.Monad.Trans.Free (FreeF, FreeT(..))+import qualified Control.Monad.Trans.Free as CMTF import Data.Functor.Identity import Control.Arrow import Data.Function (on) import Data.Functor.Classes+import Data.Functor.Compose (Compose(..))+import Data.List.NonEmpty(NonEmpty((:|)), nonEmpty, toList) import Text.Read import Text.Show #ifdef __GLASGOW_HASKELL__@@ -132,6 +139,9 @@ import qualified Data.Bifoldable as Bi import qualified Data.Bitraversable as Bi +import Data.Functor.Base hiding (head, tail)+import qualified Data.Functor.Base as NEF (NonEmptyF(..))+ type family Base t :: * -> * class Functor (Base t) => Recursive t where@@ -319,6 +329,58 @@ Cons x (Right b) -> x : apo f b Nil -> [] +type instance Base (NonEmpty a) = NonEmptyF a+instance Recursive (NonEmpty a) where+ project (x:|xs) = NonEmptyF x $ nonEmpty xs+instance Corecursive (NonEmpty a) where+ embed = (:|) <$> NEF.head <*> (maybe [] toList <$> NEF.tail)++-- | Cofree comonads are Recursive/Corecursive+type instance Base (Cofree f a) = CofreeF f a+instance Functor f => Recursive (Cofree f a) where+ project (x :< xs) = x CCTC.:< xs+instance Functor f => Corecursive (Cofree f a) where+ embed (x CCTC.:< xs) = x :< xs++-- | Cofree tranformations of comonads are Recursive/Corecusive+type instance Base (CofreeT f w a) = Compose w (CofreeF f a)+instance (Functor w, Functor f) => Recursive (CofreeT f w a) where+ project = Compose . runCofreeT+instance (Functor w, Functor f) => Corecursive (CofreeT f w a) where+ embed = CofreeT . getCompose++-- | Free monads are Recursive/Corecursive+type instance Base (Free f a) = FreeF f a++instance Functor f => Recursive (Free f a) where+ project (Pure a) = CMTF.Pure a+ project (Free f) = CMTF.Free f++improveF :: Functor f => CMFC.F f a -> Free f a+improveF x = CMFC.improve (CMFC.fromF x)+-- | It may be better to work with the instance for `CMFC.F` directly.+instance Functor f => Corecursive (Free f a) where+ embed (CMTF.Pure a) = Pure a+ embed (CMTF.Free f) = Free f+ ana coalg = improveF . ana coalg+ postpro nat coalg = improveF . postpro nat coalg+ gpostpro dist nat coalg = improveF . gpostpro dist nat coalg++-- | Free transformations of monads are Recursive/Corecursive+type instance Base (FreeT f m a) = Compose m (FreeF f a)+instance (Functor m, Functor f) => Recursive (FreeT f m a) where+ project = Compose . runFreeT+instance (Functor m, Functor f) => Corecursive (FreeT f m a) where+ embed = FreeT . getCompose++-- If you are looking for instances for the free MonadPlus, please use the+-- instance for FreeT f [].++-- If you are looking for instances for the free alternative and free+-- applicative, I'm sorry to disapoint you but you won't find them in this+-- package. They can be considered recurive, but using non-uniform recursion;+-- this package only implements uniformly recursive folds / unfolds.+ -- | Example boring stub for non-recursive data types type instance Base (Maybe a) = Const (Maybe a) instance Recursive (Maybe a) where project = Const@@ -491,6 +553,18 @@ Ident "fromFix" <- lexP fromFix <$> step readPrec #endif++-- | Church encoded free monads are Recursive/Corecursive, in the same way that+-- 'Mu' is.+type instance Base (CMFC.F f a) = FreeF f a+cmfcCata :: (a -> r) -> (f r -> r) -> CMFC.F f a -> r+cmfcCata p f (CMFC.F run) = run p f+instance Functor f => Recursive (CMFC.F f a) where+ project = lambek+ cata f = cmfcCata (f . CMTF.Pure) (f . CMTF.Free)+instance Functor f => Corecursive (CMFC.F f a) where+ embed (CMTF.Pure a) = CMFC.F $ \p _ -> p a+ embed (CMTF.Free fr) = CMFC.F $ \p f -> f $ fmap (cmfcCata p f) fr data Nu f where Nu :: (a -> f a) -> a -> Nu f type instance Base (Nu f) = f
+ Data/Functor/Foldable/TH.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE Rank2Types #-}+module Data.Functor.Foldable.TH+ ( makeBaseFunctor+ , makeBaseFunctorWith+ , BaseRules+ , baseRules+ , baseRulesType+ , baseRulesCon+ , baseRulesField+ ) where++import Control.Applicative as A+import Data.Traversable as T+import Data.Bifunctor (first)+import Data.Functor.Identity+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (mkNameG_tc, mkNameG_v)+import Data.Char (GeneralCategory (..), generalCategory)+import Data.Orphans ()+#ifndef CURRENT_PACKAGE_KEY+import Data.Version (showVersion)+import Paths_recursion_schemes (version)+#endif++-- | Build base functor with a sensible default configuration.+--+-- /e.g./+--+-- @+-- data Expr a+-- = Lit a+-- | Add (Expr a) (Expr a)+-- | Expr a :* [Expr a]+-- deriving (Show)+--+-- 'makeBaseFunctor' ''Expr+-- @+--+-- will create+--+-- @+-- data ExprF a x+-- = LitF a+-- | AddF x x+-- | x :*$ [x]+-- deriving ('Functor', 'Foldable', 'Traversable')+--+-- type instance 'Base' (Expr a) = ExprF a+--+-- instance 'Recursive' (Expr a) where+-- 'project' (Lit x) = LitF x+-- 'project' (Add x y) = AddF x y+-- 'project' (x :* y) = x :*$ y+--+-- instance 'Corecursive' (Expr a) where+-- 'embed' (LitF x) = Lit x+-- 'embed' (AddF x y) = Add x y+-- 'embed' (x :*$ y) = x :*$ y+-- @+--+-- @+-- 'makeBaseFunctor' = 'makeBaseFunctorWith' 'baseRules'+-- @+--+-- /Notes:/+--+-- 'makeBaseFunctor' works properly only with ADTs.+-- Existentials and GADTs aren't supported,+-- as we don't try to do better than+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-functor-instances GHC's DeriveFunctor>.+--+makeBaseFunctor :: Name -> DecsQ+makeBaseFunctor = makeBaseFunctorWith baseRules++-- | Build base functor with a custom configuration.+makeBaseFunctorWith :: BaseRules -> Name -> DecsQ+makeBaseFunctorWith rules name = reify name >>= f+ where+ f (TyConI dec) = makePrimForDec rules dec+ f _ = fail "makeBaseFunctor: Expected type constructor name"++-- | Rules of renaming data names+data BaseRules = BaseRules+ { _baseRulesType :: Name -> Name+ , _baseRulesCon :: Name -> Name+ , _baseRulesField :: Name -> Name+ }++-- | Default 'BaseRules': prepend @F@ or @$@ to data type, constructors and field names.+baseRules :: BaseRules+baseRules = BaseRules+ { _baseRulesType = toFName+ , _baseRulesCon = toFName+ , _baseRulesField = toFName+ }++-- | How to name the base functor type.+--+-- Default is to prepened @F@ or @$@.+baseRulesType :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules+baseRulesType f rules = (\x -> rules { _baseRulesType = x }) <$> f (_baseRulesType rules)++-- | How to rename the base functor type constructors.+--+-- Default is to prepened @F@ or @$@.+baseRulesCon :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules+baseRulesCon f rules = (\x -> rules { _baseRulesCon = x }) <$> f (_baseRulesCon rules)++-- | How to rename the base functor type field names (in records).+--+-- Default is to prepened @F@ or @$@.+baseRulesField :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules+baseRulesField f rules = (\x -> rules { _baseRulesField = x }) <$> f (_baseRulesField rules)++toFName :: Name -> Name+toFName = mkName . f . nameBase+ where+ f name | isInfixName name = name ++ "$"+ | otherwise = name ++ "F"++ isInfixName :: String -> Bool+ isInfixName = all isSymbolChar++makePrimForDec :: BaseRules -> Dec -> DecsQ+makePrimForDec rules dec = case dec of+#if MIN_VERSION_template_haskell(2,11,0)+ DataD _ tyName vars _ cons _ -> do+ makePrimForDec' rules False tyName vars cons+ NewtypeD _ tyName vars _ con _ -> do+ makePrimForDec' rules True tyName vars [con]+#else+ DataD _ tyName vars cons _ ->+ makePrimForDec' rules False tyName vars cons+ NewtypeD _ tyName vars con _ -> do+ makePrimForDec' rules True tyName vars [con]+#endif+ _ -> fail "makeFieldOptics: Expected data type-constructor"++makePrimForDec' :: BaseRules -> Bool -> Name -> [TyVarBndr] -> [Con] -> DecsQ+makePrimForDec' rules isNewtype tyName vars cons = do+ -- variable parameters+ let vars' = map VarT (typeVars vars)+ -- Name of base functor+ let tyNameF = _baseRulesType rules tyName+ -- Recursive type+ let s = conAppsT tyName vars'+ -- Additional argument+ rName <- newName "r"+ let r = VarT rName+ -- Vars+ let varsF = vars ++ [PlainTV rName]+ let fieldCons = map normalizeConstructor cons++ let consF+ = conNameMap (_baseRulesCon rules)+ . conFieldNameMap (_baseRulesField rules)+ . conTypeMap (substType s r)+ <$> cons++ -- Data definition+ let dataDec = case consF of+ [conF] | isNewtype ->+#if MIN_VERSION_template_haskell(2,11,0)+ NewtypeD [] tyNameF varsF Nothing conF [ConT functorTypeName, ConT foldableTypeName, ConT traversableTypeName]+ _ ->+ DataD [] tyNameF varsF Nothing consF [ConT functorTypeName, ConT foldableTypeName, ConT traversableTypeName]+#else+ NewtypeD [] tyNameF varsF conF [functorTypeName, foldableTypeName, traversableTypeName]+ _ ->+ DataD [] tyNameF varsF consF [functorTypeName, foldableTypeName, traversableTypeName]+#endif++ -- type instance Base+#if MIN_VERSION_template_haskell(2,9,0)+ let baseDec = TySynInstD baseTypeName (TySynEqn [s] $ conAppsT tyNameF vars')+#else+ let baseDec = TySynInstD baseTypeName [s] $ conAppsT tyNameF vars'+#endif++ -- instance Recursive+ args <- (traverse . traverse . traverse) (\_ -> newName "x") fieldCons++ let projDec = FunD projectValName (mkMorphism id toFName args)+#if MIN_VERSION_template_haskell(2,11,0)+ let recursiveDec = InstanceD Nothing [] (ConT recursiveTypeName `AppT` s) [projDec]+#else+ let recursiveDec = InstanceD [] (ConT recursiveTypeName `AppT` s) [projDec]+#endif++ -- instance Corecursive+ let embedDec = FunD embedValName (mkMorphism toFName id args)+#if MIN_VERSION_template_haskell(2,11,0)+ let corecursiveDec = InstanceD Nothing [] (ConT corecursiveTypeName `AppT` s) [embedDec]+#else+ let corecursiveDec = InstanceD [] (ConT corecursiveTypeName `AppT` s) [embedDec]+#endif++ -- Combine+ pure [dataDec, baseDec, recursiveDec, corecursiveDec]++-- | makes clauses to rename constructors+mkMorphism+ :: (Name -> Name)+ -> (Name -> Name)+ -> [(Name, [Name])]+ -> [Clause]+mkMorphism nFrom nTo args = flip map args $ \(n, fs) -> Clause+ [ConP (nFrom n) (map VarP fs)] -- patterns+ (NormalB $ foldl AppE (ConE $ nTo n) (map VarE fs)) -- body+ [] -- where dec++-- | Normalized the Con type into a uniform positional representation,+-- eliminating the variance between records, infix constructors, and normal+-- constructors.+normalizeConstructor+ :: Con+ -> (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type++normalizeConstructor (RecC n xs) =+ (n, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs])++normalizeConstructor (NormalC n xs) =+ (n, [ (Nothing, ty) | (_,ty) <- xs])++normalizeConstructor (InfixC (_,ty1) n (_,ty2)) =+ (n, [ (Nothing, ty1), (Nothing, ty2) ])++normalizeConstructor (ForallC _ _ con) =+ (fmap . fmap . first) (const Nothing) (normalizeConstructor con)++#if MIN_VERSION_template_haskell(2,11,0)+normalizeConstructor (GadtC ns xs _) =+ (head ns, [ (Nothing, ty) | (_,ty) <- xs])++normalizeConstructor (RecGadtC ns xs _) =+ (head ns, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs])+#endif++-------------------------------------------------------------------------------+-- Traversals+-------------------------------------------------------------------------------++conNameTraversal :: Applicative f => (Name -> f Name) -> Con -> f Con+conNameTraversal f (NormalC n xs) = NormalC <$> f n <*> A.pure xs+conNameTraversal f (RecC n xs) = RecC <$> f n <*> pure xs+conNameTraversal f (InfixC l n r) = InfixC l <$> f n <*> pure r+conNameTraversal f (ForallC xs ctx con) = ForallC xs ctx <$> conNameTraversal f con+#if MIN_VERSION_template_haskell(2,11,0)+conNameTraversal f (GadtC ns xs t) = GadtC <$> T.traverse f ns <*> pure xs <*> pure t+conNameTraversal f (RecGadtC ns xs t) = RecGadtC <$> traverse f ns <*> pure xs <*> pure t+#endif++conFieldNameTraversal :: Applicative f => (Name -> f Name) -> Con -> f Con+conFieldNameTraversal f (RecC n xs) = RecC n <$> (traverse . tripleFst) f xs+conFieldNameTraversal f (ForallC xs ctx con) = ForallC xs ctx <$> conFieldNameTraversal f con+#if MIN_VERSION_template_haskell(2,11,0)+conFieldNameTraversal f (RecGadtC ns xs t) = RecGadtC ns <$> (traverse . tripleFst) f xs <*> pure t+#endif+conFieldNameTraversal _ x = pure x++conTypeTraversal :: Applicative f => (Type -> f Type) -> Con -> f Con+conTypeTraversal f (NormalC n xs) = NormalC n <$> (traverse . pairSnd) f xs+conTypeTraversal f (RecC n xs) = RecC n <$> (traverse . tripleTrd) f xs+conTypeTraversal f (InfixC l n r) = InfixC <$> pairSnd f l <*> pure n <*> pairSnd f r+conTypeTraversal f (ForallC xs ctx con) = ForallC xs ctx <$> conTypeTraversal f con+#if MIN_VERSION_template_haskell(2,11,0)+conTypeTraversal f (GadtC ns xs t) = GadtC ns <$> (traverse . pairSnd) f xs <*> pure t+conTypeTraversal f (RecGadtC ns xs t) = RecGadtC ns <$> (traverse . tripleTrd) f xs <*> pure t+#endif++conNameMap :: (Name -> Name) -> Con -> Con+conNameMap f = runIdentity . conNameTraversal (Identity . f)++conFieldNameMap :: (Name -> Name) -> Con -> Con+conFieldNameMap f = runIdentity . conFieldNameTraversal (Identity . f)++conTypeMap :: (Type -> Type) -> Con -> Con+conTypeMap f = runIdentity . conTypeTraversal (Identity . f)++-------------------------------------------------------------------------------+-- Monomorphic tuple lenses+-------------------------------------------------------------------------------++type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s++pairSnd :: Lens' (a, b) b+pairSnd f (a, b) = (,) a <$> f b++tripleTrd :: Lens' (a, b, c) c+tripleTrd f (a,b,c) = (,,) a b <$> f c++tripleFst :: Lens' (a, b, c) a+tripleFst f (a,b,c) = (\a' -> (a', b, c)) <$> f a++-------------------------------------------------------------------------------+-- Type mangling+-------------------------------------------------------------------------------++-- | Extraty type variables+typeVars :: [TyVarBndr] -> [Name]+typeVars = map varBindName++varBindName :: TyVarBndr -> Name+varBindName (PlainTV n) = n+varBindName (KindedTV n _) = n++-- | Apply arguments to a type constructor.+conAppsT :: Name -> [Type] -> Type+conAppsT conName = foldl AppT (ConT conName)++-- | Provides substitution for types+substType+ :: Type+ -> Type+ -> Type+ -> Type+substType a b = go+ where+ go x | x == a = b+ go (VarT n) = VarT n+ go (AppT l r) = AppT (go l) (go r)+ go (ForallT xs ctx t) = ForallT xs ctx (go t)+ -- This may fail with kind error+ go (SigT t k) = SigT (go t) k+#if MIN_VERSION_template_haskell(2,11,0)+ go (InfixT l n r) = InfixT (go l) n (go r)+ go (UInfixT l n r) = UInfixT (go l) n (go r)+ go (ParensT t) = ParensT (go t)+#endif+ -- Rest are unchanged+ go x = x++-------------------------------------------------------------------------------+-- Compat from base-4.9+-------------------------------------------------------------------------------++isSymbolChar :: Char -> Bool+isSymbolChar c = not (isPuncChar c) && case generalCategory c of+ MathSymbol -> True+ CurrencySymbol -> True+ ModifierSymbol -> True+ OtherSymbol -> True+ DashPunctuation -> True+ OtherPunctuation -> not (c `elem` "'\"")+ ConnectorPunctuation -> c /= '_'+ _ -> False++isPuncChar :: Char -> Bool+isPuncChar c = c `elem` ",;()[]{}`"++-------------------------------------------------------------------------------+-- Manually quoted names+-------------------------------------------------------------------------------+-- By manually generating these names we avoid needing to use the+-- TemplateHaskell language extension when compiling this library.+-- This allows the library to be used in stage1 cross-compilers.++rsPackageKey :: String+#ifdef CURRENT_PACKAGE_KEY+rsPackageKey = CURRENT_PACKAGE_KEY+#else+rsPackageKey = "recursion-schemes-" ++ showVersion version+#endif++mkRsName_tc :: String -> String -> Name+mkRsName_tc = mkNameG_tc rsPackageKey++mkRsName_v :: String -> String -> Name+mkRsName_v = mkNameG_v rsPackageKey++baseTypeName :: Name+baseTypeName = mkRsName_tc "Data.Functor.Foldable" "Base"++recursiveTypeName :: Name+recursiveTypeName = mkRsName_tc "Data.Functor.Foldable" "Recursive"++corecursiveTypeName :: Name+corecursiveTypeName = mkRsName_tc "Data.Functor.Foldable" "Corecursive"++projectValName :: Name+projectValName = mkRsName_v "Data.Functor.Foldable" "project"++embedValName :: Name+embedValName = mkRsName_v "Data.Functor.Foldable" "embed"++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"
+ examples/Expr.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Main where++import Data.Functor.Foldable+import Data.Functor.Foldable.TH+import Data.List (foldl')+import Test.HUnit++data Expr a+ = Lit a+ | Add (Expr a) (Expr a)+ | Expr a :* [Expr a]+ deriving (Show)++makeBaseFunctor ''Expr++expr1 :: Expr Int+expr1 = Add (Lit 2) (Lit 3 :* [Lit 4])++-- This is to test newtype derivation+--+-- Kind of a list+newtype L a = L { getL :: Maybe (a, L a) }+ deriving (Show, Eq)++makeBaseFunctor ''L++cons :: a -> L a -> L a+cons x xs = L (Just (x, xs))++nil :: L a+nil = L Nothing++main :: IO ()+main = do+ let expr2 = ana divCoalg 55 :: Expr Int+ 14 @=? cata evalAlg expr1+ 55 @=? cata evalAlg expr2++ let lBar = cons 'b' $ cons 'a' $ cons 'r' $ nil+ "bar" @=? cata lAlg lBar+ lBar @=? ana lCoalg "bar"+ where+ evalAlg (LitF x) = x+ evalAlg (AddF x y) = x + y+ evalAlg (x :*$ y) = foldl' (*) x y++ divCoalg x+ | x < 5 = LitF x+ | even x = 2 :*$ [x']+ | otherwise = AddF x' (x - x')+ where+ x' = x `div` 2++ lAlg (LF Nothing) = []+ lAlg (LF (Just (x, xs))) = x : xs++ lCoalg [] = LF { getLF = Nothing } -- to test field renamer+ lCoalg (x : xs) = LF { getLF = Just (x, xs) }
recursion-schemes.cabal view
@@ -1,8 +1,8 @@ name: recursion-schemes category: Control, Recursion-version: 5+version: 5.0.1 license: BSD3-cabal-version: >= 1.6+cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -13,7 +13,7 @@ synopsis: Generalized bananas, lenses and barbed wire description: Generalized bananas, lenses and barbed wire -tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.1+tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2 build-type: Simple extra-source-files: .travis.yml CHANGELOG.markdown .gitignore README.markdown@@ -22,6 +22,11 @@ type: git location: git://github.com/ekmett/recursion-schemes.git +flag template-haskell+ description: About Template Haskell derivations+ manual: True+ default: True+ library extensions: CPP other-extensions:@@ -34,17 +39,37 @@ UndecidableInstances build-depends:- base >= 4 && < 5,- bifunctors >= 4 && < 6,- comonad >= 4 && < 6,- free >= 4 && < 5,- transformers >= 0.2 && < 1,- transformers-compat >= 0.3 && < 1+ base >= 4 && < 5,+ bifunctors >= 4 && < 6,+ comonad >= 4 && < 6,+ free >= 4 && < 5,+ semigroups >= 0.8.3.1 && < 1,+ transformers >= 0.2 && < 1,+ transformers-compat >= 0.3 && < 1 if impl(ghc < 7.5) build-depends: ghc-prim exposed-modules:+ Data.Functor.Base Data.Functor.Foldable + if flag(template-haskell)+ build-depends: template-haskell >= 2.5.0.0 && < 2.12, base-orphans >= 0.5.4 && <0.6+ exposed-modules:+ Data.Functor.Foldable.TH++ other-modules:+ Paths_recursion_schemes+ ghc-options: -Wall++test-suite Expr+ type: exitcode-stdio-1.0+ main-is: Expr.hs+ hs-source-dirs: examples+ ghc-options: -Wall -threaded+ build-depends:+ base,+ HUnit <1.6,+ recursion-schemes