{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- 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.Foldable
import Data.Semigroup.Foldable
import Data.Functor.Classes

import Prelude hiding (null)

-- | 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

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

instance Applicative (Ap f) where
  pure :: forall a. a -> Ap f a
pure = a -> Ap f a
forall a (f :: * -> *). a -> Ap f a
Pure
  Pure a -> b
f <*> :: forall a b. Ap f (a -> b) -> Ap f a -> Ap f b
<*> Ap f a
y = (a -> b) -> Ap f a -> Ap f b
forall a b. (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 a b. Ap f (a -> b) -> Ap f a -> Ap f 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 :: forall a. 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 a. Ap f a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract Ap f (a -> a)
y (f a -> a
forall a. f a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract f a
x)
  duplicate :: forall a. 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 a. 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 a b. (Ap f a -> b) -> Ap f a -> Ap f b
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)

-- | @foldMap f == foldMap f . 'runAp' 'Data.Foldable.toList'@
instance Foldable f => Foldable (Ap f) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Ap f a -> m
foldMap a -> m
f (Pure a
a) = a -> m
f a
a
  foldMap a -> m
f (Ap f a
x Ap f (a -> a)
y) = (a -> m) -> f a -> m
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\a
a -> ((a -> a) -> m) -> Ap f (a -> a) -> m
forall m a. Monoid m => (a -> m) -> Ap f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\a -> a
g -> a -> m
f (a -> a
g a
a)) Ap f (a -> a)
y) f a
x

  null :: forall a. Ap f a -> Bool
null (Pure a
_) = Bool
False
  null (Ap f a
x Ap f (a -> a)
y) = f a -> Bool
forall a. f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f a
x Bool -> Bool -> Bool
|| Ap f (a -> a) -> Bool
forall a. Ap f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Ap f (a -> a)
y

  length :: forall a. Ap f a -> Int
length = Int -> Ap f a -> Int
forall (t :: * -> *) a. Foldable t => Int -> Ap t a -> Int
go Int
1
    where
      -- This type annotation is required to do polymorphic recursion
      go :: Foldable t => Int -> Ap t a -> Int
      go :: forall (t :: * -> *) a. Foldable t => Int -> Ap t a -> Int
go Int
n (Pure a
_) = Int
n
      go Int
n (Ap t a
x Ap t (a -> a)
y) = case Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
x of
        Int
0  -> Int
0
        Int
n' -> Int -> Ap t (a -> a) -> Int
forall (t :: * -> *) a. Foldable t => Int -> Ap t a -> Int
go Int
n' Ap t (a -> a)
y

-- | @foldMap f == foldMap f . 'runAp' 'toNonEmpty'@
instance Foldable1 f => Foldable1 (Ap f) where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> Ap f a -> m
foldMap1 a -> m
f (Pure a
a) = a -> m
f a
a
  foldMap1 a -> m
f (Ap f a
x Ap f (a -> a)
y) = (a -> m) -> f a -> m
forall m a. Semigroup m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (\a
a -> ((a -> a) -> m) -> Ap f (a -> a) -> m
forall m a. Semigroup m => (a -> m) -> Ap f a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (\a -> a
g -> a -> m
f (a -> a
g a
a)) Ap f (a -> a)
y) f a
x


{- $note_eq1

This comment section is an internal documentation, but written in proper
Haddock markup. It is to allow rendering them to ease reading this rather long document.

=== About the definition of @Eq1 (Ap f)@ instance

The @Eq1 (Ap f)@ instance below has a complex definition. This comment
explains why it is defined like that.

The discussion given here also applies to @Ord1 (Ap f)@ instance with a little change.

==== General discussion about @Eq1@ type class

Currently, there isn't a law on the @Eq1@ type class, but the following
properties can be expected.

* If @Eq (f ())@, and @Functor f@ holds, @Eq1 f@ satisfies

    > liftEq (\_ _ -> True) x y == (() <$ x) == (() <$ y)

* If @Foldable f@ holds, @Eq1 f@ satisfies:

    * @boringEq x y@ implies @length (toList x) == length (toList y)@

    * @liftEq eq x y == liftEq (\_ _ -> True) && all (\(a,b) -> eq a b)) (zip (toList x) (toList y))@

Let's define the commonly used function @liftEq (\\_ _ -> True)@ as @boringEq@.

> boringEq :: Eq1 f => f a -> f b -> Bool
> boringEq = liftEq (\_ _ -> True)

