module Data.Functor.Foldable.Extensions
( dicata
, dendro
, dendroTri
, micro
, symplecto
, chema
, cataM
, SubHom (..)
, SubType (..)
, CoSubHom (..)
, Dummy (..)
) where
import Control.Arrow ((&&&))
import Control.Composition (fix, (-.*), (.*), (.**))
import Control.Monad ((<=<))
import Data.Functor.Foldable (Base, Corecursive, Recursive, cata,
elgot, embed, hylo, project)
class (Functor f, Functor g) => SubHom f g a b where
homo :: (f a -> a) -> (g b -> b) -> (g b -> b)
class SubType b where
switch :: b -> b
class (Functor f, Functor g) => CoSubHom f g a b where
homoCo :: (a -> f a) -> (b -> g b) -> (b -> g b)
coswitch :: a -> a
class Dummy t where
dummy :: t
symplecto :: (SubHom g f b b, CoSubHom g f a a)
=> (g b -> b)
-> (a -> g a)
-> (f b -> b)
-> (a -> f a)
-> a -> b
symplecto = homoCo -.* (flip . ((.) .* hylo .* homo))
chema :: (CoSubHom (Base t) (Base t') a b, SubType b, Corecursive t')
=> (a -> Base t a)
-> (b -> Base t' b)
-> b -> t'
chema = pseudoana .* homoCo
where pseudoana g = a where a = embed . fmap a . g . switch
dendro :: (SubHom (Base t) (Base t') a b, SubType b, Recursive t')
=> t
-> (Base t a -> a)
-> (Base t' b -> b)
-> t' -> b
dendro = const ((pseudocata .* homo))
where pseudocata f = c where c = switch . f . fmap c . project
dendroTri :: (SubHom (Base t) (Base t') a b, SubType b, Recursive t', SubHom (Base t'') (Base t) c a, SubType a, Recursive t)
=> t
-> t''
-> (Base t'' c -> c)
-> (Base t a -> a)
-> (Base t' b -> b)
-> t' -> b
dendroTri = const . (switch .** homo -.* ((.) . dendro))
dicata :: (Recursive a) => (Base a (b, a) -> b) -> (Base a (b, a) -> a) -> a -> b
dicata = fst .** (cata .* (&&&))
micro :: (Corecursive a) => (b -> Either a (Base a b)) -> b -> a
micro = elgot embed
cataM :: (Recursive t, Traversable (Base t), Monad m) => (Base t a -> m a) -> (t -> m a)
cataM phi = fix ((phi <=<) . (project -.* mapM))