{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
#include "free-common.h"
module Control.Applicative.Free
(
Ap(..)
, runAp
, runAp_
, liftAp
, iterAp
, hoistAp
, retractAp
) where
import Control.Applicative
import Control.Comonad (Comonad(..))
import Data.Functor.Apply
import Data.Typeable
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid
#endif
data Ap f a where
Pure :: a -> Ap f a
Ap :: f a -> Ap f (a -> b) -> Ap f b
#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
_ (Pure a
x) = 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 (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 forall x. f x -> g x
u Ap f (a -> a)
x
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
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 <.> :: Ap f (a -> b) -> Ap f a -> Ap f b
<.> Ap f a
y = (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 (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> Ap f a
z)
instance Applicative (Ap f) where
pure :: a -> Ap f a
pure = a -> Ap f a
forall a (f :: * -> *). a -> Ap f a
Pure
Pure a -> b
f <*> :: Ap f (a -> b) -> Ap f a -> Ap f b
<*> Ap f a
y = (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ap f a
z)
instance Comonad f => Comonad (Ap f) where
extract :: 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 (w :: * -> *) a. Comonad w => w a -> a
extract Ap f (a -> a)
y (f a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract f a
x)
duplicate :: 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 (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 (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)
liftAp :: f a -> Ap f a
liftAp :: 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 #-}
iterAp :: Functor g => (g a -> a) -> Ap g a -> a
iterAp :: (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 (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 (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)
hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b
hoistAp :: (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 forall a. f a -> g a
f Ap f (a -> b)
y)
retractAp :: Applicative f => Ap f a -> f a
retractAp :: Ap f a -> f a
retractAp (Pure a
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
#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.Ap"
#else
apTyCon = mkTyCon3 "free" "Control.Applicative.Free" "Ap"
#endif
{-# NOINLINE apTyCon #-}
#endif