Changing the constant @True@ to the constant @False@ in the definition of
@boringEq@, let @emptyEq@ function be defined as:

> emptyEq :: Eq1 f => f a -> f b -> Bool
> emptyEq = liftEq (\_ _ -> False)

From the above properties expectated on a @Eq1@ instance, @emptyEq@ satisfies the following.

> emptyEq x y = boringEq x y && null (zip (toList x) (toList y))

==== About @instance (Eq1 (Ap f))@

If we're to define @Eq1 (Ap f)@ satisfying these properties as expected, @Eq (Ap f ())@ will determine
how @liftEq@ should behave. It's not unreasonable to define equality between @Ap f ()@ as below.

> boringEqAp (Pure _) (Pure _) = True
> boringEqAp (Ap x1 y1) (Ap x2 y2) = boringEq x1 x2 && boringEqAp y1 y2
>    {-  = ((() <$ x1) == (() <$ x2)) && (y1 == y2)  -}
> boringEqAp _ _ = False

Its type can be more general than equality between @Ap f ()@:

> boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool

Using @boringEqAp@, the specification of @liftEq@ will be:

> liftEq eq x y = boringEqAp x y && and (zipWith eq (toList x) (toList y))

Then unfold @toList@ to remove the dependency to @Foldable@.

> liftEq eq (Pure a1) (Pure a2)
>   = boringEqAp (Pure a1) (Pure a2) && all (\(a,b) -> eq a b)) (zip (toList (Pure x)) (toList Pure y))
>   = True && all (\(a,b) -> eq a b) (zip [a1] [a2])
>   = eq a1 a2
> liftEq eq (Ap x1 y1) (Ap x2 y2)
>   = boringEqAp (Ap x1 y1) (Ap x2 y2) && all (\(b1, b2) -> eq b1 b2) (zip (toList (Ap x1 y1)) (toList (Ap x2 y2)))
>   = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (toList x1 <**> toList y1) (toList x2 <**> toList y2))
>   = boringEq x1 y1 && boringEqAp y1 y2 && all (\(b1, b2) -> eq b1 b2) (zip (as1 <**> gs1) (as2 <**> gs2))
>        where as1 = toList x1
>              as2 = toList x2
>              gs1 = toList y1
>              gs2 = toList y2
>   = boringEq x1 y1 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)

If @zip as1 as2@ is /not/ empty, the following transformation is valid.

> (...) | not (null (zip as1 as2))
>   = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)
>   = boringEq x1 x2 && all (\(a1, a2) -> boringEqAp y1 y2 && all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)
> --                                      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
>   = boringEq x1 x2 && all (\(a1, a2) -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2) (zip as1 as2)
>   = liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2

Because, generally, the following transformation is valid if @xs@ is a nonempty list.

> cond && all p xs = all (\x -> cond && p x) xs -- Only when xs is not empty!

If @zip as1 as2@ is empty, @all (...) (zip as1 as2)@ is vacuously true, so the following transformation is valid.

> (...) | null (zip as1 as2)
>   = boringEq x1 x2 && boringEqAp y1 y2 && all (\(a1, a2) -> all (\(g1, g2) -> eq (g1 a1) (g2 a2)) (zip gs1 gs2)) (zip as1 as2)
>   = boringEq x1 x2 && boringEqAp y1 y2

Combining two cases:

> liftEq eq (Ap x1 y1) (Ap x2 y2)
>   = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2
>       || not (null (zip as1 as2)) && liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2
>   = null (zip as1 as2) && boringEq x1 x2 && boringEqAp y1 y2
>       || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2
>   = emptyEq x1 x2 && boringEqAp y1 y2
>       || liftEq (\a1 a2 -> liftEq (\g1 g2 -> eq (g1 a1) (g2 a2)) y1 y2)) x1 x2

The property about @emptyEq@ is used in the last equation.

Hence it's defined as this source code.

-}

-- | Specialized 'boringEq' for @Ap f@.
boringEqAp :: Eq1 f => Ap f a -> Ap f b -> Bool
boringEqAp :: forall (f :: * -> *) a b. Eq1 f => Ap f a -> Ap f b -> Bool
boringEqAp (Pure a
_) (Pure b
_) = Bool
True
boringEqAp (Ap f a
x1 Ap f (a -> a)
y1) (Ap f a
x2 Ap f (a -> b)
y2) = f a -> f a -> Bool
forall (f :: * -> *) a b. Eq1 f => f a -> f b -> Bool
boringEq f a
x1 f a
x2 Bool -> Bool -> Bool
&& Ap f (a -> a) -> Ap f (a -> b) -> Bool
forall (f :: * -> *) a b. Eq1 f => Ap f a -> Ap f b -> Bool
boringEqAp Ap f (a -> a)
y1 Ap f (a -> b)
y2
boringEqAp Ap f a
_ Ap f b
_ = Bool
False

