Traversing with a Biapplicative

Question

I was thinking about unzipping operations and realized that one way to express them is by traversing in a Biapplicative functor.

import Data.Biapplicative

class Traversable2 t where
  traverse2 :: Biapplicative p
            => (a -> p b c) -> t a -> p (t b) (t c)

-- Note: sequence2 :: [(a,b)] -> ([a], [b])
sequence2 :: (Traversable2 t, Biapplicative p)
          => t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id

instance Traversable2 [] where
  traverse2 _ [] = bipure [] []
  traverse2 f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs

It smells to me as though every instance of Traversable can be transformed mechanically into an instance of Traversable2. But I haven't yet found a way to actually implement traverse2 using traverse, short of converting to and from lists or perhaps playing extremely dirty tricks with unsafeCoerce. Is there a nice way to do this?

---

Further evidence that anything Traversable is Traversable2:

class (Functor t, Foldable t) => Traversable2 t where
  traverse2 :: Biapplicative p
            => (a -> p b c) -> t a -> p (t b) (t c)
  default traverse2 ::
               (Biapplicative p, Generic1 t, GTraversable2 (Rep1 t))
            => (a -> p b c) -> t a -> p (t b) (t c)
  traverse2 f xs = bimap to1 to1 $ gtraverse2 f (from1 xs)

class GTraversable2 r where
  gtraverse2 :: Biapplicative p
             => (a -> p b c) -> r a -> p (r b) (r c)

instance GTraversable2 V1 where
  gtraverse2 _ x = bipure (case x of) (case x of)

instance GTraversable2 U1 where
  gtraverse2 _ _ = bipure U1 U1

instance GTraversable2 t => GTraversable2 (M1 i c t) where
  gtraverse2 f (M1 t) = bimap M1 M1 $ gtraverse2 f t

instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :*: u) where
  gtraverse2 f (t :*: u) = bimap (:*:) (:*:) (gtraverse2 f t) <<*>> gtraverse2 f u

instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :+: u) where
  gtraverse2 f (L1 t) = bimap L1 L1 (gtraverse2 f t)
  gtraverse2 f (R1 t) = bimap R1 R1 (gtraverse2 f t)

instance GTraversable2 (K1 i c) where
  gtraverse2 f (K1 x) = bipure (K1 x) (K1 x)

instance (Traversable2 f, GTraversable2 g) => GTraversable2 (f :.: g) where
  gtraverse2 f (Comp1 x) = bimap Comp1 Comp1 $ traverse2 (gtraverse2 f) x

instance Traversable2 t => GTraversable2 (Rec1 t) where
  gtraverse2 f (Rec1 xs) = bimap Rec1 Rec1 $ traverse2 f xs

instance GTraversable2 Par1 where
  gtraverse2 f (Par1 p) = bimap Par1 Par1 (f p)

War

Check out Conor McBride's "Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures," if you haven't already. (cis.upenn.edu/~cis39903/static/clowns.pdf) – Adhesion

@Davislor, I think that relates to an entirely different sort of "unzipping". – War

@Davislor, it should be pretty easy to implement Traversable using Traversable2. Going the other way seems rarer harder. – War

Note that traverse (f :: a -> f b) ([] :: [a]) = pure ([] :: [b]). This seems like good evidence to me that traverse is not enough to implement traverse2, since we would therefore need an Applicative instance for which pure ([] :: [b]) called bipure ([] :: [b]) ([] :: [c]) (arg. 2 (!)) (without knowing anything special about lists, since the implementation of traverse is supposed to be the piece supplying all the list-specific knowledge). IOW, every call to pure (and (<*>)) gets handed a monomorphic thing rather than a polymorphic thing, and this prevents goodness. – Palomino

Answer 1

One only mildly evil way to do this is using something like Magma from lens. This seems considerably simpler than leftaroundabout's solution, although it's not beautiful either.

data Mag a b t where
  Pure :: t -> Mag a b t
  Map :: (x -> t) -> Mag a b x -> Mag a b t
  Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u
  One :: a -> Mag a b b

instance Functor (Mag a b) where
  fmap = Map

instance Applicative (Mag a b) where
  pure = Pure
  (<*>) = Ap

traverse2 :: forall t a b c f. (Traversable t, Biapplicative f)
          => (a -> f b c) -> t a -> f (t b) (t c)
traverse2 f0 xs0 = go m m
  where
    m :: Mag a x (t x)
    m = traverse One xs0

    go :: forall x y. Mag a b x -> Mag a c y -> f x y
    go (Pure t) (Pure u) = bipure t u
    go (Map f x) (Map g y) = bimap f g (go x y)
    go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys
    go (One x) (One y) = f0 x
    go _ _ = error "Impossible"

War

Answer 2

