What are simple definitions for Control.Lens.Traversal's partsOf, holesOf and singular?

Question

I'm trying to learn more about the lens library. I already understand the lenses in the lens-family package and their derivation and also grasp the two type parameter versions of Store, Pretext and Bazaar, but I'm having trouble understanding Control.Lens.Traversal's partsOf, holesOf and singular functions, which are defined with complex types and many auxiliary functions. Can these functions also be expressed in a simpler way for learning?

Answer 1

This is a rather large and thorny question. I profess that I myself do not fully understand how holesOf and partsOf work, and I didn't understand how singular worked until a couple of minutes ago, but I wanted to write down an answer that might help you.

I want to tackle a more general problem: how to read the lens source code. Because if you keep in mind a couple of simplifying assumptions, you can often simplify crazy definitions like

singular :: (Conjoined p, Functor f)
         => Traversing p f s t a a
         -> Over p f s t a a
singular l = conjoined
  (\afb s -> let b = l sell s in case ins b of
    (w:ws) -> unsafeOuts b . (:ws) <$> afb w
    []     -> unsafeOuts b . return <$> afb (error "singular: empty traversal"))
  (\pafb s -> let b = l sell s in case pins b of
    (w:ws) -> unsafeOuts b . (:Prelude.map extract ws) <$> cosieve pafb w
    []     -> unsafeOuts b . return                    <$> cosieve pafb (error "singular: empty traversal"))

unsafeOuts :: (Bizarre p w, Corepresentable p) => w a b t -> [b] -> t
unsafeOuts = evalState `rmap` bazaar (cotabulate (\_ -> state (unconsWithDefault fakeVal)))
  where fakeVal = error "unsafePartsOf': not enough elements were supplied"

ins :: Bizarre (->) w => w a b t -> [a]
ins = toListOf (getting bazaar)

unconsWithDefault :: a -> [a] -> (a,[a])
unconsWithDefault d []     = (d,[])
unconsWithDefault _ (x:xs) = (x,xs)

But I Am Getting Ahead of Myself

These are the rules I try to apply in my ahead when I read the lens source code:

Dumber Optics

Optics generally follow the s-t-a-b form throughout the library, which allows you to modify the type of the "target" (an overloaded word, at best). But many optics can be implemented with just s and a, and there is often no point in keeping track of the ts and bs when you are just trying to read a definition.

For example, when I was trying to reverse-engineer singular, I used these types in my scratch file:

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}

import BasePrelude hiding (fold)

type Lens big small =
  forall f. (Functor f) => (small -> f small) -> (big -> f big)

type Traversal big small =
  forall ap. (Applicative ap) => (small -> ap small) -> (big -> ap big)

makeLens :: (big -> small) -> (big -> small -> big) -> Lens big small
makeLens getter setter =
  \liftSmall big -> setter big <$> liftSmall (getter big)

And the combinators look like this:

set :: ((small -> Identity small) -> big -> Identity big) -> small -> big -> big
set setter new big =
  runIdentity (setter (\_ -> Identity new) big)

view :: ((small -> Const small small) -> big -> Const small big) -> big -> small
view getter big =
  getConst (getter Const big)

Get Out of Here, Indexes and Prisms

Prisms and indexed optics are tremendously useful as a consumer of lens but they are responsible for some of the more eye-clawing pieces of code. In order to unify prisms and indexed optics, the lens developers use profunctors (e.g. Choice and Conjoined) and its attendant helper functions (dimap, rmap).

When reading lens code I find it helpful to pretty much always assume p ~ (->) (the function type) whenever I see a profunctor variable. This lets me excise the Representable, Conjoined, Bizarre, and Over typeclasses from the signatures in the above code snippet.

A Lot of Type Holes

With this and the aid of GHC's type holes we can start trying to build our own singular on top our simpler, dumber types.

singular :: Traversal big small -> Lens big small
singular = _

The general strategy, as alluded to briefly on this comonad.com's blog post, is to traverse the big value to obtain a list of smalls ([small]) using Const and then put them back where we got them from using State.

Traversing to get a list can be done with our re-implementation of toListOf:

toListOf :: Traversal big small -> big -> [small]
toListOf traversal = foldrOf traversal (:) []

-- | foldMapOf with mappend/mzero inlined
foldrOf :: Traversal big small -> (small -> r -> r) -> r -> big -> r
foldrOf traversal fold zero =
  \big -> appEndo (foldMapOf traversal (Endo . fold) big) zero

