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.HFunctor
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 x xs) = Ap x xs
fromAp :: Ap f ~> (Identity :+: Ap1 f)
fromAp = \case
Pure x -> L1 $ Identity x
Ap x xs -> R1 $ Ap1 x xs
pattern DayAp1 :: Day f (Ap f) a -> Ap1 f a
pattern DayAp1 { ap1Day } <- ((\case Ap1 x y -> Day x y (&)) -> ap1Day)
where
DayAp1 (Day x y f) = Ap1 x (flip f <$> y)
{-# COMPLETE DayAp1 #-}
deriving instance Functor (Ap1 f)
instance Apply (Ap1 f) where
Ap1 x xs <.> ys = Ap1 x (flip <$> xs <*> toAp ys)
liftAp1 :: f ~> Ap1 f
liftAp1 x = Ap1 x (Pure id)
retractAp1 :: Apply f => Ap1 f ~> f
retractAp1 (Ap1 x xs) = retractAp1_ x xs
runAp1
:: Apply g
=> (f ~> g)
-> Ap1 f ~> g
runAp1 f (Ap1 x xs) = runAp1_ f x xs
instance HFunctor Ap1 where
hmap f (Ap1 x xs) = Ap1 (f x) (hmap f xs)
instance Inject Ap1 where
inject = liftAp1
instance HBind Ap1 where
hbind = runAp1
instance Apply f => Interpret Ap1 f where
retract = retractAp1
interpret = runAp1
retractAp1_ :: Apply f => f a -> Ap f (a -> b) -> f b
retractAp1_ x = \case
Pure y -> y <$> x
Ap y ys -> (&) <$> x <.> retractAp1_ y ys
runAp1_
:: forall f g a b. Apply g
=> (f ~> g)
-> f a
-> Ap f (a -> b)
-> g b
runAp1_ f = go
where
go :: f x -> Ap f (x -> y) -> g y
go x = \case
Pure y -> y <$> f x
Ap y ys -> (&) <$> f x <.> go y ys