{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Safe #-}
module Control.Applicative.Trans.Free
(
ApT(..)
, ApF(..)
, liftApT
, liftApO
, runApT
, runApF
, runApT_
, hoistApT
, hoistApF
, transApT
, transApF
, joinApT
, Ap
, runAp
, runAp_
, retractAp
, Alt
, runAlt
) where
import Control.Applicative
import Control.Monad (liftM)
import Data.Functor.Apply
import Data.Functor.Identity
data ApF f g a where
Pure :: a -> ApF f g a
Ap :: f a -> ApT f g (a -> b) -> ApF f g b
newtype ApT f g a = ApT { forall (f :: * -> *) (g :: * -> *) a. ApT f g a -> g (ApF f g a)
getApT :: g (ApF f g a) }
instance Functor g => Functor (ApF f g) where
fmap :: forall a b. (a -> b) -> ApF f g a -> ApF f g b
fmap a -> b
f (Pure a
a) = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure (a -> b
f a
a)
fmap a -> b
f (Ap f a
x ApT f g (a -> a)
g) = f a
x forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ApT f g (a -> a)
g
instance Functor g => Functor (ApT f g) where
fmap :: forall a b. (a -> b) -> ApT f g a -> ApT f g b
fmap a -> b
f (ApT g (ApF f g a)
g) = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g a)
g)
instance Applicative g => Applicative (ApF f g) where
pure :: forall a. a -> ApF f g a
pure = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure
{-# INLINE pure #-}
Pure a -> b
f <*> :: forall a b. ApF f g (a -> b) -> ApF f g a -> ApF f g b
<*> ApF f g a
y = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ApF f g a
y
ApF f g (a -> b)
y <*> Pure a
a = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ a
a) ApF f g (a -> b)
y
Ap f a
a ApT f g (a -> a -> b)
f <*> ApF f g a
b = f a
a forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApT f g (a -> a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a. Applicative f => a -> f a
pure ApF f g a
b))
{-# INLINE (<*>) #-}
instance Applicative g => Applicative (ApT f g) where
pure :: forall a. a -> ApT f g a
pure = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE pure #-}
ApT g (ApF f g (a -> b))
xs <*> :: forall a b. ApT f g (a -> b) -> ApT f g a -> ApT f g b
<*> ApT g (ApF f g a)
ys = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g (a -> b))
xs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> g (ApF f g a)
ys)
{-# INLINE (<*>) #-}
instance Applicative g => Apply (ApF f g) where
<.> :: forall a b. ApF f g (a -> b) -> ApF f g a -> ApF f g b
(<.>) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
{-# INLINE (<.>) #-}
instance Applicative g => Apply (ApT f g) where
<.> :: forall a b. ApT f g (a -> b) -> ApT f g a -> ApT f g b
(<.>) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
{-# INLINE (<.>) #-}
instance Alternative g => Alternative (ApT f g) where
empty :: forall a. ApT f g a
empty = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE empty #-}
ApT g (ApF f g a)
g <|> :: forall a. ApT f g a -> ApT f g a -> ApT f g a
<|> ApT g (ApF f g a)
h = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (g (ApF f g a)
g forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g (ApF f g a)
h)
{-# INLINE (<|>) #-}
liftApT :: Applicative g => f a -> ApT f g a
liftApT :: forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
f a -> ApT f g a
liftApT f a
x = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
Ap f a
x (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id)))
liftApO :: Functor g => g a -> ApT f g a
liftApO :: forall (g :: * -> *) a (f :: * -> *). Functor g => g a -> ApT f g a
liftApO g a
g = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g a
g)
runApF :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApF f g b -> h b
runApF :: forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApF f g b -> h b
runApF forall a. f a -> h a
_ forall a. g (h a) -> h a
_ (Pure b
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
runApF forall a. f a -> h a
f forall a. g (h a) -> h a
g (Ap f a
x ApT f g (a -> b)
y) = forall a. f a -> h a
f f a
x forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT forall a. f a -> h a
f forall a. g (h a) -> h a
g ApT f g (a -> b)
y
runApT :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT :: forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT forall a. f a -> h a
f forall a. g (h a) -> h a
g (ApT g (ApF f g b)
a) = forall a. g (h a) -> h a
g (forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApF f g b -> h b
runApF forall a. f a -> h a
f forall a. g (h a) -> h a
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g b)
a)
runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m
runApT_ :: forall (g :: * -> *) m (f :: * -> *) b.
(Functor g, Monoid m) =>
(forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m
runApT_ forall a. f a -> m
f g m -> m
g = forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT (forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. f a -> m
f) (forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. g m -> m
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (b :: k). Const a b -> a
getConst)
hoistApF :: Functor g => (forall a. f a -> f' a) -> ApF f g b -> ApF f' g b
hoistApF :: forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApF f g b -> ApF f' g b
hoistApF forall a. f a -> f' a
_ (Pure b
x) = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure b
x
hoistApF forall a. f a -> f' a
f (Ap f a
x ApT f g (a -> b)
y) = forall a. f a -> f' a
f f a
x forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApT f g b -> ApT f' g b
hoistApT forall a. f a -> f' a
f ApT f g (a -> b)
y
hoistApT :: Functor g => (forall a. f a -> f' a) -> ApT f g b -> ApT f' g b
hoistApT :: forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApT f g b -> ApT f' g b
hoistApT forall a. f a -> f' a
f (ApT g (ApF f g b)
g) = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApF f g b -> ApF f' g b
hoistApF forall a. f a -> f' a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g b)
g)
transApF :: Functor g => (forall a. g a -> g' a) -> ApF f g b -> ApF f g' b
transApF :: forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApF f g b -> ApF f g' b
transApF forall a. g a -> g' a
_ (Pure b
x) = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure b
x
transApF forall a. g a -> g' a
f (Ap f a
x ApT f g (a -> b)
y) = f a
x forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApT f g b -> ApT f g' b
transApT forall a. g a -> g' a
f ApT f g (a -> b)
y
transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b
transApT :: forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApT f g b -> ApT f g' b
transApT forall a. g a -> g' a
f (ApT g (ApF f g b)
g) = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT forall a b. (a -> b) -> a -> b
$ forall a. g a -> g' a
f (forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApF f g b -> ApF f g' b
transApF forall a. g a -> g' a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g b)
g)
joinApT :: Monad m => ApT f m a -> m (Ap f a)
joinApT :: forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
ApT f m a -> m (Ap f a)
joinApT (ApT m (ApF f m a)
m) = m (ApF f m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {f :: * -> *} {a}.
Monad m =>
ApF f m a -> m (ApT f Identity a)
joinApF
where
joinApF :: ApF f m a -> m (ApT f Identity a)
joinApF (Pure a
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
joinApF (Ap f a
x ApT f m (a -> a)
y) = (forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
f a -> ApT f g a
liftApT f a
x forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**>) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
ApT f m a -> m (Ap f a)
joinApT ApT f m (a -> a)
y
type Ap f = ApT f Identity
runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a
runAp :: forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp forall x. f x -> g x
f = forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT forall x. f x -> g x
f forall a. Identity a -> a
runIdentity
runAp_ :: Monoid m => (forall x. f x -> m) -> Ap f a -> m
runAp_ :: forall m (f :: * -> *) a.
Monoid m =>
(forall x. f x -> m) -> Ap f a -> m
runAp_ forall x. f x -> m
f = forall (g :: * -> *) m (f :: * -> *) b.
(Functor g, Monoid m) =>
(forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m
runApT_ forall x. f x -> m
f forall a. Identity a -> a
runIdentity
retractAp :: Applicative f => Ap f a -> f a
retractAp :: forall (f :: * -> *) a. Applicative f => Ap f a -> f a
retractAp = forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp forall a. a -> a
id
type Alt f = ApT f []
runAlt :: (Alternative g, Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a
runAlt :: forall (g :: * -> *) (t :: * -> *) (f :: * -> *) a.
(Alternative g, Foldable t) =>
(forall x. f x -> g x) -> ApT f t a -> g a
runAlt forall x. f x -> g x
f (ApT t (ApF f t a)
xs) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ApF f t a
x g a
acc -> ApF f t a -> g a
h ApF f t a
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g a
acc) forall (f :: * -> *) a. Alternative f => f a
empty t (ApF f t a)
xs
where
h :: ApF f t a -> g a
h (Pure a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
h (Ap f a
x ApT f t (a -> a)
g) = forall x. f x -> g x
f f a
x forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall (g :: * -> *) (t :: * -> *) (f :: * -> *) a.
(Alternative g, Foldable t) =>
(forall x. f x -> g x) -> ApT f t a -> g a
runAlt forall x. f x -> g x
f ApT f t (a -> a)
g