{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}

-- | Functor and recursion schemes
--
-- Simple API is intended to be easier to understand (e.g. they don't use
-- xxmorphism and xxxalgebra jargon but tree-traversal-like terms).
module Haskus.Utils.Functor
   ( -- * Simple API
     BottomUpT
   , bottomUp
   , BottomUpOrigT
   , bottomUpOrig
   , TopDownStopT
   , topDownStop
   -- * Recursion schemes
   , module Data.Functor.Classes
   , module Data.Functor.Foldable
   , Algebra
   , CoAlgebra
   , RAlgebra
   , RCoAlgebra
   -- * Higher-order recursion schemes
   , type (~>)
   , type NatM
   , HBase
   , HAlgebra
   , HAlgebraM
   , HGAlgebra
   , HGAlgebraM
   , HCoalgebra
   , HCoalgebraM
   , HGCoalgebra
   , HGCoalgebraM
   , HFunctor (..)
   , HFoldable (..)
   , HTraversable (..)
   , HRecursive (..)
   , HCorecursive (..)
   , hhylo
   , hcataM
   , hlambek
   , hpara
   , hparaM
   , hanaM
   , hcolambek
   , hapo
   , hapoM
   , hhyloM
   )
where

import Data.Functor.Foldable hiding (ListF(..))
import Data.Functor.Classes
import Data.Functor.Sum
import Data.Functor.Product
import Control.Monad
import Control.Applicative

import Haskus.Utils.Types (Type)

-------------------------------------------
-- Simple API
-------------------------------------------

type BottomUpT       a f = f a -> a
type BottomUpOrigT t a f = f (t,a) -> a
type TopDownStopT    a f = f a -> Either (f a) a

-- | Bottom-up traversal (catamorphism)
bottomUp :: (Recursive t) => (Base t a -> a) -> t -> a
bottomUp :: (Base t a -> a) -> t -> a
bottomUp Base t a -> a
f t
t = (Base t a -> a) -> t -> a
forall t a. Recursive t => (Base t a -> a) -> t -> a
cata Base t a -> a
f t
t

-- | Bottom-up traversal with original value (paramorphism)
bottomUpOrig :: (Recursive t) => (Base t (t,a) -> a) -> t -> a
bottomUpOrig :: (Base t (t, a) -> a) -> t -> a
bottomUpOrig Base t (t, a) -> a
f t
t = (Base t (t, a) -> a) -> t -> a
forall t a. Recursive t => (Base t (t, a) -> a) -> t -> a
para Base t (t, a) -> a
f t
t

-- | Perform a top-down traversal
--
-- Right: stop the traversal ("right" value obtained)
-- Left: continue the traversal recursively on the new value
topDownStop :: (Recursive t, Corecursive t) => (Base t t -> Either (Base t t) t) -> t -> t
topDownStop :: (Base t t -> Either (Base t t) t) -> t -> t
topDownStop Base t t -> Either (Base t t) t
f t
t = t -> t
go t
t
   where
      go :: t -> t
go t
w = case Base t t -> Either (Base t t) t
f (t -> Base t t
forall t. Recursive t => t -> Base t t
project t
w) of
         Right t
x -> t
x                 -- stop here
         Left  Base t t
x -> Base t t -> t
forall t. Corecursive t => Base t t -> t
embed ((t -> t) -> Base t t -> Base t t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> t
go Base t t
x) -- continue recursively


-------------------------------------------
-- Recursion schemes
-------------------------------------------

type Algebra    f a   = f a -> a
type CoAlgebra  f a   = a -> f a
type RAlgebra   f t a = f (t, a) -> a
type RCoAlgebra f t a = a -> f (Either t a)


-------------------------------------------
-- Higher-order
-------------------------------------------


type f ~> g = forall a. f a -> g a
type NatM m f g = forall a. f a -> m (g a)

type family HBase (h :: k -> Type) :: (k -> Type) -> (k -> Type)

