content: {-# 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 { getApT :: g (ApF f g a) }
  
  instance Functor g => Functor (ApF f g) where
    fmap f (Pure a) = Pure (f a)
    fmap f (Ap x g) = x `Ap` fmap (f .) g
  
  instance Functor g => Functor (ApT f g) where
    fmap f (ApT g) = ApT (fmap f <$> g)
  
  instance Applicative g => Applicative (ApF f g) where
    pure = Pure
    {-# INLINE pure #-}
    Pure f   <*> y       = fmap f y      -- fmap
    y        <*> Pure a  = fmap ($ a) y  -- interchange
    Ap a f   <*> b       = a `Ap` (flip <$> f <*> ApT (pure b))
    {-# INLINE (<*>) #-}
  
  instance Applicative g => Applicative (ApT f g) where
    pure = ApT . pure . pure
    {-# INLINE pure #-}
    ApT xs <*> ApT ys = ApT ((<*>) <$> xs <*> ys)
    {-# INLINE (<*>) #-}
  
  instance Applicative g => Apply (ApF f g) where
    (<.>) = (<*>)
    {-# INLINE (<.>) #-}
  
  instance Applicative g => Apply (ApT f g) where
    (<.>) = (<*>)
    {-# INLINE (<.>) #-}
  
  instance Alternative g => Alternative (ApT f g) where
    empty = ApT empty
    {-# INLINE empty #-}
    ApT g <|> ApT h = ApT (g <|> 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 x = ApT (pure (Ap x (pure 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 g = ApT (Pure <$> 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 _ _ (Pure x) = pure x
  runApF f g (Ap x y) = f x <**> runApT f g 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 f g (ApT a) = g (runApF f g <$> 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_ f g = getConst . runApT (Const . f) (Const . g . fmap 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 _ (Pure x) = Pure x
  hoistApF f (Ap x y) = f x `Ap` hoistApT f 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 f (ApT g) = ApT (hoistApF f <$> 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 _ (Pure x) = Pure x
  transApF f (Ap x y) = x `Ap` transApT f 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 f (ApT g) = ApT $ f (transApF f <$> g)
  
  -- | Pull out and join @m@ layers of @'ApT' f m a@.
  joinApT :: Monad m => ApT f m a -> m (Ap f a)
  joinApT (ApT m) = m >>= joinApF
    where
      joinApF (Pure x) = return (pure x)
      joinApF (Ap x y) = (liftApT x <**>) `liftM` joinApT 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 f = runApT f 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_ f = runApT_ f 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 = runAp 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 f (ApT xs) = foldr (\x acc -> h x <|> acc) empty xs
    where
      h (Pure x) = pure x
      h (Ap x g) = f x <**> runAlt f g
  