module Data.Functor.Apply.Free (
Ap1(.., DayAp1, ap1Day)
, toAp, fromAp
, liftAp1
, retractAp1
, runAp1
) where
import Control.Applicative.Free
import Control.Natural
import Data.Function
import Data.Functor.Apply
import Data.Functor.Day
import Data.Functor.Identity
import Data.Functor.Invariant
import Data.HFunctor
import Data.HFunctor.HTraversable
import Data.HFunctor.Interpret
import Data.Kind
import GHC.Generics
data Ap1 :: (Type -> Type) -> Type -> Type where
Ap1 :: f a -> Ap f (a -> b) -> Ap1 f b
toAp :: Ap1 f ~> Ap f
toAp :: Ap1 f x -> Ap f x
toAp (Ap1 x :: f a
x xs :: Ap f (a -> x)
xs) = f a -> Ap f (a -> x) -> Ap f x
forall (f :: * -> *) a1 a. f a1 -> Ap f (a1 -> a) -> Ap f a
Ap f a
x Ap f (a -> x)
xs
fromAp :: Ap f ~> (Identity :+: Ap1 f)
fromAp :: Ap f x -> (:+:) Identity (Ap1 f) x
fromAp = \case
Pure x :: x
x -> Identity x -> (:+:) Identity (Ap1 f) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Identity x -> (:+:) Identity (Ap1 f) x)
-> Identity x -> (:+:) Identity (Ap1 f) x
forall a b. (a -> b) -> a -> b
$ x -> Identity x
forall a. a -> Identity a
Identity x
x
Ap x :: f a1
x xs :: Ap f (a1 -> x)
xs -> Ap1 f x -> (:+:) Identity (Ap1 f) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Ap1 f x -> (:+:) Identity (Ap1 f) x)
-> Ap1 f x -> (:+:) Identity (Ap1 f) x
forall a b. (a -> b) -> a -> b
$ f a1 -> Ap f (a1 -> x) -> Ap1 f x
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f a1
x Ap f (a1 -> x)
xs
instance Invariant (Ap1 f) where
invmap :: (a -> b) -> (b -> a) -> Ap1 f a -> Ap1 f b
invmap f :: a -> b
f _ = (a -> b) -> Ap1 f a -> Ap1 f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f
pattern DayAp1 :: Day f (Ap f) a -> Ap1 f a
pattern $bDayAp1 :: Day f (Ap f) a -> Ap1 f a
$mDayAp1 :: forall r (f :: * -> *) a.
Ap1 f a -> (Day f (Ap f) a -> r) -> (Void# -> r) -> r
DayAp1 { Ap1 f a -> Day f (Ap f) a
ap1Day } <- ((\case Ap1 x y -> Day x y (&)) -> ap1Day)
where
DayAp1 (Day x :: f b
x y :: Ap f c
y f :: b -> c -> a
f) = f b -> Ap f (b -> a) -> Ap1 f a
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f b
x ((b -> c -> a) -> c -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> c -> a
f (c -> b -> a) -> Ap f c -> Ap f (b -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ap f c
y)
{-# COMPLETE DayAp1 #-}
deriving instance Functor (Ap1 f)
instance Apply (Ap1 f) where
Ap1 x :: f a
x xs :: Ap f (a -> a -> b)
xs <.> :: Ap1 f (a -> b) -> Ap1 f a -> Ap1 f b
<.> ys :: Ap1 f a
ys = f a -> Ap f (a -> b) -> Ap1 f b
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 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)
xs 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
<*> Ap1 f a -> Ap f a
forall (f :: * -> *). Ap1 f ~> Ap f
toAp Ap1 f a
ys)
liftAp1 :: f ~> Ap1 f
liftAp1 :: f x -> Ap1 f x
liftAp1 x :: f x
x = f x -> Ap f (x -> x) -> Ap1 f x
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 f x
x ((x -> x) -> Ap f (x -> x)
forall a (f :: * -> *). a -> Ap f a
Pure x -> x
forall a. a -> a
id)
retractAp1 :: Apply f => Ap1 f ~> f
retractAp1 :: Ap1 f ~> f
retractAp1 (Ap1 x :: f a
x xs :: Ap f (a -> x)
xs) = f a -> Ap f (a -> x) -> f x
forall (f :: * -> *) a b. Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ f a
x Ap f (a -> x)
xs
runAp1
:: Apply g
=> (f ~> g)
-> Ap1 f ~> g
runAp1 :: (f ~> g) -> Ap1 f ~> g
runAp1 f :: f ~> g
f (Ap1 x :: f a
x xs :: Ap f (a -> x)
xs) = (f ~> g) -> f a -> Ap f (a -> x) -> g x
forall (f :: * -> *) (g :: * -> *) a b.
Apply g =>
(f ~> g) -> f a -> Ap f (a -> b) -> g b
runAp1_ f ~> g
f f a
x Ap f (a -> x)
xs
instance HFunctor Ap1 where
hmap :: (f ~> g) -> Ap1 f ~> Ap1 g
hmap f :: f ~> g
f (Ap1 x :: f a
x xs :: Ap f (a -> x)
xs) = g a -> Ap g (a -> x) -> Ap1 g x
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 (f a -> g a
f ~> g
f f a
x) ((f ~> g) -> Ap f (a -> x) -> Ap g (a -> x)
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap f ~> g
f Ap f (a -> x)
xs)
instance Inject Ap1 where
inject :: f x -> Ap1 f x
inject = f x -> Ap1 f x
forall (f :: * -> *). f ~> Ap1 f
liftAp1
instance HBind Ap1 where
hbind :: (f ~> Ap1 g) -> Ap1 f ~> Ap1 g
hbind = (f ~> Ap1 g) -> Ap1 f x -> Ap1 g x
forall (g :: * -> *) (f :: * -> *).
Apply g =>
(f ~> g) -> Ap1 f ~> g
runAp1
instance HTraversable Ap1 where
htraverse :: (forall x. f x -> h (g x)) -> Ap1 f a -> h (Ap1 g a)
htraverse f :: forall x. f x -> h (g x)
f (Ap1 x :: f a
x xs :: Ap f (a -> a)
xs) = g a -> Ap g (a -> a) -> Ap1 g a
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 (g a -> Ap g (a -> a) -> Ap1 g a)
-> h (g a) -> h (Ap g (a -> a) -> Ap1 g a)
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 (Ap g (a -> a) -> Ap1 g a) -> h (Ap g (a -> a)) -> h (Ap1 g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall x. f x -> h (g x)) -> Ap f (a -> a) -> h (Ap g (a -> a))
forall k k (t :: (k -> *) -> k -> *) (h :: * -> *) (f :: k -> *)
(g :: k -> *) (a :: k).
(HTraversable t, Applicative h) =>
(forall (x :: k). f x -> h (g x)) -> t f a -> h (t g a)
htraverse forall x. f x -> h (g x)
f Ap f (a -> a)
xs
instance HTraversable1 Ap1 where
htraverse1 :: (forall x. f x -> h (g x)) -> Ap1 f a -> h (Ap1 g a)
htraverse1 f :: forall x. f x -> h (g x)
f (Ap1 x :: f a
x xs :: Ap f (a -> a)
xs) = (forall x. f x -> h (g x)) -> f a -> Ap f (a -> a) -> h (Ap1 g a)
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
Apply h =>
(forall x. f x -> h (g x)) -> f a -> Ap f (a -> b) -> h (Ap1 g b)
traverseAp1_ forall x. f x -> h (g x)
f f a
x Ap f (a -> a)
xs
traverseAp1_
:: forall f g h a b. Apply h
=> (forall x. f x -> h (g x))
-> f a
-> Ap f (a -> b)
-> h (Ap1 g b)
traverseAp1_ :: (forall x. f x -> h (g x)) -> f a -> Ap f (a -> b) -> h (Ap1 g b)
traverseAp1_ f :: forall x. f x -> h (g x)
f = f a -> Ap f (a -> b) -> h (Ap1 g b)
forall x y. f x -> Ap f (x -> y) -> h (Ap1 g y)
go
where
go :: f x -> Ap f (x -> y) -> h (Ap1 g y)
go :: f x -> Ap f (x -> y) -> h (Ap1 g y)
go x :: f x
x = \case
Pure y :: x -> y
y -> (g x -> Ap g (x -> y) -> Ap1 g y
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
`Ap1` (x -> y) -> Ap g (x -> y)
forall a (f :: * -> *). a -> Ap f a
Pure x -> y
y) (g x -> Ap1 g y) -> h (g x) -> h (Ap1 g y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> h (g x)
forall x. f x -> h (g x)
f f x
x
Ap y :: f a1
y ys :: Ap f (a1 -> x -> y)
ys -> g x -> Ap g (x -> y) -> Ap1 g y
forall (f :: * -> *) a b. f a -> Ap f (a -> b) -> Ap1 f b
Ap1 (g x -> Ap g (x -> y) -> Ap1 g y)
-> h (g x) -> h (Ap g (x -> y) -> Ap1 g y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> h (g x)
forall x. f x -> h (g x)
f f x
x h (Ap g (x -> y) -> Ap1 g y) -> h (Ap g (x -> y)) -> h (Ap1 g y)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> (Ap1 g (x -> y) -> Ap g (x -> y)
forall (f :: * -> *). Ap1 f ~> Ap f
toAp (Ap1 g (x -> y) -> Ap g (x -> y))
-> h (Ap1 g (x -> y)) -> h (Ap g (x -> y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a1 -> Ap f (a1 -> x -> y) -> h (Ap1 g (x -> y))
forall x y. f x -> Ap f (x -> y) -> h (Ap1 g y)
go f a1
y Ap f (a1 -> x -> y)
ys)
instance Apply f => Interpret Ap1 f where
retract :: Ap1 f x -> f x
retract = Ap1 f x -> f x
forall (f :: * -> *). Apply f => Ap1 f ~> f
retractAp1
interpret :: (g ~> f) -> Ap1 g ~> f
interpret = (g ~> f) -> Ap1 g x -> f x
forall (g :: * -> *) (f :: * -> *).
Apply g =>
(f ~> g) -> Ap1 f ~> g
runAp1
retractAp1_ :: Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ :: f a -> Ap f (a -> b) -> f b
retractAp1_ x :: f a
x = \case
Pure y :: a -> b
y -> a -> b
y (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x
Ap y :: f a1
y ys :: Ap f (a1 -> a -> b)
ys -> a -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
(&) (a -> (a -> b) -> b) -> f a -> f ((a -> b) -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x f ((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f a1 -> Ap f (a1 -> a -> b) -> f (a -> b)
forall (f :: * -> *) a b. Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ f a1
y Ap f (a1 -> a -> b)
ys
runAp1_
:: forall f g a b. Apply g
=> (f ~> g)
-> f a
-> Ap f (a -> b)
-> g b
runAp1_ :: (f ~> g) -> f a -> Ap f (a -> b) -> g b
runAp1_ f :: f ~> g
f = f a -> Ap f (a -> b) -> g b
forall x y. f x -> Ap f (x -> y) -> g y
go
where
go :: f x -> Ap f (x -> y) -> g y
go :: f x -> Ap f (x -> y) -> g y
go x :: f x
x = \case
Pure y :: x -> y
y -> x -> y
y (x -> y) -> g x -> g y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> g x
f ~> g
f f x
x
Ap y :: f a1
y ys :: Ap f (a1 -> x -> y)
ys -> x -> (x -> y) -> y
forall a b. a -> (a -> b) -> b
(&) (x -> (x -> y) -> y) -> g x -> g ((x -> y) -> y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> g x
f ~> g
f f x
x g ((x -> y) -> y) -> g (x -> y) -> g y
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f a1 -> Ap f (a1 -> x -> y) -> g (x -> y)
forall x y. f x -> Ap f (x -> y) -> g y
go f a1
y Ap f (a1 -> x -> y)
ys