Is Traversable different for breadth-first and depth-first trees?

Question

I have a Rose Tree structure and I wanted to write a Traversable instance for it. So I started with the following:

data Tree a = Tree a [Tree a] deriving (Show)

instance Functor Tree where
  fmap f (Tree x subs) = Tree (f x) (fmap (fmap f) subs)

I did the depth-first variant of it:

newtype Depth a = Depth (Tree a) deriving (Show)

depth :: Tree a -> [a]
depth (Tree x subs) = x : concatMap depth subs

instance Functor Depth where
  fmap f (Depth t) = Depth $ fmap f t

instance Foldable Depth where
  foldMap f (Depth t) = mconcat $ f <$> depth t

instance Traversable Depth where
  traverse f (Depth t) = Depth <$> go t
    where go (Tree x subs) = Tree <$> f x <*> traverse go subs

Then I tried the breadth-first variant:

newtype Breadth a = Breadth (Tree a) deriving (Show)

breadth :: Tree a -> [a]
breadth tree = go [tree]
  where
    go [] = []
    go (Tree x subs:q) = x : go (q <> subs)

instance Functor Breadth where
  fmap f (Breadth t) = Breadth $ fmap f t

instance Foldable Breadth where
  foldMap f (Breadth t) = mconcat $ f <$> breadth t

instance Traversable Breadth where
  traverse f (Breadth t) = ???

And I realized that the breadth and depth first variants of Traversable for this should be the same. Is this the case? I don't believe I've actually read this anywhere but traversal is independent of the order of the elements?

If so, this gets a little weird because Traversable can then be implemented directly for Tree , which means that Foldable needs to be implemented for Tree , but there are obviously multiple ways that Foldable can be implemented.

Answer 1

Traversable has to agree with Foldable . Specifically, if Monoid m , then Applicative (Const m) , causing a consistency law foldMap f = getConst . traverse (Const . f) foldMap f = getConst . traverse (Const . f) . It is thus impossible for Breadth and Depth to share a Traversable . There is either a different implementation for Traversable Breadth that agrees with its Foldable , or there is none at all. I can cook up an implementation that I believe does agree, but I haven't verified the other laws.

instance Traversable Breadth where
  traverse f (Breadth t) = Breadth <$> head <$> go [t]
    where
      go [] = pure []
      go ts = zipWith Tree <$> traverse f rs
                           <*> (fmap (rebuild css) $ go $ concat css)
        where
          (rs, css) = unzip $ map (\(Tree r cs) -> (r, cs)) ts
          -- rebuild s d = evalState (traverse (state splitAt') d) s
          -- I think, but let's keep the dependencies down, shall we?
          rebuild [] [] = []
          rebuild (struct : structs) destruct
            = let (cs, destruct') = splitAt' struct destruct
              in  cs : rebuild structs destruct'
          -- ignoring the as in a [a] makes it look like a number
          splitAt' [] xs = ([], xs)
          splitAt' (_ : n) (x : xs)
            = let (pre, suf) = splitAt' n xs
              in  (x : pre, suf)

This is pretty hairy, and there's non-totality everywhere, but it should work out fine.

Answer 2

Here's a variation of HTNW's solution, using Compose instead of flattening the structure on recursive call. This means we don't need to rebuild the structure, but it is probably also slower, since it requires traversing a deep structure at every recursive step.

liftA2 together with a ZipList is used to generalize zipWith to arbitrary many Compose d nested lists. The ScopedTypeVariables is needed to give an explicit type signature to the polymorphically recursive function go .

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module BreadthFirstTraverse where
import Data.Tree (Tree(..))
import Control.Applicative (ZipList(..), Applicative (liftA2))
import Data.Functor.Compose (Compose(..))
-- import Control.Monad.Identity (Identity(..))

-- ...

instance Traversable Breadth where
  traverse f (Breadth t) = Breadth <$> bfTraverse f t

bfTraverse :: forall f a b. Applicative f => (a -> f b) -> Tree a -> f (Tree b)
bfTraverse k (Node t0 ts0) = nodeC <$> k t0 <*> go (ZipList ts0)
-- equivalent alternative: 
-- bfTraverse k t = fmap runIdentity (go (Identity t))
  where
    nodeC x xs = Node x (getZipList xs)
    go :: (Applicative t, Traversable t) => t (Tree a) -> f (t (Tree b))
    go ts | Just ts' <- nullMap ts = pure ts'
    go ts = liftA2 nodeC <$> traverse k rs <*> fmap getCompose (go $ Compose css)
        where
          rs = fmap rootLabel ts
          css = fmap (ZipList . subForest) ts

-- | If a structure is empty, replace its content type
-- > isJust . nullMap == null
nullMap :: Traversable t => t a -> Maybe (t b)
nullMap = traverse (const Nothing)