{-# 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.Trans.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' functor transformers for free

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

module Control.Applicative.Trans.Free
  (
  -- | Compared to the free monad transformers, 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://paolocapriotti.com/assets/applicative.pdf Free Applicative Functors>,

  -- by Paolo Capriotti and Ambrus Kaposi, for some applications.

    ApT(..)
  , ApF(..)
  , liftApT
  , liftApO
  , runApT
  , runApF
  , runApT_
  , hoistApT
  , hoistApF
  , transApT
  , transApF
  , joinApT
  -- * Free Applicative

  , Ap
  , runAp
  , runAp_
  , retractAp
  -- * Free Alternative

  , Alt
  , runAlt
  ) where

import Control.Applicative
import Control.Monad (liftM)
import Data.Functor.Apply
import Data.Functor.Identity
import Data.Typeable
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (Monoid)
#endif
import qualified Data.Foldable as F

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

data ApF f g a where
  Pure :: a -> ApF f g a
  Ap   :: f a -> ApT f g (a -> b) -> ApF f g b
#if __GLASGOW_HASKELL__ >= 707
  deriving Typeable
#endif

-- | The free 'Applicative' transformer for a 'Functor' @f@ over

-- 'Applicative' @g@.

newtype ApT f g a = ApT { forall (f :: * -> *) (g :: * -> *) a. ApT f g a -> g (ApF f g a)
getApT :: g (ApF f g a) }
#if __GLASGOW_HASKELL__ >= 707
  deriving Typeable
#endif

instance Functor g => Functor (ApF f g) where
  fmap :: forall a b. (a -> b) -> ApF f g a -> ApF f g b
fmap a -> b
f (Pure a
a) = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure (a -> b
f a
a)
  fmap a -> b
f (Ap f a
x ApT f g (a -> a)
g) = f a
x forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ApT f g (a -> a)
g

instance Functor g => Functor (ApT f g) where
  fmap :: forall a b. (a -> b) -> ApT f g a -> ApT f g b
fmap a -> b
f (ApT g (ApF f g a)
g) = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g a)
g)

instance Applicative g => Applicative (ApF f g) where
  pure :: forall a. a -> ApF f g a
pure = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure
  {-# INLINE pure #-}
  Pure a -> b
f   <*> :: forall a b. ApF f g (a -> b) -> ApF f g a -> ApF f g b
<*> ApF f g a
y       = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ApF f g a
y      -- fmap

  ApF f g (a -> b)
y        <*> Pure a
a  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ a
a) ApF f g (a -> b)
y  -- interchange

  Ap f a
a ApT f g (a -> a -> b)
f   <*> ApF f g a
b       = f a
a forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApT f g (a -> a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a. Applicative f => a -> f a
pure ApF f g a
b))
  {-# INLINE (<*>) #-}

instance Applicative g => Applicative (ApT f g) where
  pure :: forall a. a -> ApT f g a
pure = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  ApT g (ApF f g (a -> b))
xs <*> :: forall a b. ApT f g (a -> b) -> ApT f g a -> ApT f g b
<*> ApT g (ApF f g a)
ys = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g (a -> b))
xs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> g (ApF f g a)
ys)
  {-# INLINE (<*>) #-}

instance Applicative g => Apply (ApF f g) where
  <.> :: forall a b. ApF f g (a -> b) -> ApF f g a -> ApF f g b
(<.>) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<.>) #-}

instance Applicative g => Apply (ApT f g) where
  <.> :: forall a b. ApT f g (a -> b) -> ApT f g a -> ApT f g b
(<.>) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<.>) #-}

instance Alternative g => Alternative (ApT f g) where
  empty :: forall a. ApT f g a
empty = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE empty #-}
  ApT g (ApF f g a)
g <|> :: forall a. ApT f g a -> ApT f g a -> ApT f g a
<|> ApT g (ApF f g a)
h = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (g (ApF f g a)
g forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g (ApF f g a)
h)
  {-# INLINE (<|>) #-}

-- | A version of 'lift' that can be used with no constraint for @f@.

liftApT :: Applicative g => f a -> ApT f g a
liftApT :: forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
f a -> ApT f g a
liftApT f a
x = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
Ap f a
x (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id)))

-- | Lift an action of the \"outer\" 'Functor' @g a@ to @'ApT' f g a@.

liftApO :: Functor g => g a -> ApT f g a
liftApO :: forall (g :: * -> *) a (f :: * -> *). Functor g => g a -> ApT f g a
liftApO g a
g = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g a
g)

-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives

-- a natural transformation @ApF f g ~> h@.

runApF :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApF f g b -> h b
runApF :: forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApF f g b -> h b
runApF forall a. f a -> h a
_ forall a. g (h a) -> h a
_ (Pure b
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
runApF forall a. f a -> h a
f forall a. g (h a) -> h a
g (Ap f a
x ApT f g (a -> b)
y) = forall a. f a -> h a
f f a
x forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT forall a. f a -> h a
f forall a. g (h a) -> h a
g ApT f g (a -> b)
y

-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives

-- a natural transformation @ApT f g ~> h@.

runApT :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT :: forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT forall a. f a -> h a
f forall a. g (h a) -> h a
g (ApT g (ApF f g b)
a) = forall a. g (h a) -> h a
g (forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApF f g b -> h b
runApF forall a. f a -> h a
f forall a. g (h a) -> h a
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g b)
a)

-- | Perform a monoidal analysis over @'ApT' f g b@ value.

--

