{-# 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 x. f x -> g x) -> Ap f a -> g a
runAp forall x. f x -> g x
_ (Pure a
x) = a -> g a
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) = ((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_ 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 a -> b
f (Pure a
a)   = b -> Ap f b
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)   = 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 a -> b
f <.> :: Ap f (a -> b) -> Ap f a -> Ap f b
<.> 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 f a
x Ap f (a -> a -> b)
y <.> 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 a -> b
f <*> :: Ap f (a -> b) -> Ap f a -> Ap f b
<*> 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 f a
x Ap f (a -> a -> b)
y <*> 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
  extract (Ap f a
x 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) = 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 f a
x 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 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 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 (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 forall a. f a -> g a
_ (Pure b
a) = b -> Ap g b
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) = 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 -> f 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 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>

-}