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

    -}