{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Applicative.Trans.Free
-- Copyright   :  (C) 2012-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  GADTs, Rank2Types
--
-- 'Applicative' functor transformers for free
----------------------------------------------------------------------------
module Control.Applicative.Trans.Free
  (
  -- | Compared to the free monad transformers, they are less expressive. However, they are also more
  -- flexible to inspect and interpret, as the number of ways in which
  -- the values can be nested is more limited.
  --
  -- See <http://paolocapriotti.com/assets/applicative.pdf Free Applicative Functors>,
  -- by Paolo Capriotti and Ambrus Kaposi, for some applications.
    ApT(..)
  , ApF(..)
  , liftApT
  , liftApO
  , runApT
  , runApF
  , runApT_
  , hoistApT
  , hoistApF
  , transApT
  , transApF
  , joinApT
  -- * Free Applicative
  , Ap
  , runAp
  , runAp_
  , retractAp
  -- * Free Alternative
  , Alt
  , runAlt
  ) where

import Control.Applicative
import Control.Monad (liftM)
import Data.Functor.Apply
import Data.Functor.Identity

-- | The free 'Applicative' for a 'Functor' @f@.
data ApF f g a where
  Pure :: a -> ApF f g a
  Ap   :: f a -> ApT f g (a -> b) -> ApF f g b

-- | The free 'Applicative' transformer for a 'Functor' @f@ over
-- 'Applicative' @g@.
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      -- fmap
  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  -- interchange
  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 (<|>) #-}

-- | A version of 'lift' that can be used with no constraint for @f@.
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)))

-- | Lift an action of the \"outer\" 'Functor' @g a@ to @'ApT' f g a@.
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)

-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives
-- a natural transformation @ApF f g ~> h@.
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

-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives
-- a natural transformation @ApT f g ~> h@.
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)

-- | Perform a monoidal analysis over @'ApT' f g b@ value.
--
-- Examples:
--
-- @
-- height :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int'
-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'maximum'
-- @
--
-- @
-- size :: ('Functor' g, 'Foldable' g) => 'ApT' f g a -> 'Int'
-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'fold'
-- @
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)

-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f' g@.
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

-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f' g@.
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)

-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f 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

-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f g'@.
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)

-- | Pull out and join @m@ layers of @'ApT' f m a@.
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

-- | The free 'Applicative' for a 'Functor' @f@.
type Ap f = ApT f Identity

-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.
--
-- prop> runAp t == retractApp . hoistApp t
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

-- | Perform a monoidal analysis over free applicative value.
--
-- Example:
--
-- @
-- count :: 'Ap' f a -> 'Int'
-- count = 'getSum' . runAp_ (\\_ -> 'Sum' 1)
-- @
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

-- | Interprets the free applicative functor over f using the semantics for
--   `pure` and `<*>` given by the Applicative instance for f.
--
--   prop> retractApp == runAp id
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

-- | The free 'Alternative' for a 'Functor' @f@.
type Alt f = ApT f []

-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@.
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