Extensions.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Data.Foldable.Functor.Extensions
    ( dicata
    , dendro
    , micro
    , symplecto
    , chema
    , cataM
    , SubHom (..)
    , CoSubHom (..)
    , Dummy (..)
    ) where

import           Control.Arrow         ((&&&))
import           Control.Composition   ((-.*), (.*))
import           Control.Monad         ((<=<))
import           Data.Functor.Foldable (Base, Corecursive, Recursive, ana, cata,
                                        elgot, embed, hylo, project)

-- | Class that yields g-algebra homomorphisms between mutually recursive types.
class (Functor f, Functor g) => SubHom f g a b where

    -- | Homomorphism of g-algebras parametrized by an f-algebra
    homo :: (f a -> a) -> (g b -> b) -> (g b -> b)

-- | Class that yields g-coalgebra homomorphisms between mutually recursive types.
class (Functor f, Functor g) => CoSubHom f g a b where

    -- | Homomorphism of g-coalgebras paramterized by an f-coalgebra
    homoCo :: (a -> f a) -> (b -> g b) -> (b -> g b)

class Dummy t where
    dummy :: t

-- manjari or margaritari?

-- | Entangle two hylomorphisms. Not the same thing as a symplectomorphism from geometry.
symplecto :: (SubHom g f b b, CoSubHom g f a a)
    => (g b -> b) -- ^ A g-algebra
    -> (a -> g a) -- ^ A g-coalgebra
    -> (f b -> b) -- ^ An f-algebra
    -> (a -> f a) -- ^ An f-coalgebra
    -> a -> b
symplecto = homoCo -.* (flip . ((.) .* hylo .* homo)) -- FIXME what the fuck did I do

-- Entangle two anamorphisms
chema :: (CoSubHom (Base t) (Base t') a b, Corecursive t')
    => (a -> Base t a) -- A (Base t)-coalgebra
    -> (b -> Base t' b) -- A (Base t')-coalgebra
    -> b -> t'
chema = ana .* homoCo

-- FIXME maybe run the catamorphism on the inner bit?

-- | A dendromorphism allows us to entangle two catamorphisms
dendro :: (SubHom (Base t) (Base t') a b, Recursive t')
    => t -- ^ dummy type
    -> (Base t a -> a) -- ^ A (Base t)-algebra
    -> (Base t' b -> b) -- ^ A (Base t')-algebra
    -> t' -> b
dendro _ = cata .* homo

-- | Catamorphism collapsing along two data types simultaneously. Basically a fancy zygomorphism.
dicata :: (Recursive a) => (Base a (b, a) -> b) -> (Base a (b, a) -> a) -> a -> b
dicata f g = fst . cata (f &&& g)

-- | A micromorphism is an Elgot algebra specialized to unfolding.
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 = g where g = phi <=< (mapM g . project)