A recent proposal on the Haskell libraries mailing list led me to consider the following:
ft :: (Applicative f, Monoid m, Traversable t)
-> (b -> m) -> (a -> f b) -> t a -> f m
ft f g xs = foldMap f <$> traverse g xs
I noticed that the Traversable constraint can be weakened to Foldable:
import Data.Monoid (Ap (..)) -- Requires a recent base version
ft :: (Applicative f, Monoid m, Foldable t)
-> (b -> m) -> (a -> f b) -> t a -> f m
ft f g = getAp . foldMap (Ap . fmap f . g)
In the original proposal, f was supposed to be id, leading to
foldMapA
:: (Applicative f, Monoid m, Foldable t)
-> (a -> f m) -> t a -> f m
--foldMapA g = getAp . foldMap (Ap . fmap id . g)
foldMapA g = getAp . foldMap (Ap . g)
which is strictly better than the traverse-then-fold approach.
But in the more general ft, there's a potential problem: fmap could be expensive in the f functor, in which case the fused version could potentially be more expensive than the original!
The usual tools for dealing with expensive fmap are Yoneda and Coyoneda. Since we need to lift many times and only lower once, Coyoneda is the one that can help us:
import Data.Functor.Coyoneda
ft' :: (Applicative f, Monoid m, Foldable t)
=> (b -> m) -> (a -> f b) -> t a -> f m
ft' f g = lowerCoyoneda . getAp
. foldMap (Ap . fmap f . liftCoyoneda . g)
So now we replace all those expensive fmaps with one (buried in lowerCoyoneda). Problem solved? Not quite.
The trouble with Coyoneda is that its liftA2 is strict. So if we write something like
import Data.Monoid (First (..))
ft' (First . Just) Identity $ 1 : undefined
-- or, importing Data.Functor.Reverse,
ft' (Last . Just) Identity (Reverse $ 1 : undefined)
then it will fail, whereas ft has no trouble with those. Is there a way to have our cake and eat it too? That is, a version that uses only a Foldable constraint, only fmaps O(1) times more than traverse in the f functor, and is just as lazy as ft?
Note: we could make liftA2 for Coyoneda somewhat lazier:
liftA2 f m n = liftCoyoneda $
case (m, n) of
(Coyoneda g x, Coyoneda h y) -> liftA2 (\p q -> f (g p) (h q)) x y
This is enough to let it produce an answer to ft' (First . Just) Identity $ 1 : 2 : undefined, but not to ft' (First . Just) Identity $ 1 : undefined. I don't see any obvious way to make it lazier than that, because pattern matches on existentials must always be strict.
I don't believe it's possible. Avoiding fmaps at the elements seems to require some knowledge of the structure of the container. For example, the Traversable instance for lists can be written
traverse f (x : xs) = liftA2 (:) (f x) (traverse f xs)
We know that the first argument of (:) is a single element, so we can use liftA2 to combine the process of mapping over the action for that element with the process of combining the result of that action with the result associated with the rest of the list.
In a more generic context, the structure of a fold can be captured faithfully using a magma type with a bogus Monoid instance:
data Magma a = Bin (Magma a) (Magma a) | Leaf a | Nil
deriving (Functor, Foldable, Traversable)
instance Semigroup (Magma a) where
(<>) = Bin
instance Monoid (Magma a) where
mempty = Nil
toMagma :: Foldable t => t a -> Magma a
toMagma = foldMap Leaf
We can write
ft'' :: (Applicative f, Monoid m, Foldable t)
=> (b -> m) -> (a -> f b) -> t a -> f m
ft'' f g = fmap (lowerMagma f) . traverse g . toMagma
lowerMagma :: Monoid m => (a -> m) -> Magma a -> m
lowerMagma f (Bin x y) = lowerMagma f x <> lowerMagma f y
lowerMagma f (Leaf x) = f x
lowerMagma _ Nil = mempty
But there's trouble in the Traversable instance:
traverse f (Leaf x) = Leaf <$> f x
That's exactly the sort of trouble we were trying to avoid. And there's no lazy fix for it. If we encounter Bin l r, we can't lazily determine whether l or r are leaves. So we're stuck. If we allowed a Traversable constraint on ft'', we could capture the result of traversing with a richer sort of magma type (such as one used in lens), which I suspect could let us do something more clever though I haven't found anything yet.
Related
I have a Bitraversable called t that supports this operation:
someName :: Monad m => (t (m a) (m b) -> c) -> m (t a b) -> c
In other words, it's possible to take a function that accepts two monads packaged into the bitraversable and turn it into a mapping that accepts a single monad containing a bitraversable without the monad layer. This is something like a bitraversable and higher-level version of distribute; the type signature is similar to this:
\f -> \x -> f (distribute x)
:: (Distributive g, Functor f) => (g (f a) -> c) -> f (g a) -> c
My questions:
Is there a standard name for this "higher-level" version of distribute that works on functions that accept distributives rather than distributives themselves?
Is there a name for the bitraversable version?
Does it work with every bitraversable/functor/monad/whatever, or are there restrictions?
As per #Noughtmare, your "higher level" functions someName and distribute are just written in continuation passing style. These generally aren't worth additional names, because they are just right function compositions:
highLevelDistribute = (. distribute)
Practically speaking, anywhere you want to call highLevelDistribute on an argument:
highLevelDistribute f
this expression is equivalent to:
f . distribute
and even if you're using highLevelDistribute as a first-class value, it's just not that hard to write and understand the section (. distribute).
Note that traverse and sequenceA are a little different, since we have:
sequenceA = traverse id
You could make an argument that this difference doesn't really warrant separate names either, but that's an argument for another day.
Getting back to someName, it's a CPS version of:
someOtherName :: m (t a b) -> t (m a) (m b)
which looks like a bifunctor analogue of distribute:
distribute :: (Distributive g, Functor f) => f (g a) -> g (f a)
So, I'd suggest inventing a Bidistributive to reflect this, and someOtherName becomes bidistribute:
class Bifunctor g => Bidistributive g where
{-# MINIMAL bidistribute | bicollect #-}
bidistribute :: Functor f => f (g a b) -> g (f a) (f b)
bidistribute = bicollect id
bicollect :: Functor f => (a -> g b c) -> f a -> g (f b) (f c)
bicollect f = bidistribute . fmap f
Again, your "higher level" someName is just right-composition:
someName = (. bidistribute)
Reasonable laws for a Bidistributive would probably include the following. I'm not sure if these are sufficiently general and/or exhaustive:
-- naturality
bimap (fmap f) (fmap g) . bidistribute = bidistribute . fmap (bimap f g)
-- identity
bidistribute . Identity = bimap Identity Identity
-- composition
bimap Compose Compose . bidistribute . fmap bidistribute = bidistribute . Compose
For your question #3, not all Bitraversables are Bidistributive, for much the same reason that not all Traversables are Distributive. A Distributive allows you to "expose structure" under an arbitrary functor. So, for example, there's no Distributive instance for lists, because if there was, you could call:
distribute :: IO [a] -> [IO a]
which would allow you to determine if a list returned by an IO action was empty or not, without executing the IO action.
Similarly, Either is Bitraversable, but it can't be Bidistributive, because if it was, you'd be able to use:
bidistribute :: IO (Either a b) -> Either (IO a) (IO b)
to determine if the IO action returned a Left or Right without having to execute the IO action.
One interesting thing about bidistribute is that the "other functor" can be any Functor; it doesn't need to be an Applicative. So, just as we have:
sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)
distribute :: (Distributive g, Functor f) => f (g a) -> g (f a)
we have:
bisequence :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)
bidistribute :: (Bidistributive g, Functor f) => f (g a b) -> g (f a) (f b)
Intuitively, sequencing needs the power of an applicative functor f to be able to "build" the f (t a) from a traversal of its functorial f a "parts", while distribution only needs to take the f (g a) apart. In practical terms, this means that sequencing typically looks like this:
-- specialized to t ~ []
sequenceA :: [f a] -> f [a]
sequenceA (f:fs) = (:) <$> f <*> fs -- need applicative operations
while distribution typically looks like this:
-- specialized to g ~ (->) r
distribute :: f (r -> a) -> (r -> f a)
distribute f r = fmap ($ r) f -- only need fmap
(Technically, according to the documentation for Data.Distributive, the Distributive class only requires a Functor rather than some coapplicative class because of the lack of non-trivial comonoids in Haskell. See this SO answer.)
Working on a project and trying to write longzip using an anamorphism. I'm having some trouble writing a coalgebra for this use case. I've defined my anamorphism in terms of Fix below:
-- Fixed point of a Functor
newtype Fix f = In (f (Fix f))
deriving instance (Eq (f (Fix f))) => Eq (Fix f)
out :: Fix f -> f (Fix f)
out (In f) = f
-- Anamorphism
type Coalgebra f a = a -> f a
ana :: (Functor f) => Coalgebra f a -> a -> Fix f
ana f = In . fmap (ana f) . f
This is the definition for ana derived from "reversing the arrows" of cata:
-- Catamorphism
type Algebra f a = f a -> a
cata :: (Functor f) => Algebra f a -> Fix f -> a
cata f = f . fmap (cata f) . out
I've seen zip written using a version of ana that is obviously defined differently (takes a predicate as a parameter):
zip2 = ana unsp fin
where
fin (as,bs) = (as==[]) || (bs ==[])
unsp ((a:as), (b:bs)) = ((a,b),(as,bs))
(Taken from https://en.wikipedia.org/wiki/Anamorphism)
But I'm unsure how to move forward using the version of ana defined above, particularly in regards to writing a Coalgebra of type a -> fa. Like, would it have to take the two list parameters to zip and combine them into a single a?
First off, give yourself a starting point. Write down what you're going to do:
-- make this example actually complete
{-# Language StandaloneDeriving, UndecidableInstances, DeriveFunctor #-}
import Prelude hiding (zip)
-- Fixed point of a Functor
newtype Fix f = In (f (Fix f))
deriving instance (Eq (f (Fix f))) => Eq (Fix f)
deriving instance (Show (f (Fix f))) => Show (Fix f)
out :: Fix f -> f (Fix f)
out (In f) = f
-- Anamorphism
type Coalgebra f a = a -> f a
ana :: (Functor f) => Coalgebra f a -> a -> Fix f
ana f = In . fmap (ana f) . f
-- Base functor for a list
data ListF a f = Nil | Cons a f deriving (Eq, Show, Functor)
type List a = Fix (ListF a)
-- write down the type. It helps you think about things
zip :: List a -> List b -> List (a, b)
zip x y = ana undefined undefined
You know zip has to be implemented as a call to ana, so what remains is figuring out the seed and the coalgebra. It should be fairly clear the seed needs to contain x and y. It doesn't seem like any further information should be necessary, so let's just assume the seed will be (x, y) until/unless it poses a problem. That's enough information to pin down the types for this first try:
zip :: List a -> List b -> List (a, b)
zip x y = ana zipCoalgebra (x, y)
zipCoalgebra :: (List a, List b) -> ListF (a, b) (List a, List b)
zipCoalgebra = undefined
I feel like this is the step you've missed: writing down what you're trying to do and following the types to pin down what you need. The rest of this is sort of trivial if you've ever seen any implementation of zip. It's a matter of writing down the most boring thing that type-checks (paying close attention to the difference between List and ListF in the type). I strongly recommend you stop reading here and give it a try yourself. There isn't much else I can say that's actually helpful for learning how to think about this.
If you really have no idea at all:
zipCoalgebra :: (List a, List b) -> ListF (a, b) (List a, List b)
zipCoalgebra (In (Cons a as), In (Cons b bs)) = Cons (a, b) (as, bs)
zipCoalgebra _ = Nil
It really is what you'd expect if you've ever seen an implementation of zip before, with the necessary noise to make it type-check around Fix. Let's give it a spin:
ghci> zip (In (Cons 1 (In Nil))) (In Nil)
In Nil
ghci> zip (In (Cons 1 (In Nil))) (In (Cons 2 (In Nil)))
In (Cons (1,2) (In Nil))
Yep. Behaving as expected. It seems the two lists were sufficient as the seed, and all is well.
In the recursion-schemes package the following types are defined:
newtype Fix f = Fix (f (Fix f))
newtype Mu f = Mu (forall a. (f a -> a) -> a)
Are they isomorphic? If so, how do you prove it?
Are they isomorphic?
Yes, they are isomorphic in Haskell. See What is the difference between Fix, Mu and Nu in Ed Kmett's recursion scheme package for some additional remarks.
If so, how do you prove it?
Let's begin by defining functions to perform the conversions:
muToFix :: Mu f -> Fix f
muToFix (Mu s) = s Fix
fixToMu :: Functor f => Fix f -> Mu f
fixToMu t = Mu (\alg -> cata alg t)
To show those functions witness an isomorphism, we must show that:
muToFix . fixToMu = id
fixToMu . muToFix = id
From Fix and back
One of the directions of the isomorphism comes off somewhat more straightforwardly than the other:
muToFix (fixToMu t) = t
muToFix (fixToMu t) -- LHS
muToFix (Mu (\f -> cata f t))
(\f -> cata f t) Fix
cata Fix t -- See below.
t -- LHS = RHS
The final passage above, cata Fix t = t, can be verified through the definition of cata:
cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . fmap (cata alg) . unfix
cata Fix t, then, is Fix (fmap (cata Fix) (unfix t)). We can use induction to show it must be t, at least for a finite t (it gets more subtle with infinite structures -- see the addendum at the end of this answer). There are two possibilities to consider:
unfix t :: f (Fix f) is empty, having no recursive positions to dig into. In that case, it must be equal to fmap absurd z for some z :: f Void, and thus:
cata Fix t
Fix (fmap (cata Fix) (unfix t))
Fix (fmap (cata Fix) (fmap absurd z))
Fix (fmap (cata Fix . absurd) z)
-- fmap doesn't do anything on an empty structure.
Fix (fmap absurd z)
Fix (unfix t)
t
unfix t is not empty. In that case, we at least know that fmap (cata Fix) can't do anything beyond applying cata Fix on the recursive positions. The induction hypothesis here is that doing so will leave those positions unchanged. We then have:
cata Fix t
Fix (fmap (cata Fix) (unfix t))
Fix (unfix t) -- Induction hypothesis.
t
(Ultimately, cata Fix = id is a corollary of Fix :: f (Fix f) -> Fix x being an initial F-algebra. Resorting directly to that fact
in the context of this proof would probably be too much of a shortcut.)
From Mu and back
Given muToFix . fixToMu = id, to prove that fixToMu . muToFix = id it suffices to prove either:
that muToFix is injective, or
that fixToMu is surjective.
Let's take the second option, and review the relevant definitions:
newtype Mu f = Mu (forall a. (f a -> a) -> a)
fixToMu :: Functor f => Fix f -> Mu f
fixToMu t = Mu (\alg -> cata alg t)
fixToMu being surjective, then, means that, given any specific Functor f, all functions of type forall a. (f a -> a) -> a can be defined as \alg -> cata alg t, for some specific t :: Fix f. The task, then, becomes cataloguing the forall a. (f a -> a) -> a functions and seeing whether all of them can be expressed in that form.
How might we define a forall a. (f a -> a) -> a function without leaning on fixToMu? No matter what, it must involve using the f a -> a algebra supplied as an argument to get an a result. The direct route would be applying it to some f a value. A major caveat is that, since a is polymorphic, we must be able to conjure said f a value for any choice of a. That is a feasible strategy as long as f-values happen to exist. In that case, we can do:
fromEmpty :: Functor f => f Void -> forall a. (f a -> a) -> a
fromEmpty z = \alg -> alg (fmap absurd z)
To make the notation clearer, let's define a type for things we can use to define forall a. (f a -> a) -> a functions:
data Moo f = Empty (f Void)
fromMoo :: Functor f => Moo f -> forall a. (f a -> a) -> a
fromMoo (Empty z) = \alg -> alg (fmap absurd z)
Besides the direct route, there is just one other possibility. Given that f is a Functor, if we somehow have an f (Moo f) value we can apply the algebra twice, the first application being under the outer f layer, via fmap and fromMoo:
fromLayered :: Functor f => f (Moo f) -> forall a. (f a -> a) -> a
fromLayered u = \alg -> alg (fmap (\moo -> fromMoo moo alg) u)
Considering that we can also make forall a. (f a -> a) -> a out of f (Moo f) values, it makes sense to add them as a case of Moo:
data Moo f = Empty (f Void) | Layered (f (Moo f))
Accordingly, fromLayered can be incorporated to fromMoo:
fromMoo :: Functor f => Moo f -> forall a. (f a -> a) -> a
fromMoo = \case
Empty z -> \alg -> alg (fmap absurd z)
Layered u -> \alg -> alg (fmap (\moo -> fromMoo moo alg) u)
Note that, by doing so, we have sneakily moved from applying alg under one f layer to recursively applying alg under an arbitrary number of f layers.
Next, we can note an f Void value can be injected into the Layered constructor:
emptyLayered :: Functor f => f Void -> Moo f
emptyLayered z = Layered (fmap absurd z)
That means we don't actually need the Empty constructor:
newtype Moo f = Moo (f (Moo f))
unMoo :: Moo f -> f (Moo f)
unMoo (Moo u) = u
What about the Empty case in fromMoo? The only difference between the two cases is that, in the Empty case, we have absurd instead of \moo -> fromMoo moo alg. Since all Void -> a functions are absurd, we don't need a separate Empty case there either:
fromMoo :: Functor f => Moo f -> forall a. (f a -> a) -> a
fromMoo (Moo u) = \alg -> alg (fmap (\moo -> fromMoo moo alg) u)
A possible cosmetic tweak is flipping the fromMoo arguments, so that we don't need to write the argument to fmap as a lambda:
foldMoo :: Functor f => (f a -> a) -> Moo f -> a
foldMoo alg (Moo u) = alg (fmap (foldMoo alg) u)
Or, more pointfree:
foldMoo :: Functor f => (f a -> a) -> Moo f -> a
foldMoo alg = alg . fmap (foldMoo alg) . unMoo
At this point, a second look at our definitions suggests some renaming is in order:
newtype Fix f = Fix (f (Fix f))
unfix :: Fix f -> f (Fix f)
unfix (Fix u) = u
cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . fmap (cata alg) . unfix
fromFix :: Functor f => Fix f -> forall a. (f a -> a) -> a
fromFix t = \alg -> cata alg t
And there it is: all forall a. (f a -> a) -> a functions have the form \alg -> cata alg t for some t :: Fix f. Therefore, fixToMu is surjective, and we have the desired isomorphism.
Addendum
In the comments, a germane question was raised about the applicability of the induction argument in the cata Fix t = t derivation. At a minimum, the functor laws and parametricity ensure that fmap (cata Fix) won't create extra work (for instance, it won't enlarge the structure, or introduce additional recursive positions to dig into), which justifies why stepping into the recursive positions is all that matters in the inductive step of the derivation. That being so, if t is a finite structure, the base case of an empty f (Fix t) will eventually be reached, and all is clear. If we allow t to be infinite, however, we can keep descending endlessly, fmap after fmap after fmap, without ever reaching the base case.
The situation with infinite structures, though, is not as awful as it might seem at first. Laziness, which is what makes infinite structures viable in the first place, allows us to consume infinite structures lazily:
GHCi> :info ListF
data ListF a b = Nil | Cons a b
-- etc.
GHCi> ones = Fix (Cons 1 ones)
GHCi> (\(Fix (Cons a _)) -> a) (cata Fix ones)
1
GHCi> (\(Fix (Cons _ (Fix (Cons a _)))) -> a) (cata Fix ones)
1
While the succession of recursive positions extends infinitely, we can stop at any point and get useful results out of the surrounding ListF functorial contexts. Such contexts, it bears repeating, are unaffected by fmap, and so any finite segment of the structure we might consume will be unaffected by cata Fix.
This laziness reprieve reflects how, as mentioned elsewhere in this discussion, laziness collapses the distinction between the fixed points Mu, Fix and Nu. Without laziness, Fix is not enough to encode productive corecursion, and so we have to switch to Nu, the greatest fixed point. Here is a tiny demonstration of the difference:
GHCi> :set -XBangPatterns
GHCi> -- Like ListF, but strict in the recursive position.
GHCi> data SListF a b = SNil | SCons a !b deriving Functor
GHCi> ones = Nu (\() -> SCons 1 ()) ()
GHCi> (\(Nu c a) -> (\(SCons a _) -> a) (c a)) ones
1
GHCi> ones' = Fix (SCons 1 ones')
GHCi> (\(Fix (SCons a _)) -> a) ones'
^CInterrupted.
I have this F-Algebra (introduced in a previous question), and I want to cast an effectful algebra upon it. Through desperate trial, I managed to put together a monadic catamorphism that works. I wonder if it may be generalized to an applicative, and if not, why.
This is how I defined Traversable:
instance Traversable Expr where
traverse f (Branch xs) = fmap Branch $ traverse f xs
traverse f (Leaf i ) = pure $ Leaf i
This is the monadic catamorphism:
type AlgebraM a f b = a b -> f b
cataM :: (Monad f, Traversable a) => AlgebraM a f b -> Fix a -> f b
cataM f x = f =<< (traverse (cataM f) . unFix $ x)
And this is how it works:
λ let printAndReturn x = print x >> pure x
λ cataM (printAndReturn . evalSum) $ branch [branch [leaf 1, leaf 2], leaf 3]
1
2
3
3
6
6
My idea now is that I could rewrite like this:
cataA :: (Applicative f, Traversable a) => AlgebraM a f b -> Fix a -> f b
cataA f x = do
subtree <- traverse (cataA f) . unFix $ x
value <- f subtree
return value
Unfortunately, value here depends on subtree and, according to a paper on applicative do-notation, in such case we cannot desugar to Applicative. It seems like there's no way around this; we need a monad to float up from the depths of nesting.
Is it true? Can I safely conclude that only flat structures can be folded with applicative effects alone?
Can I safely conclude that only flat structures can be folded with applicative effects alone?
You can say that again! After all, "flattening nested structures" is exactly what makes a monad a monad, rather than Applicative which can only combine adjacent structures. Compare (a version of) the signatures of the two abstractions:
class Functor f => Applicative f where
pure :: a -> f a
(<.>) :: f a -> f b -> f (a, b)
class Applicative m => Monad m where
join :: m (m a) -> m a
What Monad adds to Applicative is the ability to flatten nested ms into one m. That's why []'s join is concat. Applicative only lets you smash together heretofore-unrelated fs.
It's no coincidence that the free monad's Free constructor contains a whole f full of Free fs, whereas the free applicative's Ap constructor only contains one Ap f.
data Free f a = Return a | Free (f (Free f a))
data Ap f a where
Pure :: a -> Ap f a
Cons :: f a -> Ap f b -> Ap f (a, b)
Hopefully that gives you some intuition as to why you should expect that it's not possible to fold a tree using an Applicative.
Let's play a little type tennis to see how it shakes out. We want to write
cataA :: (Traversable f, Applicative m) => (f a -> m a) -> Fix f -> m a
cataA f (Fix xs) = _
We have xs :: f (Fix f) and a Traversable for f. My first instinct here is to traverse the f to fold the contained subtrees:
cataA f (Fix xs) = _ $ traverse (cataA f) xs
The hole now has a goal type of m (f a) -> m a. Since there's an f :: f a -> m a knocking about, let's try going under the m to convert the contained fs:
cataA f (Fix xs) = _ $ fmap f $ traverse (cataA f) xs
Now we have a goal type of m (m a) -> m a, which is join. So you do need a Monad after all.
I generalized hoistFree from the free package to hoistFreeM, similarly to how one can generalize fmap to Data.Traversable.mapM.
import Control.Monad
import Control.Monad.Free
import Data.Traversable as T
hoistFreeM :: (Traversable g, Monad m) =>
(forall a. f a -> m (g a)) -> Free f b -> m (Free g b)
hoistFreeM f = go
where go (Pure x) = return $ Pure x
go (Free xs) = liftM Free $ T.mapM go =<< f xs
However, I don't think there is a way to further generalize it to work with any Applicative, similarly to how one can generalize Data.Traversable.mapM to Data.Traversable.traverse. Am I correct? If so, why?
You can't lift an Applicative through a Free Monad because the Monad structure demands choice (via (>>=) or join) and the Applicative can't provide that. But, perhaps unsurprisingly, you can lift an Applicative through a Free Applicative
-- also from the `free` package
data Ap f a where
Pure :: a -> Ap f a
Ap :: f a -> Ap f (a -> b) -> Ap f b
hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b
hoistAp _ (Pure a) = Pure a
hoistAp f (Ap x y) = Ap (f x) (hoistAp f y)
hoistApA :: Applicative v => (forall a. f a -> v (g a)) -> Ap f b -> v (Ap g b)
hoistApA _ (Pure a) = pure (Pure a)
hoistApA f (Ap x y) = Ap <$> f x <*> hoistApA f y
-- just what you'd expect, really
To be more explicit, let's try generalizing hoistFreeM to hoistFreeA. It's easy enough to begin
hoistFreeA :: (Traversable f, Applicative v) =>
(forall a. f a -> v (g a)) -> Free f b -> v (Free g b)
hoistFreeA _ (Pure a) = pure (Pure a)
And we can try to continue by analogy from hoistFreeM here. mapM becomes traverse and we can get as far as
hoistFreeA f (Free xs) = ?f $ traverse (hoistFreeA f) xs
where I've been using ?f as a makeshift type hole to try to figure out how to move forward. We can complete this definition if we can make
?f :: v (f (Free g b)) -> v (Free g b)
In other words, we need to transform that f layer into a g layer while living underneath our v layer. It's easy enough to get underneath v since v is a Functor, but the only way we have to transform f a to g a is our argument function forall a . f a -> v (g a).
We can try applying that f anyway along with a Free wrapper in order to fold up our g layer.
hoistFreeA f (Free xs) = ?f . fmap (fmap Free . f) $ traverse (hoistFreeA f) xs
But now we have to solve
?f :: v (v (Free g b)) -> v (Free g b)
which is just join, so we're stuck. This is fundamentally where we're always going to get stuck. Free Monads model Monads and thus in order to wrap over them we need to somehow join or bind.