micro-recursion-schemes (empty) → 5.0.2.1
raw patch · 11 files changed
+1076/−0 lines, 11 filesdep +HUnitdep +basedep +micro-recursion-schemessetup-changed
Dependencies added: HUnit, base, micro-recursion-schemes, template-haskell, th-abstraction
Files
- CHANGELOG.markdown +36/−0
- Data/Functor/Base.hs +87/−0
- Data/Functor/Foldable.hs +388/−0
- Data/Functor/Foldable/TH.hs +368/−0
- LICENSE +26/−0
- README.markdown +9/−0
- Setup.hs +2/−0
- cabal.project.local +2/−0
- examples/Expr.hs +97/−0
- micro-recursion-schemes.cabal +59/−0
- stack.yaml +2/−0
+ CHANGELOG.markdown view
@@ -0,0 +1,36 @@+## 5.0.2+* Support GHC-8.2.1+* Fix Template Haskell derivation with non-default type renamer.+* Add `Recursive` and `Corecursive Natural` instances, with `Base Natural = Maybe`.++## 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+* Use `Eq1`, `Ord1`, `Show1`, `Read1` to derive `Fix`, `Nu` and `Mu` `Eq`, `Ord` `Show` and `Read` instances+* Remove `Prim` data family. `ListF` as a new name for `Prim [a]`, with plenty of instances, e.g. `Traversable`.+* Export `unfix`+* Add chronomorphisms: `chrono` and `gchrono`.+* Add `distGApoT`++## 4.1.2+* Support for `free` 4.12.1++## 4.1.1+* Support for GHC 7.10+* Fixed `para`.++## 4.1+* Support for GHC 7.7+'s generalized `Typeable`.+* Faster `gapo` and `para` by exploiting sharing.++## 4.0++* Compatibility with `comonad` and `free` version 4.0++## 3.0++* Compatibility with `transformers` 0.3+* Resolved deprecation warnings caused by changes to `Data.Typeable`
+ Data/Functor/Base.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Base Functors for standard types not already expressed as a fixed point.+module Data.Functor.Base+ ( NonEmptyF(..)+ ) where++import Data.Data (Typeable)+import GHC.Generics (Generic, Generic1)++import Control.Applicative+import Data.Monoid++import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..),+ Read1 (..), Read2 (..), Show1 (..),+ Show2 (..))++import qualified Data.Foldable as F+import qualified Data.Traversable as T++import qualified Data.Bifoldable as Bi+import qualified Data.Bifunctor 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+ , Generic+ , Generic1+ )++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++-- 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 = maybe x (mappend x)++instance Bi.Bitraversable NonEmptyF where+ bitraverse f g = liftA2 NonEmptyF <$> (f . head) <*> (T.traverse g . tail)
+ Data/Functor/Foldable.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+----------------------------------------------------------------------------+module Data.Functor.Foldable+ (+ -- * Base functors for fixed points+ Base+ , ListF(..)+ -- * Fixed points+ , Fix(..), unfix+ , Mu(..)+ , Nu(..)+ -- * Folding+ , Recursive(..)+ -- ** Combinators+ , zygo+ , mutu+ -- * Unfolding+ , Corecursive(..)+ -- * Refolding+ , hylo+ -- ** Changing representation+ , refix+ -- * Mendler-style+ , mcata+ , mhisto+ -- * Elgot (co)algebras+ , elgot+ , coelgot+ ) where++import Control.Applicative+import Control.Arrow+import Control.Monad (join)+import Data.Data+import Data.Function (on)+import Data.Functor.Classes+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, toList)+import Data.Monoid (Monoid (..))+import GHC.Generics (Generic, Generic1)+import Numeric.Natural+import Prelude+import Text.Read++import qualified Data.Foldable as F+import qualified Data.Traversable as T++import qualified Data.Bifoldable as Bi+import qualified Data.Bifunctor as Bi+import qualified Data.Bitraversable as Bi++import Data.Functor.Base+import qualified Data.Functor.Base as NEF (NonEmptyF (..))++type family Base t :: * -> *++class Functor (Base t) => Recursive t where+ project :: t -> Base t t++ cata :: (Base t a -> a) -- ^ a (Base t)-algebra+ -> t -- ^ fixed point+ -> a -- ^ result+ cata f = c where c = f . fmap c . project++ para :: (Base t (t, a) -> a) -> t -> a+ para t = p where p x = t . fmap ((,) <*> p) $ project x++ -- | Fokkinga's prepromorphism+ prepro+ :: Corecursive t+ => (forall b. Base t b -> Base t b)+ -> (Base t a -> a)+ -> t+ -> a+ prepro e f = c where c = f . fmap (c . cata (embed . e)) . project++class Functor (Base t) => Corecursive t where+ embed :: Base t t -> t+ ana+ :: (a -> Base t a) -- ^ a (Base t)-coalgebra+ -> a -- ^ seed+ -> t -- ^ resulting fixed point+ ana g = a where a = embed . fmap a . g++ apo :: (a -> Base t (Either t a)) -> a -> t+ apo g = a where a = embed . fmap (either id a) . g++ -- | Fokkinga's postpromorphism+ postpro+ :: Recursive t+ => (forall b. Base t b -> Base t b) -- natural transformation+ -> (a -> Base t a) -- a (Base t)-coalgebra+ -> a -- seed+ -> t+ postpro e g = a where a = embed . fmap (ana (e . project) . a) . g++ -- | A generalized postpromorphism+ gpostpro+ :: (Recursive t, Monad m)+ => (forall b. m (Base t b) -> Base t (m b)) -- distributive law+ -> (forall c. Base t c -> Base t c) -- natural transformation+ -> (a -> Base t (m a)) -- a (Base t)-m-coalgebra+ -> a -- seed+ -> t+ gpostpro k e g = a . return where a = embed . fmap (ana (e . project) . a . join) . k . fmap g++hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+hylo f g = h where h = f . fmap h . g++-- | Base functor of @[]@.+data ListF a b = Nil | Cons a b+ deriving (Eq,Ord,Show,Read,Typeable+ , Generic+ , Generic1+ )++instance Eq2 ListF where+ liftEq2 _ _ Nil Nil = True+ liftEq2 f g (Cons a b) (Cons a' b') = f a a' && g b b'+ liftEq2 _ _ _ _ = False++instance Eq a => Eq1 (ListF a) where+ liftEq = liftEq2 (==)++instance Ord2 ListF where+ liftCompare2 _ _ Nil Nil = EQ+ liftCompare2 _ _ Nil _ = LT+ liftCompare2 _ _ _ Nil = GT+ liftCompare2 f g (Cons a b) (Cons a' b') = f a a' `mappend` g b b'++instance Ord a => Ord1 (ListF a) where+ liftCompare = liftCompare2 compare++instance Show a => Show1 (ListF a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 ListF where+ liftShowsPrec2 _ _ _ _ _ Nil = showString "Nil"+ liftShowsPrec2 sa _ sb _ d (Cons a b) = showParen (d > 10)+ $ showString "Cons "+ . sa 11 a+ . showString " "+ . sb 11 b++instance Read2 ListF where+ liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> nil s ++ cons s+ where+ nil s0 = do+ ("Nil", s1) <- lex s0+ return (Nil, s1)+ cons s0 = do+ ("Cons", s1) <- lex s0+ (a, s2) <- ra 11 s1+ (b, s3) <- rb 11 s2+ return (Cons a b, s3)++instance Read a => Read1 (ListF a) where+ liftReadsPrec = liftReadsPrec2 readsPrec readList++-- These instances cannot be auto-derived on with GHC <= 7.6+instance Functor (ListF a) where+ fmap _ Nil = Nil+ fmap f (Cons a b) = Cons a (f b)++instance F.Foldable (ListF a) where+ foldMap _ Nil = Data.Monoid.mempty+ foldMap f (Cons _ b) = f b++instance T.Traversable (ListF a) where+ traverse _ Nil = pure Nil+ traverse f (Cons a b) = Cons a <$> f b++instance Bi.Bifunctor ListF where+ bimap _ _ Nil = Nil+ bimap f g (Cons a b) = Cons (f a) (g b)++instance Bi.Bifoldable ListF where+ bifoldMap _ _ Nil = mempty+ bifoldMap f g (Cons a b) = mappend (f a) (g b)++instance Bi.Bitraversable ListF where+ bitraverse _ _ Nil = pure Nil+ bitraverse f g (Cons a b) = Cons <$> f a <*> g b++type instance Base [a] = ListF a+instance Recursive [a] where+ project (x:xs) = Cons x xs+ project [] = Nil++ para f (x:xs) = f (Cons x (xs, para f xs))+ para f [] = f Nil++instance Corecursive [a] where+ embed (Cons x xs) = x:xs+ embed Nil = []++ apo f a = case f a of+ Cons x (Left xs) -> x : xs+ 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)++type instance Base Natural = Maybe+instance Recursive Natural where+ project 0 = Nothing+ project n = Just (n - 1)+instance Corecursive Natural where+ embed = maybe 0 (+1)++-- 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+instance Corecursive (Maybe a) where embed = getConst++-- | Example boring stub for non-recursive data types+type instance Base (Either a b) = Const (Either a b)+instance Recursive (Either a b) where project = Const+instance Corecursive (Either a b) where embed = getConst++-------------------------------------------------------------------------------+-- Fix+-------------------------------------------------------------------------------++newtype Fix f = Fix (f (Fix f))++unfix :: Fix f -> f (Fix f)+unfix (Fix f) = f++instance Eq1 f => Eq (Fix f) where+ Fix a == Fix b = eq1 a b++instance Ord1 f => Ord (Fix f) where+ compare (Fix a) (Fix b) = compare1 a b++instance Show1 f => Show (Fix f) where+ showsPrec d (Fix a) =+ showParen (d >= 11)+ $ showString "Fix "+ . showsPrec1 11 a++instance Read1 f => Read (Fix f) where+ readPrec = parens $ prec 10 $ do+ Ident "Fix" <- lexP+ Fix <$> step (readS_to_Prec readsPrec1)++deriving instance Typeable Fix+deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)++type instance Base (Fix f) = f+instance Functor f => Recursive (Fix f) where+ project (Fix a) = a+instance Functor f => Corecursive (Fix f) where+ embed = Fix++refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t+refix = cata embed++toFix :: Recursive t => t -> Fix (Base t)+toFix = refix++fromFix :: Corecursive t => Fix (Base t) -> t+fromFix = refix++-------------------------------------------------------------------------------+-- Lambek+-------------------------------------------------------------------------------++-- | Lambek's lemma provides a default definition for 'project' in terms of 'cata' and 'embed'+lambek :: (Recursive t, Corecursive t) => (t -> Base t t)+lambek = cata (fmap embed)++-- | The dual of Lambek's lemma, provides a default definition for 'embed' in terms of 'ana' and 'project'+colambek :: (Recursive t, Corecursive t) => (Base t t -> t)+colambek = ana (fmap project)++newtype Mu f = Mu (forall a. (f a -> a) -> a)+type instance Base (Mu f) = f+instance Functor f => Recursive (Mu f) where+ project = lambek+ cata f (Mu g) = g f+instance Functor f => Corecursive (Mu f) where+ embed m = Mu (\f -> f (fmap (cata f) m))++instance (Functor f, Eq1 f) => Eq (Mu f) where+ (==) = (==) `on` toFix++instance (Functor f, Ord1 f) => Ord (Mu f) where+ compare = compare `on` toFix++instance (Functor f, Show1 f) => Show (Mu f) where+ showsPrec d f = showParen (d > 10) $+ showString "fromFix " . showsPrec 11 (toFix f)++instance (Functor f, Read1 f) => Read (Mu f) where+ readPrec = parens $ prec 10 $ do+ Ident "fromFix" <- lexP+ fromFix <$> step readPrec++data Nu f where Nu :: (a -> f a) -> a -> Nu f+type instance Base (Nu f) = f+instance Functor f => Corecursive (Nu f) where+ embed = colambek+ ana = Nu+instance Functor f => Recursive (Nu f) where+ project (Nu f a) = Nu f <$> f a++instance (Functor f, Eq1 f) => Eq (Nu f) where+ (==) = (==) `on` toFix++instance (Functor f, Ord1 f) => Ord (Nu f) where+ compare = compare `on` toFix++instance (Functor f, Show1 f) => Show (Nu f) where+ showsPrec d f = showParen (d > 10) $+ showString "fromFix " . showsPrec 11 (toFix f)++instance (Functor f, Read1 f) => Read (Nu f) where+ readPrec = parens $ prec 10 $ do+ Ident "fromFix" <- lexP+ fromFix <$> step readPrec++zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a+zygo f g = snd . cata (\x -> (f (fmap fst x), g x))++mutu :: (Recursive t) => (Base t (a, a) -> a) -> (Base t (a, a) -> a) -> t -> a+mutu f g = g . fmap (\x -> (mutu g f x, mutu f g x)) . project++-- | Mendler-style iteration+mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c+mcata psi = psi (mcata psi) . unfix++-- | Mendler-style course-of-value iteration+mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c+mhisto psi = psi (mhisto psi) unfix . unfix++-- | Elgot algebras+elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a+elgot phi psi = h where h = (id ||| phi . fmap h) . psi++-- | Elgot coalgebras: <http://comonad.com/reader/2008/elgot-coalgebras/>+coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b+coelgot phi psi = h where h = phi . (id &&& fmap h . psi)++-------------------------------------------------------------------------------+-- Not exposed anywhere+-------------------------------------------------------------------------------++-- | Read a list (using square brackets and commas), given a function+-- for reading elements.+_readListWith :: ReadS a -> ReadS [a]+_readListWith rp =+ readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])+ where+ readl s = [([],t) | ("]",t) <- lex s] +++ [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]+ readl' s = [([],t) | ("]",t) <- lex s] +++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]
+ Data/Functor/Foldable/TH.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+module Data.Functor.Foldable.TH+ ( makeBaseFunctor+ , makeBaseFunctorWith+ , BaseRules+ , baseRules+ , baseRulesType+ , baseRulesCon+ , baseRulesField+ ) where++import Control.Applicative as A+import Control.Monad+import Data.Char (GeneralCategory (..),+ generalCategory)+import Data.Functor.Identity+import Data.Traversable as T+import Language.Haskell.TH+import Language.Haskell.TH.Datatype as TH.Abs+import Language.Haskell.TH.Syntax (mkNameG_tc, mkNameG_v)++-- | 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 = reifyDatatype name >>= makePrimForDI rules++-- | Rules of renaming data names+data BaseRules = BaseRules+ { _baseRulesType :: Name -> Name+ , _baseRulesCon :: Name -> Name+ , _baseRulesField :: Name -> Name+ }++-- | Default 'BaseRules': append @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 append @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 append @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 append @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++makePrimForDI :: BaseRules -> DatatypeInfo -> DecsQ+makePrimForDI rules+ DatatypeInfo { datatypeName = tyName+ , datatypeVars = vars+ , datatypeCons = cons+ , datatypeVariant = variant } = do+ when isDataFamInstance $+ fail "makeBaseFunctor: Data families are currently not supported."+ makePrimForDI' rules (variant == Newtype) tyName+ (map toTyVarBndr vars) cons+ where+ isDataFamInstance = case variant of+ DataInstance -> True+ NewtypeInstance -> True+ Datatype -> False+ Newtype -> False++ toTyVarBndr :: Type -> TyVarBndr+ toTyVarBndr (VarT n) = PlainTV n+ toTyVarBndr (SigT (VarT n) k) = KindedTV n k+ toTyVarBndr _ = error "toTyVarBndr"++makePrimForDI' :: BaseRules -> Bool -> Name -> [TyVarBndr]+ -> [ConstructorInfo] -> DecsQ+makePrimForDI' 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]++ -- #33+ cons' <- traverse (conTypeTraversal resolveTypeSynonyms) cons+ let consF+ = toCon+ . conNameMap (_baseRulesCon rules)+ . conFieldNameMap (_baseRulesField rules)+ . conTypeMap (substType s r)+ <$> cons'++ -- Data definition+ let dataDec = case consF of+ [conF] | isNewtype ->+ NewtypeD [] tyNameF varsF Nothing conF deriveds+ _ ->+ DataD [] tyNameF varsF Nothing consF deriveds+ where+ deriveds =+ [DerivClause Nothing+ [ ConT functorTypeName+ , ConT foldableTypeName+ , ConT traversableTypeName ]]++ -- type instance Base+ let baseDec = TySynInstD baseTypeName (TySynEqn [s] $ conAppsT tyNameF vars')++ -- instance Recursive+ projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons'+ let recursiveDec = InstanceD Nothing [] (ConT recursiveTypeName `AppT` s) [projDec]++ -- instance Corecursive+ embedDec <- FunD embedValName <$> mkMorphism (_baseRulesCon rules) id cons'+ let corecursiveDec = InstanceD Nothing [] (ConT corecursiveTypeName `AppT` s) [embedDec]++ -- Combine+ A.pure [dataDec, baseDec, recursiveDec, corecursiveDec]++-- | makes clauses to rename constructors+mkMorphism+ :: (Name -> Name)+ -> (Name -> Name)+ -> [ConstructorInfo]+ -> Q [Clause]+mkMorphism nFrom nTo args = for args $ \ci -> do+ let n = constructorName ci+ fs <- replicateM (length (constructorFields ci)) (newName "x")+ pure $ Clause [ConP (nFrom n) (map VarP fs)] -- patterns+ (NormalB $ foldl AppE (ConE $ nTo n) (map VarE fs)) -- body+ [] -- where dec++-------------------------------------------------------------------------------+-- Traversals+-------------------------------------------------------------------------------++conNameTraversal :: Traversal' ConstructorInfo Name+conNameTraversal = lens constructorName (\s v -> s { constructorName = v })++conFieldNameTraversal :: Traversal' ConstructorInfo Name+conFieldNameTraversal = lens constructorVariant (\s v -> s { constructorVariant = v })+ . conVariantTraversal+ where+ conVariantTraversal :: Traversal' ConstructorVariant Name+ conVariantTraversal _ NormalConstructor = pure NormalConstructor+ conVariantTraversal _ InfixConstructor = pure InfixConstructor+ conVariantTraversal f (RecordConstructor fs) = RecordConstructor <$> traverse f fs++conTypeTraversal :: Traversal' ConstructorInfo Type+conTypeTraversal = lens constructorFields (\s v -> s { constructorFields = v })+ . traverse++conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo+conNameMap = over conNameTraversal++conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo+conFieldNameMap = over conFieldNameTraversal++conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo+conTypeMap = over conTypeTraversal++-------------------------------------------------------------------------------+-- Lenses+-------------------------------------------------------------------------------++type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s+type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s++lens :: (s -> a) -> (s -> a -> s) -> Lens' s a+lens sa sas afa s = sas s <$> afa (sa s)+{-# INLINE lens #-}++over :: Traversal' s a -> (a -> a) -> s -> s+over l f = runIdentity . l (Identity . f)+{-# INLINE over #-}++-------------------------------------------------------------------------------+-- Type mangling+-------------------------------------------------------------------------------++-- | Extract type variables+typeVars :: [TyVarBndr] -> [Name]+typeVars = map tvName++-- | 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+ 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)+ -- Rest are unchanged+ go x = x++toCon :: ConstructorInfo -> Con+toCon ConstructorInfo { constructorName = name+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ftys+ , constructorStrictness = fstricts+ , constructorVariant = variant }+ | not (null vars && null ctxt)+ = error "makeBaseFunctor: GADTs are not currently supported."+ | otherwise+ = let bangs = map toBang fstricts+ in case variant of+ NormalConstructor -> NormalC name $ zip bangs ftys+ RecordConstructor fnames -> RecC name $ zip3 fnames bangs ftys+ InfixConstructor -> let [bang1, bang2] = bangs+ [fty1, fty2] = ftys+ in InfixC (bang1, fty1) name (bang2, fty2)+ where+ toBang (FieldStrictness upkd strct) = Bang (toSourceUnpackedness upkd)+ (toSourceStrictness strct)+ where+ toSourceUnpackedness :: Unpackedness -> SourceUnpackedness+ toSourceUnpackedness UnspecifiedUnpackedness = NoSourceUnpackedness+ toSourceUnpackedness NoUnpack = SourceNoUnpack+ toSourceUnpackedness Unpack = SourceUnpack++ toSourceStrictness :: Strictness -> SourceStrictness+ toSourceStrictness UnspecifiedStrictness = NoSourceStrictness+ toSourceStrictness Lazy = SourceLazy+ toSourceStrictness TH.Abs.Strict = SourceStrict++-------------------------------------------------------------------------------+-- 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 -> c `notElem` "'\""+ 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+rsPackageKey = CURRENT_PACKAGE_KEY++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"
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2011-2015 Edward Kmett, 2018 Vanessa McHale++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.markdown view
@@ -0,0 +1,9 @@+micro-recursion-schemes+==========++[](https://hackage.haskell.org/package/micro-recursion-schemes) [](http://travis-ci.org/ekmett/micro-recursion-schemes)++This is a fork of the+[recursion-schemes](http://hackage.haskell.org/package/recursion-schemes)+package that aims to have few dependencies and optionally no dependence on+`cpphs`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal.project.local view
@@ -0,0 +1,2 @@+tests: true+documentation: true
+ examples/Expr.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Main where++import Data.Functor.Foldable+import Data.Functor.Foldable.TH+import Data.Functor.Identity+import Data.List (foldl')+import Language.Haskell.TH+import Test.HUnit++data Expr a+ = Lit a+ | Add (Expr a) (Expr a)+ | Expr a :* [Expr a]+ deriving (Show)++makeBaseFunctor ''Expr++data Expr2 a+ = Lit2 a+ | Add2 (Expr2 a) (Expr2 a)+ deriving (Show)++makeBaseFunctorWith (runIdentity $ baseRulesCon (\_-> Identity $ mkName . (++ "'") . nameBase) baseRules+ >>= baseRulesType (\_ -> Identity $ mkName . (++ "_") . nameBase)+ ) ''Expr2++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++-- Test #33+data Tree a = Node {rootLabel :: a, subForest :: Forest a}+ deriving (Show)+type Forest a = [Tree a]++makeBaseFunctor ''Tree++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"++ let expr3 = Add2 (Lit2 21) $ Add2 (Lit2 11) (Lit2 10)+ 42 @=? cata evalAlg2 expr3++ let expr4 = Node 5 [Node 6 [Node 7 []], Node 8 [Node 9 []]]+ 35 @=? cata treeAlg expr4+ where+ -- Type signatures to test name generation+ evalAlg :: ExprF Int Int -> Int+ evalAlg (LitF x) = x+ evalAlg (AddF x y) = x + y+ evalAlg (x :*$ y) = foldl' (*) x y++ evalAlg2 :: Expr2_ Int Int -> Int+ evalAlg2 (Lit2' x) = x+ evalAlg2 (Add2' x y) = 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) }++ treeAlg :: TreeF Int Int -> Int+ treeAlg (NodeF r f) = r + sum f
+ micro-recursion-schemes.cabal view
@@ -0,0 +1,59 @@+cabal-version: 1.18+name: micro-recursion-schemes+version: 5.0.2.1+license: BSD3+license-file: LICENSE+copyright: Copyright (C) 2008-2015 Edward A. Kmett, 2018 Vanessa McHale+maintainer: vmchale@gmail.com+author: Vanessa McHale, Edward A. Kmett+tested-with: ghc ==8.2.2 ghc ==8.4.1+synopsis: Simple recursion schemes+description:+ This package provides the core functionality of [recursion-schemes](http://hackage.haskell.org/package/recursion-schemes), but without odious dependencies on unneeded packages.+category: Control, Recursion+build-type: Simple+extra-source-files:+ cabal.project.local+ stack.yaml+extra-doc-files: README.markdown+ CHANGELOG.markdown++source-repository head+ type: git+ location: git://github.com/vmchale/micro-recursion-schemes.git++flag template-haskell+ description:+ Enable Template Haskell functionality+ manual: True++library+ exposed-modules:+ Data.Functor.Base+ Data.Functor.Foldable+ default-language: Haskell2010+ other-extensions: TypeFamilies Rank2Types FlexibleContexts+ FlexibleInstances GADTs StandaloneDeriving UndecidableInstances+ ghc-options: -Wall+ build-depends:+ base >=4.10 && <5+ + if flag(template-haskell)+ exposed-modules:+ Data.Functor.Foldable.TH+ build-tools: cpphs -any+ build-depends:+ th-abstraction >=0.2.4 && <1,+ template-haskell >=2.5.0.0 && <2.14++test-suite Expr+ type: exitcode-stdio-1.0+ main-is: Expr.hs+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -Wall -threaded+ build-depends:+ base -any,+ HUnit <1.7,+ micro-recursion-schemes -any,+ template-haskell >=2.5.0.0 && <2.14
+ stack.yaml view
@@ -0,0 +1,2 @@+---+resolver: lts-11.4