使用双应用程序遍历
Traversing with a Biapplicative
我在考虑解压缩操作，并意识到表达它们的一种方法是遍历 Biapplicative 仿函数。
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
我觉得 Traversable 的每个实例都可以机械地转换为 Traversable2 的实例。但是我还没有找到使用 traverse 实际实现 traverse2 的方法，除了在列表之间进行转换或者可能使用 unsafeCoerce 玩一些极其肮脏的把戏。有什么好的方法吗？
Traversable 是 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)
我想我可能有适合您要求的东西。 （编辑：它没有，请参阅评论。）您可以在 p () c 和 p b () 上定义新类型，并使它们成为 Functor 实例。
实施
这又是您的 class，使用默认定义。我按照 sequenceA 的方式实施 sequence2 因为它看起来更简单。
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
现在，Biapplicative 的 "right part" 是
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
跟"left part"大同小异。完整代码在 this gist.
现在我们可以制作p (t b) ()和p () (t c)，然后将它们重新组装成p (t b) (t c)。
instance (Functor t, Traversable t) => Traversable2 t where
sequence2 x = biliftA2 const (flip const) (sequenceL x) (sequenceR x)
我需要为该实例声明打开 FlexibleInstances 和 UndecidableInstances。另外，不知何故 ghc 想要一个 Functor containt。
测试
我用你的实例验证了 [] 它给出了相同的结果：
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
产出
[('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])
这是一个有趣的练习！
以下似乎可以解决问题，利用“仅”undefined。可能可遍历法则保证这是可以的，但我还没有尝试证明它。
{-# 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
即使这是安全的，如果它给出可怕的性能，我也不会感到惊讶，因为无可辩驳的模式和二次（甚至指数？）元组树构建。
一些观察结果没有完整的原始答案。
如果你有一个 Biapplicative 双函子，你可以用它做的是将它应用到某物上并将它分成一对与其两个分量同构的双函子。
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)
可以通过将 fmap (makeHelper . f) 应用于结构 s 来组合 @nnnmmm 和 @leftroundabout 的方法，从而消除对 undefined 的需要，但是你需要使 Helper 或其替代品成为某种类型的 instanceclass，并使用可让您解决问题的有用操作。
如果你有一个 Traversable 结构，你可以做的是 sequenceA Applicative 仿函数（在这种情况下你的解决方案看起来像 traverse2 f = fromHelper . sequenceA . fmap (makeHelper . f)，你的 Applicative 实例构建一对 t 结构）或 traverse 它使用 Functor （在这种情况下，您的解决方案将看起来像 traverse2 f = fromHelper . traverse (g . makeHelper . f) where ...）。无论哪种方式，您都需要定义一个 Functor 实例，因为 Applicative 继承自 Functor。您可以尝试从 <<*>> 和 bipure id id 或 bimap 构建您的 Functor，或者您可以在同一遍中处理两个分离的变量。
不幸的是，要使类型适用于 Functor 实例，您必须将 :: p b c 参数化为一种我们非正式地称为 :: w (b,c) 的类型，其中一个参数是笛卡尔积p 的两个参数。 Haskell 的类型系统似乎不允许在没有非标准扩展的情况下这样做，但是@leftroundabout 使用 Bimock class 巧妙地实现了这一点。使用 undefined 强制两个分离的仿函数具有相同的类型。
为了性能，你要做的只是一次遍历，它产生一个与 p (t b) (t c) 同构的对象，然后你可以转换它（类似于自然法则）。因此，您希望实现 traverse2 而不是 sequence2 并将 sequence2 定义为 traverse2 id，以避免遍历两次。如果你分离变量并产生与 (p (t b) (), p () (t c)) 同构的东西，你可以像@mmmnnn 那样重新组合它们。
在实际使用中，我怀疑您想要对问题强加一些额外的结构。您的问题使 Bifunctor 的组件 b 和 c 完全自由，但实际上它们通常是协变或逆变函子，可以用 biliftA2 排序或遍历在一起 Bitraversable 而不是 Traversable t，或者甚至可能有一个 Semigroup、Applicative 或 Monad 实例。
如果您的 p 与 Monoid 同构，而后者的 <> 操作产生与您的 t 同构的数据结构，那么优化将是特别有效的。 （这适用于列表和二叉树；Data.ByteString.Builder 是具有此 属性 的代数类型。）在这种情况下，操作的结合性允许您将结构转换为严格的左折叠或懒惰的右折叠。
这是一个很好的问题，虽然对于一般情况我没有比@leftroundabout 更好的代码，但我从中学到了很多东西。
唯一有点邪恶的方法是使用 lens 中的 Magma 之类的东西。这似乎比 leftaroundabout 的解决方案简单得多，尽管它也不漂亮。
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"
我在考虑解压缩操作，并意识到表达它们的一种方法是遍历 Biapplicative 仿函数。
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
我觉得 Traversable 的每个实例都可以机械地转换为 Traversable2 的实例。但是我还没有找到使用 traverse 实际实现 traverse2 的方法，除了在列表之间进行转换或者可能使用 unsafeCoerce 玩一些极其肮脏的把戏。有什么好的方法吗？
Traversable 是 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)
我想我可能有适合您要求的东西。 （编辑：它没有，请参阅评论。）您可以在 p () c 和 p b () 上定义新类型，并使它们成为 Functor 实例。
实施
这又是您的 class，使用默认定义。我按照 sequenceA 的方式实施 sequence2 因为它看起来更简单。
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
现在，Biapplicative 的 "right part" 是
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
跟"left part"大同小异。完整代码在 this gist.
现在我们可以制作p (t b) ()和p () (t c)，然后将它们重新组装成p (t b) (t c)。
instance (Functor t, Traversable t) => Traversable2 t where
sequence2 x = biliftA2 const (flip const) (sequenceL x) (sequenceR x)
我需要为该实例声明打开 FlexibleInstances 和 UndecidableInstances。另外，不知何故 ghc 想要一个 Functor containt。
测试
我用你的实例验证了 [] 它给出了相同的结果：
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
产出
[('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])
这是一个有趣的练习！
以下似乎可以解决问题，利用“仅”undefined。可能可遍历法则保证这是可以的，但我还没有尝试证明它。
{-# 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
即使这是安全的，如果它给出可怕的性能，我也不会感到惊讶，因为无可辩驳的模式和二次（甚至指数？）元组树构建。
一些观察结果没有完整的原始答案。
如果你有一个 Biapplicative 双函子，你可以用它做的是将它应用到某物上并将它分成一对与其两个分量同构的双函子。
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)
可以通过将 fmap (makeHelper . f) 应用于结构 s 来组合 @nnnmmm 和 @leftroundabout 的方法，从而消除对 undefined 的需要，但是你需要使 Helper 或其替代品成为某种类型的 instanceclass，并使用可让您解决问题的有用操作。
如果你有一个 Traversable 结构，你可以做的是 sequenceA Applicative 仿函数（在这种情况下你的解决方案看起来像 traverse2 f = fromHelper . sequenceA . fmap (makeHelper . f)，你的 Applicative 实例构建一对 t 结构）或 traverse 它使用 Functor （在这种情况下，您的解决方案将看起来像 traverse2 f = fromHelper . traverse (g . makeHelper . f) where ...）。无论哪种方式，您都需要定义一个 Functor 实例，因为 Applicative 继承自 Functor。您可以尝试从 <<*>> 和 bipure id id 或 bimap 构建您的 Functor，或者您可以在同一遍中处理两个分离的变量。
不幸的是，要使类型适用于 Functor 实例，您必须将 :: p b c 参数化为一种我们非正式地称为 :: w (b,c) 的类型，其中一个参数是笛卡尔积p 的两个参数。 Haskell 的类型系统似乎不允许在没有非标准扩展的情况下这样做，但是@leftroundabout 使用 Bimock class 巧妙地实现了这一点。使用 undefined 强制两个分离的仿函数具有相同的类型。
为了性能，你要做的只是一次遍历，它产生一个与 p (t b) (t c) 同构的对象，然后你可以转换它（类似于自然法则）。因此，您希望实现 traverse2 而不是 sequence2 并将 sequence2 定义为 traverse2 id，以避免遍历两次。如果你分离变量并产生与 (p (t b) (), p () (t c)) 同构的东西，你可以像@mmmnnn 那样重新组合它们。
在实际使用中，我怀疑您想要对问题强加一些额外的结构。您的问题使 Bifunctor 的组件 b 和 c 完全自由，但实际上它们通常是协变或逆变函子，可以用 biliftA2 排序或遍历在一起 Bitraversable 而不是 Traversable t，或者甚至可能有一个 Semigroup、Applicative 或 Monad 实例。
如果您的 p 与 Monoid 同构，而后者的 <> 操作产生与您的 t 同构的数据结构，那么优化将是特别有效的。 （这适用于列表和二叉树；Data.ByteString.Builder 是具有此 属性 的代数类型。）在这种情况下，操作的结合性允许您将结构转换为严格的左折叠或懒惰的右折叠。
这是一个很好的问题，虽然对于一般情况我没有比@leftroundabout 更好的代码，但我从中学到了很多东西。
唯一有点邪恶的方法是使用 lens 中的 Magma 之类的东西。这似乎比 leftaroundabout 的解决方案简单得多，尽管它也不漂亮。
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"