{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Uses of recursion schemes that use Haskell’s built-in recursion in a total
--   manner.
module Yaya.Fold.Native
  ( module Yaya.Fold.Native.Internal,
    Fix (Fix, unFix),
    distCofreeT,
  )
where

import "base" Control.Category (Category ((.)))
import "base" Data.Bifunctor (Bifunctor (bimap))
import "base" Data.Eq (Eq ((==)))
import "base" Data.Foldable (Foldable (toList))
import "base" Data.Function (($))
import "base" Data.Functor (Functor (fmap))
import "base" Data.Functor.Classes (Eq1, Ord1, Read1, Show1)
import "base" Data.List.NonEmpty (NonEmpty ((:|)))
import "base" Data.Ord (Ord (compare))
import "base" Numeric.Natural (Natural)
import "base" Text.Read (Read (readListPrec, readPrec), readListPrecDefault)
import "base" Text.Show (Show (showsPrec))
import "comonad" Control.Comonad (Comonad (extract))
import "comonad" Control.Comonad.Trans.Env (EnvT (EnvT), runEnvT)
import "free" Control.Comonad.Cofree (Cofree ((:<)), unwrap)
import "free" Control.Monad.Trans.Free (Free, FreeF (Free, Pure), free)
import "strict" Data.Strict.Classes (Strict (toStrict))
import "this" Yaya.Fold
  ( Corecursive (ana),
    DistributiveLaw,
    Projectable (project),
    Recursive (cata),
    Steppable (embed),
    recursiveCompare,
    recursiveEq,
    recursiveShowsPrec,
    steppableReadPrec,
  )
import "this" Yaya.Fold.Common (diagonal)
import "this" Yaya.Fold.Native.Internal (Cofix (unCofix))
import "this" Yaya.Pattern
  ( AndMaybe (Indeed, Only),
    Maybe,
    XNor (Both, Neither),
    uncurry,
  )

-- | A fixed-point constructor that uses Haskell's built-in recursion. This is
--   strict/recursive.
newtype Fix f = Fix {forall (f :: * -> *). Fix f -> f (Fix f)
unFix :: f (Fix f)}

instance Projectable (->) (Fix f) f where
  project :: Coalgebra (->) f (Fix f)
project = Coalgebra (->) f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

instance Steppable (->) (Fix f) f where
  embed :: Algebra (->) f (Fix f)
embed = Algebra (->) f (Fix f)
forall (f :: * -> *). Algebra (->) f (Fix f)
Fix

instance (Functor f) => Recursive (->) (Fix f) f where
  cata :: forall a. Algebra (->) f a -> Fix f -> a
cata Algebra (->) f a
ɸ = Algebra (->) f a
ɸ Algebra (->) f a -> (Fix f -> f a) -> Fix f -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Fix f -> a) -> f (Fix f) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Algebra (->) f a -> Fix f -> a
forall a. Algebra (->) f a -> Fix f -> a
forall {k} {k1} (c :: k -> k1 -> *) (t :: k) (f :: k1 -> k)
       (a :: k1).
Recursive c t f =>
Algebra c f a -> c t a
cata Algebra (->) f a
ɸ) (f (Fix f) -> f a) -> (Fix f -> f (Fix f)) -> Fix f -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Fix f -> f (Fix f)
forall {k} {k1} (c :: k -> k1 -> *) (t :: k) (f :: k -> k1).
Projectable c t f =>
Coalgebra c f t
project

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

-- | @since 0.6.1.0
instance (Functor f, Foldable f, Ord1 f) => Ord (Fix f) where
  compare :: Fix f -> Fix f -> Ordering
compare = Fix f -> Fix f -> Ordering
forall t (f :: * -> *) u.
(Recursive (->) t f, Steppable (->) u f, Functor f, Foldable f,
 Ord1 f) =>
t -> u -> Ordering
recursiveCompare

-- | @since 0.6.1.0
instance (Read1 f) => Read (Fix f) where
  readPrec :: ReadPrec (Fix f)
readPrec = ReadPrec (Fix f)
forall t (f :: * -> *). (Steppable (->) t f, Read1 f) => ReadPrec t
steppableReadPrec
  readListPrec :: ReadPrec [Fix f]
readListPrec = ReadPrec [Fix f]
forall a. Read a => ReadPrec [a]
readListPrecDefault

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

instance Recursive (->) Natural Maybe where
  cata :: forall a. Algebra (->) Maybe a -> Natural -> a
