Parameterised Traversals

PTraverse.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}

-- https://www.cs.ox.ac.uk/jeremy.gibbons/publications/dgp.pdf - 5.6
module PTraverse where

import Control.Monad.State.Strict

data ApAdapter m
  = forall g. Applicative (g m)
  => MkApAdapter (forall a. m a -> g m a) (forall a. g m a -> m a)

ptraverse
  :: (Traversable t, Applicative f)
  => ApAdapter f
  -> (a -> f b)
  -> t a
  -> f (t b)
ptraverse (MkApAdapter wrap unwrap) f = unwrap . traverse (wrap . f)

--

newtype Forwards m a = MkForwards { runForwards :: m a }
  deriving Functor

instance Applicative m => Applicative (Forwards m) where
  pure = MkForwards . pure
  f <*> x = MkForwards $ runForwards f <*> runForwards x

-- forward traversal, same as traverse
ftraverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
ftraverse = ptraverse (MkApAdapter MkForwards runForwards)

newtype Backwards m a = MkBackwards { runBackwards :: m a }
  deriving Functor

instance Applicative m => Applicative (Backwards m) where
  pure = MkBackwards . pure
  f <*> x = MkBackwards $ flip id <$> runBackwards x <*> runBackwards f

-- backwards traversal
btraverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
btraverse = ptraverse (MkApAdapter MkBackwards runBackwards)

----
-- Small example

data Tree a = Node a [Tree a]
  deriving (Show, Functor, Foldable, Traversable)

labelData :: Char -> State Int (Char, Int)
labelData c = do
  i <- get
  modify (+ 1)
  pure (c, i)

tree :: Tree Char
tree = Node
  'a'
  [ Node 'b' [Node 'x' [], Node 'x' [], Node 'x' [], Node 'x' []]
  , Node 'c' [Node 'e' [], Node 'f' [Node 'h' [], Node 'i' []], Node 'g' []]
  , Node 'd' []
  ]

main :: IO ()
main = do
  print $ evalState (ftraverse labelData tree) 0
  print $ evalState (btraverse labelData tree) 0

{-
λ> main
Node ('a',0) [Node ('b',1) [Node ('x',2) [],Node ('x',3) [],Node ('x',4) [],Node ('x',5) []],Node ('c',6) [Node ('e',7) [],Node ('f',8) [Node ('h',9) [],Node ('i',10) []],Node ('g',11) []],Node ('d',12) []]
Node ('a',12) [Node ('b',11) [Node ('x',10) [],Node ('x',9) [],Node ('x',8) [],Node ('x',7) []],Node ('c',6) [Node ('e',5) [],Node ('f',4) [Node ('h',3) [],Node ('i',2) []],Node ('g',1) []],Node ('d',0) []]
-}