Composing functors and a bifunctor.

[exergasia]

I found myself needing to compose a bifunctor and a functor in a way that preserved bifunctorality, and I think that this code might be generally useful. I'm not really sold on the naming but I hope it's clear enough, especially with the type signatures; if there's a better name for this sort of thing that comes from theory or just intuition, please feel free to change it.

-- | Compose a bifunctor and two functors, one on the 'outside' (left) of the bifunctor and one on the 'inside' (right), preserving bifunctorality.
newtype HalfBicompose f p g a b = HalfBicompose { getHalfBicompose :: f (p a (g b)) }

-- | A bifunctor composed with a functor, preserving bifunctorality.
type HalfBicomposeL = HalfBicompose Identity

-- | A functor composed with a bifunctor, preserving bifunctorality.
type HalfBicomposeR f p = HalfBicompose f p Identity

instance (Bifunctor p, Functor f, Functor g) => Bifunctor (HalfBicompose f p g) where
  bimap f g = HalfBicompose . fmap (bimap f (fmap g)) . getHalfBicompose

instance (Bifunctor p, Functor f, Functor g) => Functor (HalfBicompose f p g a) where
  fmap = second

instance (Biapply p, Apply f, Apply g) => Biapply (HalfBicompose f p g) where
  HalfBicompose f <<.>> HalfBicompose a = HalfBicompose $ liftF2 (bilift2 ($) (<.>)) f a

instance (Biapplicative p, Applicative f, Applicative g) => Biapplicative (HalfBicompose f p g) where
  bipure a b = HalfBicompose $ pure (bipure a (pure b))
  HalfBicompose f <<*>> HalfBicompose a = HalfBicompose $ liftA2 (biliftA2 ($) (<*>)) f a

instance (Bifoldable p, Foldable f, Foldable g) => Bifoldable (HalfBicompose g p f) where
  bifoldMap f g = foldMap (bifoldMap f (foldMap g)) . getHalfBicompose

instance (Bifoldable p, Foldable f, Foldable g) => Foldable (HalfBicompose f p g a) where
  foldMap = bifoldMap (const mempty)

instance (Bitraversable p, Traversable f, Traversable g) => Bitraversable (HalfBicompose f p g) where
  bitraverse f g = fmap HalfBicompose . traverse (bitraverse f (traverse g)) . getHalfBicompose

instance (Bitraversable p, Traversable f, Traversable g) => Traversable (HalfBicompose f p g a) where
  traverse = bitraverse pure

fromHalfBicomposeL :: HalfBicomposeL p f a b -> p a (f b)
fromHalfBicomposeL = runIdentity . getHalfBicompose

toHalfBicomposeL :: p a (f b) -> HalfBicomposeL p f a b
toHalfBicomposeL = HalfBicompose . Identity

fromHalfBicomposeR :: (Functor f, Bifunctor p) => HalfBicomposeR f p a b -> f (p a b)
fromHalfBicomposeR = fmap (second runIdentity) . getHalfBicompose

toHalfBicomposeR :: (Functor f, Bifunctor p) => f (p a b) -> HalfBicomposeR f p a b
toHalfBicomposeR = HalfBicompose . fmap (second Identity)

halfBicomposeL2R :: (Applicative f, Bifunctor p, Traversable (p a)) => HalfBicomposeL p f a b -> HalfBicomposeR f p a b
halfBicomposeL2R = toHalfBicomposeR . sequenceA . fromHalfBicomposeL

halfBicomposeR2L :: (Traversable f, Bifunctor p, Applicative (p a)) => HalfBicomposeR f p a b -> HalfBicomposeL p f a b
halfBicomposeR2L = toHalfBicomposeL . sequenceA . fromHalfBicomposeR

[ekmett]

In category-extras I used to have Biff

newtype Biff p f g a b = Biff { runBuff :: p (f a) (g b) }

With that you can get use things like Biff (,) Identity to compose on one side.

I left it off here because it was pretty much ad hoc, but I'd be open to reintroducing it.

I also had another one for composing a functor on the outside, which had a name that escapes me.

[ghost]

I also had another one for composing a functor on the outside, which had a name that escapes me.

If you're okay with trademark lawsuits from Universal, perhaps Tannen might be a good name ;)

[ekmett]

Sold. Write a patch. ;)