Traversing with a Biapplicative

China☆狼群 提交于 2019-12-03 22:37:28

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!

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.

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.

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"
易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!