Lifting a (Lens) Traversal to Fix

I've got the following code. As you can see the last function is undefined.

{-# LANGUAGE TemplateHaskell, DeriveFunctor, DeriveTraversable #-}

module Example where

import Control.Lens
import Data.Functor.Foldable

data PathComponent d a = Directions d | Alt [a] deriving (Show, Functor, Foldable, Traversable)

makePrisms ''PathComponent

newtype Path d a = Path [PathComponent d a] deriving (Show, Functor, Foldable, Traversable)

directions :: Traversal (Path a p) (Path b p) a b
directions a2fb (Path l) = Path <$> traverse f l where
    f (Directions d) = Directions <$> a2fb d
    f (Alt p) = (pure . Alt) p

directions' :: Traversal (Fix (Path a)) (Fix (Path b)) a b
directions' = undefined

What I ultimately want to do is map every a to a b recursively in the structure. I was hoping I could do this by lifting directions but I seem to be held back by a) the fact the function declares p in the s and t positions and also b) the fact that _Wrapping is an Iso' not a Iso. Is there an elegant way to fix this?

Solution

In directions we need to traverse the p with a2fb too. Since p is a parameter, we can take its traversal as a parameter. In addition, the f you've defined is really a traversal of PathComponent, that we can pull out as well.

First, the traversal of PathComponent a p, which is parameterized by a traversal of p (and generalized so the source and target types can vary):

data PathComponent d a = Directions d | Alt [a] deriving (Show, Functor, Foldable, Traversable)

{- Morally

traversePC ::
  Traversal pa pb a b ->
  Traversal (PathComponent a pa) (PathComponent b pb) a b

   But the following type is both simpler (rank 1) and more general.
-}
traversePC ::
  Applicative m =>
  LensLike m pa pb a b ->
  LensLike m (PathComponent a pa) (PathComponent b pb) a b
traversePC _tp f (Directions d) = Directions <$> f d
traversePC  tp f (Alt pas) = Alt <$> (traverse . tp) f pas

In the Directions case, we transform the a to a b directly. In the Alt case, we have a list of pa, so we compose a traversal of that list (traverse) with the parameter traversal (tp).

The traversal of Path passes tp to traversePC.

newtype Path d a = Path [PathComponent d a] deriving (Show, Functor, Foldable, Traversable)

{- Same idea about the types.

directions :: Traversal pa pb a b -> Traversal (Path a pa) (Path b pb) a b

-}

directions ::
  Applicative m =>
  LensLike m pa pb a b ->
  LensLike m (Path a pa) (Path b pb) a b
directions tp f (Path l) = Path <$> (traverse . traversePC tp) f l

And finally, to traverse Fix (Path a), this unpacks to h :: Path a (Fix (Path a)), and we pass down the toplevel traversal for Fix (Path a) recursively.

directions' :: Traversal (Fix (Path a)) (Fix (Path b)) a b
directions' f (Fix h) = Fix <$> directions directions' f h

In fact, there is a general pattern here for any Fix. If you have a functor f (here Path a), and there is a traversal of f x parameterized by a traversal of x, then you can tie a knot to get a traversal traverseFix' of Fix f, applying the parameterized traversal to traverseFix' itself.

{-

traverseFix ::
  (forall x y. Traversal x y a b -> Traversal (f x) (g y) a b) ->
  Traversal (Fix f) (Fix g) a b

-}

traverseFix ::
  Functor m =>
  (forall x y. LensLike m x y a b -> LensLike m (f x) (g y) a b) ->
  LensLike m (Fix f) (Fix g) a b
traverseFix traverseF = traverseFix' where
  traverseFix' f (Fix h) = Fix <$> traverseF traverseFix' f h

So we can redefine directions' as follows:

directions'' :: Traversal (Fix (Path a)) (Fix (Path b)) a b
directions'' = traverseFix directions

Full gist