Exotic.hs

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

-- | 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.Exotic
    (
    -- * Monadic recursion schemes
      cataM
    , anaM
    , hyloM
    -- * Recursion schemes for interdependent data types
    , dendro
    , scolio
    , chema
    -- * Exotic recursion schemes
    , dicata
    , micro
    , mutu
    -- * Data type for transformations
    , Trans
    -- * Helper functions
    , finish
    ) where

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

dock :: (Eq a) => [a] -> a
dock [x] = x
dock []  = undefined
dock (x:ys@(y:_))
    | x == y = y
    | otherwise = dock ys

-- | Helper function to force recursion. This can be used alongside 'dendro' to
-- simplify writing a 'Trans'
finish :: (Eq a) => (a -> a) -> a -> a
finish = dock .* iterate

-- | A map of F-algebras
type Trans s a = ∀ f. Functor f => (f a -> a) -> f s -> s

-- | Mutumorphism
mutu :: Recursive t => (Base t (b, a) -> b) -> (Base t (b, a) -> a) -> t -> a
mutu f g = snd . cata (f &&& g)

-- | Entangle two hylomorphisms.
scolio :: (Functor f, Functor g)
    => ((f b -> b) -> Trans b b) -- ^ A pseudoprism parametric in an F-algebra that allows `b` to inspect itself.
    -> ((a -> f a) -> Lens' a a) -- ^ A lens parametric in an F-coalgebra that allows `b` to inspect itself.
    -> (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
scolio p l alg coalg alg' coalg' = hylo (p alg' alg) (l coalg' coalg)

-- Entangle two anamorphisms.
chema :: (Corecursive t', Functor f)
    => ((a -> f a) -> Lens' b b) -- ^ A lens parametric in an F-coalgebra that allows `b` to inspect itself.
    -> (a -> f a) -- ^ A (Base t)-coalgebra
    -> (b -> Base t' b) -- ^ A (Base t')-coalgebra
    -> b -> t'
chema = (ana .*)

-- | A dendromorphism entangles two catamorphisms
dendro :: (Recursive t', Functor f)
    => ((f a -> a) -> Trans b b) -- ^ A pseudoprism parametric in an F-algebra that allows `b` to inspect itself.
    -> (f a -> a) -- ^ A (Base t)-algebra
    -> (Base t' b -> b) -- ^ A (Base t')-algebra
    -> t' -> b
dendro = (cata .*)

-- | 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 = c where c = phi <=< (mapM c . project)

-- | A monadic anamorphism
anaM :: (Corecursive t, Traversable (Base t), Monad m) => (a -> m (Base t a)) -> (a -> m t)
anaM psi = a where a = (fmap embed . mapM a) <=< psi

-- | A monadic hylomorphism
hyloM :: (Functor f, Monad m, Traversable f) => (f b -> m b) -> (a -> m (f a)) -> a -> m b
hyloM phi psi = h where h = phi <=< mapM h <=< psi