{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
#include "free-common.h"
module Control.Applicative.Free.Fast
(
ASeq(..)
, reduceASeq
, hoistASeq
, traverseASeq
, rebaseASeq
, 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
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
reduceASeq :: Applicative f => ASeq f u -> f u
reduceASeq :: ASeq f u -> f u
reduceASeq ASeq f u
ANil = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
reduceASeq (ACons f a
x 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
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 forall x. f x -> g x
_ ASeq f a
ANil = ASeq g a
forall (f :: * -> *). ASeq f ()
ANil
hoistASeq forall x. f x -> g x
u (ACons f a
x 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)
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 forall x. f x -> h (g x)
_ ASeq f a
ANil = ASeq g () -> h (ASeq g ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ASeq g ()
forall (f :: * -> *). ASeq f ()
ANil
traverseASeq forall x. f x -> h (g x)
f (ACons f a
x 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
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 ASeq f u
ANil forall x. (x -> y) -> ASeq f x -> z
k v -> u -> y
f = (v -> y) -> ASeq f v -> z
forall x. (x -> y) -> ASeq f x -> z
k (\v
v -> v -> u -> y
f v
v ())
rebaseASeq (ACons f a
x ASeq f u
xs) forall x. (x -> y) -> ASeq f x -> z
k 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 (\x -> a -> y
g ASeq f x
s -> ((a, x) -> y) -> ASeq f (a, x) -> z
forall x. (x -> y) -> ASeq f x -> z
k (\(a
a,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 u
u a
a -> v -> u -> y
f v
v (a
a,u
u))
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
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
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
runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m
runAp_ :: (forall a. f a -> m) -> Ap f b -> m
runAp_ 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 a -> b
g 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 (\forall x. (x -> y) -> ASeq f x -> z
k 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 (\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 = (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 (\forall x. (x -> y) -> ASeq f x -> z
k 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))
Ap f (a -> b)
x <*> :: Ap f (a -> b) -> Ap f a -> Ap f b
<*> 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 (\forall x. (x -> y) -> ASeq f x -> z
k 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) (\u
s a
a a -> b
g -> u -> b -> y
f u
s (a -> b
g a
a)))
liftAp :: f a -> Ap f a
liftAp :: f a -> Ap f a
liftAp 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 (\forall x. (x -> y) -> ASeq f x -> z
k u -> a -> y
f ASeq f u
s -> ((a, u) -> y) -> ASeq f (a, u) -> z
forall x. (x -> y) -> ASeq f x -> z
k (\(a
a',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 #-}
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 forall x. f x -> g x
g 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 (\forall x. (x -> y) -> ASeq g x -> z
k u -> a -> y
f 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
(\x -> a
f' 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
(\u
v 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)
retractAp :: Applicative f => Ap f a -> f a
retractAp :: Ap f a -> f a
retractAp 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 (\x -> a
f 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