cata Algebra (->) Maybe a
ɸ = Algebra (->) Maybe a
ɸ Algebra (->) Maybe a -> (Natural -> Maybe a) -> Natural -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Natural -> a) -> Maybe Natural -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Algebra (->) Maybe a -> Natural -> a
forall a. Algebra (->) Maybe a -> Natural -> a
forall {k} {k1} (c :: k -> k1 -> *) (t :: k) (f :: k1 -> k)
       (a :: k1).
Recursive c t f =>
Algebra c f a -> c t a
cata Algebra (->) Maybe a
ɸ) (Maybe Natural -> Maybe a)
-> (Natural -> Maybe Natural) -> Natural -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Natural -> Maybe Natural
forall {k} {k1} (c :: k -> k1 -> *) (t :: k) (f :: k -> k1).
Projectable c t f =>
Coalgebra c f t
project

instance Corecursive (->) [a] (XNor a) where
  ana :: forall a. Coalgebra (->) (XNor a) a -> a -> [a]
ana Coalgebra (->) (XNor a) a
ψ =
    ( \case
        XNor a a
Neither -> []
        Both a
h a
t -> a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Coalgebra (->) (XNor a) a -> a -> [a]
forall a. Coalgebra (->) (XNor a) a -> a -> [a]
forall {k} {k1} (c :: k -> k1 -> *) (t :: k1) (f :: k -> k1)
       (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana Coalgebra (->) (XNor a) a
ψ a
t
    )
      (XNor a a -> [a]) -> Coalgebra (->) (XNor a) a -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coalgebra (->) (XNor a) a
ψ

instance Corecursive (->) (NonEmpty a) (AndMaybe a) where
  ana :: forall a. Coalgebra (->) (AndMaybe a) a -> a -> NonEmpty a
ana Coalgebra (->) (AndMaybe a) a
ψ =
    ( \case
        Only a
h -> a
h a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []
        Indeed a
h a
t -> a
h a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| forall (t :: * -> *) a. Foldable t => t a -> [a]
toList @NonEmpty (Coalgebra (->) (AndMaybe a) a -> a -> NonEmpty a
forall a. Coalgebra (->) (AndMaybe a) a -> a -> NonEmpty a
forall {k} {k1} (c :: k -> k1 -> *) (t :: k1) (f :: k -> k1)
       (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana Coalgebra (->) (AndMaybe a) a
ψ a
t)
    )
      (AndMaybe a a -> NonEmpty a)
-> Coalgebra (->) (AndMaybe a) a -> a -> NonEmpty a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coalgebra (->) (AndMaybe a) a
ψ

instance (Functor f) => Corecursive (->) (Free f a) (FreeF f a) where
  ana :: forall a. Coalgebra (->) (FreeF f a) a -> a -> Free f a
ana Coalgebra (->) (FreeF f a) a
ψ =
    FreeF f a (Free f a) -> Free f a
forall (f :: * -> *) a. FreeF f a (Free f a) -> Free f a
free
      (FreeF f a (Free f a) -> Free f a)
-> (a -> FreeF f a (Free f a)) -> a -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ( \case
            Pure a
a -> a -> FreeF f a (Free f a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a
            Free f a
fb -> f (Free f a) -> FreeF f a (Free f a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (Free f a) -> FreeF f a (Free f a))
-> (f a -> f (Free f a)) -> f a -> FreeF f a (Free f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> Free f a) -> f a -> f (Free f a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coalgebra (->) (FreeF f a) a -> a -> Free f a
forall a. Coalgebra (->) (FreeF f a) a -> a -> Free f a
forall {k} {k1} (c :: k -> k1 -> *) (t :: k1) (f :: k -> k1)
       (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana Coalgebra (->) (FreeF f a) a
ψ) (f a -> FreeF f a (Free f a)) -> f a -> FreeF f a (Free f a)
forall a b. (a -> b) -> a -> b
$ f a
fb
        )
      (FreeF f a a -> FreeF f a (Free f a))
-> Coalgebra (->) (FreeF f a) a -> a -> FreeF f a (Free f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coalgebra (->) (FreeF f a) a
ψ

instance (Functor f) => Corecursive (->) (Cofree f a) (EnvT a f) where
  ana :: forall a. Coalgebra (->) (EnvT a f) a -> a -> Cofree f a
ana Coalgebra (->) (EnvT a f) a
ψ = (a -> f (Cofree f a) -> Cofree f a)
-> Pair a (f (Cofree f a)) -> Cofree f a
forall a b c. (a -> b -> c) -> Pair a b -> c
uncurry a -> f (Cofree f a) -> Cofree f a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
(:<) (Pair a (f (Cofree f a)) -> Cofree f a)
-> (a -> Pair a (f (Cofree f a))) -> a -> Cofree f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (f a -> f (Cofree f a)) -> Pair a (f a) -> Pair a (f (Cofree f a))
forall a b. (a -> b) -> Pair a a -> Pair a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Cofree f a) -> f a -> f (Cofree f a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coalgebra (->) (EnvT a f) a -> a -> Cofree f a
forall a. Coalgebra (->) (EnvT a f) a -> a -> Cofree f a
forall {k} {k1} (c :: k -> k1 -> *) (t :: k1) (f :: k -> k1)
       (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana Coalgebra (->) (EnvT a f) a
ψ)) (Pair a (f a) -> Pair a (f (Cofree f a)))
-> (a -> Pair a (f a)) -> a -> Pair a (f (Cofree f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a, f a) -> Pair a (f a)
forall lazy strict. Strict lazy strict => lazy -> strict
toStrict ((a, f a) -> Pair a (f a)) -> (a -> (a, f a)) -> a -> Pair a (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EnvT a f a -> (a, f a)
forall e (w :: * -> *) a. EnvT e w a -> (e, w a)
runEnvT (EnvT a f a -> (a, f a))
-> Coalgebra (->) (EnvT a f) a -> a -> (a, f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coalgebra (->) (EnvT a f) a
ψ

distCofreeT ::
  (Functor f, Functor h) =>
  DistributiveLaw (->) f h ->
  DistributiveLaw (->) f (Cofree h)
distCofreeT :: forall (f :: * -> *) (h :: * -> *).
(Functor f, Functor h) =>
DistributiveLaw (->) f h -> DistributiveLaw (->) f (Cofree h)
distCofreeT DistributiveLaw (->) f h
k =
  Coalgebra (->) (EnvT (f a) h) (f (Cofree h a))
-> f (Cofree h a) -> Cofree h (f a)
forall a. Coalgebra (->) (EnvT (f a) h) a -> a -> Cofree h (f a)
forall {k} {k1} (c :: k -> k1 -> *) (t :: k1) (f :: k -> k1)
       (a :: k).
Corecursive c t f =>
Coalgebra c f a -> c a t
ana (Coalgebra (->) (EnvT (f a) h) (f (Cofree h a))
 -> f (Cofree h a) -> Cofree h (f a))
-> Coalgebra (->) (EnvT (f a) h) (f (Cofree h a))
-> f (Cofree h a)
-> Cofree h (f a)
forall a b. (a -> b) -> a -> b
$ (f a -> h (f (Cofree h a)) -> EnvT (f a) h (f (Cofree h a)))
-> Pair (f a) (h (f (Cofree h a))) -> EnvT (f a) h (f (Cofree h a))
forall a b c. (a -> b -> c) -> Pair a b -> c
uncurry f a -> h (f (Cofree h a)) -> EnvT (f a) h (f (Cofree h a))
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT (Pair (f a) (h (f (Cofree h a))) -> EnvT (f a) h (f (Cofree h a)))
-> (f (Cofree h a) -> Pair (f a) (h (f (Cofree h a))))
-> Coalgebra (->) (EnvT (f a) h) (f (Cofree h a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (f (Cofree h a) -> f a)
-> (f (Cofree h a) -> h (f (Cofree h a)))
-> Pair (f (Cofree h a)) (f (Cofree h a))
-> Pair (f a) (h (f (Cofree h a)))
forall a b c d. (a -> b) -> (c -> d) -> Pair a c -> Pair b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Cofree h a -> a) -> f (Cofree h a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cofree h a -> a
forall a. Cofree h a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract) (f (h (Cofree h a)) -> h (f (Cofree h a))
DistributiveLaw (->) f h
k (f (h (Cofree h a)) -> h (f (Cofree h a)))
-> (f (Cofree h a) -> f (h (Cofree h a)))
-> f (Cofree h a)
-> h (f (Cofree h a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Cofree h a -> h (Cofree h a))
-> f (Cofree h a) -> f (h (Cofree h a))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cofree h a -> h (Cofree h a)
forall a. Cofree h a -> h (Cofree h a)
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap) (Pair (f (Cofree h a)) (f (Cofree h a))
 -> Pair (f a) (h (f (Cofree h a))))
-> (f (Cofree h a) -> Pair (f (Cofree h a)) (f (Cofree h a)))
-> f (Cofree h a)
-> Pair (f a) (h (f (Cofree h a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f (Cofree h a) -> Pair (f (Cofree h a)) (f (Cofree h a))
forall a. a -> Pair a a
diagonal