Extensions.hs

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

-- | Several extensions to Edward Kmett's recursion schemes package. The monadic
-- recursion schemes and exotic recursion schemes should be stable, but the
-- recursion schemes for interdependent data type (and their attendant
-- typeclasses) are experimental.
module Data.Functor.Foldable.Extensions
    ( -- * Classes
      SubHom (..)
    , SubType (..)
    , CoSubHom (..)
    , Dummy (..)
    -- * Monadic recursion schemes
    , cataM
    , anaM
    , hyloM
    -- * Recursion schemes for interdependent data types
    , dendro
    , dendroTri
    , symplecto
    , chema
    -- * Exotic recursion schemes
    , dicata
    , micro
    ) where

import           Control.Arrow
import           Control.Composition
import           Control.Monad
import           Data.Functor.Foldable

-- | 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 SubType b where

    -- | Resolve nested functions.
    switch :: 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)

-- | We need this class to make type resolution work.
class Dummy t where
    dummy :: t

--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 here

-- Entangle two anamorphisms.
chema :: (CoSubHom (Base t) (Base t') a b, SubType b, Corecursive t')
    => t -- ^ dummy type
    -> (a -> Base t a) -- A (Base t)-coalgebra
    -> (b -> Base t' b) -- A (Base t')-coalgebra
    -> b -> t'
chema = const (pseudoana .* homoCo)
    where pseudoana g = a where a = embed . fmap a . g . switch

-- | A dendromorphism allows us to entangle two catamorphisms
dendro :: (SubHom (Base t) (Base t') a b, SubType 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 = const (pseudocata .* homo)
    where pseudocata f = c where c = switch . f . fmap (switch . c) . project

-- | Entangle three base functors.
dendroTri :: (SubHom (Base t) (Base t') a b, SubType b, Recursive t', SubHom (Base t'') (Base t) c a, SubType a, Recursive t)
    => t -- ^ dummy type
    -> t'' -- ^ another dummy type
    -> (Base t'' c -> c) -- ^ A (Base t'')-algebra
    -> (Base t a -> a) -- A (Base t)-algebra
    -> (Base t' b -> b) -- A (Base t')-algebra
    -> t' -> b
dendroTri = fmap const (switch .** homo -.* (fmap <$> dendro))

-- | 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 = fst .** (cata .* (&&&))

-- | A micromorphism is an Elgot algebra specialized to unfolding.
micro :: (Corecursive a) => (b -> Either a (Base a b)) -> b -> a
micro = elgot embed

-- | A monadic catamorphism
cataM :: (Recursive t, Traversable (Base t), Monad m) => (Base t a -> m a) -> (t -> m a)
cataM phi = fix (fmap (phi <=<) (project -.* mapM))

-- | A monadic anamorphism
anaM :: (Corecursive t, Traversable (Base t), Monad m) => (a -> m (Base t a)) -> (a -> m t)
anaM = fix (fmap embed .** ((=<<) .* (fmap traverse) >=> fmap))

-- | A monadic hylomorphism
hyloM :: (Functor f, Monad m, Traversable f) => (f b -> m b) -> (a -> m (f a)) -> a -> m b
hyloM = fix (fmap (flip flip id) (ap .* ((<=<) .** (liftM2 fmap (<=<) <$> (mapM .*)))))