{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Recursion
(
Base
, Recursive (..)
, Corecursive (..)
, Fix (..)
, Mu (..)
, Nu (..)
, ListF (..)
, NonEmptyF (..)
, hylo
, prepro
, postpro
, mutu
, zygo
, para
, apo
, elgot
, coelgot
, micro
, meta
, meta'
, scolio
, cata
, ana
, mhisto
, mcata
, cataM
, anaM
, hyloM
, zygoM
, zygoM'
, scolioM
, scolioM'
, coelgotM
, elgotM
, paraM
, mutuM
, mutuM'
, microM
, lambek
, colambek
, hoist
, refix
) where
import Control.Arrow ((&&&))
import Control.Composition ((.*), (.**))
import Control.Monad ((<=<))
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Traversable (Traversable (..))
import Numeric.Natural (Natural)
type family Base t :: * -> *
class (Functor (Base t)) => Recursive t where
project :: t -> Base t t
class (Functor (Base t)) => Corecursive t where
embed :: Base t t -> t
data ListF a b = Cons a b
| Nil
deriving (Functor, Foldable, Traversable)
data NonEmptyF a b = NonEmptyF a (Maybe b)
deriving (Functor, Foldable, Traversable)
newtype Fix f = Fix { unFix :: f (Fix f) }
data Nu f = forall a. Nu (a -> f a) a
newtype Mu f = Mu (forall a. (f a -> a) -> a)
type instance Base (Fix f) = f
type instance Base (Fix f) = f
type instance Base (Mu f) = f
type instance Base (Nu f) = f
type instance Base Natural = Maybe
type instance Base [a] = ListF a
type instance Base (NonEmpty a) = NonEmptyF a
instance Recursive Natural where
project 0 = Nothing
project n = Just (n-1)
instance Corecursive Natural where
embed Nothing = 0
embed (Just n) = n+1
instance Functor f => Recursive (Nu f) where
project (Nu f a) = Nu f <$> f a
instance Functor f => Corecursive (Nu f) where
embed = colambek
instance Functor f => Recursive (Mu f) where
project = lambek
instance Functor f => Corecursive (Mu f) where
embed m = Mu (\f -> f (fmap (cata f) m))
instance Recursive [a] where
project [] = Nil
project (x:xs) = Cons x xs
instance Corecursive [a] where
embed Nil = []
embed (Cons x xs) = x : xs
instance Recursive (NonEmpty a) where
project (x :| []) = NonEmptyF x Nothing
project (x :| xs) = NonEmptyF x (Just (NE.fromList xs))
instance Corecursive (NonEmpty a) where
embed (NonEmptyF x Nothing) = x :| []
embed (NonEmptyF x (Just xs)) = x :| toList xs
instance Functor f => Recursive (Fix f) where
project = unFix
instance Functor f => Corecursive (Fix f) where
embed = Fix
eitherM :: Monad m => (a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM l r = (either l r =<<)
cata :: (Recursive t) => (Base t a -> a) -> t -> a
cata f = c where c = f . fmap c . project
{-# NOINLINE [0] cata #-}
{-# RULES
"cata/Mu" forall f (g :: forall a. (f a -> a) -> a). cata f (Mu g) = g f;
#-}
ana :: (Corecursive t) => (a -> Base t a) -> a -> t
ana g = a where a = embed . fmap a . g
{-# NOINLINE [0] ana #-}
{-# RULES
"ana/Nu" forall (f :: a -> f a). ana f = Nu f;
#-}
hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo f g = h where h = f . fmap h . g
{-# NOINLINE [0] hylo #-}
{-# RULES
"ana/cata/hylo" forall f g x. cata f (ana g x) = hylo f g x;
#-}
zipA :: (Applicative f) => f a -> f b -> f (a, b)
zipA x y = (,) <$> x <*> y
zipM :: (Monad m) => m a -> m b -> m (a, b)
zipM x y = do { a <- y; b <- x; pure (b, a) }
cataM :: (Recursive t, Traversable (Base t), Monad m) => (Base t a -> m a) -> t -> m a
cataM f = c where c = f <=< (traverse c . project)
paraM :: (Recursive t, Corecursive t, Traversable (Base t), Monad m) => (Base t (t, a) -> m a) -> t -> m a
paraM f = fmap snd . cataM (\x -> (,) (embed (fmap fst x)) <$> f x)
zygoM :: (Recursive t, Traversable (Base t), Monad m) => (Base t b -> m b) -> (Base t (b, a) -> m a) -> t -> m a
zygoM f g = fmap snd . cataM (\x -> zipA (f (fmap fst x)) (g x))
zygoM' :: (Recursive t, Traversable (Base t), Monad m) => (Base t b -> m b) -> (Base t (b, a) -> m a) -> t -> m a
zygoM' f g = fmap snd . cataM (\x -> zipM (f (fmap fst x)) (g x))
scolioM :: (Recursive t, Traversable (Base t), Monad m) => (Base t (t, a) -> m t) -> (Base t (t, a) -> m a) -> t -> m a
scolioM f g = fmap snd . cataM (\x -> zipA (f x) (g x))
scolioM' :: (Recursive t, Traversable (Base t), Monad m) => (Base t (t, a) -> m t) -> (Base t (t, a) -> m a) -> t -> m a
scolioM' f g = fmap snd . cataM (\x -> zipM (f x) (g x))
anaM :: (Corecursive t, Traversable (Base t), Monad m) => (a -> m (Base t a)) -> a -> m t
anaM f = a where a = (fmap embed . traverse a) <=< f
hyloM :: (Traversable f, Monad m) => (f b -> m b) -> (a -> m (f a)) -> a -> m b
hyloM f g = h where h = f <=< traverse h <=< g
elgotM :: (Traversable f, Monad m) => (f a -> m a) -> (b -> m (Either a (f b))) -> b -> m a
elgotM φ ψ = h where h = eitherM pure (φ <=< traverse h) . ψ
microM :: (Corecursive a, Traversable (Base a), Monad m) => (b -> m (Either a (Base a b))) -> b -> m a
microM = elgotM (pure . embed)
coelgotM :: (Traversable f, Monad m) => ((a, f b) -> m b) -> (a -> m (f a)) -> a -> m b
coelgotM φ ψ = h where h = φ <=< (\x -> (,) x <$> (traverse h <=< ψ) x)
lambek :: (Recursive t, Corecursive t) => (t -> Base t t)
lambek = cata (fmap embed)
colambek :: (Recursive t, Corecursive t) => (Base t t -> t)
colambek = ana (fmap project)
prepro :: (Recursive t, Corecursive t) => (Base t t -> Base t t) -> (Base t a -> a) -> t -> a
prepro e f = c
where c = f . fmap (c . cata (embed . e)) . project
postpro :: (Recursive t, Corecursive t) => (Base t t -> Base t t) -> (a -> Base t a) -> a -> t
postpro e g = a'
where a' = embed . fmap (ana (e . project) . a') . g
mutu :: (Recursive t) => (Base t (a, a) -> a) -> (Base t (a, a) -> a) -> t -> a
mutu f g = snd . cata (f &&& g)
mutuM :: (Recursive t, Traversable (Base t), Monad m) => (Base t (a, a) -> m a) -> (Base t (a, a) -> m a) -> t -> m a
mutuM f g = h where h = fmap snd . cataM (\x -> zipA (f x) (g x))
mutuM' :: (Recursive t, Traversable (Base t), Monad m) => (Base t (a, a) -> m a) -> (Base t (a, a) -> m a) -> t -> m a
mutuM' f g = h where h = fmap snd . cataM (\x -> zipM (f x) (g x))
scolio :: (Recursive t) => (Base t (a, t) -> a) -> (Base t (a, t) -> t) -> t -> a
scolio = fst .** (cata .* (&&&))
zygo :: (Recursive t) => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo f g = snd . cata (\x -> (f (fmap fst x), g x))
para :: (Recursive t, Corecursive t) => (Base t (t, a) -> a) -> t -> a
para f = snd . cata (\x -> (embed (fmap fst x), f x))
meta :: (Corecursive t', Recursive t) => (a -> Base t' a) -> (b -> a) -> (Base t b -> b) -> t -> t'
meta f e g = ana f . e . cata g
meta' :: (Functor g) => (f a -> a) -> (forall c. g c -> f c) -> (b -> g b) -> b -> a
meta' h e k = g
where g = h . e . fmap g . k
mcata :: (forall y. ((y -> c) -> f y -> c)) -> Fix f -> c
mcata ψ = mc where mc = ψ mc . unFix
mhisto :: (forall y. ((y -> c) -> (y -> f y) -> f y -> c)) -> Fix f -> c
mhisto ψ = mh where mh = ψ mh unFix . unFix
elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot φ ψ = h where h = either id (φ . fmap h) . ψ
micro :: (Corecursive a) => (b -> Either a (Base a b)) -> b -> a
micro = elgot embed
coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot φ ψ = h where h = φ . (\x -> (x, fmap h . ψ $ x))
apo :: (Corecursive t) => (a -> Base t (Either t a)) -> a -> t
apo g = a where a = embed . fmap (either id a) . g
hoist :: (Recursive s, Corecursive t)
=> (forall a. Base s a -> Base t a)
-> s
-> t
hoist = cata . (embed .)
{-# NOINLINE [0] hoist #-}
hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g
hoistMu η (Mu f) = Mu (f . (. η))
hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g
hoistNu ν (Nu f x) = Nu (ν . f) x
{-# RULES
"hoist/hoistMu" forall (η :: forall a. f a -> f a) (f :: forall a. (f a -> a) -> a). hoist η (Mu f) = hoistMu η (Mu f);
#-}
{-# RULES
"hoist/hoistNu" forall (η :: forall a. f a -> f a) (f :: a -> f a) x. hoist η (Nu f x) = hoistNu η (Nu f x);
#-}
refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix = cata embed