    {-# LANGUAGE CPP #-}
    {-# LANGUAGE Rank2Types #-}
    {-# LANGUAGE GADTs #-}
    #if __GLASGOW_HASKELL__ >= 707
    {-# LANGUAGE DeriveDataTypeable #-}
    #endif
    {-# OPTIONS_GHC -Wall #-}
    #include "free-common.h"

    -----------------------------------------------------------------------------
    -- |
    -- 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
    import Data.Typeable
    #if !(MIN_VERSION_base(4,8,0))
    import Data.Monoid (Monoid)
    #endif
    import qualified Data.Foldable as F

    -- | 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
    #if __GLASGOW_HASKELL__ >= 707
      deriving Typeable
    #endif

    -- | The free 'Applicative' transformer for a 'Functor' @f@ over
    -- 'Applicative' @g@.
    newtype ApT f g a = ApT { getApT :: g (ApF f g a) }
    #if __GLASGOW_HASKELL__ >= 707
      deriving Typeable
    #endif

    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, 'F.Foldable' g) => 'ApT' f g a -> 'Int'
    -- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum'
    -- @
    --
    -- @
    -- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'
    -- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.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, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a
    runAlt f (ApT xs) = F.foldr (\x acc -> h x <|> acc) empty xs
      where
        h (Pure x) = pure x
        h (Ap x g) = f x <**> runAlt f g

    #if __GLASGOW_HASKELL__ < 707
    instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where
      typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where
        f :: ApT f g a -> g (f a)
        f = undefined

    instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where
      typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where
        f :: ApF f g a -> g (f a)
        f = undefined

    apTTyCon, apFTyCon :: TyCon
    #if __GLASGOW_HASKELL__ < 704
    apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT"
    apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF"
    #else
    apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT"
    apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF"
    #endif
    {-# NOINLINE apTTyCon #-}
    {-# NOINLINE apFTyCon #-}
    #endif