{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
#else
-- Manual Typeable instances

{-# LANGUAGE Trustworthy #-}
#endif
#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 (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp forall x. f x -> g x
_ (Pure a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
runAp forall x. f x -> g x
u (Ap f a
f Ap f (a -> a)
x) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. f x -> g x
u f a
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 m (f :: * -> *) b.
Monoid m =>
(forall a. f a -> m) -> Ap f b -> m
runAp_ forall a. f a -> m
f = forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp (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)

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

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

instance Applicative (Ap f) where
  pure :: forall a. a -> Ap f a
pure = forall a (f :: * -> *). a -> Ap f a
Pure
  Pure a -> b
f <*> :: forall a b. Ap f (a -> b) -> Ap f a -> Ap f b
<*> Ap f a
y = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Ap f a
y
  Ap f a
x Ap f (a -> a -> b)
y <*> Ap f a
z = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
Ap f a
x (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ap f (a -> a -> b)
y 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 :: forall a. Ap f a -> a
extract (Pure a
a) = a
a
  extract (Ap f a
x Ap f (a -> a)
y) = forall (w :: * -> *) a. Comonad w => w a -> a
extract Ap f (a -> a)
y (forall (w :: * -> *) a. Comonad w => w a -> a
extract f a
x)
  duplicate :: forall a. Ap f a -> Ap f (Ap f a)
duplicate (Pure a
a) = forall a (f :: * -> *). a -> Ap f a
Pure (forall a (f :: * -> *). a -> Ap f a
Pure a
a)
  duplicate (Ap f a
x Ap f (a -> a)
y) = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
Ap (forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate f a
x) (forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 :: forall (f :: * -> *) a. f a -> Ap f a
liftAp f a
x = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
Ap f a
x (forall a (f :: * -> *). a -> Ap f a
Pure 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 :: forall (g :: * -> *) a. Functor g => (g a -> a) -> Ap g a -> a
iterAp g a -> a
algebra = Ap g a -> a
go
  where go :: Ap g a -> a
go (Pure a
a) = a
a
        go (Ap g a
underlying Ap g (a -> a)
apply) = g a -> a
algebra (Ap g a -> a
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ap g (a -> a)
apply forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> Ap f b -> Ap g b
hoistAp forall a. f a -> g a
_ (Pure b
a) = forall a (f :: * -> *). a -> Ap f a
Pure b
a
hoistAp forall a. f a -> g a
f (Ap f a
x Ap f (a -> b)
y) = forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap f b
Ap (forall a. f a -> g a
f f a
x) (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 :: forall (f :: * -> *) a. Applicative f => Ap f a -> f a
retractAp (Pure a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
retractAp (Ap f a
x Ap f (a -> a)
y) = f a
x forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> 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>

-}