{-# LANGUAGE GADTs #-}

module Yaya.Fold where

import Control.Applicative
import Control.Arrow
import Control.Comonad
import Control.Comonad.Cofree
import Control.Comonad.Trans.Env
import Control.Lens hiding ((:<))
import Control.Monad
import Control.Monad.Trans.Free
import Data.Bitraversable
import Data.Either.Combinators
import Data.Foldable
import Data.Functor.Classes
import Data.Functor.Day
import Data.List.NonEmpty (NonEmpty (..))
import Data.Void
import Numeric.Natural
import Yaya.Fold.Common
import Yaya.Functor
import Yaya.Pattern

type Algebra c f a = f a `c` a

type GAlgebra c w f a = f (w a) `c` a

type ElgotAlgebra c w f a = w (f a) `c` a

type AlgebraM c m f a = f a `c` m a

type GAlgebraM c m w f a = f (w a) `c` m a

type ElgotAlgebraM c m w f a = w (f a) `c` m a

type Coalgebra c f a = a `c` f a

type GCoalgebra c m f a = a `c` f (m a)

type ElgotCoalgebra c m f a = a `c` m (f a)

-- | Note that using a `CoalgebraM` “directly” is partial (e.g., with
--  `Yaya.Unsafe.Fold.anaM`). However, @ana . Compose@ can accept a `CoalgebraM`
--   and produce something like an effectful stream.
type CoalgebraM c m f a = a `c` m (f a)

type GCoalgebraM c m n f a = a `c` m (f (n a))

-- | This type class is lawless on its own, but there exist types that can’t
--   implement the corresponding `embed` operation. Laws are induced by
--   implementing either `Steppable` (which extends this) or `Corecursive`
--  (which doesn’t).
class Projectable c t f | t -> f where
  project :: Coalgebra c f t

-- | Structures you can walk through step-by-step.
class Projectable c t f => Steppable c t f | t -> f where
  embed :: Algebra c f t

-- | Inductive structures that can be reasoned about in the way we usually do –
--   with pattern matching.
class Recursive c t f | t -> f where
  cata :: Algebra c f a -> t `c` a

-- | Coinductive (potentially-infinite) structures that guarantee _productivity_
--   rather than termination.
class Corecursive c t f | t -> f where
  ana :: Coalgebra c f a -> a `c` t

-- | An implementation of `Eq` for any `Recursive` instance. Note that this is
--   actually more general than `Eq`, as it can compare between different
--   fixed-point representations of the same functor.
recursiveEq ::
  (Recursive (->) t f, Steppable (->) u f, Functor f, Foldable f, Eq1 f) =>
  t ->
  u ->
  Bool
recursiveEq :: t -> u -> Bool
recursiveEq = Algebra (->) (Day f f) Bool -> t -> u -> Bool
forall t (f :: * -> *) u (g :: * -> *) a.
(Recursive (->) t f, Projectable (->) u g) =>
Algebra (->) (Day f g) a -> t -> u -> a
cata2 Algebra (->) (Day f f) Bool
forall (f :: * -> *).
(Functor f, Foldable f, Eq1 f) =>
Day f f Bool -> Bool
equal

-- | An implementation of `Show` for any `Recursive` instance.
recursiveShowsPrec :: (Recursive (->) t f, Show1 f) => Int -> t -> ShowS
recursiveShowsPrec :: Int -> t -> ShowS
recursiveShowsPrec Int
prec =
  Algebra (->) f ShowS -> t -> ShowS
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata (Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> Algebra (->) f ShowS -> Algebra (->) f ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ShowS -> ShowS)
-> ([ShowS] -> ShowS) -> Int -> Algebra (->) f ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec ((ShowS -> ShowS) -> Int -> ShowS -> ShowS
forall a b. a -> b -> a
const ShowS -> ShowS
forall a. a -> a
id) [ShowS] -> ShowS
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Int
prec)

-- | A fixed-point operator for inductive / finite data structures.
--
--  *NB*: This is only guaranteed to be finite when @f a@ is strict in @a@
--       (having strict functors won't prevent `Nu` from being lazy). Using
--       @-XStrictData@ can help with this a lot.
newtype Mu f = Mu (forall a. Algebra (->) f a -> a)

instance Functor f => Projectable (->) (Mu f) f where
  project :: Coalgebra (->) f (Mu f)
project = Coalgebra (->) f (Mu f)
forall t (f :: * -> *).
(Steppable (->) t f, Recursive (->) t f, Functor f) =>
Coalgebra (->) f t
lambek

instance Functor f => Steppable (->) (Mu f) f where
  embed :: Algebra (->) f (Mu f)
embed f (Mu f)
m = (forall a. Algebra (->) f a -> a) -> Mu f
forall (f :: * -> *). (forall a. Algebra (->) f a -> a) -> Mu f
Mu (\Algebra (->) f a
f -> Algebra (->) f a
f ((Mu f -> a) -> f (Mu f) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Algebra (->) f a -> Mu f -> a
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata Algebra (->) f a
f) f (Mu f)
m))

instance Recursive (->) (Mu f) f where
  cata :: Algebra (->) f a -> Mu f -> a
cata Algebra (->) f a
φ (Mu forall a. Algebra (->) f a -> a
f) = Algebra (->) f a -> a
forall a. Algebra (->) f a -> a
f Algebra (->) f a
φ

