{-# 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 { 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 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 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 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 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 (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 (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 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 <.> :: 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 forall x. f x -> g x
k 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 forall x. f x -> g x
k)

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

{- $examples

<examples/ValidationForm.hs Validation form>

-}