{-# LANGUAGE DefaultSignatures         #-}
{-# LANGUAGE DeriveFoldable            #-}
{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE DeriveTraversable         #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE Rank2Types                #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}

module Control.Recursion
    ( -- * Typeclasses
      Base
    , Recursive (..)
    , Corecursive (..)
    -- * Types
    , Fix (..)
    , Mu (..)
    , Nu (..)
    , ListF (..)
    , NonEmptyF (..)
    -- * Recursion schemes
    , hylo
    , prepro
    , postpro
    , mutu
    , zygo
    , para
    , apo
    , hypo
    , elgot
    , coelgot
    , micro
    , meta
    , meta'
    , scolio
    , cata
    , ana
    -- * Mendler-style recursion schemes
    , mhisto
    , mcata
    , mzygo
    , mpara
    , mana
    , mfutu
    , mapo
    -- * Monadic recursion schemes
    , cataM
    , anaM
    , hyloM
    , zygoM
    , zygoM'
    , scolioM
    , scolioM'
    , coelgotM
    , elgotM
    , paraM
    , mutuM
    , mutuM'
    , microM
    -- * Helper functions
    , lambek
    , colambek
    , refix
    ) where

import           Control.Arrow       ((&&&))
import           Control.Composition ((.*), (.**))
import           Control.Monad       ((<=<))
import           Data.Foldable       (toList)
import           Data.Kind           (Type)
import           Data.List.NonEmpty  (NonEmpty (..))
import qualified Data.List.NonEmpty  as NE
import           GHC.Generics
import           Numeric.Natural     (Natural)

type family Base t :: Type -> Type

class (Functor (Base t)) => Recursive t where

    project :: t -> Base t t

    default project :: (Generic t, Generic (Base t t), HCoerce (Rep t) (Rep (Base t t))) => t -> Base t t
    project = Rep (Base t t) Any -> Base t t
forall a x. Generic a => Rep a x -> a
to (Rep (Base t t) Any -> Base t t)
-> (t -> Rep (Base t t) Any) -> t -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep t Any -> Rep (Base t t) Any
forall (f :: * -> *) (g :: * -> *) a. HCoerce f g => f a -> g a
hcoerce (Rep t Any -> Rep (Base t t) Any)
-> (t -> Rep t Any) -> t -> Rep (Base t t) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from

class (Functor (Base t)) => Corecursive t where

    embed :: Base t t -> t

    default embed :: (Generic t, Generic (Base t t), HCoerce (Rep (Base t t)) (Rep t)) => Base t t -> t
    embed = Rep t Any -> t
forall a x. Generic a => Rep a x -> a
to (Rep t Any -> t) -> (Base t t -> Rep t Any) -> Base t t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep (Base t t) Any -> Rep t Any
forall (f :: * -> *) (g :: * -> *) a. HCoerce f g => f a -> g a
hcoerce (Rep (Base t t) Any -> Rep t Any)
-> (Base t t -> Rep (Base t t) Any) -> Base t t -> Rep t Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base t t -> Rep (Base t t) Any
forall a x. Generic a => a -> Rep a x
from

-- | Base functor for a list of type @[a]@.
data ListF a b = Cons a b
               | Nil
               deriving (a -> ListF a b -> ListF a a
(a -> b) -> ListF a a -> ListF a b
(forall a b. (a -> b) -> ListF a a -> ListF a b)
-> (forall a b. a -> ListF a b -> ListF a a) -> Functor (ListF a)
forall a b. a -> ListF a b -> ListF a a
forall a b. (a -> b) -> ListF a a -> ListF a b
forall a a b. a -> ListF a b -> ListF a a
forall a a b. (a -> b) -> ListF a a -> ListF a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ListF a b -> ListF a a
$c<$ :: forall a a b. a -> ListF a b -> ListF a a
fmap :: (a -> b) -> ListF a a -> ListF a b
$cfmap :: forall a a b. (a -> b) -> ListF a a -> ListF a b
Functor, ListF a a -> Bool
(a -> m) -> ListF a a -> m
(a -> b -> b) -> b -> ListF a a -> b
(forall m. Monoid m => ListF a m -> m)
-> (forall m a. Monoid m => (a -> m) -> ListF a a -> m)
-> (forall m a. Monoid m => (a -> m) -> ListF a a -> m)
-> (forall a b. (a -> b -> b) -> b -> ListF a a -> b)
-> (forall a b. (a -> b -> b) -> b -> ListF a a -> b)
-> (forall b a. (b -> a -> b) -> b -> ListF a a -> b)
-> (forall b a. (b -> a -> b) -> b -> ListF a a -> b)
-> (forall a. (a -> a -> a) -> ListF a a -> a)
-> (forall a. (a -> a -> a) -> ListF a a -> a)
-> (forall a. ListF a a -> [a])
-> (forall a. ListF a a -> Bool)
-> (forall a. ListF a a -> Int)
-> (forall a. Eq a => a -> ListF a a -> Bool)
-> (forall a. Ord a => ListF a a -> a)
-> (forall a. Ord a => ListF a a -> a)
-> (forall a. Num a => ListF a a -> a)
-> (forall a. Num a => ListF a a -> a)
-> Foldable (ListF a)
forall a. Eq a => a -> ListF a a -> Bool
forall a. Num a => ListF a a -> a
forall a. Ord a => ListF a a -> a
forall m. Monoid m => ListF a m -> m
forall a. ListF a a -> Bool
forall a. ListF a a -> Int
forall a. ListF a a -> [a]
forall a. (a -> a -> a) -> ListF a a -> a
forall a a. Eq a => a -> ListF a a -> Bool
forall a a. Num a => ListF a a -> a
forall a a. Ord a => ListF a a -> a
forall m a. Monoid m => (a -> m) -> ListF a a -> m
forall a m. Monoid m => ListF a m -> m
forall a a. ListF a a -> Bool
forall a a. ListF a a -> Int
forall a a. ListF a a -> [a]
forall b a. (b -> a -> b) -> b -> ListF a a -> b
forall a b. (a -> b -> b) -> b -> ListF a a -> b
forall a a. (a -> a -> a) -> ListF a a -> a
forall a m a. Monoid m => (a -> m) -> ListF a a -> m
forall a b a. (b -> a -> b) -> b -> ListF a a -> b
forall a a b. (a -> b -> b) -> b -> ListF a a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: ListF a a -> a
$cproduct :: forall a a. Num a => ListF a a -> a
sum :: ListF a a -> a
$csum :: forall a a. Num a => ListF a a -> a
minimum :: ListF a a -> a
$cminimum :: forall a a. Ord a => ListF a a -> a
maximum :: ListF a a -> a
$cmaximum :: forall a a. Ord a => ListF a a -> a
elem :: a -> ListF a a -> Bool
$celem :: forall a a. Eq a => a -> ListF a a -> Bool
length :: ListF a a -> Int
$clength :: forall a a. ListF a a -> Int
null :: ListF a a -> Bool
$cnull :: forall a a. ListF a a -> Bool
toList :: ListF a a -> [a]
$ctoList :: forall a a. ListF a a -> [a]
foldl1 :: (a -> a -> a) -> ListF a a -> a
$cfoldl1 :: forall a a. (a -> a -> a) -> ListF a a -> a
foldr1 :: (a -> a -> a) -> ListF a a -> a
$cfoldr1 :: forall a a. (a -> a -> a) -> ListF a a -> a
foldl' :: (b -> a -> b) -> b -> ListF a a -> b
$cfoldl' :: forall a b a. (b -> a -> b) -> b -> ListF a a -> b
foldl :: (b -> a -> b) -> b -> ListF a a -> b
$cfoldl :: forall a b a. (b -> a -> b) -> b -> ListF a a -> b
foldr' :: (a -> b -> b) -> b -> ListF a a -> b
$cfoldr' :: forall a a b. (a -> b -> b) -> b -> ListF a a -> b
foldr :: (a -> b -> b) -> b -> ListF a a -> b
$cfoldr :: forall a a b. (a -> b -> b) -> b -> ListF a a -> b
foldMap' :: (a -> m) -> ListF a a -> m
$cfoldMap' :: forall a m a. Monoid m => (a -> m) -> ListF a a -> m
foldMap :: (a -> m) -> ListF a a -> m
$cfoldMap :: forall a m a. Monoid m => (a -> m) -> ListF a a -> m
fold :: ListF a m -> m
$cfold :: forall a m. Monoid m => ListF a m -> m
Foldable, Functor (ListF a)
Foldable (ListF a)
Functor (ListF a)
-> Foldable (ListF a)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> ListF a a -> f (ListF a b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ListF a (f a) -> f (ListF a a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ListF a a -> m (ListF a b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ListF a (m a) -> m (ListF a a))
-> Traversable (ListF a)
(a -> f b) -> ListF a a -> f (ListF a b)
forall a. Functor (ListF a)
forall a. Foldable (ListF a)
forall a (m :: * -> *) a. Monad m => ListF a (m a) -> m (ListF a a)
forall a (f :: * -> *) a.
Applicative f =>
ListF a (f a) -> f (ListF a a)
forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ListF a a -> m (ListF a b)
forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ListF a a -> f (ListF a b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => ListF a (m a) -> m (ListF a a)
forall (f :: * -> *) a.
Applicative f =>
ListF a (f a) -> f (ListF a a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ListF a a -> m (ListF a b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ListF a a -> f (ListF a b)
sequence :: ListF a (m a) -> m (ListF a a)
$csequence :: forall a (m :: * -> *) a. Monad m => ListF a (m a) -> m (ListF a a)
mapM :: (a -> m b) -> ListF a a -> m (ListF a b)
$cmapM :: forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ListF a a -> m (ListF a b)
sequenceA :: ListF a (f a) -> f (ListF a a)
$csequenceA :: forall a (f :: * -> *) a.
Applicative f =>
ListF a (f a) -> f (ListF a a)
traverse :: (a -> f b) -> ListF a a -> f (ListF a b)
$ctraverse :: forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ListF a a -> f (ListF a b)
$cp2Traversable :: forall a. Foldable (ListF a)
$cp1Traversable :: forall a. Functor (ListF a)
Traversable)

data NonEmptyF a b = NonEmptyF a (Maybe b)
    deriving (a -> NonEmptyF a b -> NonEmptyF a a
(a -> b) -> NonEmptyF a a -> NonEmptyF a b
(forall a b. (a -> b) -> NonEmptyF a a -> NonEmptyF a b)
-> (forall a b. a -> NonEmptyF a b -> NonEmptyF a a)
-> Functor (NonEmptyF a)
forall a b. a -> NonEmptyF a b -> NonEmptyF a a
forall a b. (a -> b) -> NonEmptyF a a -> NonEmptyF a b
forall a a b. a -> NonEmptyF a b -> NonEmptyF a a
forall a a b. (a -> b) -> NonEmptyF a a -> NonEmptyF a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NonEmptyF a b -> NonEmptyF a a
$c<$ :: forall a a b. a -> NonEmptyF a b -> NonEmptyF a a
fmap :: (a -> b) -> NonEmptyF a a -> NonEmptyF a b
$cfmap :: forall a a b. (a -> b) -> NonEmptyF a a -> NonEmptyF a b
Functor, NonEmptyF a a -> Bool
(a -> m) -> NonEmptyF a a -> m
(a -> b -> b) -> b -> NonEmptyF a a -> b
(forall m. Monoid m => NonEmptyF a m -> m)
-> (forall m a. Monoid m => (a -> m) -> NonEmptyF a a -> m)
-> (forall m a. Monoid m => (a -> m) -> NonEmptyF a a -> m)
-> (forall a b. (a -> b -> b) -> b -> NonEmptyF a a -> b)
-> (forall a b. (a -> b -> b) -> b -> NonEmptyF a a -> b)
-> (forall b a. (b -> a -> b) -> b -> NonEmptyF a a -> b)
-> (forall b a. (b -> a -> b) -> b -> NonEmptyF a a -> b)
-> (forall a. (a -> a -> a) -> NonEmptyF a a -> a)
-> (forall a. (a -> a -> a) -> NonEmptyF a a -> a)
-> (forall a. NonEmptyF a a -> [a])
-> (forall a. NonEmptyF a a -> Bool)
-> (forall a. NonEmptyF a a -> Int)
-> (forall a. Eq a => a -> NonEmptyF a a -> Bool)
-> (forall a. Ord a => NonEmptyF a a -> a)
-> (forall a. Ord a => NonEmptyF a a -> a)
-> (forall a. Num a => NonEmptyF a a -> a)
-> (forall a. Num a => NonEmptyF a a -> a)
-> Foldable (NonEmptyF a)
forall a. Eq a => a -> NonEmptyF a a -> Bool
forall a. Num a => NonEmptyF a a -> a
forall a. Ord a => NonEmptyF a a -> a
forall m. Monoid m => NonEmptyF a m -> m
forall a. NonEmptyF a a -> Bool
forall a. NonEmptyF a a -> Int
forall a. NonEmptyF a a -> [a]
forall a. (a -> a -> a) -> NonEmptyF a a -> a
forall a a. Eq a => a -> NonEmptyF a a -> Bool
forall a a. Num a => NonEmptyF a a -> a
forall a a. Ord a => NonEmptyF a a -> a
forall m a. Monoid m => (a -> m) -> NonEmptyF a a -> m
forall a m. Monoid m => NonEmptyF a m -> m
forall a a. NonEmptyF a a -> Bool
forall a a. NonEmptyF a a -> Int
forall a a. NonEmptyF a a -> [a]
forall b a. (b -> a -> b) -> b -> NonEmptyF a a -> b
forall a b. (a -> b -> b) -> b -> NonEmptyF a a -> b
forall a a. (a -> a -> a) -> NonEmptyF a a -> a
forall a m a. Monoid m => (a -> m) -> NonEmptyF a a -> m
forall a b a. (b -> a -> b) -> b -> NonEmptyF a a -> b
forall a a b. (a -> b -> b) -> b -> NonEmptyF a a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: NonEmptyF a a -> a
$cproduct :: forall a a. Num a => NonEmptyF a a -> a
sum :: NonEmptyF a a -> a
$csum :: forall a a. Num a => NonEmptyF a a -> a
minimum :: NonEmptyF a a -> a
$cminimum :: forall a a. Ord a => NonEmptyF a a -> a
maximum :: NonEmptyF a a -> a
$cmaximum :: forall a a. Ord a => NonEmptyF a a -> a
elem :: a -> NonEmptyF a a -> Bool
$celem :: forall a a. Eq a => a -> NonEmptyF a a -> Bool
length :: NonEmptyF a a -> Int
$clength :: forall a a. NonEmptyF a a -> Int
null :: NonEmptyF a a -> Bool
$cnull :: forall a a. NonEmptyF a a -> Bool
toList :: NonEmptyF a a -> [a]
$ctoList :: forall a a. NonEmptyF a a -> [a]
foldl1 :: (a -> a -> a) -> NonEmptyF a a -> a
$cfoldl1 :: forall a a. (a -> a -> a) -> NonEmptyF a a -> a
foldr1 :: (a -> a -> a) -> NonEmptyF a a -> a
$cfoldr1 :: forall a a. (a -> a -> a) -> NonEmptyF a a -> a
foldl' :: (b -> a -> b) -> b -> NonEmptyF a a -> b
$cfoldl' :: forall a b a. (b -> a -> b) -> b -> NonEmptyF a a -> b
foldl :: (b -> a -> b) -> b -> NonEmptyF a a -> b
$cfoldl :: forall a b a. (b -> a -> b) -> b -> NonEmptyF a a -> b
foldr' :: (a -> b -> b) -> b -> NonEmptyF a a -> b
$cfoldr' :: forall a a b. (a -> b -> b) -> b -> NonEmptyF a a -> b
foldr :: (a -> b -> b) -> b -> NonEmptyF a a -> b
$cfoldr :: forall a a b. (a -> b -> b) -> b -> NonEmptyF a a -> b
foldMap' :: (a -> m) -> NonEmptyF a a -> m
$cfoldMap' :: forall a m a. Monoid m => (a -> m) -> NonEmptyF a a -> m
foldMap :: (a -> m) -> NonEmptyF a a -> m
$cfoldMap :: forall a m a. Monoid m => (a -> m) -> NonEmptyF a a -> m
fold :: NonEmptyF a m -> m
$cfold :: forall a m. Monoid m => NonEmptyF a m -> m
Foldable, Functor (NonEmptyF a)
Foldable (NonEmptyF a)
Functor (NonEmptyF a)
-> Foldable (NonEmptyF a)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> NonEmptyF a a -> f (NonEmptyF a b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    NonEmptyF a (f a) -> f (NonEmptyF a a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> NonEmptyF a a -> m (NonEmptyF a b))
-> (forall (m :: * -> *) a.
    Monad m =>
    NonEmptyF a (m a) -> m (NonEmptyF a a))
-> Traversable (NonEmptyF a)
(a -> f b) -> NonEmptyF a a -> f (NonEmptyF a b)
forall a. Functor (NonEmptyF a)
forall a. Foldable (NonEmptyF a)
forall a (m :: * -> *) a.
Monad m =>
NonEmptyF a (m a) -> m (NonEmptyF a a)
forall a (f :: * -> *) a.
Applicative f =>
NonEmptyF a (f a) -> f (NonEmptyF a a)
forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmptyF a a -> m (NonEmptyF a b)
forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmptyF a a -> f (NonEmptyF a b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
NonEmptyF a (m a) -> m (NonEmptyF a a)
forall (f :: * -> *) a.
Applicative f =>
NonEmptyF a (f a) -> f (NonEmptyF a a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmptyF a a -> m (NonEmptyF a b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmptyF a a -> f (NonEmptyF a b)
sequence :: NonEmptyF a (m a) -> m (NonEmptyF a a)
$csequence :: forall a (m :: * -> *) a.
Monad m =>
NonEmptyF a (m a) -> m (NonEmptyF a a)
mapM :: (a -> m b) -> NonEmptyF a a -> m (NonEmptyF a b)
$cmapM :: forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmptyF a a -> m (NonEmptyF a b)
sequenceA :: NonEmptyF a (f a) -> f (NonEmptyF a a)
$csequenceA :: forall a (f :: * -> *) a.
Applicative f =>
NonEmptyF a (f a) -> f (NonEmptyF a a)
traverse :: (a -> f b) -> NonEmptyF a a -> f (NonEmptyF a b)
$ctraverse :: forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmptyF a a -> f (NonEmptyF a b)
$cp2Traversable :: forall a. Foldable (NonEmptyF a)
$cp1Traversable :: forall a. Functor (NonEmptyF a)
Traversable)

newtype Fix f = Fix { Fix f -> f (Fix f)
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 :: Natural -> Base Natural Natural
project Natural
0 = Base Natural Natural
forall a. Maybe a
Nothing
    project Natural
n = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural
nNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
-Natural
1)

instance Corecursive Natural where
    embed :: Base Natural Natural -> Natural
embed Base Natural Natural
Nothing  = Natural
0
    embed (Just n) = Natural
nNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1

instance Functor f => Recursive (Nu f) where
    project :: Nu f -> Base (Nu f) (Nu f)
project (Nu a -> f a
f a
a) = (a -> f a) -> a -> Nu f
forall (f :: * -> *) a. (a -> f a) -> a -> Nu f
Nu a -> f a
f (a -> Nu f) -> f a -> f (Nu f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f a
a

instance Functor f => Corecursive (Nu f) where
    embed :: Base (Nu f) (Nu f) -> Nu f
embed = Base (Nu f) (Nu f) -> Nu f
forall t. (Recursive t, Corecursive t) => Base t t -> t
colambek

instance Functor f => Recursive (Mu f) where
    project :: Mu f -> Base (Mu f) (Mu f)
project = Mu f -> Base (Mu f) (Mu f)
forall t. (Recursive t, Corecursive t) => t -> Base t t
lambek

instance Functor f => Corecursive (Mu f) where
    embed :: Base (Mu f) (Mu f) -> Mu f
embed Base (Mu f) (Mu f)
μ = (forall a. (f a -> a) -> a) -> Mu f
forall (f :: * -> *). (forall a. (f a -> a) -> a) -> Mu f
Mu (\f a -> a
f -> f a -> a
f ((Mu f -> a) -> f (Mu f) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Base (Mu f) a -> a) -> Mu f -> a
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata f a -> a
Base (Mu f) a -> a
f) f (Mu f)
Base (Mu f) (Mu f)
μ))

instance Recursive [a] where
    project :: [a] -> Base [a] [a]
project []     = Base [a] [a]
forall a b. ListF a b
Nil
    project (a
x:[a]
xs) = a -> [a] -> ListF a [a]
forall a b. a -> b -> ListF a b
Cons a
x [a]
xs

instance Corecursive [a] where
    embed :: Base [a] [a] -> [a]
embed Base [a] [a]
Nil         = []
    embed (Cons x xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

instance Recursive (NonEmpty a) where
    project :: NonEmpty a -> Base (NonEmpty a) (NonEmpty a)
project (a
x :| []) = a -> Maybe (NonEmpty a) -> NonEmptyF a (NonEmpty a)
forall a b. a -> Maybe b -> NonEmptyF a b
NonEmptyF a
x Maybe (NonEmpty a)
forall a. Maybe a
Nothing
    project (a
x :| [a]
xs) = a -> Maybe (NonEmpty a) -> NonEmptyF a (NonEmpty a)
forall a b. a -> Maybe b -> NonEmptyF a b
NonEmptyF a
x (NonEmpty a -> Maybe (NonEmpty a)
forall a. a -> Maybe a
Just ([a] -> NonEmpty a
forall a. [a] -> NonEmpty a
NE.fromList [a]
xs))

instance Corecursive (NonEmpty a) where
    embed :: Base (NonEmpty a) (NonEmpty a) -> NonEmpty a
embed (NonEmptyF x Nothing)   = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []
    embed (NonEmptyF x (Just xs)) = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
xs

instance Functor f => Recursive (Fix f) where
    project :: Fix f -> Base (Fix f) (Fix f)
project = Fix f -> Base (Fix f) (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

instance Functor f => Corecursive (Fix f) where
    embed :: Base (Fix f) (Fix f) -> Fix f
embed = Base (Fix f) (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix

eitherM :: Monad m => (a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM :: (a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM a -> m c
l b -> m c
r = ((a -> m c) -> (b -> m c) -> Either a b -> m c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m c
l b -> m c
r (Either a b -> m c) -> m (Either a b) -> m c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

-- | Catamorphism. Folds a structure. (see [here](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.41.125&rep=rep1&type=pdf))
--
-- >>> :{
-- let {
--   sum' :: (Num a) => [a] -> a ;
--   sum' = cata a
--     where
--       a Nil         = 0
--       a (Cons x xs) = x + xs
-- }
-- :}
--
-- >>> sum' [1..100]
-- 5050
cata :: (Recursive t) => (Base t a -> a) -> t -> a
cata :: (Base t a -> a) -> t -> a
cata Base t a -> a
f = t -> a
c where c :: t -> a
c = Base t a -> a
f (Base t a -> a) -> (t -> Base t a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> a) -> Base t t -> Base t a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> a
c (Base t t -> Base t a) -> (t -> Base t t) -> t -> Base t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project
{-# NOINLINE [0] cata #-}

{-# RULES
  "cata/Mu" forall f (g :: forall a. (f a -> a) -> a). cata f (Mu g) = g f;
     #-}

-- | Anamorphism, meant to build up a structure recursively.
ana :: (Corecursive t) => (a -> Base t a) -> a -> t
ana :: (a -> Base t a) -> a -> t
ana a -> Base t a
g = a -> t
a where a :: a -> t
a = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (a -> Base t t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> t) -> Base t a -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> t
a (Base t a -> Base t t) -> (a -> Base t a) -> a -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Base t a
g
{-# NOINLINE [0] ana #-}

{-# RULES
   "ana/Nu" forall (f :: a -> f a). ana f = Nu f;
      #-}

-- | Hylomorphism; fold a structure while building it up.
hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo :: (f b -> b) -> (a -> f a) -> a -> b
hylo f b -> b
f a -> f a
g = a -> b
h where h :: a -> b
h = f b -> b
f (f b -> b) -> (a -> f b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
h (f a -> f b) -> (a -> f a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
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 :: f a -> f b -> f (a, b)
zipA f a
x f b
y = (,) (a -> b -> (a, b)) -> f a -> f (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x f (b -> (a, b)) -> f b -> f (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f b
y

zipM :: (Monad m) => m a -> m b -> m (a, b)
zipM :: m a -> m b -> m (a, b)
zipM m a
x m b
y = do { b
a <- m b
y; a
b <- m a
x; (a, b) -> m (a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
b, b
a) }

cataM :: (Recursive t, Traversable (Base t), Monad m) => (Base t a -> m a) -> t -> m a
cataM :: (Base t a -> m a) -> t -> m a
cataM Base t a -> m a
f = t -> m a
c where c :: t -> m a
c = Base t a -> m a
f (Base t a -> m a) -> (t -> m (Base t a)) -> t -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ((t -> m a) -> Base t t -> m (Base t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse t -> m a
c (Base t t -> m (Base t a)) -> (t -> Base t t) -> t -> m (Base t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project)

paraM :: (Recursive t, Corecursive t, Traversable (Base t), Monad m) => (Base t (t, a) -> m a) -> t -> m a
paraM :: (Base t (t, a) -> m a) -> t -> m a
paraM Base t (t, a) -> m a
f = ((t, a) -> a) -> m (t, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, a) -> a
forall a b. (a, b) -> b
snd (m (t, a) -> m a) -> (t -> m (t, a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (t, a) -> m (t, a)) -> t -> m (t, a)
forall t (m :: * -> *) a.
(Recursive t, Traversable (Base t), Monad m) =>
(Base t a -> m a) -> t -> m a
cataM (\Base t (t, a)
x -> (,) (Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (((t, a) -> t) -> Base t (t, a) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, a) -> t
forall a b. (a, b) -> a
fst Base t (t, a)
x)) (a -> (t, a)) -> m a -> m (t, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Base t (t, a) -> m a
f Base t (t, a)
x)

zygoM :: (Recursive t, Traversable (Base t), Monad m) => (Base t b -> m b) -> (Base t (b, a) -> m a) -> t -> m a
zygoM :: (Base t b -> m b) -> (Base t (b, a) -> m a) -> t -> m a
zygoM Base t b -> m b
f Base t (b, a) -> m a
g = ((b, a) -> a) -> m (b, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> a
forall a b. (a, b) -> b
snd (m (b, a) -> m a) -> (t -> m (b, a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (b, a) -> m (b, a)) -> t -> m (b, a)
forall t (m :: * -> *) a.
(Recursive t, Traversable (Base t), Monad m) =>
(Base t a -> m a) -> t -> m a
cataM (\Base t (b, a)
x -> m b -> m a -> m (b, a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f (a, b)
zipA (Base t b -> m b
f (((b, a) -> b) -> Base t (b, a) -> Base t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> b
forall a b. (a, b) -> a
fst Base t (b, a)
x)) (Base t (b, a) -> m a
g Base t (b, a)
x))

-- | See
-- [here](http://hackage.haskell.org/package/cpkg-0.2.3.1/src/src/Package/C/Build/Tree.hs)
-- for an example
zygoM' :: (Recursive t, Traversable (Base t), Monad m) => (Base t b -> m b) -> (Base t (b, a) -> m a) -> t -> m a
zygoM' :: (Base t b -> m b) -> (Base t (b, a) -> m a) -> t -> m a
zygoM' Base t b -> m b
f Base t (b, a) -> m a
g = ((b, a) -> a) -> m (b, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> a
forall a b. (a, b) -> b
snd (m (b, a) -> m a) -> (t -> m (b, a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (b, a) -> m (b, a)) -> t -> m (b, a)
forall t (m :: * -> *) a.
(Recursive t, Traversable (Base t), Monad m) =>
(Base t a -> m a) -> t -> m a
cataM (\Base t (b, a)
x -> m b -> m a -> m (b, a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
zipM (Base t b -> m b
f (((b, a) -> b) -> Base t (b, a) -> Base t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> b
forall a b. (a, b) -> a
fst Base t (b, a)
x)) (Base t (b, a) -> m a
g Base t (b, a)
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 :: (Base t (t, a) -> m t) -> (Base t (t, a) -> m a) -> t -> m a
scolioM Base t (t, a) -> m t
f Base t (t, a) -> m a
g = ((t, a) -> a) -> m (t, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, a) -> a
forall a b. (a, b) -> b
snd (m (t, a) -> m a) -> (t -> m (t, a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (t, a) -> m (t, a)) -> t -> m (t, a)
forall t (m :: * -> *) a.
(Recursive t, Traversable (Base t), Monad m) =>
(Base t a -> m a) -> t -> m a
cataM (\Base t (t, a)
x -> m t -> m a -> m (t, a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f (a, b)
zipA (Base t (t, a) -> m t
f Base t (t, a)
x) (Base t (t, a) -> m a
g Base t (t, a)
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' :: (Base t (t, a) -> m t) -> (Base t (t, a) -> m a) -> t -> m a
scolioM' Base t (t, a) -> m t
f Base t (t, a) -> m a
g = ((t, a) -> a) -> m (t, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, a) -> a
forall a b. (a, b) -> b
snd (m (t, a) -> m a) -> (t -> m (t, a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (t, a) -> m (t, a)) -> t -> m (t, a)
forall t (m :: * -> *) a.
(Recursive t, Traversable (Base t), Monad m) =>
(Base t a -> m a) -> t -> m a
cataM (\Base t (t, a)
x -> m t -> m a -> m (t, a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
zipM (Base t (t, a) -> m t
f Base t (t, a)
x) (Base t (t, a) -> m a
g Base t (t, a)
x))

anaM :: (Corecursive t, Traversable (Base t), Monad m) => (a -> m (Base t a)) -> a -> m t
anaM :: (a -> m (Base t a)) -> a -> m t
anaM a -> m (Base t a)
f = a -> m t
a where a :: a -> m t
a = ((Base t t -> t) -> m (Base t t) -> m t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (m (Base t t) -> m t)
-> (Base t a -> m (Base t t)) -> Base t a -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m t) -> Base t a -> m (Base t t)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m t
a) (Base t a -> m t) -> (a -> m (Base t a)) -> a -> m t
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m (Base t a)
f

hyloM :: (Traversable f, Monad m) => (f b -> m b) -> (a -> m (f a)) -> a -> m b
hyloM :: (f b -> m b) -> (a -> m (f a)) -> a -> m b
hyloM f b -> m b
f a -> m (f a)
g = a -> m b
h where h :: a -> m b
h = f b -> m b
f (f b -> m b) -> (a -> m (f b)) -> a -> m b
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (a -> m b) -> f a -> m (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m b
h (f a -> m (f b)) -> (a -> m (f a)) -> a -> m (f b)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m (f a)
g

elgotM :: (Traversable f, Monad m) => (f a -> m a) -> (b -> m (Either a (f b))) -> b -> m a
elgotM :: (f a -> m a) -> (b -> m (Either a (f b))) -> b -> m a
elgotM f a -> m a
φ b -> m (Either a (f b))
ψ = b -> m a
h where h :: b -> m a
h = (a -> m a) -> (f b -> m a) -> m (Either a (f b)) -> m a
forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> m a
φ (f a -> m a) -> (f b -> m (f a)) -> f b -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (b -> m a) -> f b -> m (f a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse b -> m a
h) (m (Either a (f b)) -> m a)
-> (b -> m (Either a (f b))) -> b -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> m (Either a (f b))
ψ

microM :: (Corecursive a, Traversable (Base a), Monad m) => (b -> m (Either a (Base a b))) -> b -> m a
microM :: (b -> m (Either a (Base a b))) -> b -> m a
microM = (Base a a -> m a) -> (b -> m (Either a (Base a b))) -> b -> m a
forall (f :: * -> *) (m :: * -> *) a b.
(Traversable f, Monad m) =>
(f a -> m a) -> (b -> m (Either a (f b))) -> b -> m a
elgotM (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (Base a a -> a) -> Base a a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base a a -> a
forall t. Corecursive t => Base t t -> t
embed)

coelgotM :: (Traversable f, Monad m) => ((a, f b) -> m b) -> (a -> m (f a)) -> a -> m b
coelgotM :: ((a, f b) -> m b) -> (a -> m (f a)) -> a -> m b
coelgotM (a, f b) -> m b
φ a -> m (f a)
ψ = a -> m b
h where h :: a -> m b
h = (a, f b) -> m b
φ ((a, f b) -> m b) -> (a -> m (a, f b)) -> a -> m b
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (\a
x -> (,) a
x (f b -> (a, f b)) -> m (f b) -> m (a, f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((a -> m b) -> f a -> m (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m b
h (f a -> m (f b)) -> (a -> m (f a)) -> a -> m (f b)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m (f a)
ψ) a
x)

lambek :: (Recursive t, Corecursive t) => (t -> Base t t)
lambek :: t -> Base t t
lambek = (Base t (Base t t) -> Base t t) -> t -> Base t t
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata ((Base t t -> t) -> Base t (Base t t) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Base t t -> t
forall t. Corecursive t => Base t t -> t
embed)

colambek :: (Recursive t, Corecursive t) => (Base t t -> t)
colambek :: Base t t -> t
colambek = (Base t t -> Base t (Base t t)) -> Base t t -> t
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana ((t -> Base t t) -> Base t t -> Base t (Base t t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> Base t t
forall t. Recursive t => t -> Base t t
project)

-- | Prepromorphism. Fold a structure while applying a natural transformation at each step.
prepro :: (Recursive t, Corecursive t) => (Base t t -> Base t t) -> (Base t a -> a) -> t -> a
prepro :: (Base t t -> Base t t) -> (Base t a -> a) -> t -> a
prepro Base t t -> Base t t
e Base t a -> a
f = t -> a
c
    where c :: t -> a
c = Base t a -> a
f (Base t a -> a) -> (t -> Base t a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> a) -> Base t t -> Base t a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> a
c (t -> a) -> (t -> t) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t t -> t) -> t -> t
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata (Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (Base t t -> Base t t) -> Base t t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base t t -> Base t t
e)) (Base t t -> Base t a) -> (t -> Base t t) -> t -> Base t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project

-- | Postpromorphism. Build up a structure, applying a natural transformation along the way.
postpro :: (Recursive t, Corecursive t) => (Base t t -> Base t t) -> (a -> Base t a) -> a -> t
postpro :: (Base t t -> Base t t) -> (a -> Base t a) -> a -> t
postpro Base t t -> Base t t
e a -> Base t a
g = a -> t
a'
    where a' :: a -> t
a' = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (a -> Base t t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> t) -> Base t a -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((t -> Base t t) -> t -> t
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana (Base t t -> Base t t
e (Base t t -> Base t t) -> (t -> Base t t) -> t -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Base t t
forall t. Recursive t => t -> Base t t
project) (t -> t) -> (a -> t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t
a') (Base t a -> Base t t) -> (a -> Base t a) -> a -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Base t a
g

-- | A mutumorphism.
--
-- >>> :{
-- let {
--   even' :: Natural -> Bool ;
--   even' = mutu o e
--     where
--       o :: Maybe (Bool, Bool) -> Bool
--       o Nothing = False
--       o (Just (_, b)) = b
--       e :: Maybe (Bool, Bool) -> Bool
--       e Nothing = True
--       e (Just (_, b)) = b
-- }
-- :}
--
-- >>> even' 10
-- True
mutu :: (Recursive t) => (Base t (a, a) -> a) -> (Base t (a, a) -> a) -> t -> a
mutu :: (Base t (a, a) -> a) -> (Base t (a, a) -> a) -> t -> a
mutu Base t (a, a) -> a
f Base t (a, a) -> a
g = (a, a) -> a
forall a b. (a, b) -> b
snd ((a, a) -> a) -> (t -> (a, a)) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (a, a) -> (a, a)) -> t -> (a, a)
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata (Base t (a, a) -> a
f (Base t (a, a) -> a)
-> (Base t (a, a) -> a) -> Base t (a, a) -> (a, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Base t (a, a) -> a
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 :: (Base t (a, a) -> m a) -> (Base t (a, a) -> m a) -> t -> m a
mutuM Base t (a, a) -> m a
f Base t (a, a) -> m a
g = t -> m a
h where h :: t -> m a
h = ((a, a) -> a) -> m (a, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, a) -> a
forall a b. (a, b) -> b
snd (m (a, a) -> m a) -> (t -> m (a, a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (a, a) -> m (a, a)) -> t -> m (a, a)
forall t (m :: * -> *) a.
(Recursive t, Traversable (Base t), Monad m) =>
(Base t a -> m a) -> t -> m a
cataM (\Base t (a, a)
x -> m a -> m a -> m (a, a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f (a, b)
zipA (Base t (a, a) -> m a
f Base t (a, a)
x) (Base t (a, a) -> m a
g Base t (a, a)
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' :: (Base t (a, a) -> m a) -> (Base t (a, a) -> m a) -> t -> m a
mutuM' Base t (a, a) -> m a
f Base t (a, a) -> m a
g = t -> m a
h where h :: t -> m a
h = ((a, a) -> a) -> m (a, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, a) -> a
forall a b. (a, b) -> b
snd (m (a, a) -> m a) -> (t -> m (a, a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (a, a) -> m (a, a)) -> t -> m (a, a)
forall t (m :: * -> *) a.
(Recursive t, Traversable (Base t), Monad m) =>
(Base t a -> m a) -> t -> m a
cataM (\Base t (a, a)
x -> m a -> m a -> m (a, a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m (a, b)
zipM (Base t (a, a) -> m a
f Base t (a, a)
x) (Base t (a, a) -> m a
g Base t (a, a)
x))

-- | Catamorphism collapsing along two data types simultaneously.
scolio :: (Recursive t) => (Base t (a, t) -> a) -> (Base t (a, t) -> t) -> t -> a
scolio :: (Base t (a, t) -> a) -> (Base t (a, t) -> t) -> t -> a
scolio = (a, t) -> a
forall a b. (a, b) -> a
fst ((a, t) -> a)
-> ((Base t (a, t) -> a) -> (Base t (a, t) -> t) -> t -> (a, t))
-> (Base t (a, t) -> a)
-> (Base t (a, t) -> t)
-> t
-> a
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.** ((Base t (a, t) -> (a, t)) -> t -> (a, t)
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata ((Base t (a, t) -> (a, t)) -> t -> (a, t))
-> ((Base t (a, t) -> a)
    -> (Base t (a, t) -> t) -> Base t (a, t) -> (a, t))
-> (Base t (a, t) -> a)
-> (Base t (a, t) -> t)
-> t
-> (a, t)
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* (Base t (a, t) -> a)
-> (Base t (a, t) -> t) -> Base t (a, t) -> (a, t)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
(&&&))

-- | Zygomorphism (see [here](http://www.iis.sinica.edu.tw/~scm/pub/mds.pdf) for a neat example)
--
-- >>> :set -XTypeFamilies
-- >>> import Data.Char (toUpper, toLower)
-- >>> :{
-- let {
--   spongebobZygo :: String -> String ;
--   spongebobZygo = zygo a pa
--     where
--       a :: ListF Char Bool -> Bool
--       a Nil          = False
--       a (Cons ' ' b) = b
--       a (Cons ',' b) = b
--       a (Cons _ b)   = not b
--       pa :: ListF Char (Bool, String) -> String
--       pa Nil                 = ""
--       pa (Cons c (True, s))  = toUpper c : s
--       pa (Cons c (False, s)) = toLower c : s
-- }
-- :}
--
-- >>> spongebobZygo "Hello, World"
-- "HeLlO, wOrLd"
--
-- >>> :set -XFlexibleContexts
-- >>> :{
-- let {
--   succDiff :: Integral a => [a] -> [a] ;
--   succDiff = zygo a pa
--       where a Nil = Nothing
--             a (Cons i _) = Just i
--             pa Nil = []
--             pa (Cons x (Nothing, xs)) = []
--             pa (Cons x (Just y, xs)) = (y - x) : xs
-- }
-- :}
--
-- >>> succDiff [ i^2 | i <- [1..10] ]
-- [3,5,7,9,11,13,15,17,19]
zygo :: (Recursive t) => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo :: (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo Base t b -> b
f Base t (b, a) -> a
g = (b, a) -> a
forall a b. (a, b) -> b
snd ((b, a) -> a) -> (t -> (b, a)) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (b, a) -> (b, a)) -> t -> (b, a)
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata (\Base t (b, a)
x -> (Base t b -> b
f (((b, a) -> b) -> Base t (b, a) -> Base t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> b
forall a b. (a, b) -> a
fst Base t (b, a)
x), Base t (b, a) -> a
g Base t (b, a)
x))

-- todo: successive difference?

-- | Paramorphism
--
-- >>> :{
-- let {
--   dedup :: Eq a => [a] -> [a] ;
--   dedup = para pa
--     where
--       pa :: Eq a => ListF a ([a], [a]) -> [a]
--       pa Nil = []
--       pa (Cons x (past, xs)) = if x `elem` past then xs else x:xs
-- }
-- :}
--
-- >>> dedup [1,1,2]
-- [1,2]
para :: (Recursive t, Corecursive t) => (Base t (t, a) -> a) -> t -> a
para :: (Base t (t, a) -> a) -> t -> a
para Base t (t, a) -> a
f = (t, a) -> a
forall a b. (a, b) -> b
snd ((t, a) -> a) -> (t -> (t, a)) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t (t, a) -> (t, a)) -> t -> (t, a)
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata (\Base t (t, a)
x -> (Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (((t, a) -> t) -> Base t (t, a) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t, a) -> t
forall a b. (a, b) -> a
fst Base t (t, a)
x), Base t (t, a) -> a
f Base t (t, a)
x))

-- | Gibbons' metamorphism. Tear down a structure, transform it, and then build up a new structure
meta :: (Corecursive t', Recursive t) => (a -> Base t' a) -> (b -> a) -> (Base t b -> b) -> t -> t'
meta :: (a -> Base t' a) -> (b -> a) -> (Base t b -> b) -> t -> t'
meta a -> Base t' a
f b -> a
e Base t b -> b
g = (a -> Base t' a) -> a -> t'
forall t a. Corecursive t => (a -> Base t a) -> a -> t
ana a -> Base t' a
f (a -> t') -> (t -> a) -> t -> t'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
e (b -> a) -> (t -> b) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base t b -> b) -> t -> b
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata Base t b -> b
g

-- | Erwig's metamorphism. Essentially a hylomorphism with a natural
-- transformation in between. This allows us to use more than one functor in a
-- hylomorphism.
meta' :: (Functor g) => (f a -> a) -> (forall c. g c -> f c) -> (b -> g b) -> b -> a
meta' :: (f a -> a) -> (forall c. g c -> f c) -> (b -> g b) -> b -> a
meta' f a -> a
h forall c. g c -> f c
e b -> g b
k = b -> a
g
    where g :: b -> a
g = f a -> a
h (f a -> a) -> (b -> f a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> f a
forall c. g c -> f c
e (g a -> f a) -> (b -> g a) -> b -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a) -> g b -> g a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
g (g b -> g a) -> (b -> g b) -> b -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> g b
k

-- | Mendler's catamorphism
--
-- >>> import Data.Word (Word64)
-- >>> let asFix = cata Fix
-- >>> let base = (2 ^ (64 :: Int)) :: Integer
-- >>> :{
-- let {
--   wordListToInteger :: [Word64] -> Integer ;
--   wordListToInteger = mcata ma . asFix
--     where
--       ma f (Cons x xs) = fromIntegral x + base * f xs
--       ma _ Nil         = 0
-- }
-- :}
--
-- >>> wordListToInteger [1,0,1]
-- 340282366920938463463374607431768211457
mcata :: (forall y. ((y -> c) -> f y -> c)) -> Fix f -> c
mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata forall y. (y -> c) -> f y -> c
ψ = Fix f -> c
mc where mc :: Fix f -> c
mc = (Fix f -> c) -> f (Fix f) -> c
forall y. (y -> c) -> f y -> c
ψ Fix f -> c
mc (f (Fix f) -> c) -> (Fix f -> f (Fix f)) -> Fix f -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | Mendler's histomorphism
--
-- See [here](https://dl.acm.org/doi/pdf/10.1145/3409004) for an example
mhisto :: (forall y. ((y -> c) -> (y -> f y) -> f y -> c)) -> Fix f -> c
mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
mhisto forall y. (y -> c) -> (y -> f y) -> f y -> c
ψ = Fix f -> c
mh where mh :: Fix f -> c
mh = (Fix f -> c) -> (Fix f -> f (Fix f)) -> f (Fix f) -> c
forall y. (y -> c) -> (y -> f y) -> f y -> c
ψ Fix f -> c
mh Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (f (Fix f) -> c) -> (Fix f -> f (Fix f)) -> Fix f -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | @since 2.2.5.0
mpara :: (forall y. (y -> c) -> (y -> Fix f) -> f y -> c) -> Fix f -> c
mpara :: (forall y. (y -> c) -> (y -> Fix f) -> f y -> c) -> Fix f -> c
mpara forall y. (y -> c) -> (y -> Fix f) -> f y -> c
ψ = Fix f -> c
c where c :: Fix f -> c
c = (Fix f -> c) -> (Fix f -> Fix f) -> f (Fix f) -> c
forall y. (y -> c) -> (y -> Fix f) -> f y -> c
ψ Fix f -> c
c Fix f -> Fix f
forall a. a -> a
id (f (Fix f) -> c) -> (Fix f -> f (Fix f)) -> Fix f -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | @since 2.2.5.0
mzygo :: (forall y. (y -> b) -> f y -> b) -> (forall y. (y -> c) -> (y -> b) -> f y -> c) -> Fix f -> c
mzygo :: (forall y. (y -> b) -> f y -> b)
-> (forall y. (y -> c) -> (y -> b) -> f y -> c) -> Fix f -> c
mzygo forall y. (y -> b) -> f y -> b
φ forall y. (y -> c) -> (y -> b) -> f y -> c
ψ = Fix f -> c
c where c :: Fix f -> c
c = (Fix f -> c) -> (Fix f -> b) -> f (Fix f) -> c
forall y. (y -> c) -> (y -> b) -> f y -> c
ψ Fix f -> c
c ((forall y. (y -> b) -> f y -> b) -> Fix f -> b
forall c (f :: * -> *).
(forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata forall y. (y -> b) -> f y -> b
φ) (f (Fix f) -> c) -> (Fix f -> f (Fix f)) -> Fix f -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | @since 2.2.5.0
mana :: (forall y. (x -> y) -> x -> f y) -> x -> Fix f
mana :: (forall y. (x -> y) -> x -> f y) -> x -> Fix f
mana forall y. (x -> y) -> x -> f y
φ = x -> Fix f
c where c :: x -> Fix f
c = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> (x -> f (Fix f)) -> x -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> Fix f) -> x -> f (Fix f)
forall y. (x -> y) -> x -> f y
φ x -> Fix f
c

-- | @since 2.2.5.0
mapo :: (forall y. (Fix f -> y) -> (x -> y) -> x -> f y) -> x -> Fix f
mapo :: (forall y. (Fix f -> y) -> (x -> y) -> x -> f y) -> x -> Fix f
mapo forall y. (Fix f -> y) -> (x -> y) -> x -> f y
φ = x -> Fix f
c where c :: x -> Fix f
c = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> (x -> f (Fix f)) -> x -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> Fix f) -> (x -> Fix f) -> x -> f (Fix f)
forall y. (Fix f -> y) -> (x -> y) -> x -> f y
φ Fix f -> Fix f
forall a. a -> a
id x -> Fix f
c

-- | @since 2.2.5.0
mfutu :: (forall y. (f y -> y) -> (x -> y) -> x -> f y) -> x -> Fix f
mfutu :: (forall y. (f y -> y) -> (x -> y) -> x -> f y) -> x -> Fix f
mfutu forall y. (f y -> y) -> (x -> y) -> x -> f y
φ = x -> Fix f
c where c :: x -> Fix f
c = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> (x -> f (Fix f)) -> x -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Fix f) -> Fix f) -> (x -> Fix f) -> x -> f (Fix f)
forall y. (f y -> y) -> (x -> y) -> x -> f y
φ f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix x -> Fix f
c

-- | Elgot algebra (see [this paper](https://arxiv.org/abs/cs/0609040))
--
-- >>> :{
-- let {
--   collatzLength :: Integer -> Integer ;
--   collatzLength = elgot a pc
--     where
--       pc :: Integer -> Either Integer (ListF Integer Integer)
--       pc 1 = Left 1
--       pc n
--         | n `mod` 2 == 0 = Right $ Cons n (div n 2)
--         | otherwise = Right $ Cons n (3 * n + 1)
--       a :: ListF Integer Integer -> Integer
--       a Nil        = 0
--       a (Cons _ x) = x + 1
-- }
-- :}
--
-- >>> collatzLength 2223
-- 183
elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot :: (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot f a -> a
φ b -> Either a (f b)
ψ = b -> a
h where h :: b -> a
h = (a -> a) -> (f b -> a) -> Either a (f b) -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id (f a -> a
φ (f a -> a) -> (f b -> f a) -> f b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a) -> f b -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
h) (Either a (f b) -> a) -> (b -> Either a (f b)) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a (f b)
ψ

-- | Anamorphism allowing shortcuts. Compare 'apo'
--
-- >>> :{
-- let {
--   collatzSequence :: Integer -> [Integer] ;
--   collatzSequence = micro pc
--     where
--       pc :: Integer -> Either [Integer] (ListF Integer Integer)
--       pc 1 = Left [1]
--       pc n
--         | n `mod` 2 == 0 = Right $ Cons n (div n 2)
--         | otherwise = Right $ Cons n (3 * n + 1)
-- }
-- :}
--
-- >>> collatzSequence 13
-- [13,40,20,10,5,16,8,4,2,1]
micro :: (Corecursive a) => (b -> Either a (Base a b)) -> b -> a
micro :: (b -> Either a (Base a b)) -> b -> a
micro = (Base a a -> a) -> (b -> Either a (Base a b)) -> b -> a
forall (f :: * -> *) a b.
Functor f =>
(f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot Base a a -> a
forall t. Corecursive t => Base t t -> t
embed

-- | Co-(Elgot algebra)
--
-- >>> import Data.Word (Word64)
-- >>> let base = (2 ^ (64 :: Int)) :: Integer
-- >>> :{
-- let {
--   integerToWordList :: Integer -> [Word64] ;
--   integerToWordList = coelgot pa c
--     where
--       c i = Cons (fromIntegral (i `mod` (2 ^ (64 :: Int)))) (i `div` (2 ^ (64 :: Int)))
--       pa (i, ws) | i < 2 ^ (64 :: Int) = [fromIntegral i]
--                  | otherwise = embed ws
-- }
-- :}
--
-- >>> integerToWordList 340282366920938463463374607431768211457
-- [1,0,1]
coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot :: ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot (a, f b) -> b
φ a -> f a
ψ = a -> b
h where h :: a -> b
h = (a, f b) -> b
φ ((a, f b) -> b) -> (a -> (a, f b)) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\a
x -> (a
x, (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
h (f a -> f b) -> (a -> f a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
ψ (a -> f b) -> a -> f b
forall a b. (a -> b) -> a -> b
$ a
x))

-- | Apomorphism. Compare 'micro'.
--
-- >>> :{
-- let {
--   isInteger :: (RealFrac a) => a -> Bool ;
--   isInteger = idem (realToFrac . floor)
--     where
--       idem f x = x == f x
-- }
-- :}
--
-- >>> :{
-- let {
--   continuedFraction :: (RealFrac a, Integral b) => a -> [b] ;
--   continuedFraction = apo pc
--     where
--       pc x
--         | isInteger x = go $ Left []
--         | otherwise   = go $ Right alpha
--           where
--             alpha = 1 / (x - realToFrac (floor x))
--             go    = Cons (floor x)
-- }
-- :}
--
-- >>> take 13 $ continuedFraction pi
-- [3,7,15,1,292,1,1,1,2,1,3,1,14]
--
-- >>> :{
-- let {
--   integerToWordList :: Integral a => a -> a -> [a] ;
--   integerToWordList base = apo pc
--     where
--       pc i | i < base  = Cons (fromIntegral i) (Left [])
--            | otherwise = Cons (fromIntegral (i `mod` base)) (Right (i `div` base))
-- }
-- :}
--
-- >>> integerToWordList 2 5
-- [1,0,1]
apo :: (Corecursive t) => (a -> Base t (Either t a)) -> a -> t
apo :: (a -> Base t (Either t a)) -> a -> t
apo a -> Base t (Either t a)
ψ = a -> t
a where a :: a -> t
a = Base t t -> t
forall t. Corecursive t => Base t t -> t
embed (Base t t -> t) -> (a -> Base t t) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either t a -> t) -> Base t (Either t a) -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((t -> t) -> (a -> t) -> Either t a -> t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> t
forall a. a -> a
id a -> t
a) (Base t (Either t a) -> Base t t)
-> (a -> Base t (Either t a)) -> a -> Base t t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Base t (Either t a)
ψ

-- | Hypomorphism.
--
-- @since 2.2.3.0
hypo :: (Recursive t, Corecursive t) => (a -> Base t (Either t a)) -> (Base t (t, b) -> b) -> a -> b
hypo :: (a -> Base t (Either t a)) -> (Base t (t, b) -> b) -> a -> b
hypo a -> Base t (Either t a)
φ Base t (t, b) -> b
ψ = (Base t (t, b) -> b) -> t -> b
forall t a.
(Recursive t, Corecursive t) =>
(Base t (t, a) -> a) -> t -> a
para Base t (t, b) -> b
ψ (t -> b) -> (a -> t) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Base t (Either t a)) -> a -> t
forall t a. Corecursive t => (a -> Base t (Either t a)) -> a -> t
apo a -> Base t (Either t a)
φ

refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix :: s -> t
refix = (Base s t -> t) -> s -> t
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata Base s t -> t
forall t. Corecursive t => Base t t -> t
embed

-- taken from http://hackage.haskell.org/package/recursion-schemes/docs/src/Data.Functor.Foldable.html#gcoerce
class HCoerce f g where
    hcoerce :: f a -> g a

instance HCoerce f g => HCoerce (M1 i c f) (M1 i c' g) where
    hcoerce :: M1 i c f a -> M1 i c' g a
hcoerce (M1 f a
x) = g a -> M1 i c' g a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> g a
forall (f :: * -> *) (g :: * -> *) a. HCoerce f g => f a -> g a
hcoerce f a
x)

instance HCoerce (K1 i c) (K1 j c) where
    hcoerce :: K1 i c a -> K1 j c a
hcoerce = c -> K1 j c a
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 j c a) -> (K1 i c a -> c) -> K1 i c a -> K1 j c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i c a -> c
forall i c k (p :: k). K1 i c p -> c
unK1

instance HCoerce U1 U1 where
    hcoerce :: U1 a -> U1 a
hcoerce = U1 a -> U1 a
forall a. a -> a
id

instance HCoerce V1 V1 where
    hcoerce :: V1 a -> V1 a
hcoerce = V1 a -> V1 a
forall a. a -> a
id

instance (HCoerce f g, HCoerce f' g') => HCoerce (f :*: f') (g :*: g') where
    hcoerce :: (:*:) f f' a -> (:*:) g g' a
hcoerce (f a
x :*: f' a
y) = f a -> g a
forall (f :: * -> *) (g :: * -> *) a. HCoerce f g => f a -> g a
hcoerce f a
x g a -> g' a -> (:*:) g g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: f' a -> g' a
forall (f :: * -> *) (g :: * -> *) a. HCoerce f g => f a -> g a
hcoerce f' a
y

instance (HCoerce f g, HCoerce f' g') => HCoerce (f :+: f') (g :+: g') where
    hcoerce :: (:+:) f f' a -> (:+:) g g' a
hcoerce (L1 f a
x) = g a -> (:+:) g g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> g a
forall (f :: * -> *) (g :: * -> *) a. HCoerce f g => f a -> g a
hcoerce f a
x)
    hcoerce (R1 f' a
x) = g' a -> (:+:) g g' a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (f' a -> g' a
forall (f :: * -> *) (g :: * -> *) a. HCoerce f g => f a -> g a
hcoerce f' a
x)