I think I might have something that fits your bill. (Edit: It doesn't, see comments.) You can define newtypes over p () c and p b () and make them Functor instances.

Implementation

Here's your class again with default definitions. I went the route of implementing sequence2 in terms of sequenceA because it seemed simpler.

class Functor t => Traversable2 t where
  {-# MINIMAL traverse2 | sequence2 #-}
  traverse2 :: Biapplicative p => (a -> p b c) -> t a -> p (t b) (t c)
  traverse2 f = sequence2 . fmap f

  sequence2 :: Biapplicative p => t (p b c) -> p (t b) (t c)
  sequence2 = traverse2 id

Now, the "right part" of the Biapplicative is

newtype R p c = R { runR :: p () c }

instance Bifunctor p => Functor (R p) where
  fmap f (R x) = R $ bimap id f x

instance Biapplicative p => Applicative (R p) where
  pure x = R (bipure () x)
  R f <*> R x =
    let f' = biliftA2 const (flip const) (bipure id ()) f
    in  R $ f' <<*>> x

mkR :: Biapplicative p => p b c -> R p c
mkR = R . biliftA2 const (flip const) (bipure () ())

sequenceR :: (Traversable t, Biapplicative p) => t (p b c) -> p () (t c)
sequenceR = runR . sequenceA . fmap mkR

with the "left part" much the same. The full code is in this gist.

Now we can make p (t b) () and p () (t c) and reassemble them into p (t b) (t c).

instance (Functor t, Traversable t) => Traversable2 t where
  sequence2 x = biliftA2 const (flip const) (sequenceL x) (sequenceR x)

I needed to turn on FlexibleInstances and UndecidableInstances for that instance declaration. Also, somehow ghc wanted a Functor constaint.

Testing

I verified with your instance for [] that it gives the same results:

main :: IO ()
main = do
  let xs = [(x, ord x - 97) | x <- ['a'..'g']]
  print xs
  print (sequence2 xs)
  print (sequence2' xs)

traverse2' :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c]
traverse2' _ [] = bipure [] []
traverse2' f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs

sequence2' :: Biapplicative p => [p b c] -> p [b] [c]
sequence2' = traverse2' id

outputs

[('a',0),('b',1),('c',2),('d',3),('e',4),('f',5),('g',6)]
("abcdefg",[0,1,2,3,4,5,6])
("abcdefg",[0,1,2,3,4,5,6])

This was a fun exercise!

Clad

I don't think that works. You traverse the sequence twice, which performs each effect twice. – War

Do you have an example for that? – Clad

Use a more exciting Biapplicative. Try newtype BIO x y = BIO (IO (x, y)) (that is, Tannen IO (,)) and use input and output in your traversal. – War

You're right, if I print a '+' everytime, I get a different number of pluses. So I assume this implementation violates some law of Traverse2. – Clad

I haven't written laws, but I think the Traversable ones should translate. I think your implementation will break the composition law. – War

Answer 3

The following seems to do the trick, exploiting “only” undefined. Possibly the traversable laws guarantee that this is ok, but I've not attempted to prove it.

{-# LANGUAGE GADTs, KindSignatures, TupleSections #-}

import Data.Biapplicative

import Data.Traversable

data Bimock :: (* -> * -> *) -> * -> * where
   Bimock :: p a b -> Bimock p (a,b)
   Bimfmap :: ((a,b) -> c) -> p a b -> Bimock p c
   Bimpure :: a -> Bimock p a
   Bimapp :: Bimock p ((a,b) -> c) -> p a b -> Bimock p c

instance Functor (Bimock p) where
  fmap f (Bimock p) = Bimfmap f p
  fmap f (Bimfmap g p) = Bimfmap (f . g) p
  fmap f (Bimpure x) = Bimpure (f x)
  fmap f (Bimapp gs xs) = Bimapp (fmap (f .) gs) xs
instance Biapplicative p => Applicative (Bimock p) where
  pure = Bimpure
  Bimpure f<*>xs = fmap f xs
  fs<*>Bimpure x = fmap ($x) fs
  fs<*>Bimock p = Bimapp fs p
  Bimfmap g h<*>Bimfmap i xs = Bimfmap (\(~(a₁,a₂),~(b₁,b₂)) -> g (a₁,b₁) $ i (a₂, b₂))
                              $ bimap (,) (,) h<<*>>xs
  Bimapp g h<*>xs = fmap uncurry g <*> ((,)<$>Bimock h<*>xs)

runBimock :: Biapplicative p => Bimock p (a,b) -> p a b
runBimock (Bimock p) = p
runBimock (Bimfmap f p) = bimap (fst . f . (,undefined)) (snd . f . (undefined,)) p
runBimock (Bimpure (a,b)) = bipure a b
runBimock (Bimapp (Bimpure f) xs) = runBimock . fmap f $ Bimock xs
runBimock (Bimapp (Bimfmap h g) xs)
     = runBimock . fmap (\(~(a₂,a₁),~(b₂,b₁)) -> h (a₂,b₂) (a₁,b₁))
           . Bimock $ bimap (,) (,) g<<*>>xs
runBimock (Bimapp (Bimapp h g) xs)
     = runBimock . (fmap (\θ (~(a₂,a₁),~(b₂,b₁)) -> θ (a₂,b₂) (a₁,b₁)) h<*>)
           . Bimock $ bimap (,) (,) g<<*>>xs

traverse2 :: (Biapplicative p, Traversable t) => (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f s = runBimock . fmap (\bcs->(fmap fst bcs, fmap snd bcs)) $ traverse (Bimock . f) s


sequence2 :: (Traversable t, Biapplicative p)
          => t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id

And even if this is safe, I wouldn't be surprised if it gives horrible performance, what with the irrefutable patterns and quadratic (or even exponential?) tuple-tree buildup.

Marymarya

Any reason to use undefined rather than ()? – Adhesion

@Adhesion () always has type (). – Marymarya

Okay, so it's conceptually similar to nnnmmm’s answer, but instead of defining two types, R and L, which replace either a or b with (), or what I did for my first unposted solution and required T a and T b to be Monoids so I could use mempty, you use undefined to work around the type system. Got it. – Adhesion

I'm guessing it might be possible to use the machinery in gist.github.com/treeowl/9621f58d55fe0c4f9162be0e074b1b29 to get a more principled and (somewhat) less inefficient implementation. But I don't think either approach will help with infinite traversals. – War

As long as you're using undefined, is there a reason not to do the dead simple thing of using toList and then traversing in State? – War

@War Does that necessarily preserve the shape of any Traversable? – Adhesion

@Davislor, yes. Where it has trouble is with infinite traversables and lazy applicatives. – War

I understand this better now. Thanks. – War

Answer 4

A few observations short of a complete, original answer.

If you have a Biapplicative bifunctor, what you can do with it is apply it to something and separate it into a pair of bifunctors isomorphic to its two components.

data Helper w a b = Helper {
  left :: w a (),
  right :: w () b
}

runHelper :: forall p a b. Biapplicative p => Helper p a b -> p a b
runHelper x = biliftA2 const (flip const) (left x) (right x)

makeHelper :: (Biapplicative p)
           => p a b -> Helper p a b
makeHelper w = Helper (bimap id (const ()) w)
                      (bimap (const ()) id w)

type Separated w a b = (w a (), w () b)

It would be possible to combine the approaches of @nnnmmm and @leftroundabout by applying fmap (makeHelper . f) to the structure s, eliminating the need for undefined, but then you would need to make Helper or its replacement an instance of some typeclass with the useful operations that let you solve the problem.

If you have a Traversable structure, what you can do is sequenceA Applicative functors (in which case your solution will look like traverse2 f = fromHelper . sequenceA . fmap (makeHelper . f), where your Applicative instance builds a pair of t structures) or traverse it using a Functor (in which case your solution will look like traverse2 f = fromHelper . traverse (g . makeHelper . f) where ...). Either way, you need to define a Functor instance, since Applicative inherits from Functor. You might try to build your Functor from <<*>> and bipure id id, or bimap, or you might work on both separated variables in the same pass.

Unfortunately, to make the types work for the Functor instance, you have to paramaterize :: p b c to a type we would informally call :: w (b,c) where the one parameter is the Cartesian product of the two parameters of p. Haskell’s type system doesn’t seem to allow this without non-standard extensions, but @leftroundabout pulls this off ably with the Bimock class. using undefined to coerce both separated functors to have the same type.

For performance, what you want to do is make no more than one traversal, which produces an object isomorphic to p (t b) (t c) that you can then convert (similar to the Naturality law). You therefore want to implement traverse2 rather than sequence2 and define sequence2 as traverse2 id, to avoid traversing twice. If you separate variables and produce something isomorphic to (p (t b) (), p () (t c)), you can then recombine them as @mmmnnn does.

In practical use, I suspect you would want to impose some additional structure on the problem. Your question kept the components b and c of the Bifunctor completely free, but in practice they will usually be either covariant or contravariant functors that can be sequenced with biliftA2 or traversed together over a Bitraversable rather than Traversable t, or perhaps even have a Semigroup, Applicative or Monad instance.

A particularly efficient optimization would be if your p is isomorphic to a Monoid whose <> operation produces a data structure isomorphic to your t. (This works for lists and binary trees; Data.ByteString.Builder is an algebraic type that has this property.) In this case, the associativity of the operation lets you transform the structure into either a strict left fold or a lazy right fold.

This was an excellent question, and although I don’t have better code than @leftroundabout for the general case, I learned a lot from working on it.

Adhesion