type HAlgebra h f = h f ~> f
type HAlgebraM m h f = NatM m (h f) f
type HGAlgebra w h a = h (w a) ~> a
type HGAlgebraM w m h a = NatM m (h (w a)) a

type HCoalgebra h f = f ~> h f
type HCoalgebraM m h f = NatM m f (h f)
type HGCoalgebra m h a = a ~> h (m a)
type HGCoalgebraM n m h a = NatM m a (h (n a))

class HFunctor (h :: (k -> Type) -> (k -> Type)) where
  hfmap :: (f ~> g) -> h f ~> h g

class HFunctor h => HFoldable (h :: (k -> Type) -> (k -> Type)) where
  hfoldMap :: Monoid m => (forall b. f b -> m) -> h f a -> m

class HFoldable h => HTraversable (h :: (k -> Type) -> (k -> Type))  where
  htraverse :: Applicative e => NatM e f g -> NatM e (h f) (h g)

class HFunctor (HBase h) => HRecursive (h :: k -> Type) where
  hproject :: HCoalgebra (HBase h) h

  hcata :: HAlgebra (HBase h) f -> h ~> f
  hcata HAlgebra (HBase h) f
algebra = HBase h f a -> f a
HAlgebra (HBase h) f
algebra (HBase h f a -> f a) -> (h a -> HBase h f a) -> h a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h ~> f) -> HBase h h ~> HBase h f
forall k (h :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor h =>
(f ~> g) -> h f ~> h g
hfmap (HAlgebra (HBase h) f -> h ~> f
forall k (h :: k -> *) (f :: k -> *).
HRecursive h =>
HAlgebra (HBase h) f -> h ~> f
hcata HAlgebra (HBase h) f
algebra) (HBase h h a -> HBase h f a)
-> (h a -> HBase h h a) -> h a -> HBase h f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h a -> HBase h h a
forall k (h :: k -> *). HRecursive h => HCoalgebra (HBase h) h
hproject

class HFunctor (HBase h) => HCorecursive (h :: k -> Type) where
  hembed :: HAlgebra (HBase h) h

  hana :: HCoalgebra (HBase h) f -> f ~> h
  hana HCoalgebra (HBase h) f
coalgebra = HBase h h a -> h a
forall k (h :: k -> *). HCorecursive h => HAlgebra (HBase h) h
hembed (HBase h h a -> h a) -> (f a -> HBase h h a) -> f a -> h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ~> h) -> HBase h f ~> HBase h h
forall k (h :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor h =>
(f ~> g) -> h f ~> h g
hfmap (HCoalgebra (HBase h) f -> f ~> h
forall k (h :: k -> *) (f :: k -> *).
HCorecursive h =>
HCoalgebra (HBase h) f -> f ~> h
hana HCoalgebra (HBase h) f
coalgebra) (HBase h f a -> HBase h h a)
-> (f a -> HBase h f a) -> f a -> HBase h h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> HBase h f a
HCoalgebra (HBase h) f
coalgebra

hhylo :: HFunctor f => HAlgebra f b -> HCoalgebra f a -> a ~> b
hhylo :: HAlgebra f b -> HCoalgebra f a -> a ~> b
hhylo HAlgebra f b
f HCoalgebra f a
g = f b a -> b a
HAlgebra f b
f (f b a -> b a) -> (a a -> f b a) -> a a -> b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a ~> b) -> f a ~> f b
forall k (h :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor h =>
(f ~> g) -> h f ~> h g
hfmap (HAlgebra f b -> HCoalgebra f a -> a ~> b
forall k (f :: (k -> *) -> k -> *) (b :: k -> *) (a :: k -> *).
HFunctor f =>
HAlgebra f b -> HCoalgebra f a -> a ~> b
hhylo HAlgebra f b
f HCoalgebra f a
g) (f a a -> f b a) -> (a a -> f a a) -> a a -> f b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a a -> f a a
HCoalgebra f a
g

hcataM :: (Monad m, HTraversable (HBase h), HRecursive h) => HAlgebraM m (HBase h) f -> h a -> m (f a)
hcataM :: HAlgebraM m (HBase h) f -> h a -> m (f a)
hcataM HAlgebraM m (HBase h) f
f = HBase h f a -> m (f a)
HAlgebraM m (HBase h) f
f (HBase h f a -> m (f a))
-> (h a -> m (HBase h f a)) -> h a -> m (f a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< NatM m h f -> NatM m (HBase h h) (HBase h f)
forall k (h :: (k -> *) -> k -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(HTraversable h, Applicative e) =>
NatM e f g -> NatM e (h f) (h g)
htraverse (HAlgebraM m (HBase h) f -> h a -> m (f a)
forall k (m :: * -> *) (h :: k -> *) (f :: k -> *) (a :: k).
(Monad m, HTraversable (HBase h), HRecursive h) =>
HAlgebraM m (HBase h) f -> h a -> m (f a)
hcataM HAlgebraM m (HBase h) f
f) (HBase h h a -> m (HBase h f a))
-> (h a -> HBase h h a) -> h a -> m (HBase h f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h a -> HBase h h a
forall k (h :: k -> *). HRecursive h => HCoalgebra (HBase h) h
hproject

hlambek :: (HRecursive h, HCorecursive h) => HCoalgebra (HBase h) h
hlambek :: HCoalgebra (HBase h) h
hlambek = HAlgebra (HBase h) (HBase h h) -> HCoalgebra (HBase h) h
forall k (h :: k -> *) (f :: k -> *).
HRecursive h =>
HAlgebra (HBase h) f -> h ~> f
hcata ((HBase h h ~> h) -> HAlgebra (HBase h) (HBase h h)
forall k (h :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor h =>
(f ~> g) -> h f ~> h g
hfmap HBase h h ~> h
forall k (h :: k -> *). HCorecursive h => HAlgebra (HBase h) h
hembed)

hpara :: (HFunctor (HBase h), HRecursive h) => HGAlgebra (Product h) (HBase h) a -> h ~> a
hpara :: HGAlgebra (Product h) (HBase h) a -> h ~> a
hpara HGAlgebra (Product h) (HBase h) a
phi = HBase h (Product h a) a -> a a
HGAlgebra (Product h) (HBase h) a
phi (HBase h (Product h a) a -> a a)
-> (h a -> HBase h (Product h a) a) -> h a -> a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h ~> Product h a) -> HBase h h ~> HBase h (Product h a)
forall k (h :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor h =>
(f ~> g) -> h f ~> h g
hfmap (\h a
a -> h a -> a a -> Product h a a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair h a
a (HGAlgebra (Product h) (HBase h) a -> h a -> a a
forall k (h :: k -> *) (a :: k -> *).
(HFunctor (HBase h), HRecursive h) =>
HGAlgebra (Product h) (HBase h) a -> h ~> a
hpara HGAlgebra (Product h) (HBase h) a
phi h a
a)) (HBase h h a -> HBase h (Product h a) a)
-> (h a -> HBase h h a) -> h a -> HBase h (Product h a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h a -> HBase h h a
forall k (h :: k -> *). HRecursive h => HCoalgebra (HBase h) h
hproject

hparaM :: (HTraversable (HBase h), HRecursive h, Monad m) => HGAlgebraM (Product h) m (HBase h) a -> NatM m h a
hparaM :: HGAlgebraM (Product h) m (HBase h) a -> NatM m h a
hparaM HGAlgebraM (Product h) m (HBase h) a
phiM = HBase h (Product h a) a -> m (a a)
HGAlgebraM (Product h) m (HBase h) a
phiM (HBase h (Product h a) a -> m (a a))
-> (h a -> m (HBase h (Product h a) a)) -> h a -> m (a a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< NatM m h (Product h a)
-> NatM m (HBase h h) (HBase h (Product h a))
forall k (h :: (k -> *) -> k -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(HTraversable h, Applicative e) =>
NatM e f g -> NatM e (h f) (h g)
htraverse (\h a
a -> (h a -> a a -> Product h a a)
-> m (h a) -> m (a a) -> m (Product h a a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 h a -> a a -> Product h a a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (h a -> m (h a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure h a
a) (HGAlgebraM (Product h) m (HBase h) a -> h a -> m (a a)
forall k (h :: k -> *) (m :: * -> *) (a :: k -> *).
(HTraversable (HBase h), HRecursive h, Monad m) =>
HGAlgebraM (Product h) m (HBase h) a -> NatM m h a
hparaM HGAlgebraM (Product h) m (HBase h) a
phiM h a
a)) (HBase h h a -> m (HBase h (Product h a) a))
-> (h a -> HBase h h a) -> h a -> m (HBase h (Product h a) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h a -> HBase h h a
forall k (h :: k -> *). HRecursive h => HCoalgebra (HBase h) h
hproject

hanaM :: (Monad m, HTraversable (HBase h), HCorecursive h) => HCoalgebraM m (HBase h) f -> f a -> m (h a)
hanaM :: HCoalgebraM m (HBase h) f -> f a -> m (h a)
hanaM HCoalgebraM m (HBase h) f
f = (HBase h h a -> h a) -> m (HBase h h a) -> m (h a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HBase h h a -> h a
forall k (h :: k -> *). HCorecursive h => HAlgebra (HBase h) h
hembed (m (HBase h h a) -> m (h a))
-> (HBase h f a -> m (HBase h h a)) -> HBase h f a -> m (h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NatM m f h -> NatM m (HBase h f) (HBase h h)
forall k (h :: (k -> *) -> k -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(HTraversable h, Applicative e) =>
NatM e f g -> NatM e (h f) (h g)
htraverse (HCoalgebraM m (HBase h) f -> f a -> m (h a)
forall k (m :: * -> *) (h :: k -> *) (f :: k -> *) (a :: k).
(Monad m, HTraversable (HBase h), HCorecursive h) =>
HCoalgebraM m (HBase h) f -> f a -> m (h a)
hanaM HCoalgebraM m (HBase h) f
f) (HBase h f a -> m (h a))
-> (f a -> m (HBase h f a)) -> f a -> m (h a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< f a -> m (HBase h f a)
HCoalgebraM m (HBase h) f
f

hcolambek :: HRecursive h => HCorecursive h => HAlgebra (HBase h) h
hcolambek :: HAlgebra (HBase h) h
hcolambek = HCoalgebra (HBase h) (HBase h h) -> HAlgebra (HBase h) h
forall k (h :: k -> *) (f :: k -> *).
HCorecursive h =>
HCoalgebra (HBase h) f -> f ~> h
hana ((h ~> HBase h h) -> HCoalgebra (HBase h) (HBase h h)
forall k (h :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor h =>
(f ~> g) -> h f ~> h g
hfmap h ~> HBase h h
forall k (h :: k -> *). HRecursive h => HCoalgebra (HBase h) h
hproject)

hapo :: HCorecursive h => HGCoalgebra (Sum h) (HBase h) a -> a ~> h
hapo :: HGCoalgebra (Sum h) (HBase h) a -> a ~> h
hapo HGCoalgebra (Sum h) (HBase h) a
psi = HBase h h a -> h a
forall k (h :: k -> *). HCorecursive h => HAlgebra (HBase h) h
hembed (HBase h h a -> h a) -> (a a -> HBase h h a) -> a a -> h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sum h a ~> h) -> HBase h (Sum h a) ~> HBase h h
forall k (h :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor h =>
(f ~> g) -> h f ~> h g
hfmap ((h a -> h a) -> (a a -> h a) -> Sum h a a -> h a
forall k (f :: k -> *) (a :: k) p (g :: k -> *).
(f a -> p) -> (g a -> p) -> Sum f g a -> p
coproduct h a -> h a
forall a. a -> a
id (HGCoalgebra (Sum h) (HBase h) a -> a ~> h
forall k (h :: k -> *) (a :: k -> *).
HCorecursive h =>
HGCoalgebra (Sum h) (HBase h) a -> a ~> h
hapo HGCoalgebra (Sum h) (HBase h) a
psi)) (HBase h (Sum h a) a -> HBase h h a)
-> (a a -> HBase h (Sum h a) a) -> a a -> HBase h h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a a -> HBase h (Sum h a) a
HGCoalgebra (Sum h) (HBase h) a
psi
  where
    coproduct :: (f a -> p) -> (g a -> p) -> Sum f g a -> p
coproduct f a -> p
f g a -> p
_ (InL f a
a) = f a -> p
f f a
a
    coproduct f a -> p
_ g a -> p
g (InR g a
a) = g a -> p
g g a
a

hapoM :: (HCorecursive h, HTraversable (HBase h), Monad m) => HGCoalgebraM (Sum h) m (HBase h) a -> NatM m a h
hapoM :: HGCoalgebraM (Sum h) m (HBase h) a -> NatM m a h
hapoM HGCoalgebraM (Sum h) m (HBase h) a
psiM = (HBase h h a -> h a) -> m (HBase h h a) -> m (h a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HBase h h a -> h a
forall k (h :: k -> *). HCorecursive h => HAlgebra (HBase h) h
hembed (m (HBase h h a) -> m (h a))
-> (HBase h (Sum h a) a -> m (HBase h h a))
-> HBase h (Sum h a) a
-> m (h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NatM m (Sum h a) h -> NatM m (HBase h (Sum h a)) (HBase h h)
forall k (h :: (k -> *) -> k -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(HTraversable h, Applicative e) =>
NatM e f g -> NatM e (h f) (h g)
htraverse ((h a -> m (h a)) -> (a a -> m (h a)) -> Sum h a a -> m (h a)
forall k (f :: k -> *) (a :: k) p (g :: k -> *).
(f a -> p) -> (g a -> p) -> Sum f g a -> p
coproduct h a -> m (h a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HGCoalgebraM (Sum h) m (HBase h) a -> NatM m a h
forall k (h :: k -> *) (m :: * -> *) (a :: k -> *).
(HCorecursive h, HTraversable (HBase h), Monad m) =>
HGCoalgebraM (Sum h) m (HBase h) a -> NatM m a h
hapoM HGCoalgebraM (Sum h) m (HBase h) a
psiM)) (HBase h (Sum h a) a -> m (h a))
-> (a a -> m (HBase h (Sum h a) a)) -> a a -> m (h a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a a -> m (HBase h (Sum h a) a)
HGCoalgebraM (Sum h) m (HBase h) a
psiM
  where
    coproduct :: (f a -> p) -> (g a -> p) -> Sum f g a -> p
coproduct f a -> p
f g a -> p
_ (InL f a
a) = f a -> p
f f a
a
    coproduct f a -> p
_ g a -> p
g (InR g a
a) = g a -> p
g g a
a

hhyloM :: (HTraversable t, Monad m) => HAlgebraM m t h -> HCoalgebraM m t f -> f a -> m (h a)
hhyloM :: HAlgebraM m t h -> HCoalgebraM m t f -> f a -> m (h a)
hhyloM HAlgebraM m t h
f HCoalgebraM m t f
g = t h a -> m (h a)
HAlgebraM m t h
f (t h a -> m (h a)) -> (f a -> m (t h a)) -> f a -> m (h a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< NatM m f h -> NatM m (t f) (t h)
forall k (h :: (k -> *) -> k -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(HTraversable h, Applicative e) =>
NatM e f g -> NatM e (h f) (h g)
htraverse(HAlgebraM m t h -> HCoalgebraM m t f -> f a -> m (h a)
forall k (t :: (k -> *) -> k -> *) (m :: * -> *) (h :: k -> *)
       (f :: k -> *) (a :: k).
(HTraversable t, Monad m) =>
HAlgebraM m t h -> HCoalgebraM m t f -> f a -> m (h a)
hhyloM HAlgebraM m t h
f HCoalgebraM m t f
g) (t f a -> m (t h a)) -> (f a -> m (t f a)) -> f a -> m (t h a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< f a -> m (t f a)
HCoalgebraM m t f
g