Fast.hs

{-# 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 ANil         = pure ()
reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq 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 _ ANil = ANil
hoistASeq u (ACons x xs) = ACons (u x) (u `hoistASeq` 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 _ ANil      = pure ANil
traverseASeq f (ACons x xs) = ACons <$> f x <*> traverseASeq f 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 ANil         k f = k (\v -> f v ())
rebaseASeq (ACons x xs) k f =
  rebaseASeq xs (\g s -> k (\(a,u) -> g u a) (ACons x s))
    (\v u a -> f v (a,u))


-- | The faster free 'Applicative'.
newtype Ap f a = Ap
  { 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 u = retractAp . hoistAp 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_ f = getConst . runAp (Const . f)

instance Functor (Ap f) where
  fmap g x = Ap (\k f -> unAp x k (\s -> f s . g))

instance Apply (Ap f) where
  (<.>) = (<*>)

instance Applicative (Ap f) where
  pure a = Ap (\k f -> k (`f` a))
  x <*> y = Ap (\k f -> unAp y (unAp x k) (\s a g -> f s (g a)))

-- | A version of 'lift' that can be used with just a 'Functor' for @f@.
liftAp :: f a -> Ap f a
liftAp a = Ap (\k f s -> k (\(a',s') -> f s' a') (ACons a 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 g x = Ap (\k f s ->
  unAp x
    (\f' s' ->
      rebaseASeq (hoistASeq g s') k
        (\v u -> f v (f' u)) s)
    (const id)
    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 x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) 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