module Control.Applicative.Fraxl.Free
( ASeq(..)
, reduceASeq
, Ap(..)
, liftAp
, retractAp
, runAp
, runAp_
, hoistASeq
, traverseASeq
, rebaseASeq
, hoistAp
) where
import Control.Applicative
import Data.Typeable
data ASeq f a where
ANil :: ASeq f ()
ACons :: f a -> ASeq f u -> ASeq f (a,u)
deriving Typeable
reduceASeq :: Applicative f => ASeq f u -> f u
reduceASeq ANil = pure ()
reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq xs
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)
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
rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) ->
(v -> u -> y) -> ASeq f v -> z
rebaseASeq ANil k f = k (`f` ())
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))
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 }
deriving Typeable
runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a
runAp u = retractAp . hoistAp u
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 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)))
liftAp :: f a -> Ap f a
liftAp a = Ap (\k f s -> k (\(a',s') -> f s' a') (ACons a s))
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)
retractAp :: Applicative f => Ap f a -> f a
retractAp x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil