{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe #-}
#include "free-common.h"

-----------------------------------------------------------------------------

-- |

-- Module      :  Control.Applicative.Free.Final

-- Copyright   :  (C) 2012-2013 Edward Kmett

-- License     :  BSD-style (see the file LICENSE)

--

-- Maintainer  :  Edward Kmett <ekmett@gmail.com>

-- Stability   :  provisional

-- Portability :  GADTs, Rank2Types

--

-- Final encoding of free 'Applicative' functors.

----------------------------------------------------------------------------

module Control.Applicative.Free.Final
  (
  -- | 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.


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

  -- * Examples

  -- $examples

  ) where

import Control.Applicative
import Data.Functor.Apply

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

-- | The free 'Applicative' for a 'Functor' @f@.

newtype Ap f a = Ap { forall (f :: * -> *) a.
Ap f a
-> forall (g :: * -> *).
   Applicative g =>
   (forall x. f x -> g x) -> g a
_runAp :: forall g. Applicative g => (forall x. f x -> g x) -> g a }

-- | 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
phi Ap f a
m = Ap f a
-> forall (g :: * -> *).
   Applicative g =>
   (forall x. f x -> g x) -> g a
forall (f :: * -> *) a.
Ap f a
-> forall (g :: * -> *).
   Applicative g =>
   (forall x. f x -> g x) -> g a
_runAp Ap f a
m f x -> g x
forall x. f x -> g x
phi

-- | 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 = Const m b -> m
forall {k} a (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 :: forall a b. (a -> b) -> Ap f a -> Ap f b
fmap a -> b
f (Ap forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
g) = (forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g b)
-> Ap f b
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
Ap (\forall x. f x -> g x
k -> (a -> b) -> g a -> g b
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ((forall x. f x -> g x) -> g a
forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
g f x -> g x
forall x. f x -> g x
k))

instance Apply (Ap f) where
  Ap forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g (a -> b)
f <.> :: forall a b. Ap f (a -> b) -> Ap f a -> Ap f b
<.> Ap forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
x = (forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g b)
-> Ap f b
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
Ap (\forall x. f x -> g x
k -> (forall x. f x -> g x) -> g (a -> b)
forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g (a -> b)
f f x -> g x
forall x. f x -> g x
k g (a -> b) -> g a -> g b
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall x. f x -> g x) -> g a
forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
x f x -> g x
forall x. f x -> g x
k)

instance Applicative (Ap f) where
  pure :: forall a. a -> Ap f a
pure a
x = (forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
Ap (\forall x. f x -> g x
_ -> a -> g a
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  Ap forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g (a -> b)
f <*> :: forall a b. Ap f (a -> b) -> Ap f a -> Ap f b
<*> Ap forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
x = (forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g b)
-> Ap f b
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
Ap (\forall x. f x -> g x
k -> (forall x. f x -> g x) -> g (a -> b)
forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g (a -> b)
f f x -> g x
forall x. f x -> g x
k g (a -> b) -> g a -> g b
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall x. f x -> g x) -> g a
forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
x f x -> g x
forall x. f x -> g x
k)

-- | 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 (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
Ap (\forall x. f x -> g x
k -> f a -> g a
forall x. f x -> g x
k f a
x)

-- | 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
f (Ap forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g b
g) = (forall (g :: * -> *).
 Applicative g =>
 (forall x. g x -> g x) -> g b)
-> Ap g b
forall (f :: * -> *) a.
(forall (g :: * -> *).
 Applicative g =>
 (forall x. f x -> g x) -> g a)
-> Ap f a
Ap (\forall x. g x -> g x
k -> (forall x. f x -> g x) -> g b
forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g b
g (g x -> g x
forall x. g x -> g x
k (g x -> g x) -> (f x -> g x) -> f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x
forall a. f a -> g a
f))

-- | 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 (Ap forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
g) = (forall x. f x -> f x) -> f a
forall (g :: * -> *).
Applicative g =>
(forall x. f x -> g x) -> g a
g f x -> f x
forall a. a -> a
forall x. f x -> f x
id

{- $examples

<examples/ValidationForm.hs Validation form>

-}