An answer to https://stackoverflow.com/questions/48220977/traversing-with-a-biapplicative

Main.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

-- https://stackoverflow.com/questions/48220977/traversing-with-a-biapplicative
module Main where

import Data.Biapplicative
import Data.Char          (ord)

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


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


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

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

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

newtype L p b = L { runL :: p b () }

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

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

sequenceL :: (Traversable t, Biapplicative p) => t (p b c) -> p (t b) ()
sequenceL = runL . sequenceA . fmap mkL

mkL :: Biapplicative p => p b c -> L p b
mkL = L . biliftA2 (flip const) const (bipure () ())


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