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

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Applicative.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' functors for free
    ----------------------------------------------------------------------------
    module Control.Applicative.Free
      (
      -- | Compared to the free monad, 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://arxiv.org/abs/1403.0749 Free Applicative Functors>,
      -- by Paolo Capriotti and Ambrus Kaposi, for some applications.

        Ap(..)
      , runAp
      , runAp_
      , liftAp
      , iterAp
      , hoistAp
      , retractAp

      -- * Examples
      -- $examples
      ) where

    import Control.Applicative
    import Control.Comonad (Comonad(..))
    import Data.Functor.Apply
    import Data.Typeable

    #if !(MIN_VERSION_base(4,8,0))
    import Data.Monoid
    #endif

    -- | The free 'Applicative' for a 'Functor' @f@.
    data Ap f a where
      Pure :: a -> Ap f a
      Ap   :: f a -> Ap f (a -> b) -> Ap f b
    #if __GLASGOW_HASKELL__ >= 707
      deriving Typeable
    #endif

    -- | 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 x. f x -> g x) -> Ap f a -> g a
    runAp _ (Pure x :: a
    x) = a -> g a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    x
    runAp u :: forall x. f x -> g x
    u (Ap f :: f a
    f x :: Ap f (a -> a)
    x) = ((a -> a) -> a -> a) -> a -> (a -> a) -> a
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (a -> a) -> a -> a
    forall a. a -> a
    id (a -> (a -> a) -> a) -> g a -> g ((a -> a) -> a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> f a -> g a
    forall x. f x -> g x
    u f a
    f g ((a -> a) -> a) -> g (a -> a) -> g a
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> (forall x. f x -> g x) -> Ap f (a -> a) -> g (a -> a)
    forall (g :: * -> *) (f :: * -> *) a.
    Applicative g =>
    (forall x. f x -> g x) -> Ap f a -> g a
    runAp forall x. f x -> g x
    u Ap f (a -> a)
    x

    -- | Perform a monoidal analysis over free applicative value.
    --
    -- Example:
    --
    -- @
    -- count :: Ap f a -> Int
    -- count = getSum . runAp_ (\\_ -> Sum 1)
    -- @
    runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m
    runAp_ :: (forall a. f a -> m) -> Ap f b -> m
    runAp_ f :: forall a. f a -> m
    f = Const m b -> m
    forall a k (b :: k). Const a b -> a
    getConst (Const m b -> m) -> (Ap f b -> Const m b) -> Ap f b -> m
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (forall x. f x -> Const m x) -> Ap f b -> Const m b
    forall (g :: * -> *) (f :: * -> *) a.
    Applicative g =>
    (forall x. f x -> g x) -> Ap f a -> g a
    runAp (m -> Const m x
    forall k a (b :: k). a -> Const a b
    Const (m -> Const m x) -> (f x -> m) -> f x -> Const m x
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . f x -> m
    forall a. f a -> m
    f)

    instance Functor (Ap f) where
      fmap :: (a -> b) -> Ap f a -> Ap f b
    fmap f :: a -> b
    f (Pure a :: a
    a)   = b -> Ap f b
    forall a (f :: * -> *). a -> Ap f a
    Pure (a -> b
    f a
    a)
      fmap f :: a -> b
    f (Ap x :: f a
    x y :: Ap f (a -> a)
    y)   = f a -> Ap f (a -> b) -> Ap f b
    forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
    Ap f a
    x ((a -> b
    f (a -> b) -> (a -> a) -> a -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .) ((a -> a) -> a -> b) -> Ap f (a -> a) -> Ap f (a -> b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Ap f (a -> a)
    y)

    instance Apply (Ap f) where
      Pure f :: a -> b
    f <.> :: Ap f (a -> b) -> Ap f a -> Ap f b
    <.> y :: Ap f a
    y = (a -> b) -> Ap f a -> Ap f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> b
    f Ap f a
    y
      Ap x :: f a
    x y :: Ap f (a -> a -> b)
    y <.> z :: Ap f a
    z = f a -> Ap f (a -> b) -> Ap f b
    forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
    Ap f a
    x ((a -> a -> b) -> a -> a -> b
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((a -> a -> b) -> a -> a -> b)
    -> Ap f (a -> a -> b) -> Ap f (a -> a -> b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Ap f (a -> a -> b)
    y Ap f (a -> a -> b) -> Ap f a -> Ap f (a -> b)
    forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
    <.> Ap f a
    z)

    instance Applicative (Ap f) where
      pure :: a -> Ap f a
    pure = a -> Ap f a
    forall a (f :: * -> *). a -> Ap f a
    Pure
      Pure f :: a -> b
    f <*> :: Ap f (a -> b) -> Ap f a -> Ap f b
    <*> y :: Ap f a
    y = (a -> b) -> Ap f a -> Ap f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> b
    f Ap f a
    y
      Ap x :: f a
    x y :: Ap f (a -> a -> b)
    y <*> z :: Ap f a
    z = f a -> Ap f (a -> b) -> Ap f b
    forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
    Ap f a
    x ((a -> a -> b) -> a -> a -> b
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((a -> a -> b) -> a -> a -> b)
    -> Ap f (a -> a -> b) -> Ap f (a -> a -> b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Ap f (a -> a -> b)
    y Ap f (a -> a -> b) -> Ap f a -> Ap f (a -> b)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Ap f a
    z)

    instance Comonad f => Comonad (Ap f) where
      extract :: Ap f a -> a
    extract (Pure a :: a
    a) = a
    a
      extract (Ap x :: f a
    x y :: Ap f (a -> a)
    y) = Ap f (a -> a) -> a -> a
    forall (w :: * -> *) a. Comonad w => w a -> a
    extract Ap f (a -> a)
    y (f a -> a
    forall (w :: * -> *) a. Comonad w => w a -> a
    extract f a
    x)
      duplicate :: Ap f a -> Ap f (Ap f a)
    duplicate (Pure a :: a
    a) = Ap f a -> Ap f (Ap f a)
    forall a (f :: * -> *). a -> Ap f a
    Pure (a -> Ap f a
    forall a (f :: * -> *). a -> Ap f a
    Pure a
    a)
      duplicate (Ap x :: f a
    x y :: Ap f (a -> a)
    y) = f (f a) -> Ap f (f a -> Ap f a) -> Ap f (Ap f a)
    forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
    Ap (f a -> f (f a)
    forall (w :: * -> *) a. Comonad w => w a -> w (w a)
    duplicate f a
    x) ((Ap f (a -> a) -> f a -> Ap f a)
    -> Ap f (a -> a) -> Ap f (f a -> Ap f a)
    forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
    extend ((f a -> Ap f (a -> a) -> Ap f a) -> Ap f (a -> a) -> f a -> Ap f a
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip f a -> Ap f (a -> a) -> Ap f a
    forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
    Ap) Ap f (a -> a)
    y)

    -- | A version of 'lift' that can be used with just a 'Functor' for @f@.
    liftAp :: f a -> Ap f a
    liftAp :: f a -> Ap f a
    liftAp x :: f a
    x = f a -> Ap f (a -> a) -> Ap f a
    forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
    Ap f a
    x ((a -> a) -> Ap f (a -> a)
    forall a (f :: * -> *). a -> Ap f a
    Pure a -> a
    forall a. a -> a
    id)
    {-# INLINE liftAp #-}

    -- | Tear down a free 'Applicative' using iteration.
    iterAp :: Functor g => (g a -> a) -> Ap g a -> a
    iterAp :: (g a -> a) -> Ap g a -> a
    iterAp algebra :: g a -> a
    algebra = Ap g a -> a
    go
      where go :: Ap g a -> a
    go (Pure a :: a
    a) = a
    a
            go (Ap underlying :: g a
    underlying apply :: Ap g (a -> a)
    apply) = g a -> a
    algebra (Ap g a -> a
    go (Ap g a -> a) -> (a -> Ap g a) -> a -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Ap g (a -> a)
    apply Ap g (a -> a) -> Ap g a -> Ap g a
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*>) (Ap g a -> Ap g a) -> (a -> Ap g a) -> a -> Ap g a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Ap g a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a -> a) -> g a -> g a
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> g a
    underlying)

    -- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.
    hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b
    hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b
    hoistAp _ (Pure a :: b
    a) = b -> Ap g b
    forall a (f :: * -> *). a -> Ap f a
    Pure b
    a
    hoistAp f :: forall a. f a -> g a
    f (Ap x :: f a
    x y :: Ap f (a -> b)
    y) = g a -> Ap g (a -> b) -> Ap g b
    forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
    Ap (f a -> g a
    forall a. f a -> g a
    f f a
    x) ((forall a. f a -> g a) -> Ap f (a -> b) -> Ap g (a -> b)
    forall (f :: * -> *) (g :: * -> *) b.
    (forall a. f a -> g a) -> Ap f b -> Ap g b
    hoistAp forall a. f a -> g a
    f Ap f (a -> b)
    y)

    -- | 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 :: Ap f a -> f a
    retractAp (Pure a :: a
    a) = a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    a
    retractAp (Ap x :: f a
    x y :: Ap f (a -> a)
    y) = f a
    x f a -> f (a -> a) -> f a
    forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
    <**> Ap f (a -> a) -> f (a -> a)
    forall (f :: * -> *) a. Applicative f => Ap f a -> f a
    retractAp Ap f (a -> a)
    y

    #if __GLASGOW_HASKELL__ < 707
    instance Typeable1 f => Typeable1 (Ap f) where
      typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where
        f :: Ap f a -> f a
        f = undefined

    apTyCon :: TyCon
    #if __GLASGOW_HASKELL__ < 704
    apTyCon = mkTyCon "Control.Applicative.Free.Ap"
    #else
    apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap"
    #endif
    {-# NOINLINE apTyCon #-}

    #endif

    {- $examples

    <examples/ValidationForm.hs Validation form>

    -}