-- | Twan van Laarhoven’s free applicative (see
-- <https://ro-che.info/articles/2013-03-31-flavours-of-free-applicative-functors>)
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
module Data.Yaml.Combinators.Free where

data Free f a where
  Pure :: a -> Free f a
  Ap :: Free f (a -> b) -> f a -> Free f b

instance Functor (Free f) where
  fmap :: forall a b. (a -> b) -> Free f a -> Free f b
fmap a -> b
f (Pure a
x) = forall a (f :: * -> *). a -> Free f a
Pure forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
  fmap a -> b
f (Ap Free f (a -> a)
tx f a
ay) = forall (f :: * -> *) a b. Free f (a -> b) -> f a -> Free f b
Ap ((a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Free f (a -> a)
tx) f a
ay

instance Applicative (Free f) where
  pure :: forall a. a -> Free f a
pure = forall a (f :: * -> *). a -> Free f a
Pure
  Pure a -> b
f <*> :: forall a b. Free f (a -> b) -> Free f a -> Free f b
<*> Free f a
tx = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Free f a
tx
  Ap Free f (a -> a -> b)
tx f a
ay <*> Free f a
tz = forall (f :: * -> *) a b. Free f (a -> b) -> f a -> Free f b
Ap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Free f (a -> a -> b)
tx forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Free f a
tz) f a
ay

lift :: f a -> Free f a
lift :: forall (f :: * -> *) a. f a -> Free f a
lift = forall (f :: * -> *) a b. Free f (a -> b) -> f a -> Free f b
Ap (forall a (f :: * -> *). a -> Free f a
Pure forall a. a -> a
id)

-- | A strict, tail-recursive monoidal foldMap over a free applicative functor
foldMap :: forall a b f . Monoid b => (forall c . f c -> b) -> Free f a -> b
foldMap :: forall a b (f :: * -> *).
Monoid b =>
(forall c. f c -> b) -> Free f a -> b
foldMap forall c. f c -> b
f Free f a
free0 = forall c. Free f c -> b -> b
go Free f a
free0 forall a. Monoid a => a
mempty
  where
    go :: forall c . Free f c -> b -> b
    go :: forall c. Free f c -> b -> b
go Free f c
free b
acc = case Free f c
free of
      Pure c
_ -> b
acc
      Ap Free f (a -> c)
free' f a
base -> forall c. Free f c -> b -> b
go Free f (a -> c)
free' forall a b. (a -> b) -> a -> b
$! forall c. f c -> b
f f a
base forall a. Semigroup a => a -> a -> a
<> b
acc

run :: forall a f g . Applicative g => (forall c . f c -> g c) -> Free f a -> g a
run :: forall a (f :: * -> *) (g :: * -> *).
Applicative g =>
(forall c. f c -> g c) -> Free f a -> g a
run forall c. f c -> g c
f = forall c. Free f c -> g c
go
  where
    go :: forall c . Free f c -> g c
    go :: forall c. Free f c -> g c
go Free f c
free = case Free f c
free of
      Pure c
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure c
a
      Ap Free f (a -> c)
free' f a
base -> forall c. Free f c -> g c
go Free f (a -> c)
free' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall c. f c -> g c
f f a
base)