{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

-- | Various utility functions on 'FreeT'
module Control.Monad.Trans.Free.Extra where

import Control.Arrow ((>>>))
import Control.Monad.Trans.Free
import FFunctor (type (~>))

ffmapFreeF :: forall f g a. (f ~> g) -> FreeF f a ~> FreeF g a
ffmapFreeF :: forall (f :: * -> *) (g :: * -> *) a.
(f ~> g) -> FreeF f a ~> FreeF g a
ffmapFreeF f ~> g
_ (Pure a
a) = a -> FreeF g a x
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a
ffmapFreeF f ~> g
fg (Free f x
fb) = g x -> FreeF g a x
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f x -> g x
f ~> g
fg f x
fb)

transFreeT_ :: forall f g m. (Functor g, Functor m) => (f ~> g) -> FreeT f m ~> FreeT g m
transFreeT_ :: forall (f :: * -> *) (g :: * -> *) (m :: * -> *).
(Functor g, Functor m) =>
(f ~> g) -> FreeT f m ~> FreeT g m
transFreeT_ f ~> g
fg =
  let go :: FreeT f m a -> FreeT g m a
go = m (FreeF g a (FreeT g m a)) -> FreeT g m a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF g a (FreeT g m a)) -> FreeT g m a)
-> (FreeT f m a -> m (FreeF g a (FreeT g m a)))
-> FreeT f m a
-> FreeT g m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeF f a (FreeT f m a) -> FreeF g a (FreeT g m a))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF g a (FreeT g m a))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FreeT f m a -> FreeT g m a)
-> FreeF g a (FreeT f m a) -> FreeF g a (FreeT g m a)
forall a b. (a -> b) -> FreeF g a a -> FreeF g a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeT f m a -> FreeT g m a
go (FreeF g a (FreeT f m a) -> FreeF g a (FreeT g m a))
-> (FreeF f a (FreeT f m a) -> FreeF g a (FreeT f m a))
-> FreeF f a (FreeT f m a)
-> FreeF g a (FreeT g m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ~> g) -> FreeF f a ~> FreeF g a
forall (f :: * -> *) (g :: * -> *) a.
(f ~> g) -> FreeF f a ~> FreeF g a
ffmapFreeF f x -> g x
f ~> g
fg) (m (FreeF f a (FreeT f m a)) -> m (FreeF g a (FreeT g m a)))
-> (FreeT f m a -> m (FreeF f a (FreeT f m a)))
-> FreeT f m a
-> m (FreeF g a (FreeT g m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m a -> m (FreeF f a (FreeT f m a))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT in FreeT f m x -> FreeT g m x
forall {a}. FreeT f m a -> FreeT g m a
go

traverseFreeT_ ::
  (Traversable f, Traversable m, Applicative g) =>
  (a -> g b) ->
  FreeT f m a ->
  g (FreeT f m b)
traverseFreeT_ :: forall (f :: * -> *) (m :: * -> *) (g :: * -> *) a b.
(Traversable f, Traversable m, Applicative g) =>
(a -> g b) -> FreeT f m a -> g (FreeT f m b)
traverseFreeT_ a -> g b
f = FreeT f m a -> g (FreeT f m b)
forall {m :: * -> *} {f :: * -> *}.
(Traversable m, Traversable f) =>
FreeT f m a -> g (FreeT f m b)
go
  where
    go :: FreeT f m a -> g (FreeT f m b)
go (FreeT m (FreeF f a (FreeT f m a))
x) = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> g (m (FreeF f b (FreeT f m b))) -> g (FreeT f m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FreeF f a (FreeT f m a) -> g (FreeF f b (FreeT f m b)))
-> m (FreeF f a (FreeT f m a)) -> g (m (FreeF f b (FreeT f m b)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> m a -> f (m b)
traverse FreeF f a (FreeT f m a) -> g (FreeF f b (FreeT f m b))
goF m (FreeF f a (FreeT f m a))
x
    goF :: FreeF f a (FreeT f m a) -> g (FreeF f b (FreeT f m b))
goF (Pure a
a) = b -> FreeF f b (FreeT f m b)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (b -> FreeF f b (FreeT f m b))
-> g b -> g (FreeF f b (FreeT f m b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> g b
f a
a
    goF (Free f (FreeT f m a)
fmx) = f (FreeT f m b) -> FreeF f b (FreeT f m b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m b) -> FreeF f b (FreeT f m b))
-> g (f (FreeT f m b)) -> g (FreeF f b (FreeT f m b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FreeT f m a -> g (FreeT f m b))
-> f (FreeT f m a) -> g (f (FreeT f m b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse FreeT f m a -> g (FreeT f m b)
go f (FreeT f m a)
fmx

inr :: Functor m => m ~> FreeT f m
inr :: forall (m :: * -> *) (f :: * -> *). Functor m => m ~> FreeT f m
inr = m (FreeF f x (FreeT f m x)) -> FreeT f m x
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f x (FreeT f m x)) -> FreeT f m x)
-> (m x -> m (FreeF f x (FreeT f m x))) -> m x -> FreeT f m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> FreeF f x (FreeT f m x))
-> m x -> m (FreeF f x (FreeT f m x))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> FreeF f x (FreeT f m x)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure

inl :: (Functor f, Monad m) => f ~> FreeT f m
inl :: forall (f :: * -> *) (m :: * -> *).
(Functor f, Monad m) =>
f ~> FreeT f m
inl = m (FreeF f x (FreeT f m x)) -> FreeT f m x
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f x (FreeT f m x)) -> FreeT f m x)
-> (f x -> m (FreeF f x (FreeT f m x))) -> f x -> FreeT f m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeF f x (FreeT f m x) -> m (FreeF f x (FreeT f m x))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeF f x (FreeT f m x) -> m (FreeF f x (FreeT f m x)))
-> (f x -> FreeF f x (FreeT f m x))
-> f x
-> m (FreeF f x (FreeT f m x))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (FreeT f m x) -> FreeF f x (FreeT f m x)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m x) -> FreeF f x (FreeT f m x))
-> (f x -> f (FreeT f m x)) -> f x -> FreeF f x (FreeT f m x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> FreeT f m x) -> f x -> f (FreeT f m x)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> FreeT f m x
forall a. a -> FreeT f m a
forall (m :: * -> *) a. Monad m => a -> m a
return

eitherFreeT_ :: Monad n => (f ~> n) -> (m ~> n) -> (FreeT f m ~> n)
eitherFreeT_ :: forall (n :: * -> *) (f :: * -> *) (m :: * -> *).
Monad n =>
(f ~> n) -> (m ~> n) -> FreeT f m ~> n
eitherFreeT_ f ~> n
nt1 m ~> n
nt2 = FreeT f m x -> n x
forall {b}. FreeT f m b -> n b
go
  where
    go :: FreeT f m b -> n b
go FreeT f m b
ma =
      do
        FreeF f b (FreeT f m b)
v <- m (FreeF f b (FreeT f m b)) -> n (FreeF f b (FreeT f m b))
m ~> n
nt2 (FreeT f m b -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT FreeT f m b
ma)
        case FreeF f b (FreeT f m b)
v of
          Pure b
a -> b -> n b
forall a. a -> n a
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
          Free f (FreeT f m b)
fm -> f (FreeT f m b) -> n (FreeT f m b)
f ~> n
nt1 f (FreeT f m b)
fm n (FreeT f m b) -> (FreeT f m b -> n b) -> n b
forall a b. n a -> (a -> n b) -> n b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FreeT f m b -> n b
go

caseFreeF :: (a -> r) -> (f b -> r) -> FreeF f a b -> r
caseFreeF :: forall a r (f :: * -> *) b.
(a -> r) -> (f b -> r) -> FreeF f a b -> r
caseFreeF a -> r
pureCase f b -> r
freeCase FreeF f a b
freef = case FreeF f a b
freef of
  Pure a
a -> a -> r
pureCase a
a
  Free f b
fb -> f b -> r
freeCase f b
fb

fbindFreeT_ :: forall f m n a. (Functor f, Functor m, Functor n) => (m ~> FreeT f n) -> FreeT f m a -> FreeT f n a
fbindFreeT_ :: forall (f :: * -> *) (m :: * -> *) (n :: * -> *) a.
(Functor f, Functor m, Functor n) =>
(m ~> FreeT f n) -> FreeT f m a -> FreeT f n a
fbindFreeT_ m ~> FreeT f n
k = FreeT f m a -> FreeT f n a
outer
  where
    outer :: FreeT f m a -> FreeT f n a
    outer :: FreeT f m a -> FreeT f n a