-- | Traverses a value of type big, accumulating the result in monoid mon
foldMapOf :: Monoid mon => Traversal big small -> (small -> mon) -> big -> mon
foldMapOf traversal fold =
  getConst . traversal (Const . fold)

A nesting doll of monoids here: lists from Endos from Consts.

Now we have:

singular :: Traversal big small -> Lens big small
singular traversal liftSmall big = do
  case toListOf traversal big of
    (x:xs) -> _
    [] -> _

Putting the values back is a little brain-bending. There's this kind of insane function that we have been avoiding talking about:

unsafeOuts :: (Bizarre p w, Corepresentable p) => w a b t -> [b] -> t
unsafeOuts = evalState `rmap` bazaar (cotabulate (\_ -> state (unconsWithDefault fakeVal)))
  where fakeVal = error "unsafePartsOf': not enough elements were supplied"

Which, in our simplified universe, becomes

newtype Bazaar' small small' big =
  Bazaar { unBazaar :: forall ap. Applicative ap => (small -> ap small') -> ap big }
  deriving Functor

instance Applicative (Bazaar' small small') where
  pure big =
    Bazaar (\_ -> pure big)
  Bazaar lhs <*> Bazaar rhs =
    Bazaar (\liftSmall -> lhs liftSmall <*> rhs liftSmall)

type Bazaar small big = Bazaar' small small big

gobble :: StateT Identity [a] a
gobble = state (unconsWithDefault (error "empty!"))

unsafeOuts :: Bazaar small big -> [small] -> big
unsafeOuts (Bazaar bazaar) smalls =
  evalState (bazaar (\_ -> gobble)) smalls

Here we have inlined rmap = (.) and cotabulate f = f . Identity, and we were able to do so because we assumed p ~ (->).

A Half-Hearted Attempt at Puzzling Out Bazaars

Bazaars are weird, and scant seems to have been written about them. The lens documentation mentions that it's like a traversal that's already been applied to a structure. Indeed a bazaar is what you get if you take the Traversal type and apply it to a big value that you already have.

It is also something like a fancy free applicative, but I do not know if that helps or hurts.

On the last comment of this blog post about a seeming unrelated FunList datatype, the user Zemyla works out an equivalence between

data FunList a b t
    = Done t
    | More a (FunList a b (b -> t))

instance Functor (FunList a b) where ...
instance Applicative (FunList a b) where ...
instance Profunctor (FunList a) where ...

-- example values:
-- * Done (x :: t)
-- * More (a1 :: a) (Done (x :: a -> t))
-- * More (a1 :: a) (More (a2 :: a) (Done (x :: a -> a -> t))

and the lens Bazaar. I find this representation to be a little more helpful in intuiting what's going on.

Dat State Monad

The gem here is gobble, which pops off the head of the list from the state each time it runs. Our bazaar is able to upgrade the gobble :: StateT Identity [small] small value into a bazaar (\_ -> gobble) :: StateT Identity [small] big. Very much like a traversal we are able to take an effectful action acting on a part of a small value and upgrade it to an action that acts on the whole value. This all happens very quickly and with seemingly not enough code; it sort of makes my head spin.

(Something that might be helpful is to play with bazaars in GHCi using this helper function:

bazaarOf :: Traversal big small -> big -> Bazaar small big
bazaarOf traversal =
  traversal (\small -> Bazaar (\liftSmall -> liftSmall small))

-- See below for `ix`.

λ> unBazaar (bazaarOf (ix 3) [1,2,3,4]) Right
Right [1,2,3,4]

λ> unBazaar (bazaarOf (ix 3) [1,2,3,4]) (\_ -> Right 10)
Right [1,2,3,100]

λ> unBazaar (bazaarOf (ix 1) [1,2,3,4]) Left
Left 2

In simple cases it seems to approximately be a "deferred" version of traverse.)

In Any Case

unsafeOuts gives us a way to retrieve a second big value given a list of small values and a bazaar constructed from the first big value. Now we need to construct a bazaar from the original traversal we were passed in:

singular :: Traversal big small -> Lens big small
singular traversal liftSmall big = do
  let bazaar = traversal (\small -> Bazaar ($ small)) big
  case toListOf traversal big of
    (x:xs) -> _
    [] -> _

Here we do two things:

• First we mint ourselves a Bazaar small small. Since we plan on traversing over big, we can take each x :: small value we get and construct a Bazaar (\f -> f x) :: Bazaar small small. This suffices!

• The traversal type then smoothly upgrades our Bazaar small small into a bazaar :: Bazaar small big.

The original lens code does this with b = traversal sell big, using sell from the Sellable (->) (Bazaar (->)) instace. If you inline that definition you should end up with the same result.

In the x:xs case the x is the value we want to act on. It is the first value targeted by the traversal we were given, which now becomes the first value targeted the lens we return. We call liftSmall x to get a f small for some functor f; then we append xs inside the functor to get a f [small]; then we call unsafeOuts bazaar inside the functor to turn the f [small] back into a f big:

singular :: Traversal big small -> Lens big small
singular traversal liftSmall big = do
  let bazaar = traversal (\small -> Bazaar ($ small)) big
  case toListOf traversal big of
    (x:xs) -> fmap (\y -> unsafeOuts bazaar (y:xs)) <$> liftSmall x
    [] -> _

In the case of the empty of list, we act the same way except we stuff a bottom value in:

singular :: Traversal big small -> Lens big small
singular traversal liftSmall big = do
  let bazaar = traversal (\small -> Bazaar ($ small)) big
  case toListOf traversal big of
    (x:xs) -> fmap (\y -> unsafeOuts bazaar (y:xs)) <$> liftSmall x
    [] -> fmap (\y -> unsafeOuts bazaar [y]) <$> liftSmall (error "singularity")

Let's define some basic optics so we can play with our definition:

-- | Constructs a Traversal that targets zero or one
makePrism :: (small -> big) -> (big -> Either big small) -> Traversal big small
makePrism constructor getter =
  \liftSmall big -> case (fmap liftSmall . getter) big of
    Left big' -> pure big'
    Right fsmall -> fmap constructor fsmall

_Cons :: Traversal [a] (a, [a])
_Cons = makePrism (uncurry (:)) (\case (x:xs) -> Right (x, xs); [] -> Left [])

_1 :: Lens (a, b) a
_1 = makeLens fst (\(_, b) a' -> (a', b))

_head :: Traversal [a] a
_head = _Cons . _1

ix :: Int -> Traversal [a] a
ix k liftSmall big =
  if k < 0 then pure big else go big k
  where
    go [] _ = pure []
    go (x:xs) 0 = (:xs) <$> liftSmall x
    go (x:xs) i = (x:) <$> go xs (i - 1)

These are all stolen from the lens library.

As expected, it helps us shoo the annoying Monoid typeclass away:

λ> :t view _head
view _head :: Monoid a => [a] -> a
λ> :t view (singular _head)
view (singular _head) :: [small] -> small

λ> view _head [1,2,3,4]
    [snip]
    • Ambiguous type variable ‘a0’ arising from a use of ‘print’
      prevents the constraint ‘(Show a0)’ from being solved.
    [snip]
λ> view (singular _head) [1,2,3,4]
1

And it does nothing, as expected, with setters (since traversals are already setters):

λ> set (ix 100) 50 [1,2,3]
[1,2,3]
λ> set (singular (ix 100)) 50 [1,2,3]
[1,2,3]
λ> set _head 50 [1,2,3,4]
[50,2,3,4]
λ> set (singular _head) 50 [1,2,3,4]
[50,2,3,4]

partsOf and holesOf

-- | A type-restricted version of 'partsOf' that can only be used with a 'Traversal'.
partsOf' :: ATraversal s t a a -> Lens s t [a] [a]
partsOf' l f s = outs b <$> f (ins b) where b = l sell s

Pure conjecture follows: as far as I can tell, partsOf is exceedingly similar to singular in that it first constructs a bazaar b, calls f (ins b) on the bazaar, and then "puts the values back where it found it."

holesOf :: forall p s t a. Conjoined p => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOf l s = unTagged
  ( conjoined
     (Tagged $ let
        f [] _ = []
        f (x:xs) g = Pretext (\xfy -> g . (:xs) <$> xfy x) : f xs (g . (x:))
      in f (ins b) (unsafeOuts b))
     (Tagged $ let
        f [] _ = []
        f (wx:xs) g = Pretext (\wxfy -> g . (:Prelude.map extract xs) <$> cosieve wxfy wx) : f xs (g . (extract wx:))
      in f (pins b) (unsafeOuts b))
    :: Tagged (p a b) [Pretext p a a t]
  ) where b = l sell s

holesOf is also making a bazaar (l sell s for the third time!)) and once again suffers from conjunctivitis: by assuming p ~ (->) you can delete the second branch of the conjoined. But then you are left with a pile of Pretexts and comonads and I am not entirely sure how it all hangs together. It warrants further exploration!

Here is a gist of all the code I had in my scratch file at the time I hit Submit on this wall of text.