recursion-schemes 5.1 → 5.1.1
raw patch · 11 files changed
+1463/−1317 lines, 11 files
Files
- .travis.yml +7/−2
- CHANGELOG.markdown +7/−0
- Data/Functor/Base.hs +0/−116
- Data/Functor/Foldable.hs +0/−769
- Data/Functor/Foldable/TH.hs +0/−415
- README.markdown +30/−8
- examples/Expr.hs +28/−0
- recursion-schemes.cabal +9/−7
- src/Data/Functor/Base.hs +116/−0
- src/Data/Functor/Foldable.hs +851/−0
- src/Data/Functor/Foldable/TH.hs +415/−0
.travis.yml view
@@ -1,6 +1,6 @@ # This Travis job script has been generated by a script via #-# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project'+# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--doctest' '--doctest-options=-DCURRENT_PACKAGE_KEY='"recursion-schemes"'' '--no-unconstrained' 'cabal.project' # # For more information, see https://github.com/haskell-CI/haskell-ci #@@ -108,6 +108,8 @@ cabal new-update head.hackage -v fi - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+ - (cd /tmp && echo '' | cabal new-repl -w ${HC} --build-dep fail)+ - if [ $HCNUMVER -ge 80000 ]; then cabal new-install -w ${HC} -j2 --symlink-bindir=$HOME/.local/bin doctest --constraint='doctest ==0.16.*'; fi - "printf 'packages: \".\"\\n' > cabal.project" - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - touch cabal.project.local@@ -141,11 +143,14 @@ - cabal new-build -w ${HC} ${TEST} ${BENCH} all - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi + # doctest+ - if [ $HCNUMVER -ge 80000 ]; then (cd recursion-schemes-* && doctest -DCURRENT_PACKAGE_KEY='"recursion-schemes"' src); fi+ # cabal check - (cd recursion-schemes-* && cabal check) # haddock - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi -# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"]+# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--doctest","--doctest-options=-DCURRENT_PACKAGE_KEY='\"recursion-schemes\"'","--no-unconstrained","cabal.project"] # EOF
CHANGELOG.markdown view
@@ -1,3 +1,10 @@+## 5.1.1++* Add `cotransverse`+* Add `Generic` based default implementation to `embed` and `project`.+ `Recursive` and `Corecursive` can be `DeriveAnyClass`-derived now,+ if you write the base functor by hand.+ ## 5.1 * Export gfutu * `distGHisto`, `ghisto`, and `gchrono` now use `Cofree (Base t)`
− Data/Functor/Base.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE CPP #-}-#include "recursion-schemes-common.h"--#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(..)-#ifdef LIFTED_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- )--#ifdef LIFTED_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
@@ -1,769 +0,0 @@-{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-}-#include "recursion-schemes-common.h"--#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE ConstrainedClassMethods #-}-#endif-#if HAS_GENERIC-{-# LANGUAGE DeriveGeneric #-}-#endif-#endif---------------------------------------------------------------------------------- |--- 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(..), hoistMu- , Nu(..), hoistNu- -- * Folding- , Recursive(..)- -- ** Combinators- , gapo- , gcata- , zygo- , gzygo- , histo- , ghisto- , futu- , gfutu- , chrono- , gchrono- -- ** Distributive laws- , distCata- , distPara- , distParaT- , distZygo- , distZygoT- , distHisto- , distGHisto- , distFutu- , distGFutu- -- * Unfolding- , Corecursive(..)- -- ** Combinators- , gana- -- ** Distributive laws- , distAna- , distApo- , distGApo- , distGApoT- -- * Refolding- , hylo- , ghylo- -- ** Changing representation- , hoist- , refix- -- * Common names- , fold, gfold- , unfold, gunfold- , refold, grefold- -- * Mendler-style- , mcata- , mhisto- -- * Elgot (co)algebras- , elgot- , coelgot- -- * Zygohistomorphic prepromorphisms- , zygoHistoPrepro- -- * Effectful combinators- , cataA- , transverse- ) where--import Control.Applicative-import Control.Comonad-import Control.Comonad.Trans.Class-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__-import Data.Data hiding (gunfold)-#if HAS_POLY_TYPEABLE-#else-import qualified Data.Data as Data-#endif-#if HAS_GENERIC-import GHC.Generics (Generic)-#endif-#if HAS_GENERIC1-import GHC.Generics (Generic1)-#endif-#endif-import Numeric.Natural-import Data.Monoid (Monoid (..))-import Prelude--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 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- 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-- gpara :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (EnvT t w a) -> a) -> t -> a- gpara t = gzygo embed t-- -- | 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 . hoist e) . project-- --- | A generalized prepromorphism- gprepro- :: (Corecursive t, Comonad w)- => (forall b. Base t (w b) -> w (Base t b))- -> (forall c. Base t c -> Base t c)- -> (Base t (w a) -> a)- -> t- -> a- gprepro k e f = extract . c where c = fmap f . k . fmap (duplicate . c . hoist e) . project--distPara :: Corecursive t => Base t (t, a) -> (t, Base t a)-distPara = distZygo embed--distParaT :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> Base t (EnvT t w a) -> EnvT t w (Base t a)-distParaT t = distZygoT embed t--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 (hoist e . 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 (hoist e . a . join) . k . liftM g--hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b-hylo f g = h where h = f . fmap h . g--fold :: Recursive t => (Base t a -> a) -> t -> a-fold = cata--unfold :: Corecursive t => (a -> Base t a) -> a -> t-unfold = ana--refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b-refold = hylo---- | Base functor of @[]@.-data ListF a b = Nil | Cons a b- deriving (Eq,Ord,Show,Read,Typeable-#if HAS_GENERIC- , Generic-#endif-#if HAS_GENERIC1- , Generic1-#endif- )--#ifdef LIFTED_FUNCTOR_CLASSES-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--#else-instance Eq a => Eq1 (ListF a) where eq1 = (==)-instance Ord a => Ord1 (ListF a) where compare1 = compare-instance Show a => Show1 (ListF a) where showsPrec1 = showsPrec-instance Read a => Read1 (ListF a) where readsPrec1 = readsPrec-#endif---- 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)---- | 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-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---- | A generalized catamorphism-gfold, gcata- :: (Recursive t, Comonad w)- => (forall b. Base t (w b) -> w (Base t b)) -- ^ a distributive law- -> (Base t (w a) -> a) -- ^ a (Base t)-w-algebra- -> t -- ^ fixed point- -> a-gcata k g = g . extract . c where- c = k . fmap (duplicate . fmap g . c) . project-gfold k g t = gcata k g t--distCata :: Functor f => f (Identity a) -> Identity (f a)-distCata = Identity . fmap runIdentity---- | A generalized anamorphism-gunfold, gana- :: (Corecursive t, Monad m)- => (forall b. m (Base t b) -> Base t (m b)) -- ^ a distributive law- -> (a -> Base t (m a)) -- ^ a (Base t)-m-coalgebra- -> a -- ^ seed- -> t-gana k f = a . return . f where- a = embed . fmap (a . liftM f . join) . k-gunfold k f t = gana k f t--distAna :: Functor f => Identity (f a) -> f (Identity a)-distAna = fmap Identity . runIdentity---- | A generalized hylomorphism-grefold, ghylo- :: (Comonad w, Functor f, Monad m)- => (forall c. f (w c) -> w (f c))- -> (forall d. m (f d) -> f (m d))- -> (f (w b) -> b)- -> (a -> f (m a))- -> a- -> b-ghylo w m f g = extract . h . return where- h = fmap f . w . fmap (duplicate . h . join) . m . liftM g-grefold w m f g a = ghylo w m f g a--futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t-futu = gana distFutu--gfutu :: (Corecursive t, Functor m, Monad m) => (forall b. m (Base t b) -> Base t (m b)) -> (a -> Base t (FreeT (Base t) m a)) -> a -> t-gfutu g = gana (distGFutu g)--distFutu :: Functor f => Free f (f a) -> f (Free f a)-distFutu (Pure fx) = Pure <$> fx-distFutu (Free ff) = Free . distFutu <$> ff--distGFutu :: (Functor f, Functor h) => (forall b. h (f b) -> f (h b)) -> FreeT f h (f a) -> f (FreeT f h a)-distGFutu k = d where- d = fmap FreeT . k . fmap d' . runFreeT- d' (CMTF.Pure ff) = CMTF.Pure <$> ff- d' (CMTF.Free ff) = CMTF.Free . d <$> ff------------------------------------------------------------------------------------ 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)--#ifdef __GLASGOW_HASKELL__-#if HAS_POLY_TYPEABLE-deriving instance Typeable Fix-deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)-#else-instance Typeable1 f => Typeable (Fix f) where- typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)]- where asArgsTypeOf :: f a -> Fix f -> f a- asArgsTypeOf = const--fixTyCon :: TyCon-#if MIN_VERSION_base(4,4,0)-fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix"-#else-fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"-#endif-{-# NOINLINE fixTyCon #-}--instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where- gfoldl f z (Fix a) = z Fix `f` a- toConstr _ = fixConstr- gunfold k z c = case constrIndex c of- 1 -> k (z (Fix))- _ -> error "gunfold"- dataTypeOf _ = fixDataType--fixConstr :: Constr-fixConstr = mkConstr fixDataType "Fix" [] Prefix--fixDataType :: DataType-fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr]-#endif-#endif--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--hoist :: (Recursive s, Corecursive t)- => (forall a. Base s a -> Base t a) -> s -> t-hoist n = cata (embed . n)--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 (fold 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)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read1 f) => Read (Mu f) where- readPrec = parens $ prec 10 $ do- Ident "fromFix" <- lexP- fromFix <$> step readPrec-#endif---- | A specialized, faster version of 'hoist' for 'Mu'.-hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g-hoistMu n (Mu mk) = Mu $ \roll -> mk (roll . n)----- | 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-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)--#ifdef __GLASGOW_HASKELL__-instance (Functor f, Read1 f) => Read (Nu f) where- readPrec = parens $ prec 10 $ do- Ident "fromFix" <- lexP- fromFix <$> step readPrec-#endif---- | A specialized, faster version of 'hoist' for 'Nu'.-hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g-hoistNu n (Nu next seed) = Nu (n . next) seed---zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a-zygo f = gfold (distZygo f)--distZygo- :: Functor f- => (f b -> b) -- An f-algebra- -> (f (b, a) -> (b, f a)) -- ^ A distributive for semi-mutual recursion-distZygo g m = (g (fmap fst m), fmap snd m)--gzygo- :: (Recursive t, Comonad w)- => (Base t b -> b)- -> (forall c. Base t (w c) -> w (Base t c))- -> (Base t (EnvT b w a) -> a)- -> t- -> a-gzygo f w = gfold (distZygoT f w)--distZygoT- :: (Functor f, Comonad w)- => (f b -> b) -- An f-w-algebra to use for semi-mutual recursion- -> (forall c. f (w c) -> w (f c)) -- A base Distributive law- -> f (EnvT b w a) -> EnvT b w (f a) -- A new distributive law that adds semi-mutual recursion-distZygoT g k fe = EnvT (g (getEnv <$> fe)) (k (lower <$> fe))- where getEnv (EnvT e _) = e--gapo :: Corecursive t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t-gapo g = gunfold (distGApo g)--distApo :: Recursive t => Either t (Base t a) -> Base t (Either t a)-distApo = distGApo project--distGApo :: Functor f => (b -> f b) -> Either b (f a) -> f (Either b a)-distGApo f = either (fmap Left . f) (fmap Right)--distGApoT- :: (Functor f, Functor m)- => (b -> f b)- -> (forall c. m (f c) -> f (m c))- -> ExceptT b m (f a)- -> f (ExceptT b m a)-distGApoT g k = fmap ExceptT . k . fmap (distGApo g) . runExceptT---- | Course-of-value iteration-histo :: Recursive t => (Base t (Cofree (Base t) a) -> a) -> t -> a-histo = gcata distHisto--ghisto :: (Recursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (CofreeT (Base t) w a) -> a) -> t -> a-ghisto g = gcata (distGHisto g)--distHisto :: Functor f => f (Cofree f a) -> Cofree f (f a)-distHisto fc = fmap extract fc :< fmap (distHisto . Cofree.unwrap) fc--distGHisto :: (Functor f, Functor h) => (forall b. f (h b) -> h (f b)) -> f (CofreeT f h a) -> CofreeT f h (f a)-distGHisto k = d where d = CofreeT . fmap (\fc -> fmap CCTC.headF fc CCTC.:< fmap (d . CCTC.tailF) fc) . k . fmap runCofreeT--chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> (a -> b)-chrono = ghylo distHisto distFutu--gchrono :: (Functor f, Functor w, Functor m, Comonad w, Monad m) =>- (forall c. f (w c) -> w (f c)) ->- (forall c. m (f c) -> f (m c)) ->- (f (CofreeT f w b) -> b) -> (a -> f (FreeT f m a)) ->- (a -> b)-gchrono w m = ghylo (distGHisto w) (distGFutu m)---- | 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)---- | Zygohistomorphic prepromorphisms:------ A corrected and modernized version of <http://www.haskell.org/haskellwiki/Zygohistomorphic_prepromorphisms>-zygoHistoPrepro- :: (Corecursive t, Recursive t)- => (Base t b -> b)- -> (forall c. Base t c -> Base t c)- -> (Base t (EnvT b (Cofree (Base t)) a) -> a)- -> t- -> a-zygoHistoPrepro f g t = gprepro (distZygoT f distHisto) g t------------------------------------------------------------------------------------ Effectful combinators------------------------------------------------------------------------------------ | Effectful |fold|.------ This is a type specialisation of 'cata'.------ An example terminating a recursion immediately:------ >>> cataA (\alg -> case alg of { Nil -> pure (); Cons a _ -> Const [a] }) "hello"--- Const "h"----cataA :: (Recursive t) => (Base t (f a) -> f a) -> t -> f a-cataA = cata---- | An effectful version of 'hoist'.------ Properties:------ @--- 'transverse' 'sequenceA' = 'pure'--- @------ Examples:------ The weird type of first argument allows user to decide--- an order of sequencing:------ >>> transverse (\x -> print (void x) *> sequence x) "foo" :: IO String--- Cons 'f' ()--- Cons 'o' ()--- Cons 'o' ()--- Nil--- "foo"------ >>> transverse (\x -> sequence x <* print (void x)) "foo" :: IO String--- Nil--- Cons 'o' ()--- Cons 'o' ()--- Cons 'f' ()--- "foo"----transverse :: (Recursive s, Corecursive t, Functor f)- => (forall a. Base s (f a) -> f (Base t a)) -> s -> f t-transverse n = cata (fmap embed . n)------------------------------------------------------------------------------------ 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
@@ -1,415 +0,0 @@-{-# LANGUAGE CPP, Rank2Types #-}-module Data.Functor.Foldable.TH- ( makeBaseFunctor- , makeBaseFunctorWith- , BaseRules- , baseRules- , baseRulesType- , baseRulesCon- , baseRulesField- ) where--import Control.Applicative as A-import Control.Monad-import Data.Traversable as T-import Data.Functor.Identity-import Language.Haskell.TH-import Language.Haskell.TH.Datatype as TH.Abs-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 = 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-#if MIN_VERSION_template_haskell(2,11,0)- [conF] | isNewtype ->- NewtypeD [] tyNameF varsF Nothing conF deriveds- _ ->- DataD [] tyNameF varsF Nothing consF deriveds-#else- [conF] | isNewtype ->- NewtypeD [] tyNameF varsF conF deriveds- _ ->- DataD [] tyNameF varsF consF deriveds-#endif- where- deriveds =-#if MIN_VERSION_template_haskell(2,12,0)- [DerivClause Nothing- [ ConT functorTypeName- , ConT foldableTypeName- , ConT traversableTypeName ]]-#elif MIN_VERSION_template_haskell(2,11,0)- [ ConT functorTypeName- , ConT foldableTypeName- , ConT traversableTypeName ]-#else- [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- projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons'-#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- embedDec <- FunD embedValName <$> mkMorphism (_baseRulesCon rules) id cons'-#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- 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-#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--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-#if MIN_VERSION_template_haskell(2,11,0)- 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-#else- -- On old versions of Template Haskell, there isn't as rich of strictness- -- information available, so the conversion is somewhat lossy. We try our- -- best to recognize certain common combinations, and fall back to NotStrict- -- in the event there's an exotic combination.- toBang (FieldStrictness UnspecifiedUnpackedness Strict) = IsStrict- toBang (FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness) = NotStrict- toBang (FieldStrictness Unpack Strict) = Unpacked- toBang FieldStrictness{} = NotStrict-#endif------------------------------------------------------------------------------------ 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-#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"
README.markdown view
@@ -1,15 +1,37 @@-recursion-schemes-==========+# recursion-schemes [](https://hackage.haskell.org/package/recursion-schemes) [](http://travis-ci.org/ekmett/recursion-schemes) -This package includes code for functional programming with bananas, envelopes, lenses, barbed wire and all that.+## What is a recursion scheme? -Contact Information--------------------+Many recursive functions share the same structure, e.g. pattern-match on the input and, depending on the data constructor, either recur on a smaller input or terminate the recursion with the base case. Another one: start with a seed value, use it to produce the first element of an infinite list, and recur on a modified seed in order to produce the rest of the list. Such a structure is called a recursion scheme. -Contributions and bug reports are welcome!+## Benefits -Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.+### Clearer --Edward Kmett+Each recursion scheme has a unique name, such as "fold" and "unfold"; or, if you prefer the fancy names, "catamorphism" and "anamorphism". If you program with others, it can be useful to have names to refer to those recursion patterns, so you can discuss which type of recursion is the most appropriate for the problem at hand. Even if you program alone, having names with which to clearly label those different solutions can help to structure your thoughts while writing recursive functions.++This library lists the most common recursion schemes, and also provides an implementation corresponding to each one. The idea is that a recursive function may be broken into two parts: the part which is the same in all the recursive functions which follow a given recursion scheme, and the part which is different in each function. Our implementation performs the recursive, common part, and takes as input a function which performs the non-recursive, unique part.++If you use those implementations instead of making explicit recursive calls, your code will simultaneously become clearer (to those who are familiar with recursion schemes) and more obscure (to those who aren't). Obviously, if one knows how to read and understand recursive code but does not know what e.g. `para` means, then the version which uses `para` will look needlessly obfuscated compared to the version they already know how to read. But if one is familiar with `para`, then seeing this familiar name will instantly clarify that this is a spine-based function, like `Map.insert`, which allocates new nodes along a spine but leaves the rest of the nodes untouched. This is a very useful starting point, guiding the reader to look for the logic which decides which sub-trees to drill through and which sub-trees to leave untouched. In contrast, with the general-recursion version, the reader has no such starting point and must thus read through the entire function (or guess based on the function's name) before they can infer that kind of big picture information.++### Faster++Using recursion schemes can guide you towards optimizations. When multiple functions are composed, Haskellers often use equational reasoning in order to rearrange those compositions into equivalent compositions which compute the same result, but do so in a different, possibly more efficient manner. When the recursive and non-recursive portions of a function are written separately, more equations become available, as they have more pieces to work with. The paper [Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire](https://maartenfokkinga.github.io/utwente/mmf91m.pdf) has a lot more details on that subject.++### Safer++Using recursion schemes can help you to avoid accidentally writing infinite or non-productive loops. For example, when producing an infinite list, it would be a mistake to look at the result of the recursive call in order to decide which element to produce as the head of the list, because that recursive call will itself look at its recursive call, etc., and so the information will never be returned. With `ana`, the non-recursive function you need to provide as input intentionally does not have access to the result of the recursive call, so you cannot make that mistake.++### Composable++Many recursion schemes can be implemented in terms of each other. So if you notice that the non-recursive functions you provide themselves seem to share a common pattern, you might be accidentally reimplementing an existing recursion scheme which already has those common parts builtin; or maybe you have stumbled upon a new recursion scheme which does not yet have a name, and which you may want to implement yourself.++One way to implement such a custom recursion scheme is to combine the features of existing recursion schemes. For example, a "paramorphism" gives the non-recursive function access to the original sub-trees, a "zygomorphism" gives that function access to auxiliary results computed from those sub-trees, and so the combined "zygomorphic paramorphism" gives that function access to both the original sub-trees and the auxiliary results. In order to construct such combinations, most of our recursion schemes come in a generalized variant, e.g. `gzygo`, and in a "distributive law transformer" variant, e.g. `distZygoT`. Just like monad transformers, distributive law transformers can be combined into stacks, and like monad transformers, the order in which you combine the layers determines how the layers interact with each other. Apply a generalized recursion scheme to a stack of distributive laws in order to obtain a recursion scheme which has both the features of the generalized recursion scheme and those of the distributive laws.++## Contributing++Contributions and bug reports are welcome!++Please feel free to contact us by opening a github issue or by hopping onto the #haskell IRC channel on irc.freenode.net.
examples/Expr.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-} module Main where import Data.Functor.Foldable import Data.Functor.Foldable.TH import Language.Haskell.TH+import GHC.Generics (Generic) import Data.List (foldl') import Test.HUnit import Data.Functor.Identity@@ -26,6 +28,32 @@ >>= baseRulesCon (\_-> Identity $ mkName . (++ "'") . nameBase) >>= baseRulesType (\_ -> Identity $ mkName . (++ "_") . nameBase) ) ''Expr2++data Expr3 a+ = Lit3 a+ | Add3 (Expr3 a) (Expr3 a)+ | OpA (Expr3 a) (Expr3 a) Int+ | OpB (Expr3 a) (Expr3 a) Char+ | OpC (Expr3 a) (Expr3 a) Bool+ | OpD (Expr3 a) (Expr3 a) Int+ | OpE (Expr3 a) (Expr3 a) Char+ | OpF (Expr3 a) (Expr3 a) Bool Bool Bool+ deriving (Show, Generic)++data Expr3F a b+ = Lit3F a+ | Add3F b b+ | OpAF b b Int+ | OpBF b b Char+ | OpCF b b Bool+ | OpDF b b Int+ | OpEF b b Char+ | OpFF b b Bool Bool Bool+ deriving (Show, Generic, Functor)++type instance Base (Expr3 a) = (Expr3F a)+instance Recursive (Expr3 a)+instance Corecursive (Expr3 a) expr1 :: Expr Int expr1 = Add (Lit 2) (Lit 3 :* [Lit 4])
recursion-schemes.cabal view
@@ -1,20 +1,19 @@ name: recursion-schemes category: Control, Recursion-version: 5.1+version: 5.1.1 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett-maintainer: Edward A. Kmett <ekmett@gmail.com>+maintainer: "Samuel Gélineau" <gelisam@gmail.com>,+ "Oleg Grenrus" <oleg.grenrus@iki.fi>,+ "Ryan Scott" <ryan.gl.scott@gmail.com> stability: provisional homepage: http://github.com/ekmett/recursion-schemes/ bug-reports: http://github.com/ekmett/recursion-schemes/issues copyright: Copyright (C) 2008-2015 Edward A. Kmett-synopsis: Generalized bananas, lenses and barbed wire-description:- Recursion operators, see- "Generalized bananas, lenses and barbed wire"- by Erik Meijer, Maarten Fokkinga and Ross Paterson.+synopsis: Representing common recursion patterns as higher-order functions+description: Many recursive functions share the same structure, e.g. pattern-match on the input and, depending on the data constructor, either recur on a smaller input or terminate the recursion with the base case. Another one: start with a seed value, use it to produce the first element of an infinite list, and recur on a modified seed in order to produce the rest of the list. Such a structure is called a recursion scheme. Using higher-order functions to implement those recursion schemes makes your code clearer, faster, and safer. See README for details. tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3 @@ -41,6 +40,7 @@ StandaloneDeriving UndecidableInstances + hs-source-dirs: src include-dirs: include -- includes: recursion-schemes-common.h @@ -101,3 +101,5 @@ recursion-schemes, template-haskell, transformers >= 0.2 && < 1+ if impl(ghc < 7.5)+ build-depends: ghc-prim
+ src/Data/Functor/Base.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+#include "recursion-schemes-common.h"++#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(..)+#ifdef LIFTED_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+ )++#ifdef LIFTED_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)
+ src/Data/Functor/Foldable.hs view
@@ -0,0 +1,851 @@+{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-}+#include "recursion-schemes-common.h"++#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE ConstrainedClassMethods #-}+#endif+#if HAS_GENERIC+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables, DefaultSignatures, MultiParamTypeClasses, TypeOperators #-}+#endif+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2008-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : "Samuel Gélineau" <gelisam@gmail.com>,+-- "Oleg Grenrus" <oleg.grenrus@iki.fi>,+-- "Ryan Scott" <ryan.gl.scott@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+----------------------------------------------------------------------------+module Data.Functor.Foldable+ (+ -- * Base functors for fixed points+ Base+ , ListF(..)+ -- * Fixed points+ , Fix(..), unfix+ , Mu(..), hoistMu+ , Nu(..), hoistNu+ -- * Folding+ , Recursive(..)+ -- ** Combinators+ , gapo+ , gcata+ , zygo+ , gzygo+ , histo+ , ghisto+ , futu+ , gfutu+ , chrono+ , gchrono+ -- ** Distributive laws+ , distCata+ , distPara+ , distParaT+ , distZygo+ , distZygoT+ , distHisto+ , distGHisto+ , distFutu+ , distGFutu+ -- * Unfolding+ , Corecursive(..)+ -- ** Combinators+ , gana+ -- ** Distributive laws+ , distAna+ , distApo+ , distGApo+ , distGApoT+ -- * Refolding+ , hylo+ , ghylo+ -- ** Changing representation+ , hoist+ , refix+ -- * Common names+ , fold, gfold+ , unfold, gunfold+ , refold, grefold+ -- * Mendler-style+ , mcata+ , mhisto+ -- * Elgot (co)algebras+ , elgot+ , coelgot+ -- * Zygohistomorphic prepromorphisms+ , zygoHistoPrepro+ -- * Effectful combinators+ , cataA+ , transverse+ , cotransverse+ ) where++import Control.Applicative+import Control.Comonad+import Control.Comonad.Trans.Class+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__+import Data.Data hiding (gunfold)+#if HAS_POLY_TYPEABLE+#else+import qualified Data.Data as Data+#endif+#if HAS_GENERIC+import GHC.Generics (Generic (..), M1 (..), K1 (..), (:+:) (..), (:*:) (..))+#endif+#if HAS_GENERIC1+import GHC.Generics (Generic1)+#endif+#endif+import Numeric.Natural+import Data.Monoid (Monoid (..))+import Prelude++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 Data.Functor.Base hiding (head, tail)+import qualified Data.Functor.Base as NEF (NonEmptyF(..))++-- $setup+-- >>> import Control.Monad (void)+-- >>> import Data.Char (toUpper)++type family Base t :: * -> *++class Functor (Base t) => Recursive t where+ project :: t -> Base t t+#ifdef HAS_GENERIC+ default project :: (Generic t, Generic (Base t t), GCoerce (Rep t) (Rep (Base t t))) => t -> Base t t+ project = to . gcoerce . from+#endif++ 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++ gpara :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (EnvT t w a) -> a) -> t -> a+ gpara t = gzygo embed t++ -- | 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 . hoist e) . project++ --- | A generalized prepromorphism+ gprepro+ :: (Corecursive t, Comonad w)+ => (forall b. Base t (w b) -> w (Base t b))+ -> (forall c. Base t c -> Base t c)+ -> (Base t (w a) -> a)+ -> t+ -> a+ gprepro k e f = extract . c where c = fmap f . k . fmap (duplicate . c . hoist e) . project++distPara :: Corecursive t => Base t (t, a) -> (t, Base t a)+distPara = distZygo embed++distParaT :: (Corecursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> Base t (EnvT t w a) -> EnvT t w (Base t a)+distParaT t = distZygoT embed t++class Functor (Base t) => Corecursive t where+ embed :: Base t t -> t+#ifdef HAS_GENERIC+ default embed :: (Generic t, Generic (Base t t), GCoerce (Rep (Base t t)) (Rep t)) => Base t t -> t+ embed = to . gcoerce . from+#endif++ 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 (hoist e . 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 (hoist e . a . join) . k . liftM g++hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+hylo f g = h where h = f . fmap h . g++fold :: Recursive t => (Base t a -> a) -> t -> a+fold = cata++unfold :: Corecursive t => (a -> Base t a) -> a -> t+unfold = ana++refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+refold = hylo++-- | Base functor of @[]@.+data ListF a b = Nil | Cons a b+ deriving (Eq,Ord,Show,Read,Typeable+#if HAS_GENERIC+ , Generic+#endif+#if HAS_GENERIC1+ , Generic1+#endif+ )++#ifdef LIFTED_FUNCTOR_CLASSES+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++#else+instance Eq a => Eq1 (ListF a) where eq1 = (==)+instance Ord a => Ord1 (ListF a) where compare1 = compare+instance Show a => Show1 (ListF a) where showsPrec1 = showsPrec+instance Read a => Read1 (ListF a) where readsPrec1 = readsPrec+#endif++-- 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)++-- | 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+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++-- | A generalized catamorphism+gfold, gcata+ :: (Recursive t, Comonad w)+ => (forall b. Base t (w b) -> w (Base t b)) -- ^ a distributive law+ -> (Base t (w a) -> a) -- ^ a (Base t)-w-algebra+ -> t -- ^ fixed point+ -> a+gcata k g = g . extract . c where+ c = k . fmap (duplicate . fmap g . c) . project+gfold k g t = gcata k g t++distCata :: Functor f => f (Identity a) -> Identity (f a)+distCata = Identity . fmap runIdentity++-- | A generalized anamorphism+gunfold, gana+ :: (Corecursive t, Monad m)+ => (forall b. m (Base t b) -> Base t (m b)) -- ^ a distributive law+ -> (a -> Base t (m a)) -- ^ a (Base t)-m-coalgebra+ -> a -- ^ seed+ -> t+gana k f = a . return . f where+ a = embed . fmap (a . liftM f . join) . k+gunfold k f t = gana k f t++distAna :: Functor f => Identity (f a) -> f (Identity a)+distAna = fmap Identity . runIdentity++-- | A generalized hylomorphism+grefold, ghylo+ :: (Comonad w, Functor f, Monad m)+ => (forall c. f (w c) -> w (f c))+ -> (forall d. m (f d) -> f (m d))+ -> (f (w b) -> b)+ -> (a -> f (m a))+ -> a+ -> b+ghylo w m f g = extract . h . return where+ h = fmap f . w . fmap (duplicate . h . join) . m . liftM g+grefold w m f g a = ghylo w m f g a++futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t+futu = gana distFutu++gfutu :: (Corecursive t, Functor m, Monad m) => (forall b. m (Base t b) -> Base t (m b)) -> (a -> Base t (FreeT (Base t) m a)) -> a -> t+gfutu g = gana (distGFutu g)++distFutu :: Functor f => Free f (f a) -> f (Free f a)+distFutu (Pure fx) = Pure <$> fx+distFutu (Free ff) = Free . distFutu <$> ff++distGFutu :: (Functor f, Functor h) => (forall b. h (f b) -> f (h b)) -> FreeT f h (f a) -> f (FreeT f h a)+distGFutu k = d where+ d = fmap FreeT . k . fmap d' . runFreeT+ d' (CMTF.Pure ff) = CMTF.Pure <$> ff+ d' (CMTF.Free ff) = CMTF.Free . d <$> ff++-------------------------------------------------------------------------------+-- 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)++#ifdef __GLASGOW_HASKELL__+#if HAS_POLY_TYPEABLE+deriving instance Typeable Fix+deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)+#else+instance Typeable1 f => Typeable (Fix f) where+ typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)]+ where asArgsTypeOf :: f a -> Fix f -> f a+ asArgsTypeOf = const++fixTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix"+#else+fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"+#endif+{-# NOINLINE fixTyCon #-}++instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where+ gfoldl f z (Fix a) = z Fix `f` a+ toConstr _ = fixConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z (Fix))+ _ -> error "gunfold"+ dataTypeOf _ = fixDataType++fixConstr :: Constr+fixConstr = mkConstr fixDataType "Fix" [] Prefix++fixDataType :: DataType+fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr]+#endif+#endif++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++hoist :: (Recursive s, Corecursive t)+ => (forall a. Base s a -> Base t a) -> s -> t+hoist n = cata (embed . n)++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 (fold 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)++#ifdef __GLASGOW_HASKELL__+instance (Functor f, Read1 f) => Read (Mu f) where+ readPrec = parens $ prec 10 $ do+ Ident "fromFix" <- lexP+ fromFix <$> step readPrec+#endif++-- | A specialized, faster version of 'hoist' for 'Mu'.+hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g+hoistMu n (Mu mk) = Mu $ \roll -> mk (roll . n)+++-- | 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+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)++#ifdef __GLASGOW_HASKELL__+instance (Functor f, Read1 f) => Read (Nu f) where+ readPrec = parens $ prec 10 $ do+ Ident "fromFix" <- lexP+ fromFix <$> step readPrec+#endif++-- | A specialized, faster version of 'hoist' for 'Nu'.+hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g+hoistNu n (Nu next seed) = Nu (n . next) seed+++zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a+zygo f = gfold (distZygo f)++distZygo+ :: Functor f+ => (f b -> b) -- An f-algebra+ -> (f (b, a) -> (b, f a)) -- ^ A distributive for semi-mutual recursion+distZygo g m = (g (fmap fst m), fmap snd m)++gzygo+ :: (Recursive t, Comonad w)+ => (Base t b -> b)+ -> (forall c. Base t (w c) -> w (Base t c))+ -> (Base t (EnvT b w a) -> a)+ -> t+ -> a+gzygo f w = gfold (distZygoT f w)++distZygoT+ :: (Functor f, Comonad w)+ => (f b -> b) -- An f-w-algebra to use for semi-mutual recursion+ -> (forall c. f (w c) -> w (f c)) -- A base Distributive law+ -> f (EnvT b w a) -> EnvT b w (f a) -- A new distributive law that adds semi-mutual recursion+distZygoT g k fe = EnvT (g (getEnv <$> fe)) (k (lower <$> fe))+ where getEnv (EnvT e _) = e++gapo :: Corecursive t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t+gapo g = gunfold (distGApo g)++distApo :: Recursive t => Either t (Base t a) -> Base t (Either t a)+distApo = distGApo project++distGApo :: Functor f => (b -> f b) -> Either b (f a) -> f (Either b a)+distGApo f = either (fmap Left . f) (fmap Right)++distGApoT+ :: (Functor f, Functor m)+ => (b -> f b)+ -> (forall c. m (f c) -> f (m c))+ -> ExceptT b m (f a)+ -> f (ExceptT b m a)+distGApoT g k = fmap ExceptT . k . fmap (distGApo g) . runExceptT++-- | Course-of-value iteration+histo :: Recursive t => (Base t (Cofree (Base t) a) -> a) -> t -> a+histo = gcata distHisto++ghisto :: (Recursive t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (CofreeT (Base t) w a) -> a) -> t -> a+ghisto g = gcata (distGHisto g)++distHisto :: Functor f => f (Cofree f a) -> Cofree f (f a)+distHisto fc = fmap extract fc :< fmap (distHisto . Cofree.unwrap) fc++distGHisto :: (Functor f, Functor h) => (forall b. f (h b) -> h (f b)) -> f (CofreeT f h a) -> CofreeT f h (f a)+distGHisto k = d where d = CofreeT . fmap (\fc -> fmap CCTC.headF fc CCTC.:< fmap (d . CCTC.tailF) fc) . k . fmap runCofreeT++chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> (a -> b)+chrono = ghylo distHisto distFutu++gchrono :: (Functor f, Functor w, Functor m, Comonad w, Monad m) =>+ (forall c. f (w c) -> w (f c)) ->+ (forall c. m (f c) -> f (m c)) ->+ (f (CofreeT f w b) -> b) -> (a -> f (FreeT f m a)) ->+ (a -> b)+gchrono w m = ghylo (distGHisto w) (distGFutu m)++-- | 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)++-- | Zygohistomorphic prepromorphisms:+--+-- A corrected and modernized version of <http://www.haskell.org/haskellwiki/Zygohistomorphic_prepromorphisms>+zygoHistoPrepro+ :: (Corecursive t, Recursive t)+ => (Base t b -> b)+ -> (forall c. Base t c -> Base t c)+ -> (Base t (EnvT b (Cofree (Base t)) a) -> a)+ -> t+ -> a+zygoHistoPrepro f g t = gprepro (distZygoT f distHisto) g t++-------------------------------------------------------------------------------+-- Effectful combinators+-------------------------------------------------------------------------------++-- | Effectful 'fold'.+--+-- This is a type specialisation of 'cata'.+--+-- An example terminating a recursion immediately:+--+-- >>> cataA (\alg -> case alg of { Nil -> pure (); Cons a _ -> Const [a] }) "hello"+-- Const "h"+--+cataA :: (Recursive t) => (Base t (f a) -> f a) -> t -> f a+cataA = cata++-- | An effectful version of 'hoist'.+--+-- Properties:+--+-- @+-- 'transverse' 'sequenceA' = 'pure'+-- @+--+-- Examples:+--+-- The weird type of first argument allows user to decide+-- an order of sequencing:+--+-- >>> transverse (\x -> print (void x) *> sequence x) "foo" :: IO String+-- Cons 'f' ()+-- Cons 'o' ()+-- Cons 'o' ()+-- Nil+-- "foo"+--+-- >>> transverse (\x -> sequence x <* print (void x)) "foo" :: IO String+-- Nil+-- Cons 'o' ()+-- Cons 'o' ()+-- Cons 'f' ()+-- "foo"+--+transverse :: (Recursive s, Corecursive t, Functor f)+ => (forall a. Base s (f a) -> f (Base t a)) -> s -> f t+transverse n = cata (fmap embed . n)++-- | A coeffectful version of 'hoist'.+--+-- Properties:+--+-- @+-- 'cotransverse' 'distAna' = 'runIdentity'+-- @+--+-- Examples:+--+-- Stateful transformations:+--+-- >>> :{+-- cotransverse+-- (\(u, b) -> case b of+-- Nil -> Nil+-- Cons x a -> Cons (if u then toUpper x else x) (not u, a))+-- (True, "foobar") :: String+-- :}+-- "FoObAr"+--+-- We can implement `zipWith`+--+-- >>> :{+-- let zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]+-- zipWith' f = curry $ cotransverse $ \(xs, base) -> case (project xs, base) of+-- (Nil, _) -> Nil+-- (_, Nil) -> Nil+-- (Cons x a, Cons y b) -> Cons (f x y) (a, b)+-- :}+--+-- >>> zipWith' (*) [1,2,3] [4,5,6]+-- [4,10,18]+--+-- >>> zipWith' (*) [1,2,3] [4,5,6,8]+-- [4,10,18]+--+-- >>> zipWith' (*) [1,2,3,3] [4,5,6]+-- [4,10,18]+--+cotransverse :: (Recursive s, Corecursive t, Functor f)+ => (forall a. f (Base s a) -> Base t (f a)) -> f s -> t+cotransverse n = ana (n . fmap project)++-------------------------------------------------------------------------------+-- 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]++-------------------------------------------------------------------------------+-- GCoerce+-------------------------------------------------------------------------------++class GCoerce f g where+ gcoerce :: f a -> g a++instance GCoerce f g => GCoerce (M1 i c f) (M1 i c' g) where+ gcoerce (M1 x) = M1 (gcoerce x)++-- R changes to/from P with GHC-7.4.2 at least.+instance GCoerce (K1 i c) (K1 j c) where+ gcoerce = K1 . unK1++instance (GCoerce f g, GCoerce f' g') => GCoerce (f :*: f') (g :*: g') where+ gcoerce (x :*: y) = gcoerce x :*: gcoerce y++instance (GCoerce f g, GCoerce f' g') => GCoerce (f :+: f') (g :+: g') where+ gcoerce (L1 x) = L1 (gcoerce x)+ gcoerce (R1 x) = R1 (gcoerce x)
+ src/Data/Functor/Foldable/TH.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE CPP, Rank2Types #-}+module Data.Functor.Foldable.TH+ ( makeBaseFunctor+ , makeBaseFunctorWith+ , BaseRules+ , baseRules+ , baseRulesType+ , baseRulesCon+ , baseRulesField+ ) where++import Control.Applicative as A+import Control.Monad+import Data.Traversable as T+import Data.Functor.Identity+import Language.Haskell.TH+import Language.Haskell.TH.Datatype as TH.Abs+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 = 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+#if MIN_VERSION_template_haskell(2,11,0)+ [conF] | isNewtype ->+ NewtypeD [] tyNameF varsF Nothing conF deriveds+ _ ->+ DataD [] tyNameF varsF Nothing consF deriveds+#else+ [conF] | isNewtype ->+ NewtypeD [] tyNameF varsF conF deriveds+ _ ->+ DataD [] tyNameF varsF consF deriveds+#endif+ where+ deriveds =+#if MIN_VERSION_template_haskell(2,12,0)+ [DerivClause Nothing+ [ ConT functorTypeName+ , ConT foldableTypeName+ , ConT traversableTypeName ]]+#elif MIN_VERSION_template_haskell(2,11,0)+ [ ConT functorTypeName+ , ConT foldableTypeName+ , ConT traversableTypeName ]+#else+ [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+ projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons'+#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+ embedDec <- FunD embedValName <$> mkMorphism (_baseRulesCon rules) id cons'+#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+ 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+#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++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+#if MIN_VERSION_template_haskell(2,11,0)+ 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+#else+ -- On old versions of Template Haskell, there isn't as rich of strictness+ -- information available, so the conversion is somewhat lossy. We try our+ -- best to recognize certain common combinations, and fall back to NotStrict+ -- in the event there's an exotic combination.+ toBang (FieldStrictness UnspecifiedUnpackedness Strict) = IsStrict+ toBang (FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness) = NotStrict+ toBang (FieldStrictness Unpack Strict) = Unpacked+ toBang FieldStrictness{} = NotStrict+#endif++-------------------------------------------------------------------------------+-- 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+#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"