Recursive functors with some fiddling for type parameter order

1. RFunctor.hs

-- Old friends.
newtype Fix f = Fix { unFix :: f (Fix f) }
data Free f a = Free (f (Free f a)) | Pure a
data Cofree f a = a :< f (Cofree f a)

-- A recursive functor. We can’t define a Functor instance for e.g. `Fix` because:
-- 1. Its type parameter is of kind (* -> *). Maybe PolyKinds could hack around this, I’ve not tried.
-- 2. Following from that, its type parameter is applied to `Fix f` itself, and thus `(f (Fix f) -> g (Fix g)) -> Fix f -> Fix g` would probably be a mistake too; we want to ensure that `Fix` recursively maps its parameter functor into the new type, and not leave that map the responsibility of the function argument.
class RFunctor f
  where rmap :: Functor a => (a (f b) -> b (f b)) -> f a -> f b

-- Free and Cofree both take a second type parameter applied after the recursive one we want to swap out. I’m too tired to figure out a better way of dealing with this, so we just define a second typeclass for them.
class RFunctor' f
  where rmap' :: Functor a => (a (f b c) -> b (f b c)) -> f a c -> f b c

instance RFunctor Fix
  where rmap f = Fix . f . fmap (rmap f) . unFix

instance RFunctor' Free
  where rmap' f free = case free of
          Free g -> Free (f (rmap' f <$> g))
          Pure a -> Pure a

instance RFunctor' Cofree
  where rmap' f (a :< g) = a :< f (rmap' f <$> g)

2. NaturalTransformations.hs

{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, TypeFamilies, TypeOperators, TypeSynonymInstances #-}

import Control.Comonad.Trans.Cofree -- from the `free` package
import Control.Monad.Trans.Free -- from the `free` package
import Data.Functor.Foldable -- from the `recursion-schemes` package
import Data.Text (Text, pack, unpack) -- from the `text` package
import Prelude hiding (Foldable)

-- | Natural transformations between functors f and g.
type (~>) f g = (forall a. f a -> g a)

-- | What a nice little functor.
data REPLF s rest
  = Write s rest
  | Read (s -> rest)
  | Exit

-- | A REPL.
type REPL s = Fix (REPLF s)

-- | A more composable REPL.
type REPL' s = Free (REPLF s) s

-- REPLF embeds a value of its first type parameter, but also uses it as the domain in a functional. That makes it both co- and contra-variant, and therefore invariant, so we need to be able to map in both directions.
--
-- I was going to make this into a nice Isofunctor type class until I realized that it’d have to be some sort of IsoBiProDifunctor monstrosity because it’s invariant on the first parameter but covariant on the second. Yuck.
isomap :: (a -> b) -> (b -> a) -> REPLF a c -> REPLF b c
isomap f _ (Write s v) = Write (f s) v
isomap f g (Read h) = Read (h . g)
isomap _ _ Exit = Exit

-- | Lift a natural transformation over Foldable/Unfoldable functors.
liftNat :: (Foldable f, Unfoldable g, Functor (Base f), Functor (Base g)) => (Base f ~> Base g) -> f -> g
liftNat nat = embed . nat . fmap (liftNat nat) . project

packREPL :: REPL String -> REPL Text
packREPL = liftNat (isomap pack unpack)

packREPL' :: REPL' String -> REPL' Text
packREPL' = liftNat (liftFreeF (isomap pack unpack) pack)

liftFreeF :: (Functor f) => (f ~> g) -> (a -> b) -> FreeF f a ~> FreeF g b
liftFreeF f g (Free r) = Free (f r)
liftFreeF f g (Pure a) = Pure (g a)


-- | Instances

instance Functor (REPLF s) where
  fmap f (Write s v) = Write s (f v)
  fmap f (Read g) = Read (f . g)
  fmap f Exit = Exit

-- Having a `Base` instance for `Free f a` which produces `FreeF f a` makes it possible for us to write both `Foldable` and `Unfoldable` instances for it, whereas if we took the more traditional view of the underlying functor as f, we could really only make an `Unfoldable` instance. (Consider: If we used `f`, how would we implement `project` over the `Pure` constructor?)
--
-- Inconveniently, this means that when we apply `liftNat` to  is going to take a natural transformation between `FreeF`s instead of between `f`s. That’s why `liftFreeF` exists.
type instance Base (Free f a) = FreeF f a
instance Functor f => Foldable (Free f a) where project = runFree
instance Functor f => Unfoldable (Free f a) where embed = free

type instance Base (FreeF f a b) = f
instance (Functor f, Unfoldable b, Base b b ~ FreeF f a b) => Unfoldable (FreeF f a b) where embed = Free . fmap embed

type instance Base (Cofree f a) = CofreeF f a
instance Functor f => Foldable (Cofree f a) where project = runCofree
instance Functor f => Unfoldable (Cofree f a) where embed = cofree

It should be possible to write an RFunctor' instance for the Rec type from Functional Programming with Structured Graphs, but I haven’t tried—my implementation of structured graphs is higher-order (for use over GADTs) and regrettably I lack the PolyKinds moxie required to unify my HRec with their Rec.

But hmap is pretty much 1:1 with rmap'.

Wouldn't this sort of thing be better expressed as a natural transformation btwn functors? type (~>) f g = forall x. f x -> g x. Then you could write liftNat :: Functor f, Functor g => (f ~> g) -> Fix f -> Fix g with an implementation like liftNat nat = Fix . nat . fmap (liftNat nat) . unFix

Here's a type-level flip that works for Free (requires poly kinds)

type family Flip (f :: i -> j -> k) (b :: j) (a :: i) :: k where
   Flip f b a = f a b

*Main> :k Free
Free :: (* -> *) -> * -> *
*Main> :k Flip Free
Flip Free :: * -> (* -> *) -> *

@cbarrett: Thank you for the comments!

Wouldn't this sort of thing be better expressed as a natural transformation btwn functors?

That’s lovely! I have been using natural transformations in the project that spawned this gist, but I hadn’t noticed that they express this so nicely.

It tuns out that one can combine this with e.g. the recursion-schemes package to define a liftNat operation for anything in both their Foldable and Unfoldable typeclasses (NB: this is quite distinct from the Data.Foldable typeclass). I’ve added a module implementing this to the gist.

Here's a type-level flip that works for Free (requires poly kinds)

Your Flip definition is pretty great! I was having quite a bit of trouble defining such myself 💖