Traversing with a Biapplicative

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)

Solution

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"