instance DFunctor Mu where
  dmap :: (forall x. f x -> g x) -> Mu f -> Mu g
dmap forall x. f x -> g x
f (Mu forall a. Algebra (->) f a -> a
run) = (forall a. Algebra (->) g a -> a) -> Mu g
forall (f :: * -> *). (forall a. Algebra (->) f a -> a) -> Mu f
Mu (\Algebra (->) g a
φ -> Algebra (->) f a -> a
forall a. Algebra (->) f a -> a
run (Algebra (->) g a
φ Algebra (->) g a -> (f a -> g a) -> Algebra (->) f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a
forall x. f x -> g x
f))

instance Show1 f => Show (Mu f) where
  showsPrec :: Int -> Mu f -> ShowS
showsPrec = Int -> Mu f -> ShowS
forall t (f :: * -> *).
(Recursive (->) t f, Show1 f) =>
Int -> t -> ShowS
recursiveShowsPrec

instance (Functor f, Foldable f, Eq1 f) => Eq (Mu f) where
  == :: Mu f -> Mu f -> Bool
(==) = Mu f -> Mu f -> Bool
forall t (f :: * -> *) u.
(Recursive (->) t f, Steppable (->) u f, Functor f, Foldable f,
 Eq1 f) =>
t -> u -> Bool
recursiveEq

-- | A fixed-point operator for coinductive / potentially-infinite data
--   structures.
data Nu f where Nu :: Coalgebra (->) f a -> a -> Nu f

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

instance Functor f => Steppable (->) (Nu f) f where
  embed :: Algebra (->) f (Nu f)
embed = Algebra (->) f (Nu f)
forall t (f :: * -> *).
(Projectable (->) t f, Corecursive (->) t f, Functor f) =>
Algebra (->) f t
colambek

instance Corecursive (->) (Nu f) f where
  ana :: Coalgebra (->) f a -> a -> Nu f
ana = Coalgebra (->) f a -> a -> Nu f
forall (f :: * -> *) a. Coalgebra (->) f a -> a -> Nu f
Nu

instance DFunctor Nu where
  dmap :: (forall x. f x -> g x) -> Nu f -> Nu g
dmap forall x. f x -> g x
f (Nu Coalgebra (->) f a
φ a
a) = Coalgebra (->) g a -> a -> Nu g
forall (f :: * -> *) a. Coalgebra (->) f a -> a -> Nu f
Nu (f a -> g a
forall x. f x -> g x
f (f a -> g a) -> Coalgebra (->) f a -> Coalgebra (->) g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coalgebra (->) f a
φ) a
a

instance Projectable (->) [a] (XNor a) where
  project :: Coalgebra (->) (XNor a) [a]
project [] = XNor a [a]
forall a b. XNor a b
Neither
  project (a
h : [a]
t) = a -> Coalgebra (->) (XNor a) [a]
forall a b. a -> b -> XNor a b
Both a
h [a]
t

instance Steppable (->) [a] (XNor a) where
  embed :: Algebra (->) (XNor a) [a]
embed XNor a [a]
Neither = []
  embed (Both a
h [a]
t) = a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
t

instance Projectable (->) (NonEmpty a) (AndMaybe a) where
  project :: Coalgebra (->) (AndMaybe a) (NonEmpty a)
project (a
a :| []) = a -> AndMaybe a (NonEmpty a)
forall a b. a -> AndMaybe a b
Only a
a
  project (a
a :| a
b : [a]
bs) = a -> Coalgebra (->) (AndMaybe a) (NonEmpty a)
forall a b. a -> b -> AndMaybe a b
Indeed a
a (a
b a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
bs)

instance Steppable (->) (NonEmpty a) (AndMaybe a) where
  embed :: Algebra (->) (AndMaybe a) (NonEmpty a)
embed (Only a
a) = a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []
  embed (Indeed a
a NonEmpty a
b) = a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
b

instance Projectable (->) Natural Maybe where
  project :: Coalgebra (->) Maybe Natural
project Natural
0 = Maybe Natural
forall a. Maybe a
Nothing
  project Natural
n = Coalgebra (->) Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Natural
forall a. Enum a => a -> a
pred Natural
n)

instance Steppable (->) Natural Maybe where
  embed :: Algebra (->) Maybe Natural
embed = Natural -> (Natural -> Natural) -> Algebra (->) Maybe Natural
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Natural
0 Natural -> Natural
forall a. Enum a => a -> a
succ

instance Projectable (->) Void Identity where
  project :: Coalgebra (->) Identity Void
project = Coalgebra (->) Identity Void
forall a. a -> Identity a
Identity

instance Steppable (->) Void Identity where
  embed :: Algebra (->) Identity Void
embed = Algebra (->) Identity Void
forall a. Identity a -> a
runIdentity

instance Recursive (->) Void Identity where
  cata :: Algebra (->) Identity a -> Void -> a
cata Algebra (->) Identity a
_ = Void -> a
forall a. Void -> a
absurd

instance Projectable (->) (Cofree f a) (EnvT a f) where
  project :: Coalgebra (->) (EnvT a f) (Cofree f a)
project (a
a :< f (Cofree f a)
ft) = a -> f (Cofree f a) -> EnvT a f (Cofree f a)
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT a
a f (Cofree f a)
ft