-- | Implementaion of 'liftEq' for @Ap f@.
liftEqAp :: Eq1 f => (a -> b -> Bool) -> Ap f a -> Ap f b -> Bool
liftEqAp :: forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> Ap f a -> Ap f b -> Bool
liftEqAp a -> b -> Bool
eq (Pure a
a1) (Pure b
a2) = a -> b -> Bool
eq a
a1 b
a2
liftEqAp a -> b -> Bool
eq (Ap f a
x1 Ap f (a -> a)
y1) (Ap f a
x2 Ap f (a -> b)
y2)
    -- This branching is necessary and not just an optimization.
    -- See the above comment for more
  | f a -> f a -> Bool
forall (f :: * -> *) a b. Eq1 f => f a -> f b -> Bool
emptyEq f a
x1 f a
x2 = Ap f (a -> a) -> Ap f (a -> b) -> Bool
forall (f :: * -> *) a b. Eq1 f => Ap f a -> Ap f b -> Bool
boringEqAp Ap f (a -> a)
y1 Ap f (a -> b)
y2
  | Bool
otherwise =
      (a -> a -> Bool) -> f a -> f a -> Bool
forall a b. (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (\a
a1 a
a2 -> ((a -> a) -> (a -> b) -> Bool)
-> Ap f (a -> a) -> Ap f (a -> b) -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> Ap f a -> Ap f b -> Bool
liftEqAp (\a -> a
g1 a -> b
g2 -> a -> b -> Bool
eq (a -> a
g1 a
a1) (a -> b
g2 a
a2)) Ap f (a -> a)
y1 Ap f (a -> b)
y2) f a
x1 f a
x2
liftEqAp a -> b -> Bool
_ Ap f a
_ Ap f b
_ = Bool
False

-- | @boringEq fa fb@ tests if @fa@ and @fb@ are equal ignoring any difference between
--   their content (the values of their last parameters @a@ and @b@.)
--
--   It is named \'boring\' because the type parameters @a@ and @b@ are
--   treated as if they are the most boring type @()@.
boringEq :: Eq1 f => f a -> f b -> Bool
boringEq :: forall (f :: * -> *) a b. Eq1 f => f a -> f b -> Bool
boringEq = (a -> b -> Bool) -> f a -> f b -> Bool
forall a b. (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (\a
_ b
_ -> Bool
True)

-- | @emptyEq fa fb@ tests if @fa@ and @fb@ are equal /and/ they don't have any content
--   (the values of their last parameters @a@ and @b@.)
--
--   It is named \'empty\' because it only tests for values without any content,
--   like an empty list or @Nothing@.
--
--   If @f@ is also @Foldable@, @emptyEq fa fb@ would be equivalent to
--   @null fa && null fb && liftEq eq@ for any @eq :: a -> b -> Bool@.
--
--   (It depends on each instance of @Eq1@. Since @Eq1@ does not have
--   any laws currently, this is not a hard guarantee. But all instances in "base", "transformers",
--   "containers", "array", and "free" satisfy it.)
--
--   Note that @emptyEq@ is not a equivalence relation, since it's possible @emptyEq x x == False@.
emptyEq :: Eq1 f => f a -> f b -> Bool
emptyEq :: forall (f :: * -> *) a b. Eq1 f => f a -> f b -> Bool
emptyEq = (a -> b -> Bool) -> f a -> f b -> Bool
forall a b. (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (\a
_ b
_ -> Bool
False)

instance Eq1 f => Eq1 (Ap f) where
  liftEq :: forall a b. (a -> b -> Bool) -> Ap f a -> Ap f b -> Bool
liftEq = (a -> b -> Bool) -> Ap f a -> Ap f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> Ap f a -> Ap f b -> Bool
liftEqAp

instance (Eq1 f, Eq a) => Eq (Ap f a) where
  == :: Ap f a -> Ap f a -> Bool
(==) = Ap f a -> Ap f a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

-- | Specialized 'boringCompare' for @Ap f@.
boringCompareAp :: Ord1 f => Ap f a -> Ap f b -> Ordering
boringCompareAp :: forall (f :: * -> *) a b. Ord1 f => Ap f a -> Ap f b -> Ordering
boringCompareAp (Pure a
_) (Pure b
_) = Ordering
EQ
boringCompareAp (Pure a
_) (Ap f a
_ Ap f (a -> b)
_) = Ordering
LT
boringCompareAp (Ap f a
x1 Ap f (a -> a)
y1) (Ap f a
x2 Ap f (a -> b)
y2) = f a -> f a -> Ordering
forall (f :: * -> *) a b. Ord1 f => f a -> f b -> Ordering
boringCompare f a
x1 f a
x2 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Ap f (a -> a) -> Ap f (a -> b) -> Ordering
forall (f :: * -> *) a b. Ord1 f => Ap f a -> Ap f b -> Ordering
boringCompareAp Ap f (a -> a)
y1 Ap f (a -> b)
y2
boringCompareAp (Ap f a
_ Ap f (a -> a)
_) (Pure b
_) = Ordering
GT

-- | Implementation of 'liftCompare' for @Ap f@
liftCompareAp :: Ord1 f => (a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering
liftCompareAp :: forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering
liftCompareAp a -> b -> Ordering
cmp (Pure a
a1) (Pure b
a2) = a -> b -> Ordering
cmp a
a1 b
a2
liftCompareAp a -> b -> Ordering
_   (Pure a
_) (Ap f a
_ Ap f (a -> b)
_) = Ordering
LT
liftCompareAp a -> b -> Ordering
cmp (Ap f a
x1 Ap f (a -> a)
y1) (Ap f a
x2 Ap f (a -> b)
y2)
    -- This branching is necessary and not just an optimization.
    -- See the above comment for more
  | f a -> f a -> Bool
forall (f :: * -> *) a b. Eq1 f => f a -> f b -> Bool
emptyEq f a
x1 f a
x2 = Ap f (a -> a) -> Ap f (a -> b) -> Ordering
forall (f :: * -> *) a b. Ord1 f => Ap f a -> Ap f b -> Ordering
boringCompareAp Ap f (a -> a)
y1 Ap f (a -> b)
y2
  | Bool
otherwise     = (a -> a -> Ordering) -> f a -> f a -> Ordering
forall a b. (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (\a
a1 a
a2 -> ((a -> a) -> (a -> b) -> Ordering)
-> Ap f (a -> a) -> Ap f (a -> b) -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering
liftCompareAp (\a -> a
g1 a -> b
g2 -> a -> b -> Ordering
cmp (a -> a
g1 a
a1) (a -> b
g2 a
a2)) Ap f (a -> a)
y1 Ap f (a -> b)
y2) f a
x1 f a
x2
liftCompareAp a -> b -> Ordering
_   (Ap f a
_ Ap f (a -> a)
_) (Pure b
_) = Ordering
GT

-- | @boringCompare fa fb@ compares @fa@ and @fb@ ignoring any difference between
--   their content (the values of their last parameters @a@ and @b@.)
--
--   It is named \'boring\' because the type parameters @a@ and @b@ are
--   treated as if they are the most boring type @()@.
boringCompare :: Ord1 f => f a -> f b -> Ordering
boringCompare :: forall (f :: * -> *) a b. Ord1 f => f a -> f b -> Ordering
boringCompare = (a -> b -> Ordering) -> f a -> f b -> Ordering
forall a b. (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (\a
_ b
_ -> Ordering
EQ)

instance Ord1 f => Ord1 (Ap f) where
  liftCompare :: forall a b. (a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering
liftCompare = (a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> Ap f a -> Ap f b -> Ordering
liftCompareAp

instance (Ord1 f, Ord a) => Ord (Ap f a) where
  compare :: Ap f a -> Ap f a -> Ordering
compare = Ap f a -> Ap f a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

-- | 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 = 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 :: forall (g :: * -> *) a. Functor g => (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 a b. Ap g (a -> b) -> Ap g a -> Ap g b
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 a. 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 (f :: * -> *) (g :: * -> *) b.
(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 f a -> g a
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 :: forall (f :: * -> *) a. Applicative f => Ap f a -> f a
retractAp (Pure a
a) = a -> f a
forall 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

{- $examples

<examples/ValidationForm.hs Validation form>

-}