outer = FreeT f m a -> m (FreeF f a (FreeT f m a))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (FreeT f m a -> m (FreeF f a (FreeT f m a)))
-> (m (FreeF f a (FreeT f m a)) -> FreeT f n a)
-> FreeT f m a
-> FreeT f n a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> m (FreeF f a (FreeT f m a)) -> FreeT f n (FreeF f a (FreeT f m a))
m ~> FreeT f n
k (m (FreeF f a (FreeT f m a))
 -> FreeT f n (FreeF f a (FreeT f m a)))
-> (FreeT f n (FreeF f a (FreeT f m a)) -> FreeT f n a)
-> m (FreeF f a (FreeT f m a))
-> FreeT f n a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> FreeT f n (FreeF f a (FreeT f m a)) -> FreeT f n a
inner

    inner :: FreeT f n (FreeF f a (FreeT f m a)) -> FreeT f n a
    inner :: FreeT f n (FreeF f a (FreeT f m a)) -> FreeT f n a
inner =
      -- T m (F a (T m a))
      FreeT f n (FreeF f a (FreeT f m a))
-> n (FreeF
        f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a))))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT
        (FreeT f n (FreeF f a (FreeT f m a))
 -> n (FreeF
         f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a)))))
-> (n (FreeF
         f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a))))
    -> FreeT f n a)
-> FreeT f n (FreeF f a (FreeT f m a))
-> FreeT f n a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (FreeF
   f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a)))
 -> FreeF f a (FreeT f n a))
-> n (FreeF
        f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a))))
-> n (FreeF f a (FreeT f n a))
forall a b. (a -> b) -> n a -> n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FreeF f a (FreeT f m a) -> FreeF f a (FreeT f n a))
-> (f (FreeT f n (FreeF f a (FreeT f m a)))
    -> FreeF f a (FreeT f n a))
-> FreeF
     f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a)))
-> FreeF f a (FreeT f n a)
forall a r (f :: * -> *) b.
(a -> r) -> (f b -> r) -> FreeF f a b -> r
caseFreeF ((a -> FreeF f a (FreeT f n a))
-> (f (FreeT f m a) -> FreeF f a (FreeT f n a))
-> FreeF f a (FreeT f m a)
-> FreeF f a (FreeT f n a)
forall a r (f :: * -> *) b.
(a -> r) -> (f b -> r) -> FreeF f a b -> r
caseFreeF a -> FreeF f a (FreeT f n a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (f (FreeT f n a) -> FreeF f a (FreeT f n a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f n a) -> FreeF f a (FreeT f n a))
-> (f (FreeT f m a) -> f (FreeT f n a))
-> f (FreeT f m a)
-> FreeF f a (FreeT f n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeT f m a -> FreeT f n a) -> f (FreeT f m a) -> f (FreeT f n a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeT f m a -> FreeT f n a
outer)) (f (FreeT f n a) -> FreeF f a (FreeT f n a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f n a) -> FreeF f a (FreeT f n a))
-> (f (FreeT f n (FreeF f a (FreeT f m a))) -> f (FreeT f n a))
-> f (FreeT f n (FreeF f a (FreeT f m a)))
-> FreeF f a (FreeT f n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeT f n (FreeF f a (FreeT f m a)) -> FreeT f n a)
-> f (FreeT f n (FreeF f a (FreeT f m a))) -> f (FreeT f n a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeT f n (FreeF f a (FreeT f m a)) -> FreeT f n a
inner))
        (n (FreeF
      f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a))))
 -> n (FreeF f a (FreeT f n a)))
-> (n (FreeF f a (FreeT f n a)) -> FreeT f n a)
-> n (FreeF
        f (FreeF f a (FreeT f m a)) (FreeT f n (FreeF f a (FreeT f m a))))
-> FreeT f n a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> n (FreeF f a (FreeT f n a)) -> FreeT f n a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT

fconcatFreeT_ :: forall f m. (Functor f, Functor m) => FreeT f (FreeT f m) ~> FreeT f m
fconcatFreeT_ :: forall (f :: * -> *) (m :: * -> *).
(Functor f, Functor m) =>
FreeT f (FreeT f m) ~> FreeT f m
fconcatFreeT_ = (FreeT f m ~> FreeT f m) -> FreeT f (FreeT f m) x -> FreeT f m x
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) a.
(Functor f, Functor m, Functor n) =>
(m ~> FreeT f n) -> FreeT f m a -> FreeT f n a
fbindFreeT_ FreeT f m x -> FreeT f m x
forall a. a -> a
FreeT f m ~> FreeT f m
id