instance Steppable (->) (Cofree f a) (EnvT a f) where
  embed :: Algebra (->) (EnvT a f) (Cofree f a)
embed (EnvT a
a f (Cofree f a)
ft) = a
a a -> f (Cofree f a) -> Cofree f a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< f (Cofree f a)
ft

instance Projectable (->) (Free f a) (FreeF f a) where
  project :: Coalgebra (->) (FreeF f a) (Free f a)
project = Coalgebra (->) (FreeF f a) (Free f a)
forall (f :: * -> *) a. Coalgebra (->) (FreeF f a) (Free f a)
runFree

instance Steppable (->) (Free f a) (FreeF f a) where
  embed :: Algebra (->) (FreeF f a) (Free f a)
embed = Algebra (->) (FreeF f a) (Free f a)
forall (f :: * -> *) a. Algebra (->) (FreeF f a) (Free f a)
free

-- | Combines two `Algebra`s with different carriers into a single tupled
--  `Algebra`.
zipAlgebras :: Functor f => Algebra (->) f a -> Algebra (->) f b -> Algebra (->) f (a, b)
zipAlgebras :: Algebra (->) f a -> Algebra (->) f b -> Algebra (->) f (a, b)
zipAlgebras Algebra (->) f a
f Algebra (->) f b
g = Algebra (->) f a
f Algebra (->) f a -> (f (a, b) -> f a) -> f (a, b) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> a) -> f (a, b) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst (f (a, b) -> a) -> (f (a, b) -> b) -> Algebra (->) f (a, b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Algebra (->) f b
g Algebra (->) f b -> (f (a, b) -> f b) -> f (a, b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> b) -> f (a, b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd

-- | Combines two `AlgebraM`s with different carriers into a single tupled
--  `AlgebraM`.
zipAlgebraMs ::
  (Applicative m, Functor f) =>
  AlgebraM (->) m f a ->
  AlgebraM (->) m f b ->
  AlgebraM (->) m f (a, b)
zipAlgebraMs :: AlgebraM (->) m f a
-> AlgebraM (->) m f b -> AlgebraM (->) m f (a, b)
zipAlgebraMs AlgebraM (->) m f a
f AlgebraM (->) m f b
g = (m a -> m b -> m (a, b)) -> (m a, m b) -> m (a, b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((a -> b -> (a, b)) -> m a -> m b -> m (a, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)) ((m a, m b) -> m (a, b))
-> (f (a, b) -> (m a, m b)) -> AlgebraM (->) m f (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AlgebraM (->) m f a
f AlgebraM (->) m f a -> (f (a, b) -> f a) -> f (a, b) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> a) -> f (a, b) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst (f (a, b) -> m a) -> (f (a, b) -> m b) -> f (a, b) -> (m a, m b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& AlgebraM (->) m f b
g AlgebraM (->) m f b -> (f (a, b) -> f b) -> f (a, b) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> b) -> f (a, b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd)

-- | Algebras over Day convolution are convenient for binary operations, but
--   aren’t directly handleable by `cata`.
lowerDay :: Projectable (->) t g => Algebra (->) (Day f g) a -> Algebra (->) f (t -> a)
lowerDay :: Algebra (->) (Day f g) a -> Algebra (->) f (t -> a)
lowerDay Algebra (->) (Day f g) a
φ f (t -> a)
fta t
t = Algebra (->) (Day f g) a
φ (f (t -> a) -> g t -> ((t -> a) -> t -> a) -> Day f g a
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day f (t -> a)
fta (Coalgebra (->) g t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Projectable c t f =>
Coalgebra c f t
project t
t) (t -> a) -> t -> a
forall a b. (a -> b) -> a -> b
($))

-- | By analogy with `liftA2` (which also relies on `Day`, at least
--   conceptually).
cata2 :: (Recursive (->) t f, Projectable (->) u g) => Algebra (->) (Day f g) a -> t -> u -> a
cata2 :: Algebra (->) (Day f g) a -> t -> u -> a
cata2 = Algebra (->) f (u -> a) -> t -> u -> a
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata (Algebra (->) f (u -> a) -> t -> u -> a)
-> (Algebra (->) (Day f g) a -> Algebra (->) f (u -> a))
-> Algebra (->) (Day f g) a
-> t
-> u
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Algebra (->) (Day f g) a -> Algebra (->) f (u -> a)
forall t (g :: * -> *) (f :: * -> *) a.
Projectable (->) t g =>
Algebra (->) (Day f g) a -> Algebra (->) f (t -> a)
lowerDay

-- | Makes it possible to provide a `GAlgebra` to `cata`.
lowerAlgebra ::
  (Functor f, Comonad w) =>
  DistributiveLaw (->) f w ->
  GAlgebra (->) w f a ->
  Algebra (->) f (w a)
lowerAlgebra :: DistributiveLaw (->) f w
-> GAlgebra (->) w f a -> Algebra (->) f (w a)
lowerAlgebra DistributiveLaw (->) f w
k GAlgebra (->) w f a
φ = GAlgebra (->) w f a -> w (f (w a)) -> w a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GAlgebra (->) w f a
φ (w (f (w a)) -> w a)
-> (f (w a) -> w (f (w a))) -> Algebra (->) f (w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (w (w a)) -> w (f (w a))
DistributiveLaw (->) f w
k (f (w (w a)) -> w (f (w a)))
-> (f (w a) -> f (w (w a))) -> f (w a) -> w (f (w a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w a -> w (w a)) -> f (w a) -> f (w (w a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap w a -> w (w a)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate

-- | Makes it possible to provide a `GAlgebraM` to `Yaya.Zoo.cataM`.
lowerAlgebraM ::
  (Applicative m, Traversable f, Comonad w, Traversable w) =>
  DistributiveLaw (->) f w ->
  GAlgebraM (->) m w f a ->
  AlgebraM (->) m f (w a)
lowerAlgebraM :: DistributiveLaw (->) f w
-> GAlgebraM (->) m w f a -> AlgebraM (->) m f (w a)
lowerAlgebraM DistributiveLaw (->) f w
k GAlgebraM (->) m w f a
φ = GAlgebraM (->) m w f a -> w (f (w a)) -> m (w a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse GAlgebraM (->) m w f a
φ (w (f (w a)) -> m (w a))
-> (f (w a) -> w (f (w a))) -> AlgebraM (->) m f (w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (w (w a)) -> w (f (w a))
DistributiveLaw (->) f w
k (f (w (w a)) -> w (f (w a)))
-> (f (w a) -> f (w (w a))) -> f (w a) -> w (f (w a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w a -> w (w a)) -> f (w a) -> f (w (w a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap w a -> w (w a)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate

-- | Makes it possible to provide a `GCoalgebra` to `ana`.
lowerCoalgebra ::
  (Functor f, Monad m) =>
  DistributiveLaw (->) m f ->
  GCoalgebra (->) m f a ->
  Coalgebra (->) f (m a)
lowerCoalgebra :: DistributiveLaw (->) m f
-> GCoalgebra (->) m f a -> Coalgebra (->) f (m a)
lowerCoalgebra DistributiveLaw (->) m f
k GCoalgebra (->) m f a
ψ = (m (m a) -> m a) -> f (m (m a)) -> f (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (f (m (m a)) -> f (m a))
-> (m a -> f (m (m a))) -> Coalgebra (->) f (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (f (m a)) -> f (m (m a))
DistributiveLaw (->) m f
k (m (f (m a)) -> f (m (m a)))
-> (m a -> m (f (m a))) -> m a -> f (m (m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GCoalgebra (->) m f a -> m a -> m (f (m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GCoalgebra (->) m f a
ψ

-- | Makes it possible to provide a `GCoalgebraM` to `Yaya.Unsafe.Fold.anaM`.
lowerCoalgebraM ::
  (Applicative m, Traversable f, Monad n, Traversable n) =>
  DistributiveLaw (->) n f ->
  GCoalgebraM (->) m n f a ->
  CoalgebraM (->) m f (n a)
lowerCoalgebraM :: DistributiveLaw (->) n f
-> GCoalgebraM (->) m n f a -> CoalgebraM (->) m f (n a)
lowerCoalgebraM DistributiveLaw (->) n f
k GCoalgebraM (->) m n f a
ψ = (n (f (n a)) -> f (n a)) -> m (n (f (n a))) -> m (f (n a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((n (n a) -> n a) -> f (n (n a)) -> f (n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n (n a) -> n a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (f (n (n a)) -> f (n a))
-> (n (f (n a)) -> f (n (n a))) -> n (f (n a)) -> f (n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n (f (n a)) -> f (n (n a))
DistributiveLaw (->) n f
k) (m (n (f (n a))) -> m (f (n a)))
-> (n a -> m (n (f (n a)))) -> CoalgebraM (->) m f (n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GCoalgebraM (->) m n f a -> n a -> m (n (f (n a)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse GCoalgebraM (->) m n f a
ψ

gcata ::
  (Recursive (->) t f, Functor f, Comonad w) =>
  DistributiveLaw (->) f w ->
  GAlgebra (->) w f a ->
  t ->
  a
gcata :: DistributiveLaw (->) f w -> GAlgebra (->) w f a -> t -> a
gcata DistributiveLaw (->) f w
k GAlgebra (->) w f a
φ = w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract (w a -> a) -> (t -> w a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Algebra (->) f (w a) -> t -> w a
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata (DistributiveLaw (->) f w
-> GAlgebra (->) w f a -> Algebra (->) f (w a)
forall (f :: * -> *) (w :: * -> *) a.
(Functor f, Comonad w) =>
DistributiveLaw (->) f w
-> GAlgebra (->) w f a -> Algebra (->) f (w a)
lowerAlgebra DistributiveLaw (->) f w
k GAlgebra (->) w f a
φ)

elgotCata ::
  (Recursive (->) t f, Functor f, Comonad w) =>
  DistributiveLaw (->) f w ->
  ElgotAlgebra (->) w f a ->
  t ->
  a
elgotCata :: DistributiveLaw (->) f w -> ElgotAlgebra (->) w f a -> t -> a
elgotCata DistributiveLaw (->) f w
k ElgotAlgebra (->) w f a
φ = ElgotAlgebra (->) w f a
φ ElgotAlgebra (->) w f a -> (t -> w (f a)) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Algebra (->) f (w (f a)) -> t -> w (f a)
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata (f (w a) -> w (f a)
DistributiveLaw (->) f w
k (f (w a) -> w (f a))
-> (f (w (f a)) -> f (w a)) -> Algebra (->) f (w (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w (f a) -> w a) -> f (w (f a)) -> f (w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ElgotAlgebra (->) w f a -> w (f a) -> w a
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend ElgotAlgebra (->) w f a
φ))

gcataM ::
  (Monad m, Recursive (->) t f, Traversable f, Comonad w, Traversable w) =>
  DistributiveLaw (->) f w ->
  GAlgebraM (->) m w f a ->
  t ->
  m a
gcataM :: DistributiveLaw (->) f w -> GAlgebraM (->) m w f a -> t -> m a
gcataM DistributiveLaw (->) f w
w GAlgebraM (->) m w f a
φ = (w a -> a) -> m (w a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract (m (w a) -> m a) -> (t -> m (w a)) -> t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Algebra (->) f (m (w a)) -> t -> m (w a)
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata (DistributiveLaw (->) f w
-> GAlgebraM (->) m w f a -> AlgebraM (->) m f (w a)
forall (m :: * -> *) (f :: * -> *) (w :: * -> *) a.
(Applicative m, Traversable f, Comonad w, Traversable w) =>
DistributiveLaw (->) f w
-> GAlgebraM (->) m w f a -> AlgebraM (->) m f (w a)
lowerAlgebraM DistributiveLaw (->) f w
w GAlgebraM (->) m w f a
φ AlgebraM (->) m f (w a)
-> (f (m (w a)) -> m (f (w a))) -> Algebra (->) f (m (w a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< f (m (w a)) -> m (f (w a))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA)

elgotCataM ::
  (Monad m, Recursive (->) t f, Traversable f, Comonad w, Traversable w) =>
  DistributiveLaw (->) f w ->
  ElgotAlgebraM (->) m w f a ->
  t ->
  m a
elgotCataM :: DistributiveLaw (->) f w -> ElgotAlgebraM (->) m w f a -> t -> m a
elgotCataM DistributiveLaw (->) f w
w ElgotAlgebraM (->) m w f a
φ = ElgotAlgebraM (->) m w f a
φ ElgotAlgebraM (->) m w f a -> (t -> m (w (f a))) -> t -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Algebra (->) f (m (w (f a))) -> t -> m (w (f a))
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata ((f (w a) -> w (f a)) -> m (f (w a)) -> m (w (f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (w a) -> w (f a)
DistributiveLaw (->) f w
w (m (f (w a)) -> m (w (f a)))
-> (f (w (f a)) -> m (f (w a))) -> f (w (f a)) -> m (w (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w (f a) -> m (w a)) -> f (w (f a)) -> m (f (w a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (w (m a) -> m (w a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (w (m a) -> m (w a)) -> (w (f a) -> w (m a)) -> w (f a) -> m (w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElgotAlgebraM (->) m w f a -> w (f a) -> w (m a)
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend ElgotAlgebraM (->) m w f a
φ) (f (w (f a)) -> m (w (f a)))
-> (f (m (w (f a))) -> m (f (w (f a))))
-> Algebra (->) f (m (w (f a)))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< f (m (w (f a))) -> m (f (w (f a)))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA)

ezygoM ::
  (Monad m, Recursive (->) t f, Traversable f) =>
  AlgebraM (->) m f b ->
  ElgotAlgebraM (->) m ((,) b) f a ->
  t ->
  m a
ezygoM :: AlgebraM (->) m f b -> ElgotAlgebraM (->) m ((,) b) f a -> t -> m a
ezygoM AlgebraM (->) m f b
φ' ElgotAlgebraM (->) m ((,) b) f a
φ =
  ((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
. Algebra (->) f (m (b, a)) -> t -> m (b, a)
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata
      ( (\x :: (b, f a)
x@(b
b, f a
_) -> (b
b,) (a -> (b, a)) -> m a -> m (b, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElgotAlgebraM (->) m ((,) b) f a
φ (b, f a)
x)
          ((b, f a) -> m (b, a))
-> (f (m (b, a)) -> m (b, f a)) -> Algebra (->) f (m (b, a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (m b, m (f a)) -> m (b, f a)
forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequence ((m b, m (f a)) -> m (b, f a))
-> (f (b, a) -> (m b, m (f a))) -> f (b, a) -> m (b, f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AlgebraM (->) m f b
φ' AlgebraM (->) m f b -> (f (b, a) -> f b) -> f (b, a) -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, a) -> b) -> f (b, a) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> b
forall a b. (a, b) -> a
fst (f (b, a) -> m b)
-> (f (b, a) -> m (f a)) -> f (b, a) -> (m b, m (f a))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> m (f a)) -> (f (b, a) -> f a) -> f (b, a) -> m (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, a) -> a) -> f (b, a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, a) -> a
forall a b. (a, b) -> b
snd)
          (f (b, a) -> m (b, f a))
-> (f (m (b, a)) -> m (f (b, a))) -> f (m (b, a)) -> m (b, f a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< f (m (b, a)) -> m (f (b, a))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
      )

gana ::
  (Corecursive (->) t f, Functor f, Monad m) =>
  DistributiveLaw (->) m f ->
  GCoalgebra (->) m f a ->
  a ->
  t
gana :: DistributiveLaw (->) m f -> GCoalgebra (->) m f a -> a -> t
gana DistributiveLaw (->) m f
k GCoalgebra (->) m f a
ψ = Coalgebra (->) f (m a) -> m a -> t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana (DistributiveLaw (->) m f
-> GCoalgebra (->) m f a -> Coalgebra (->) f (m a)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
DistributiveLaw (->) m f
-> GCoalgebra (->) m f a -> Coalgebra (->) f (m a)
lowerCoalgebra DistributiveLaw (->) m f
k GCoalgebra (->) m f a
ψ) (m a -> t) -> (a -> m a) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

elgotAna ::
  (Corecursive (->) t f, Functor f, Monad m) =>
  DistributiveLaw (->) m f ->
  ElgotCoalgebra (->) m f a ->
  a ->
  t
elgotAna :: DistributiveLaw (->) m f -> ElgotCoalgebra (->) m f a -> a -> t
elgotAna DistributiveLaw (->) m f
k ElgotCoalgebra (->) m f a
ψ = Coalgebra (->) f (m (f a)) -> m (f a) -> t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana ((m a -> m (f a)) -> f (m a) -> f (m (f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m a -> ElgotCoalgebra (->) m f a -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ElgotCoalgebra (->) m f a
ψ) (f (m a) -> f (m (f a)))
-> (m (f a) -> f (m a)) -> Coalgebra (->) f (m (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (f a) -> f (m a)
DistributiveLaw (->) m f
k) (m (f a) -> t) -> ElgotCoalgebra (->) m f a -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElgotCoalgebra (->) m f a
ψ

lambek :: (Steppable (->) t f, Recursive (->) t f, Functor f) => Coalgebra (->) f t
lambek :: Coalgebra (->) f t
lambek = Algebra (->) f (f t) -> Coalgebra (->) f t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata ((f t -> t) -> Algebra (->) f (f t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f t -> t
forall k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Steppable c t f =>
Algebra c f t
embed)

colambek :: (Projectable (->) t f, Corecursive (->) t f, Functor f) => Algebra (->) f t
colambek :: Algebra (->) f t
colambek = Coalgebra (->) f (f t) -> Algebra (->) f t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana ((t -> f t) -> Coalgebra (->) f (f t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> f t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Projectable c t f =>
Coalgebra c f t
project)

-- | There are a number of distributive laws, including
--  `Data.Traversable.sequenceA`, `Data.Distributive.distribute`, and
--  `Data.Align.sequenceL`. Yaya also provides others for specific recursion
--   schemes.
type DistributiveLaw c f g = forall a. f (g a) `c` g (f a)

-- | A less-constrained `distribute` for `Identity`.
distIdentity :: Functor f => DistributiveLaw (->) f Identity
distIdentity :: DistributiveLaw (->) f Identity
distIdentity = f a -> Identity (f a)
forall a. a -> Identity a
Identity (f a -> Identity (f a))
-> (f (Identity a) -> f a) -> f (Identity a) -> Identity (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity a -> a) -> f (Identity a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity a -> a
forall a. Identity a -> a
runIdentity

-- | A less-constrained `sequenceA` for `Identity`.
seqIdentity :: Functor f => DistributiveLaw (->) Identity f
seqIdentity :: DistributiveLaw (->) Identity f
seqIdentity = (a -> Identity a) -> f a -> f (Identity a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Identity a
forall a. a -> Identity a
Identity (f a -> f (Identity a))
-> (Identity (f a) -> f a) -> Identity (f a) -> f (Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (f a) -> f a
forall a. Identity a -> a
runIdentity

distTuple :: Functor f => Algebra (->) f a -> DistributiveLaw (->) f ((,) a)
distTuple :: Algebra (->) f a -> DistributiveLaw (->) f ((,) a)
distTuple Algebra (->) f a
φ = Algebra (->) f a
φ Algebra (->) f a -> (f (a, a) -> f a) -> f (a, a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, a) -> a) -> f (a, a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, a) -> a
forall a b. (a, b) -> a
fst (f (a, a) -> a) -> (f (a, a) -> f a) -> f (a, a) -> (a, f a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((a, a) -> a) -> f (a, a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, a) -> a
forall a b. (a, b) -> b
snd

distEnvT ::
  Functor f =>
  Algebra (->) f a ->
  DistributiveLaw (->) f w ->
  DistributiveLaw (->) f (EnvT a w)
distEnvT :: Algebra (->) f a
-> DistributiveLaw (->) f w -> DistributiveLaw (->) f (EnvT a w)
distEnvT Algebra (->) f a
φ DistributiveLaw (->) f w
k = (a -> w (f a) -> EnvT a w (f a)) -> (a, w (f a)) -> EnvT a w (f a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> w (f a) -> EnvT a w (f a)
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT ((a, w (f a)) -> EnvT a w (f a))
-> (f (EnvT a w a) -> (a, w (f a)))
-> f (EnvT a w a)
-> EnvT a w (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Algebra (->) f a
φ Algebra (->) f a -> (f (EnvT a w a) -> f a) -> f (EnvT a w a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvT a w a -> a) -> f (EnvT a w a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EnvT a w a -> a
forall e (w :: * -> *) a. EnvT e w a -> e
ask (f (EnvT a w a) -> a)
-> (f (EnvT a w a) -> w (f a)) -> f (EnvT a w a) -> (a, w (f a))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& f (w a) -> w (f a)
DistributiveLaw (->) f w
k (f (w a) -> w (f a))
-> (f (EnvT a w a) -> f (w a)) -> f (EnvT a w a) -> w (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvT a w a -> w a) -> f (EnvT a w a) -> f (w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EnvT a w a -> w a
forall e (w :: * -> *) a. EnvT e w a -> w a
lowerEnvT)

seqEither :: Functor f => Coalgebra (->) f a -> DistributiveLaw (->) (Either a) f
seqEither :: Coalgebra (->) f a -> DistributiveLaw (->) (Either a) f
seqEither Coalgebra (->) f a
ψ = (a -> Either a a) -> f a -> f (Either a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a a
forall a b. a -> Either a b
Left (f a -> f (Either a a))
-> Coalgebra (->) f a -> a -> f (Either a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coalgebra (->) f a
ψ (a -> f (Either a a))
-> (f a -> f (Either a a)) -> Either a (f a) -> f (Either a a)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| (a -> Either a a) -> f a -> f (Either a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a a
forall a b. b -> Either a b
Right

-- | Converts an `Algebra` to one that annotates the tree with the result for
--   each node.
attributeAlgebra ::
  (Steppable (->) t (EnvT a f), Functor f) =>
  Algebra (->) f a ->
  Algebra (->) f t
attributeAlgebra :: Algebra (->) f a -> Algebra (->) f t
attributeAlgebra Algebra (->) f a
φ f t
ft = Algebra (->) (EnvT a f) t
forall k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Steppable c t f =>
Algebra c f t
embed Algebra (->) (EnvT a f) t -> Algebra (->) (EnvT a f) t
forall a b. (a -> b) -> a -> b
$ a -> f t -> EnvT a f t
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT (Algebra (->) f a
φ ((t -> a) -> f t -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, f t) -> a
forall a b. (a, b) -> a
fst ((a, f t) -> a) -> (t -> (a, f t)) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvT a f t -> (a, f t)
forall e (w :: * -> *) a. EnvT e w a -> (e, w a)
runEnvT (EnvT a f t -> (a, f t)) -> (t -> EnvT a f t) -> t -> (a, f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> EnvT a f t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Projectable c t f =>
Coalgebra c f t
project) f t
ft)) f t
ft

-- | Converts a `Coalgebra` to one that annotates the tree with the seed that
--   generated each node.
attributeCoalgebra :: Coalgebra (->) f a -> Coalgebra (->) (EnvT a f) a
attributeCoalgebra :: Coalgebra (->) f a -> Coalgebra (->) (EnvT a f) a
attributeCoalgebra Coalgebra (->) f a
ψ = (a -> f a -> EnvT a f a) -> (a, f a) -> EnvT a f a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> f a -> EnvT a f a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT ((a, f a) -> EnvT a f a)
-> (a -> (a, f a)) -> Coalgebra (->) (EnvT a f) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a
forall a. a -> a
id (a -> a) -> Coalgebra (->) f a -> a -> (a, f a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Coalgebra (->) f a
ψ)

-- | This is just a more obvious name for composing `lowerEnvT` with your
--   algebra directly.
ignoringAttribute :: Algebra (->) f a -> Algebra (->) (EnvT b f) a
ignoringAttribute :: Algebra (->) f a -> Algebra (->) (EnvT b f) a
ignoringAttribute Algebra (->) f a
φ = Algebra (->) f a
φ Algebra (->) f a
-> (EnvT b f a -> f a) -> Algebra (->) (EnvT b f) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvT b f a -> f a
forall e (w :: * -> *) a. EnvT e w a -> w a
lowerEnvT

-- | It is somewhat common to have a natural transformation that looks like
--  @η :: forall a. f a -> Free g a@. This maps naturally to a `GCoalgebra` (to
--   pass to `Yaya.Zoo.apo`) with @η . project@, but the desired `Algebra` is
--   more likely to be @cata unFree . η@ than @embed . η@. See yaya-streams for
--   some examples of this.
unFree :: Steppable (->) t f => Algebra (->) (FreeF f t) t
unFree :: Algebra (->) (FreeF f t) t
unFree = \case
  Pure t
t -> t
t
  Free f t
ft -> Algebra (->) f t
forall k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Steppable c t f =>
Algebra c f t
embed f t
ft

-- preservingAttribute :: (forall a. f a -> g a) -> EnvT a f b -> EnvT a g b
-- preservingAttribute = cohoist

-- * instances for non-recursive types

constEmbed :: Algebra (->) (Const a) a
constEmbed :: Algebra (->) (Const a) a
constEmbed = Algebra (->) (Const a) a
forall a k (b :: k). Const a b -> a
getConst

constProject :: Coalgebra (->) (Const a) a
constProject :: Coalgebra (->) (Const a) a
constProject = Coalgebra (->) (Const a) a
forall k a (b :: k). a -> Const a b
Const

constCata :: Algebra (->) (Const b) a -> b -> a
constCata :: Algebra (->) (Const b) a -> b -> a
constCata Algebra (->) (Const b) a
φ = Algebra (->) (Const b) a
φ Algebra (->) (Const b) a -> (b -> Const b a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Const b a
forall k a (b :: k). a -> Const a b
Const

constAna :: Coalgebra (->) (Const b) a -> a -> b
constAna :: Coalgebra (->) (Const b) a -> a -> b
constAna Coalgebra (->) (Const b) a
ψ = Const b a -> b
forall a k (b :: k). Const a b -> a
getConst (Const b a -> b) -> Coalgebra (->) (Const b) a -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coalgebra (->) (Const b) a
ψ

instance Projectable (->) (Either a b) (Const (Either a b)) where
  project :: Coalgebra (->) (Const (Either a b)) (Either a b)
project = Coalgebra (->) (Const (Either a b)) (Either a b)
forall a. Coalgebra (->) (Const a) a
constProject

instance Steppable (->) (Either a b) (Const (Either a b)) where
  embed :: Algebra (->) (Const (Either a b)) (Either a b)
embed = Algebra (->) (Const (Either a b)) (Either a b)
forall a. Algebra (->) (Const a) a
constEmbed

instance Recursive (->) (Either a b) (Const (Either a b)) where
  cata :: Algebra (->) (Const (Either a b)) a -> Either a b -> a
cata = Algebra (->) (Const (Either a b)) a -> Either a b -> a
forall b a. Algebra (->) (Const b) a -> b -> a
constCata

instance Corecursive (->) (Either a b) (Const (Either a b)) where
  ana :: Coalgebra (->) (Const (Either a b)) a -> a -> Either a b
ana = Coalgebra (->) (Const (Either a b)) a -> a -> Either a b
forall b a. Coalgebra (->) (Const b) a -> a -> b
constAna

instance Projectable (->) (Maybe a) (Const (Maybe a)) where
  project :: Coalgebra (->) (Const (Maybe a)) (Maybe a)
project = Coalgebra (->) (Const (Maybe a)) (Maybe a)
forall a. Coalgebra (->) (Const a) a
constProject

instance Steppable (->) (Maybe a) (Const (Maybe a)) where
  embed :: Algebra (->) (Const (Maybe a)) (Maybe a)
embed = Algebra (->) (Const (Maybe a)) (Maybe a)
forall a. Algebra (->) (Const a) a
constEmbed

instance Recursive (->) (Maybe a) (Const (Maybe a)) where
  cata :: Algebra (->) (Const (Maybe a)) a -> Maybe a -> a
cata = Algebra (->) (Const (Maybe a)) a -> Maybe a -> a
forall b a. Algebra (->) (Const b) a -> b -> a
constCata

instance Corecursive (->) (Maybe a) (Const (Maybe a)) where
  ana :: Coalgebra (->) (Const (Maybe a)) a -> a -> Maybe a
ana = Coalgebra (->) (Const (Maybe a)) a -> a -> Maybe a
forall b a. Coalgebra (->) (Const b) a -> a -> b
constAna

-- * Optics

type BialgebraIso f a = Iso' (f a) a

type AlgebraPrism f a = Prism' (f a) a

type CoalgebraPrism f a = Prism' a (f a)

steppableIso :: Steppable (->) t f => BialgebraIso f t
steppableIso :: BialgebraIso f t
steppableIso = (f t -> t) -> (t -> f t) -> BialgebraIso f t
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso f t -> t
forall k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Steppable c t f =>
Algebra c f t
embed t -> f t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Projectable c t f =>
Coalgebra c f t
project

birecursiveIso ::
  (Recursive (->) t f, Corecursive (->) t f) =>
  BialgebraIso f a ->
  Iso' t a
birecursiveIso :: BialgebraIso f a -> Iso' t a
birecursiveIso BialgebraIso f a
alg = (t -> a) -> (a -> t) -> Iso' t a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (Algebra (->) f a -> t -> a
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata (Getting a (f a) a -> Algebra (->) f a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting a (f a) a
BialgebraIso f a
alg)) (Coalgebra (->) f a -> a -> t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana (AReview (f a) a -> Coalgebra (->) f a
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview (f a) a
BialgebraIso f a
alg))

recursivePrism ::
  (Recursive (->) t f, Corecursive (->) t f, Traversable f) =>
  AlgebraPrism f a ->
  Prism' t a
recursivePrism :: AlgebraPrism f a -> Prism' t a
recursivePrism AlgebraPrism f a
alg =
  (a -> t) -> (t -> Either t a) -> Prism' t a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    (Coalgebra (->) f a -> a -> t
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana (AReview (f a) a -> Coalgebra (->) f a
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview (f a) a
AlgebraPrism f a
alg))
    (\t
t -> (f a -> t) -> Either (f a) a -> Either t a
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (t -> f a -> t
forall a b. a -> b -> a
const t
t) (Either (f a) a -> Either t a) -> Either (f a) a -> Either t a
forall a b. (a -> b) -> a -> b
$ Algebra (->) f (Either (f a) a) -> t -> Either (f a) a
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (a :: k).
Recursive c t f =>
Algebra c f a -> c t a
cata (APrism (f a) (f a) a a -> f a -> Either (f a) a
forall s t a b. APrism s t a b -> s -> Either t a
matching APrism (f a) (f a) a a
AlgebraPrism f a
alg (f a -> Either (f a) a)
-> (f (Either (f a) a) -> Either (f a) (f a))
-> Algebra (->) f (Either (f a) a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< f (Either (f a) a) -> Either (f a) (f a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA) t
t)