{-# OPTIONS_GHC -Wno-orphans #-}

-- | Uses of recursion schemes that use Haskell’s built-in recursion in a total
--   manner.
module Yaya.Fold.Native where

import Control.Arrow
import Control.Comonad
import Control.Comonad.Cofree
import Control.Comonad.Trans.Env
import Control.Monad.Trans.Free
import Data.List.NonEmpty
import Numeric.Natural
import Yaya.Fold
import Yaya.Pattern

-- | A fixed-point constructor that uses Haskell's built-in recursion. This is
--   lazy/corecursive.
newtype Fix f = Fix {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 :: * -> *). Coalgebra (->) 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 => Corecursive (->) (Fix f) f where
  ana :: Coalgebra (->) f a -> a -> Fix f
ana Coalgebra (->) f a
φ = Algebra (->) f (Fix f)
forall k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Steppable c t f =>
Algebra c f t
embed Algebra (->) f (Fix f) -> (a -> f (Fix f)) -> a -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Fix f) -> f a -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coalgebra (->) f a -> a -> Fix f
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 Coalgebra (->) f a
φ) (f a -> f (Fix f)) -> Coalgebra (->) f a -> a -> f (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coalgebra (->) f a
φ

instance Recursive (->) Natural Maybe where
  cata :: 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
. (Natural -> a) -> Maybe Natural -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Algebra (->) Maybe a -> Natural -> 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 (->) Maybe a
ɸ) (Maybe Natural -> Maybe a)
-> (Natural -> Maybe Natural) -> Natural -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Maybe Natural
forall k k (c :: k -> k -> *) (t :: k) (f :: k -> k).
Projectable c t f =>
Coalgebra c f t
project

instance Corecursive (->) [a] (XNor a) where
  ana :: 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 k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (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
. Coalgebra (->) (XNor a) a
ψ

instance Corecursive (->) (NonEmpty a) (AndMaybe a) where
  ana :: 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
:| NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
toList (Coalgebra (->) (AndMaybe a) a -> a -> NonEmpty a
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 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
. Coalgebra (->) (AndMaybe a) a
ψ

instance Functor f => Corecursive (->) (Free f a) (FreeF f a) where
  ana :: 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
. ( \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
. (a -> Free f a) -> f a -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coalgebra (->) (FreeF f a) a -> a -> Free f a
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 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
. Coalgebra (->) (FreeF f a) a
ψ

instance Functor f => Corecursive (->) (Cofree f a) (EnvT a f) where
  ana :: Coalgebra (->) (EnvT a f) a -> a -> Cofree f a
ana Coalgebra (->) (EnvT a f) a
ψ = (a -> f (Cofree f a) -> Cofree f a)
-> (a, f (Cofree f a)) -> Cofree f a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> f (Cofree f a) -> Cofree f a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
(:<) ((a, f (Cofree f a)) -> Cofree f a)
-> (a -> (a, f (Cofree f a))) -> a -> Cofree f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> f (Cofree f a)) -> (a, f a) -> (a, f (Cofree f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Cofree f a) -> f a -> f (Cofree f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coalgebra (->) (EnvT a f) a -> a -> Cofree f a
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 Coalgebra (->) (EnvT a f) a
ψ)) ((a, f a) -> (a, f (Cofree f a)))
-> (a -> (a, f a)) -> a -> (a, f (Cofree f a))
forall b c a. (b -> c) -> (a -> b) -> 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
. Coalgebra (->) (EnvT a f) a
ψ

distCofreeT ::
  (Functor f, Functor h) =>
  DistributiveLaw (->) f h ->
  DistributiveLaw (->) f (Cofree h)
distCofreeT :: 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 k k (c :: k -> k -> *) (t :: k) (f :: k -> k) (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)))
-> (f a, h (f (Cofree h a))) -> EnvT (f a) h (f (Cofree h a))
forall a b c. (a -> b -> c) -> (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 ((f a, h (f (Cofree h a))) -> EnvT (f a) h (f (Cofree h a)))
-> (f (Cofree h a) -> (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
. ((Cofree h a -> a) -> f (Cofree h a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cofree h a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract (f (Cofree h a) -> f a)
-> (f (Cofree h a) -> h (f (Cofree h a)))
-> f (Cofree h a)
-> (f a, h (f (Cofree h a)))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& 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
. (Cofree h a -> h (Cofree h a))
-> f (Cofree h a) -> f (h (Cofree h a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cofree h a -> h (Cofree h a)
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap)