{-# 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 { 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 :: (a -> b) -> ApF f g a -> ApF f g b
fmap a -> b
f (Pure a
a) = b -> ApF f g b
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 f a -> ApT f g (a -> b) -> ApF f g b
forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` ((a -> a) -> a -> b) -> ApT f g (a -> a) -> ApT f g (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f (a -> b) -> (a -> a) -> a -> b
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 :: (a -> b) -> ApT f g a -> ApT f g b
fmap a -> b
f (ApT g (ApF f g a)
g) = g (ApF f g b) -> ApT f g b
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT ((a -> b) -> ApF f g a -> ApF f g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ApF f g a -> ApF f g b) -> g (ApF f g a) -> g (ApF f g b)
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 :: a -> ApF f g a
pure = a -> ApF f g a
forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure
  {-# INLINE pure #-}
  Pure a -> b
f   <*> :: ApF f g (a -> b) -> ApF f g a -> ApF f g b
<*> ApF f g a
y       = (a -> b) -> ApF f g a -> ApF f g b
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  = ((a -> b) -> b) -> ApF f g (a -> b) -> ApF f g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
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 f a -> ApT f g (a -> b) -> ApF f g b
forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` ((a -> a -> b) -> a -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> b) -> a -> a -> b)
-> ApT f g (a -> a -> b) -> ApT f g (a -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApT f g (a -> a -> b)
f ApT f g (a -> a -> b) -> ApT f g a -> ApT f g (a -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> g (ApF f g a) -> ApT f g a
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (ApF f g a -> g (ApF f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ApF f g a
b))
  {-# INLINE (<*>) #-}

instance Applicative g => Applicative (ApT f g) where
  pure :: a -> ApT f g a
pure = g (ApF f g a) -> ApT f g a
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (g (ApF f g a) -> ApT f g a)
-> (a -> g (ApF f g a)) -> a -> ApT f g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApF f g a -> g (ApF f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApF f g a -> g (ApF f g a))
-> (a -> ApF f g a) -> a -> g (ApF f g a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ApF f g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  ApT g (ApF f g (a -> b))
xs <*> :: ApT f g (a -> b) -> ApT f g a -> ApT f g b
<*> ApT g (ApF f g a)
ys = g (ApF f g b) -> ApT f g b
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (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
(<*>) (ApF f g (a -> b) -> ApF f g a -> ApF f g b)
-> g (ApF f g (a -> b)) -> g (ApF f g a -> ApF f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (ApF f g (a -> b))
xs g (ApF f g a -> ApF f g b) -> g (ApF f g a) -> g (ApF f g b)
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
  <.> :: ApF f g (a -> b) -> ApF f g a -> ApF f g 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
  <.> :: ApT f g (a -> b) -> ApT f g a -> ApT f g 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 :: ApT f g a
empty = g (ApF f g a) -> ApT f g a
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT g (ApF f g a)
forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE empty #-}
  ApT g (ApF f g a)
g <|> :: ApT f g a -> ApT f g a -> ApT f g a
<|> ApT g (ApF f g a)
h = g (ApF f g a) -> ApT f g a
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (g (ApF f g a)
g g (ApF f g a) -> g (ApF f g a) -> g (ApF f g a)
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 :: f a -> ApT f g a
liftApT f a
x = g (ApF f g a) -> ApT f g a
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (ApF f g a -> g (ApF f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f a -> ApT f g (a -> a) -> ApF f g a
forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
Ap f a
x ((a -> a) -> ApT f g (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
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 :: g a -> ApT f g a
liftApO g a
g = g (ApF f g a) -> ApT f g a
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (a -> ApF f g a
forall a (f :: * -> *) (g :: * -> *). a -> ApF f g a
Pure (a -> ApF f g a) -> g a -> g (ApF f g a)
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 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) = b -> h b
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) = f a -> h a
forall a. f a -> h a
f f a
x h a -> h (a -> b) -> h b
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApT f g (a -> b) -> h (a -> 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 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) = g (h b) -> h b
forall a. g (h a) -> h a
g ((forall a. f a -> h a)
-> (forall a. g (h a) -> h a) -> ApF f g b -> h b
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 (ApF f g b -> h b) -> g (ApF f g b) -> g (h b)
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 a. f a -> m) -> (g m -> m) -> ApT f g b -> m
runApT_ forall a. f a -> m
f g m -> m
g = Const m b -> m
forall a k (b :: k). Const a b -> a
getConst (Const m b -> m) -> (ApT f g b -> Const m b) -> ApT f g b -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. f a -> Const m a)
-> (forall a. g (Const m a) -> Const m a) -> ApT f g b -> Const m 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 (m -> Const m a
forall k a (b :: k). a -> Const a b
Const (m -> Const m a) -> (f a -> m) -> f a -> Const m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> m
forall a. f a -> m
f) (m -> Const m a
forall k a (b :: k). a -> Const a b
Const (m -> Const m a)
-> (g (Const m a) -> m) -> g (Const m a) -> Const m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g m -> m
g (g m -> m) -> (g (Const m a) -> g m) -> g (Const m a) -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Const m a -> m) -> g (Const m a) -> g m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Const m a -> m
forall a k (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 a. f a -> f' a) -> ApF f g b -> ApF f' g b
hoistApF forall a. f a -> f' a
_ (Pure b
x) = b -> ApF f' g b
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) = f a -> f' a
forall a. f a -> f' a
f f a
x f' a -> ApT f' g (a -> b) -> ApF f' g b
forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` (forall a. f a -> f' a) -> ApT f g (a -> b) -> ApT f' g (a -> b)
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 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) = g (ApF f' g b) -> ApT f' g b
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT ((forall a. f a -> f' a) -> ApF f g b -> ApF f' g b
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 (ApF f g b -> ApF f' g b) -> g (ApF f g b) -> g (ApF f' g b)
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 a. g a -> g' a) -> ApF f g b -> ApF f g' b
transApF forall a. g a -> g' a
_ (Pure b
x) = b -> ApF f g' b
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 f a -> ApT f g' (a -> b) -> ApF f g' b
forall (f :: * -> *) a (g :: * -> *) b.
f a -> ApT f g (a -> b) -> ApF f g b
`Ap` (forall a. g a -> g' a) -> ApT f g (a -> b) -> ApT f g' (a -> b)
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 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) = g' (ApF f g' b) -> ApT f g' b
forall (f :: * -> *) (g :: * -> *) a. g (ApF f g a) -> ApT f g a
ApT (g' (ApF f g' b) -> ApT f g' b) -> g' (ApF f g' b) -> ApT f g' b
forall a b. (a -> b) -> a -> b
$ g (ApF f g' b) -> g' (ApF f g' b)
forall a. g a -> g' a
f ((forall a. g a -> g' a) -> ApF f g b -> ApF f g' b
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 (ApF f g b -> ApF f g' b) -> g (ApF f g b) -> g (ApF f g' b)
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 :: ApT f m a -> m (Ap f a)
joinApT (ApT m (ApF f m a)
m) = m (ApF f m a)
m m (ApF f m a) -> (ApF f m a -> m (Ap f a)) -> m (Ap f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ApF f m a -> m (Ap f a)
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) = ApT f Identity a -> m (ApT f Identity a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ApT f Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
    joinApF (Ap f a
x ApT f m (a -> a)
y) = (f a -> ApT f Identity a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
f a -> ApT f g a
liftApT f a
x ApT f Identity a -> ApT f Identity (a -> a) -> ApT f Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**>) (ApT f Identity (a -> a) -> ApT f Identity a)
-> m (ApT f Identity (a -> a)) -> m (ApT f Identity a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ApT f m (a -> a) -> m (ApT f Identity (a -> a))
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 x. f x -> g x) -> Ap f a -> g a
runAp forall x. f x -> g x
f = (forall x. f x -> g x)
-> (forall a. Identity (g a) -> g a) -> Ap f a -> g a
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
forall a. Identity (g a) -> g 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 x. f x -> m) -> Ap f a -> m
runAp_ forall x. f x -> m
f = (forall x. f x -> m) -> (Identity m -> m) -> Ap f a -> m
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 Identity m -> m
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 :: Ap f a -> f a
retractAp = (forall x. f x -> f x) -> Ap f a -> f a
forall (g :: * -> *) (f :: * -> *) a.
Applicative g =>
(forall x. f x -> g x) -> Ap f a -> g a
runAp forall a. a -> a
forall x. f x -> f x
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 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) = (ApF f t a -> g a -> g a) -> g a -> t (ApF f t a) -> g a
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 g a -> g a -> g a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g a
acc) g a
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) = a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    h (Ap f a
x ApT f t (a -> a)
g) = f a -> g a
forall x. f x -> g x
f f a
x g a -> g (a -> a) -> g a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (forall x. f x -> g x) -> ApT f t (a -> a) -> g (a -> a)
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