Useful operations on free arrows

Question

We know free monads are useful, and packages like Operational make it easy to define new monads by only caring about the application-specific effects, not the monadic structure itself.

We can easily define "free arrows" analogous to how free monads are defined:

{-# LANGUAGE GADTs #-}
module FreeA
       ( FreeA, effect
       ) where

import Prelude hiding ((.), id)
import Control.Category
import Control.Arrow
import Control.Applicative
import Data.Monoid

data FreeA eff a b where
    Pure :: (a -> b) -> FreeA eff a b
    Effect :: eff a b -> FreeA eff a b
    Seq :: FreeA eff a b -> FreeA eff b c -> FreeA eff a c
    Par :: FreeA eff a₁ b₁ -> FreeA eff a₂ b₂ -> FreeA eff (a₁, a₂) (b₁, b₂)

effect :: eff a b -> FreeA eff a b
effect = Effect

instance Category (FreeA eff) where
    id = Pure id
    (.) = flip Seq

instance Arrow (FreeA eff) where
    arr = Pure
    first f = Par f id
    second f = Par id f
    (***) = Par

My question is, what would be the most useful generic operations on free arrows? For my particular application, I needed special cases of these two:

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
analyze :: forall f eff a₀ b₀ r. (Applicative f, Monoid r)
        => (forall a b. eff a b -> f r)
        -> FreeA eff a₀ b₀ -> f r
analyze visit = go
  where
    go :: forall a b. FreeA eff a b -> f r
    go arr = case arr of
        Pure _ -> pure mempty
        Seq f₁ f₂ -> mappend <$> go f₁ <*> go f₂
        Par f₁ f₂ -> mappend <$> go f₁ <*> go f₂
        Effect eff -> visit eff

evalA :: forall eff arr a₀ b₀. (Arrow arr) => (forall a b. eff a b -> arr a b) -> FreeA eff a₀ b₀ -> arr a₀ b₀
evalA exec = go
  where
    go :: forall a b. FreeA eff a b -> arr a b
    go freeA = case freeA of
        Pure f -> arr f
        Seq f₁ f₂ -> go f₂ . go f₁
        Par f₁ f₂ -> go f₁ *** go f₂
        Effect eff -> exec eff

but I don't have any theoretical arguments on why these (and not others) would be the useful ones.

Answer 1

A free functor is left adjoint to a forgetful functor. For the adjunction you need to have the isomorphism (natural in x and y):

(Free y :~> x) <-> (y :~> Forget x)

In what category should this be? The forgetful functor forgets the Arrow instance, so it goes from the category of Arrow instances to the category of all bifunctors. And the free functor goes the other way, it turns any bifunctor into a free Arrow instance.

The haskell type of arrows in the category of bifunctors is:

type x :~> y = forall a b. x a b -> y a b

It's the same for arrows in the category of Arrow instances, but with addition of Arrow constraints. Since the forgetful functor only forgets the constraint, we don't need to represent it in Haskell. This turns the above isomorphism into two functions:

leftAdjunct :: (FreeA x :~> y) -> x :~> y
rightAdjunct :: Arrow y => (x :~> y) -> FreeA x :~> y

leftAdjunct should also have an Arrow y constraint, but it turns out it is never needed in the implementation. There's actually a very simple implementation in terms of the more useful unit:

unit :: x :~> FreeA x

leftAdjunct f = f . unit

unit is your effect and rightAdjunct is your evalA. So you have exactly the functions needed for the adjunction! You'd need to show that leftAdjunct and rightAdjunct are isomorphic. The easiest way to do that is to prove that rightAdjunct unit = id, in your case evalA effect = id, which is straightforward.

What about analyze? That's evalA specialized to the constant arrow, with the resulting Monoid constraint specialized to the applicative monoid. I.e.

analyze visit = getApp . getConstArr . evalA (ConstArr . Ap . visit)

with

newtype ConstArr m a b = ConstArr { getConstArr :: m }

and Ap from the reducers package.

Edit: I almost forgot, FreeA should be a higher order functor! Edit2: Which, on second thought, can also be implemented with rightAdjunct and unit.

hfmap :: (x :~> y) -> FreeA x :~> FreeA y
hfmap f = evalA (effect . f)

By the way: There's another way to define free functors, for which I put a package on Hackage recently. It does not support kind * -> * -> * (Edit: it does now!), but the code can be adapted to free arrows:

newtype FreeA eff a b = FreeA { runFreeA :: forall arr. Arrow arr => (eff :~> arr) -> arr a b }
evalA f a = runFreeA a f
effect a = FreeA $ \k -> k a

instance Category (FreeA f) where
  id = FreeA $ const id
  FreeA f . FreeA g = FreeA $ \k -> f k . g k

instance Arrow (FreeA f) where
  arr f = FreeA $ const (arr f)
  first (FreeA f) = FreeA $ \k -> first (f k)
  second (FreeA f) = FreeA $ \k -> second (f k)
  FreeA f *** FreeA g = FreeA $ \k -> f k *** g k
  FreeA f &&& FreeA g = FreeA $ \k -> f k &&& g k

If you don't need the introspection your FreeA offers, this FreeA is probably faster.