-- Examples:

--

-- @

-- height :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'

-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum'

-- @

--

-- @

-- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'

-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.fold'

-- @

runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m
runApT_ :: forall (g :: * -> *) m (f :: * -> *) b.
(Functor g, Monoid m) =>
(forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m
runApT_ forall a. f a -> m
f g m -> m
g = forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT (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) (forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. g m -> m
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (b :: k). Const a b -> a
getConst)

-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f' g@.

hoistApF :: Functor g => (forall a. f a -> f' a) -> ApF f g b -> ApF f' g b
hoistApF :: forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApF f g b -> ApF f' g b
hoistApF forall a. f a -> f' a
_ (Pure b
x) = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure b
x
hoistApF forall a. f a -> f' a
f (Ap f a
x ApT f g (a -> b)
y) = forall a. f a -> f' a
f f a
x forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApT f g b -> ApT f' g b
hoistApT forall a. f a -> f' a
f ApT f g (a -> b)
y

-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f' g@.

hoistApT :: Functor g => (forall a. f a -> f' a) -> ApT f g b -> ApT f' g b
hoistApT :: forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApT f g b -> ApT f' g b
hoistApT forall a. f a -> f' a
f (ApT g (ApF f g b)
g) = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (forall (g :: * -> *) (f :: * -> *) (f' :: * -> *) b.
Functor g =>
(forall a. f a -> f' a) -> ApF f g b -> ApF f' g b
hoistApF forall a. f a -> f' a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g b)
g)

-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f g'@.

transApF :: Functor g => (forall a. g a -> g' a) -> ApF f g b -> ApF f g' b
transApF :: forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApF f g b -> ApF f g' b
transApF forall a. g a -> g' a
_ (Pure b
x) = forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure b
x
transApF forall a. g a -> g' a
f (Ap f a
x ApT f g (a -> b)
y) = f a
x forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApT f g b -> ApT f g' b
transApT forall a. g a -> g' a
f ApT f g (a -> b)
y

-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f g'@.

transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b
transApT :: forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApT f g b -> ApT f g' b
transApT forall a. g a -> g' a
f (ApT g (ApF f g b)
g) = forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT forall a b. (a -> b) -> a -> b
$ forall a. g a -> g' a
f (forall (g :: * -> *) (g' :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. g a -> g' a) -> ApF f g b -> ApF f g' b
transApF forall a. g a -> g' a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g b)
g)

-- | Pull out and join @m@ layers of @'ApT' f m a@.

joinApT :: Monad m => ApT f m a -> m (Ap f a)
joinApT :: forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
ApT f m a -> m (Ap f a)
joinApT (ApT m (ApF f m a)
m) = m (ApF f m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {f :: * -> *} {a}.
Monad m =>
ApF f m a -> m (ApT f Identity a)
joinApF
  where
    joinApF :: ApF f m a -> m (ApT f Identity a)
joinApF (Pure a
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
    joinApF (Ap f a
x ApT f m (a -> a)
y) = (forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
f a -> ApT f g a
liftApT f a
x forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**>) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
ApT f m a -> m (Ap f a)
joinApT ApT f m (a -> a)
y

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

type Ap f = ApT f Identity

-- | 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
f = forall (h :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Applicative h, Functor g) =>
(forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g b -> h b
runApT forall x. f x -> g x
f forall a. Identity a -> a
runIdentity

-- | Perform a monoidal analysis over free applicative value.

--

-- Example:

--

-- @

-- count :: 'Ap' f a -> 'Int'

-- count = 'getSum' . runAp_ (\\_ -> 'Sum' 1)

-- @

runAp_ :: Monoid m => (forall x. f x -> m) -> Ap f a -> m
runAp_ :: forall m (f :: * -> *) a.
Monoid m =>
(forall x. f x -> m) -> Ap f a -> m
runAp_ forall x. f x -> m
f = forall (g :: * -> *) m (f :: * -> *) b.
(Functor g, Monoid m) =>
(forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m
runApT_ forall x. f x -> m
f forall a. Identity a -> a
runIdentity

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

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

type Alt f = ApT f []

-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@.

runAlt :: (Alternative g, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a
runAlt :: forall (g :: * -> *) (t :: * -> *) (f :: * -> *) a.
(Alternative g, Foldable t) =>
(forall x. f x -> g x) -> ApT f t a -> g a
runAlt forall x. f x -> g x
f (ApT t (ApF f t a)
xs) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (\ApF f t a
x g a
acc -> ApF f t a -> g a
h ApF f t a
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g a
acc) forall (f :: * -> *) a. Alternative f => f a
empty t (ApF f t a)
xs
  where
    h :: ApF f t a -> g a
h (Pure a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    h (Ap f a
x ApT f t (a -> a)
g) = forall x. f x -> g x
f f a
x forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall (g :: * -> *) (t :: * -> *) (f :: * -> *) a.
(Alternative g, Foldable t) =>
(forall x. f x -> g x) -> ApT f t a -> g a
runAlt forall x. f x -> g x
f ApT f t (a -> a)
g

#if __GLASGOW_HASKELL__ < 707
instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where
  typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where
    f :: ApT f g a -> g (f a)
    f = undefined

instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where
  typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where
    f :: ApF f g a -> g (f a)
    f = undefined

apTTyCon, apFTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT"
apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF"
#else
apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT"
apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF"
#endif
{-# NOINLINE apTTyCon #-}
{-# NOINLINE apFTyCon #-}
#endif