What's the Profunctor Representation of "Wither"?

This article by Chris Penner talks about "Witherable Optics"; Optics that can be used to filter items out from a structure.

The article uses the following "Van Laarhoven" representation for these optics:

type Wither s t a b = forall f. Alternative f => (a -> f b) -> s -> f t

Most (if not all) Van Laarhoven optics have an equivalent profunctor representation. For example Lens:

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

Is equivalent to:

type Lens s t a b = forall p. Strong p => p a b -> p s t

Does Wither also have a Profuctor representation? And if so, what is it?

Solution

Chris here; here's my swing at the profunctor optics representation:

Here's the profunctor class:

import Data.Profunctor
import Data.Profunctor.Traversing
import Control.Applicative

class (Traversing p) => Withering p where
  cull :: (forall f. Alternative f => (a -> f b) -> (s -> f t)) -> p a b -> p s t

instance Alternative f => Withering (Star f) where
  cull f (Star amb) = Star (f amb)

instance Monoid m => Withering (Forget m) where
  cull f (Forget h) = Forget (getAnnihilation . f (AltConst . Just . h))
    where
      getAnnihilation (AltConst Nothing) = mempty
      getAnnihilation (AltConst (Just m)) = m

newtype AltConst a b = AltConst (Maybe a)
  deriving stock (Eq, Ord, Show, Functor)

instance Monoid a => Applicative (AltConst a) where
  pure _ = (AltConst (Just mempty))
  (AltConst Nothing) <*> _ = (AltConst Nothing)
  _ <*> (AltConst Nothing) = (AltConst Nothing)
  (AltConst (Just a)) <*> (AltConst (Just b)) = AltConst (Just (a <> b))

instance (Semigroup a) => Semigroup (AltConst a x) where
  (AltConst Nothing) <> _ = (AltConst Nothing)
  _ <> (AltConst Nothing) = (AltConst Nothing)
  (AltConst (Just a)) <> (AltConst (Just b)) = AltConst (Just (a <> b))

instance (Monoid a) => Monoid (AltConst a x) where
  mempty = (AltConst (Just mempty))

instance Monoid m => Alternative (AltConst m) where
  empty = (AltConst Nothing)
  (AltConst Nothing) <|> a = a
  a <|> (AltConst Nothing) = a
  (AltConst (Just a)) <|> (AltConst (Just b)) = (AltConst (Just (a <> b)))

If you're interested in some of the optics that arise, I've implemented a few of those here:

It's definitely possible there are other interpretations or perhaps some simpler representation, but at the moment this seems to do the trick. If anyone else has other ideas I'd love to see them!

Happy to chat about it more if you have any other questions!