    {-# LANGUAGE CPP                #-}
    {-# LANGUAGE GADTs              #-}
    {-# LANGUAGE RankNTypes         #-}
    #if __GLASGOW_HASKELL__ >= 707
    {-# LANGUAGE DeriveDataTypeable #-}
    #endif
    {-# OPTIONS_GHC -Wall #-}

    #ifndef MIN_VERSION_base
    #define MIN_VERSION_base(x,y,z) 1
    #endif
    --------------------------------------------------------------------------------
    -- |
    -- A faster free applicative.
    -- Based on <https://www.eyrie.org/~zednenem/2013/05/27/freeapp Dave Menendez's work>.
    --------------------------------------------------------------------------------
    module Control.Applicative.Free.Fast
      (
      -- * The Sequence of Effects
        ASeq(..)
      , reduceASeq
      , hoistASeq
      , traverseASeq
      , rebaseASeq
      -- * The Faster Free Applicative
      , Ap(..)
      , liftAp
      , retractAp
      , runAp
      , runAp_
      , hoistAp
      ) where

    import           Control.Applicative
    import           Data.Functor.Apply
    import           Data.Typeable

    #if !(MIN_VERSION_base(4,8,0))
    import           Data.Monoid
    #endif

    -- | The free applicative is composed of a sequence of effects,
    -- and a pure function to apply that sequence to.
    -- The fast free applicative separates these from each other,
    -- so that the sequence may be built up independently,
    -- and so that 'fmap' can run in constant time by having immediate access to the pure function.
    data ASeq f a where
      ANil :: ASeq f ()
      ACons :: f a -> ASeq f u -> ASeq f (a,u)
    #if __GLASGOW_HASKELL__ >= 707
      deriving Typeable
    #endif

    -- | Interprets the sequence of effects using the semantics for
    --   `pure` and `<*>` given by the Applicative instance for 'f'.
    reduceASeq :: Applicative f => ASeq f u -> f u
    reduceASeq :: ASeq f u -> f u
    reduceASeq ANil         = () -> f ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
    reduceASeq (ACons x :: f a
    x xs :: ASeq f u
    xs) = (,) (a -> u -> (a, u)) -> f a -> f (u -> (a, u))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> f a
    x f (u -> (a, u)) -> f u -> f (a, u)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> ASeq f u -> f u
    forall (f :: * -> *) u. Applicative f => ASeq f u -> f u
    reduceASeq ASeq f u
    xs

    -- | Given a natural transformation from @f@ to @g@ this gives a natural transformation from @ASeq f@ to @ASeq g@.
    hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a
    hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a
    hoistASeq _ ANil = ASeq g a
    forall (f :: * -> *). ASeq f ()
    ANil
    hoistASeq u :: forall x. f x -> g x
    u (ACons x :: f a
    x xs :: ASeq f u
    xs) = g a -> ASeq g u -> ASeq g (a, u)
    forall (f :: * -> *) a u. f a -> ASeq f u -> ASeq f (a, u)
    ACons (f a -> g a
    forall x. f x -> g x
    u f a
    x) (forall x. f x -> g x
    u (forall x. f x -> g x) -> ASeq f u -> ASeq g u
    forall (f :: * -> *) (g :: * -> *) a.
    (forall x. f x -> g x) -> ASeq f a -> ASeq g a
    `hoistASeq` ASeq f u
    xs)

    -- | Traverse a sequence with resepect to its interpretation type 'f'.
    traverseASeq :: Applicative h => (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a)
    traverseASeq :: (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a)
    traverseASeq _ ANil      = ASeq g () -> h (ASeq g ())
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ASeq g ()
    forall (f :: * -> *). ASeq f ()
    ANil
    traverseASeq f :: forall x. f x -> h (g x)
    f (ACons x :: f a
    x xs :: ASeq f u
    xs) = g a -> ASeq g u -> ASeq g (a, u)
    forall (f :: * -> *) a u. f a -> ASeq f u -> ASeq f (a, u)
    ACons (g a -> ASeq g u -> ASeq g (a, u))
    -> h (g a) -> h (ASeq g u -> ASeq g (a, u))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> f a -> h (g a)
    forall x. f x -> h (g x)
    f f a
    x h (ASeq g u -> ASeq g (a, u)) -> h (ASeq g u) -> h (ASeq g (a, u))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> (forall x. f x -> h (g x)) -> ASeq f u -> h (ASeq g u)
    forall (h :: * -> *) (f :: * -> *) (g :: * -> *) a.
    Applicative h =>
    (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a)
    traverseASeq forall x. f x -> h (g x)
    f ASeq f u
    xs

    -- | It may not be obvious, but this essentially acts like ++,
    -- traversing the first sequence and creating a new one by appending the second sequence.
    -- The difference is that this also has to modify the return functions and that the return type depends on the input types.
    --
    -- See the source of 'hoistAp' as an example usage.
    rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) ->
      (v -> u -> y) -> ASeq f v -> z
    rebaseASeq :: ASeq f u
    -> (forall x. (x -> y) -> ASeq f x -> z)
    -> (v -> u -> y)
    -> ASeq f v
    -> z
    rebaseASeq ANil         k :: forall x. (x -> y) -> ASeq f x -> z
    k f :: v -> u -> y
    f = (v -> y) -> ASeq f v -> z
    forall x. (x -> y) -> ASeq f x -> z
    k (\v :: v
    v -> v -> u -> y
    f v
    v ())
    rebaseASeq (ACons x :: f a
    x xs :: ASeq f u
    xs) k :: forall x. (x -> y) -> ASeq f x -> z
    k f :: v -> u -> y
    f =
      ASeq f u
    -> (forall x. (x -> a -> y) -> ASeq f x -> z)
    -> (v -> u -> a -> y)
    -> ASeq f v
    -> z
    forall (f :: * -> *) u y z v.
    ASeq f u
    -> (forall x. (x -> y) -> ASeq f x -> z)
    -> (v -> u -> y)
    -> ASeq f v
    -> z
    rebaseASeq ASeq f u
    xs (\g :: x -> a -> y
    g s :: ASeq f x
    s -> ((a, x) -> y) -> ASeq f (a, x) -> z
    forall x. (x -> y) -> ASeq f x -> z
    k (\(a :: a
    a,u :: x
    u) -> x -> a -> y
    g x
    u a
    a) (f a -> ASeq f x -> ASeq f (a, x)
    forall (f :: * -> *) a u. f a -> ASeq f u -> ASeq f (a, u)
    ACons f a
    x ASeq f x
    s))
        (\v :: v
    v u :: u
    u a :: a
    a -> v -> u -> y
    f v
    v (a
    a,u
    u))

    -- | The faster free 'Applicative'.
    newtype Ap f a = Ap
      { Ap f a
    -> forall u y z.
       (forall x. (x -> y) -> ASeq f x -> z)
       -> (u -> a -> y) -> ASeq f u -> z
    unAp :: forall u y z.
        (forall x. (x -> y) -> ASeq f x -> z) ->
        (u -> a -> y) -> ASeq f u -> z }
    #if __GLASGOW_HASKELL__ >= 707
      deriving Typeable
    #endif

    -- | 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 u :: forall x. f x -> g x
    u = Ap g a -> g a
    forall (f :: * -> *) a. Applicative f => Ap f a -> f a
    retractAp (Ap g a -> g a) -> (Ap f a -> Ap g a) -> Ap f a -> g a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (forall x. f x -> g x) -> Ap f a -> Ap g a
    forall (f :: * -> *) (g :: * -> *) a.
    (forall x. f x -> g x) -> Ap f a -> Ap g a
    hoistAp forall x. f x -> g x
    u

    -- | 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_ f :: 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 g :: a -> b
    g x :: Ap f a
    x = (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> b -> y) -> ASeq f u -> z)
    -> Ap f b
    forall (f :: * -> *) a.
    (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> a -> y) -> ASeq f u -> z)
    -> Ap f a
    Ap (\k :: forall x. (x -> y) -> ASeq f x -> z
    k f :: u -> b -> y
    f -> Ap f a
    -> (forall x. (x -> y) -> ASeq f x -> z)
    -> (u -> a -> y)
    -> ASeq f u
    -> z
    forall (f :: * -> *) a.
    Ap f a
    -> forall u y z.
       (forall x. (x -> y) -> ASeq f x -> z)
       -> (u -> a -> y) -> ASeq f u -> z
    unAp Ap f a
    x forall x. (x -> y) -> ASeq f x -> z
    k (\s :: u
    s -> u -> b -> y
    f u
    s (b -> y) -> (a -> b) -> a -> y
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> b
    g))

    instance Apply (Ap f) where
      <.> :: Ap f (a -> b) -> Ap f a -> Ap f b
    (<.>) = Ap f (a -> b) -> Ap f a -> Ap f b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    (<*>)

    instance Applicative (Ap f) where
      pure :: a -> Ap f a
    pure a :: a
    a = (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> a -> y) -> ASeq f u -> z)
    -> Ap f a
    forall (f :: * -> *) a.
    (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> a -> y) -> ASeq f u -> z)
    -> Ap f a
    Ap (\k :: forall x. (x -> y) -> ASeq f x -> z
    k f :: u -> a -> y
    f -> (u -> y) -> ASeq f u -> z
    forall x. (x -> y) -> ASeq f x -> z
    k (u -> a -> y
    `f` a
    a))
      x :: Ap f (a -> b)
    x <*> :: Ap f (a -> b) -> Ap f a -> Ap f b
    <*> y :: Ap f a
    y = (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> b -> y) -> ASeq f u -> z)
    -> Ap f b
    forall (f :: * -> *) a.
    (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> a -> y) -> ASeq f u -> z)
    -> Ap f a
    Ap (\k :: forall x. (x -> y) -> ASeq f x -> z
    k f :: u -> b -> y
    f -> Ap f a
    -> (forall x. (x -> (a -> b) -> y) -> ASeq f x -> z)
    -> (u -> a -> (a -> b) -> y)
    -> ASeq f u
    -> z
    forall (f :: * -> *) a.
    Ap f a
    -> forall u y z.
       (forall x. (x -> y) -> ASeq f x -> z)
       -> (u -> a -> y) -> ASeq f u -> z
    unAp Ap f a
    y (Ap f (a -> b)
    -> (forall x. (x -> y) -> ASeq f x -> z)
    -> (x -> (a -> b) -> y)
    -> ASeq f x
    -> z
    forall (f :: * -> *) a.
    Ap f a
    -> forall u y z.
       (forall x. (x -> y) -> ASeq f x -> z)
       -> (u -> a -> y) -> ASeq f u -> z
    unAp Ap f (a -> b)
    x forall x. (x -> y) -> ASeq f x -> z
    k) (\s :: u
    s a :: a
    a g :: a -> b
    g -> u -> b -> y
    f u
    s (a -> b
    g a
    a)))

    -- | 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 a :: f a
    a = (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> a -> y) -> ASeq f u -> z)
    -> Ap f a
    forall (f :: * -> *) a.
    (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> a -> y) -> ASeq f u -> z)
    -> Ap f a
    Ap (\k :: forall x. (x -> y) -> ASeq f x -> z
    k f :: u -> a -> y
    f s :: ASeq f u
    s -> ((a, u) -> y) -> ASeq f (a, u) -> z
    forall x. (x -> y) -> ASeq f x -> z
    k (\(a' :: a
    a',s' :: u
    s') -> u -> a -> y
    f u
    s' a
    a') (f a -> ASeq f u -> ASeq f (a, u)
    forall (f :: * -> *) a u. f a -> ASeq f u -> ASeq f (a, u)
    ACons f a
    a ASeq f u
    s))
    {-# INLINE liftAp #-}

    -- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.
    hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a
    hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a
    hoistAp g :: forall x. f x -> g x
    g x :: Ap f a
    x = (forall u y z.
     (forall x. (x -> y) -> ASeq g x -> z)
     -> (u -> a -> y) -> ASeq g u -> z)
    -> Ap g a
    forall (f :: * -> *) a.
    (forall u y z.
     (forall x. (x -> y) -> ASeq f x -> z)
     -> (u -> a -> y) -> ASeq f u -> z)
    -> Ap f a
    Ap (\k :: forall x. (x -> y) -> ASeq g x -> z
    k f :: u -> a -> y
    f s :: ASeq g u
    s ->
      Ap f a
    -> (forall x. (x -> a) -> ASeq f x -> z)
    -> (() -> a -> a)
    -> ASeq f ()
    -> z
    forall (f :: * -> *) a.
    Ap f a
    -> forall u y z.
       (forall x. (x -> y) -> ASeq f x -> z)
       -> (u -> a -> y) -> ASeq f u -> z
    unAp Ap f a
    x
        (\f' :: x -> a
    f' s' :: ASeq f x
    s' ->
          ASeq g x
    -> (forall x. (x -> y) -> ASeq g x -> z)
    -> (u -> x -> y)
    -> ASeq g u
    -> z
    forall (f :: * -> *) u y z v.
    ASeq f u
    -> (forall x. (x -> y) -> ASeq f x -> z)
    -> (v -> u -> y)
    -> ASeq f v
    -> z
    rebaseASeq ((forall x. f x -> g x) -> ASeq f x -> ASeq g x
    forall (f :: * -> *) (g :: * -> *) a.
    (forall x. f x -> g x) -> ASeq f a -> ASeq g a
    hoistASeq forall x. f x -> g x
    g ASeq f x
    s') forall x. (x -> y) -> ASeq g x -> z
    k
            (\v :: u
    v u :: x
    u -> u -> a -> y
    f u
    v (x -> a
    f' x
    u)) ASeq g u
    s)
        ((a -> a) -> () -> a -> a
    forall a b. a -> b -> a
    const a -> a
    forall a. a -> a
    id)
        ASeq f ()
    forall (f :: * -> *). ASeq f ()
    ANil)

    -- | 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 x :: Ap f a
    x = Ap f a
    -> (forall x. (x -> a) -> ASeq f x -> f a)
    -> (() -> a -> a)
    -> ASeq f ()
    -> f a
    forall (f :: * -> *) a.
    Ap f a
    -> forall u y z.
       (forall x. (x -> y) -> ASeq f x -> z)
       -> (u -> a -> y) -> ASeq f u -> z
    unAp Ap f a
    x (\f :: x -> a
    f s :: ASeq f x
    s -> x -> a
    f (x -> a) -> f x -> f a
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ASeq f x -> f x
    forall (f :: * -> *) u. Applicative f => ASeq f u -> f u
    reduceASeq ASeq f x
    s) (\() -> a -> a
    forall a. a -> a
    id) ASeq f ()
    forall (f :: * -> *). ASeq f ()
    ANil

    #if __GLASGOW_HASKELL__ < 707
    instance Typeable1 f => Typeable1 (Ap f) where
      typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where
        f :: Ap f a -> f a
        f = undefined

    apTyCon :: TyCon
    #if __GLASGOW_HASKELL__ < 704
    apTyCon = mkTyCon "Control.Applicative.Free.Fast.Ap"
    #else
    apTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "Ap"
    #endif
    {-# NOINLINE apTyCon #-}

    instance Typeable1 f => Typeable1 (ASeq f) where
      typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where
        f :: ASeq f a -> f a
        f = undefined

    apSeqTyCon :: TyCon
    #if __GLASGOW_HASKELL__ < 704
    apSeqTyCon = mkTyCon "Control.Applicative.Free.Fast.ASeq"
    #else
    apSeqTyCon = mkTyCon3 "free" "Control.Applicative.Free.Fast" "ASeq"
    #endif
    {-# NOINLINE apSeqTyCon #-}

    #endif