Posted on 2017-03-20
by Oleg Grenrus

Thanks to Matthew Pickering, I learned about affine traversals. Affine traversal is an optic that has 0 or 1 target; the fact which you can check by using specialised view function! While playing with them, you have to use `Pointed`

in the van Laarhoven formulation; profunctor one doesn't suffer from this (subjective) unelegancy!

Behold, profunctors ahead:

```
{-# LANGUAGE RankNTypes, TupleSections #-}
import Control.Applicative
import Data.Bifunctor
import Data.Default
import Data.Functor.Apply
import Data.Pointed
import Data.Profunctor
import Data.Semigroup.Traversable
```

*Affine traversal* is an optic that has 0 or 1 target (see e.g. `failing`

)

The simplest example would be:

`ex1 f = (_1 . _Right) f`

The problem is that in `lens`

(var Laarhoven encoding) a `Prism`

is:

```
type PrismVL s t a b =
forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
```

here, `Applicative`

is too restrictive, forcing combination with

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

to be full

```
type TraversalVL s t a b =
forall f. (Applicative f) => (a -> f b) -> s -> f t
```

To define prism, the disputed `Pointed`

class would be enough. In lens usage it won't be as bad, as library writer controls how they will instantiate `f`

in the optic!

**If** we had

```
type PrismVL' s t a b =
forall p f. (Choice p, Functor f, Pointed f) => p a (f b) -> p s (f t)
-- | Using 'point', not 'pure'
prismVL' :: (b -> t) -> (s -> Either t a) -> PrismVL' s t a b
prismVL' bt seta = dimap seta (either point (fmap bt)) . right'
```

then we could define

```
type AffTraversalVL s t a b =
forall p f. (Functor f, Pointed f) => (a -> f b) -> s -> f t
```

The "nice" consequence, is that

```
type GettingVL r s a = (a -> Const r a) -> s -> Const r s
viewVL :: GettingVL a s a -> s -> a
viewVL l s = getConst (l Const s)
```

used on a `AffTraversalVL`

```
ex1' :: AffTraversalVL (Either c a, d) (Either c b, d) a b
ex1' = _1 . _Right
```

would give `Default`

values on non-match (and not `mempty`

):

```
λ> viewVL ex1 (Right 42, True) :: Int
42
λ> viewVL ex1 (Left 'a', True) :: Int
0
```

because `Pointed (Const r)`

is defined in terms of `Default r`

.

If we'd use profunctor optics, `Lens`

and `Prism`

are defined more uniformly:

```
type LensP s t a b = forall p. Strong p => p a b -> p s t
type PrismP s t a b = forall p. Choice p => p a b -> p s t
```

It turns out that their combination is the affine traversal!

```
type AffTraversalP s t a b =
forall p. (Strong p, Choice p) => p a b -> p s t
```

We can repeat the above example, if we define `Choice (Forget r)`

using `Default`

(instances are at the end):

```
newtype ForgetD r a b = ForgetD { runForgetD :: a -> r }
type GettingP r s a = ForgetD r a a -> ForgetD r s s
viewP :: GettingP a s a -> s -> a
viewP l = runForgetD (l (ForgetD id))
```

used on an optic

```
ex2 :: AffTraversalP (Either c a, d) (Either c b, d) a b
ex2 = first' . right'
```

seems to work:

```
λ> viewP ex2 (Right 42, True) :: Int
42
λ> viewP ex2 (Left 'a', True) :: Int
0
```

Another approach is to define

```
newtype ForgetM r a b = ForgetM { runForgetM :: a -> Maybe r }
type AffGettingP r s a = ForgetM r a a -> ForgetM r s s
affviewP :: AffGettingP a s a -> s -> Maybe a
affviewP l = runForgetM (l (ForgetM Just))
```

```
λ> affviewP ex2 (Right 42, True) :: Maybe Int
Just 42
λ> affviewP ex2 (Left 'a', True) :: Maybe Int
Nothing
```

And as `ForgetM`

isn't (cannot be?) `Traversing`

, this won't type-check:

```
λ> affviewP traverse' ["foo", "bar"]
<interactive>:_:10: error:
• No instance for (Traversing (ForgetM [Char]))
```

but the `viewP`

does fold:

```
λ> viewP traverse' ["foo", "bar"]
"foobar"
```

We *could* define `Traversing`

instance for `ForgetM`

, but we deliberately don't, as we want that type-check failure to occur.

The profunctor approach is more elegant, as we don't need to rely on `Pointed`

, the `point`

is baked into `affviewP`

formulation!

I think the `AffTraversal`

can be useful in practice. There are situations where you know that there is *at most one* value, hidden inside your big structure. By using `firstOf`

, we don't enforce that fact, but we could!

We can show that the definitions are equivalent. We start by specifying the constructors:

```
afftraversalVL
:: (s -> Either t a)
-> (s -> b -> t)
-> AffTraversalVL s t a b
afftraversalVL getter setter f s = case getter s of
Left t -> point t
Right a -> (\b -> setter s b) <$> f a
afftraversalP
:: (s -> Either t a)
-> (s -> b -> t)
-> AffTraversalP s t a b
afftraversalP getter setter pab = dimap r l (first' (right' pab))
where
r s = (getter s, setter s)
l (Left t, _) = t
l (Right b, g) = g b
```

Then to go from profunctor to van Laarhoven, we'll need a profunctor kiosk:

```
data Kiosk a b s t = Kiosk (s -> Either t a) (s -> b -> t)
sellKiosk :: Kiosk a b a b
sellKiosk = Kiosk Right (\_ -> id)
instance Profunctor (Kiosk u v) where
dimap f g (Kiosk getter setter) = Kiosk
(\a -> first g $ getter (f a))
(\a v -> g (setter (f a) v))
instance Strong (Kiosk u v) where
first' (Kiosk getter setter) = Kiosk
(\(a, c) -> first (,c) $ getter a)
(\(a, c) v -> (setter a v, c))
instance Choice (Kiosk u v) where
right' (Kiosk getter setter) = Kiosk
(\eca -> assoc (second getter eca))
(\eca v -> second (`setter` v) eca)
where
assoc :: Either a (Either b c) -> Either (Either a b) c
assoc (Left a) = Left (Left a)
assoc (Right (Left b)) = Left (Right b)
assoc (Right (Right c)) = Right c
```

Then conversion is simple, as `Kiosk`

characterizes affine traversal, we can run the profunctor optic to get getters and setters, which in turn are used to construct van Laarhoven variant:

```
toVL :: AffTraversalP s t a b -> AffTraversalVL s t a b
toVL l = afftraversalVL getter setter
where
Kiosk getter setter = l sellKiosk
```

To go in other direction we need a functor kiask:

```
newtype Kiask a b t = Kiask { runKiask :: (Either t a, b -> t) }
sellKiask :: a -> Kiask a b b
sellKiask a = Kiask (Right a, id)
instance Functor (Kiask a b) where
fmap f (Kiask (Left t, g)) = Kiask (Left (f t), f . g)
fmap f (Kiask (Right a, g)) = Kiask (Right a, f . g)
instance Pointed (Kiask a b) where
point x = Kiask (Left x, const x)
```

And the conversion functions follows the same principle as previous one:

```
toP :: AffTraversalVL s t a b -> AffTraversalP s t a b
toP l = afftraversalP (fst . b) (snd . b)
where
b s = runKiask $ l sellKiask s
```

And those seem to work!

```
λ> viewVL (toVL ex2) (Right 42, True) :: Int
42
λ> viewVL (toVL ex2) (Left 'a', True) :: Int
0
λ> viewP (toP ex1) (Right 42, True) :: Int
42
λ> viewP (toP ex1) (Left 'a', True) :: Int
0
```

The traversal in profunctor optics is defined using `Traversing`

or `Wander`

class:

```
class (Choice p, Strong p) => Traversing p where
traverse' :: Traversable f => p a b -> p (f a) (f b)
traverse' = wander traverse
wander :: (forall f. Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
```

It's trivial to define `Wander1`

for non-empty traversals: replace `Applicative`

with `Apply`

and postfix `1`

to the symbol names:

```
class (Choice p, Strong p) => Traversing1 p where
traverse1' :: Traversable1 f => p a b -> p (f a) (f b)
traverse1' = wander1 traverse1
wander1 :: (forall f. Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
```

So let's go for affine traversal as well:

```
class (Choice p, Strong p) => AffTraversing p where
affwander
:: (forall f. (Functor f, Pointed f) => (a -> f b) -> s -> f t)
-> p a b -> p s t
afftraverse' :: AffTraversable f => p a b -> p (f a) (f b)
afftraverse' = affwander afftraverse
```

where `AffTraversable`

has obvious definition, and `Maybe`

is a canonical instance:

```
class Functor t => AffTraversable t where
afftraverse :: (Functor f, Pointed f) => (a -> f b) -> t a -> f (t b)
instance AffTraversable Maybe where
afftraverse _ Nothing = point Nothing
afftraverse f (Just x) = Just <$> f x
```

Using the conversion functions from the previous section, we can show that

```
type X s t a b = forall p. (Strong p, Choice p) => p a b -> p s t
type Y s t a b = forall p. (AffTraversing p) => p a b -> p s t
```

are isomorphic! It's 10 at the morning, so I don't try to conclude from that `AffTraversing p`

is equivalent to `(Strong p, Choice p)`

, but they are close. And what that means to the `Default`

& `Pointed`

story?

Class | Functor | Container | Example | Cat |
---|---|---|---|---|

Default | Pointed | AffTraversable |
Maybe | ? |

Semigroup | Apply | Traversable1 | NonEmpty | Semigroupoid |

Monoid | Applicative | Traversable | [] | Category |

`AffTraversal`

isn't equaivalent to `Lens s t (Maybe a) (Maybe b)`

as the latter let you *remove* values from the structure (e.g. `at`

).

The `Lens s t (Maybe a) b`

is closer:

```
ex3 :: LensVL (Either c a, d) (Either c b, d) (Maybe a) b
ex3 = lensVL getter setter
where
getter (Right a, _) = Just a
getter (_, _) = Nothing
setter (Right _, d) b = (Right b, d)
setter (Left x, d) b = (Left x, d)
```

but doesn't seem practical (and needs differently specified lens laws!)

Simple van Laarhoven optics:

```
lensVL :: (s -> a) -> (s -> b -> t) -> LensVL s t a b
lensVL sa sbt afb s = sbt s <$> afb (sa s)
_1 :: LensVL (a, c) (b, c) a b
_1 f (a, c) = flip (,) c <$> f a
_Right :: PrismVL' (Either c a) (Either c b) a b
_Right = prismVL' Right $ \e -> case e of
Left c -> Left (Left c)
Right a -> Right a
```

```
instance Profunctor (ForgetD r) where
dimap f _ (ForgetD k) = ForgetD (k . f)
instance Strong (ForgetD r) where
first' (ForgetD k) = ForgetD (k . fst)
-- | 'Default', not 'Monoid'
instance Default r => Choice (ForgetD r) where
left' (ForgetD k) = ForgetD (either k (const def))
instance (Default r, Monoid r) => Traversing (ForgetD r) where
wander f (ForgetD k) = ForgetD $ \s ->
getConst (f (Const . k) s)
instance Profunctor (ForgetM r) where
dimap f _ (ForgetM k) = ForgetM (k . f)
instance Strong (ForgetM r) where
first' (ForgetM k) = ForgetM (k . fst)
instance Choice (ForgetM r) where
left' (ForgetM k) = ForgetM (either k (const Nothing))
```

You can run this file with

```
stack --resolver=nightly-2017-03-01 ghci --ghci-options='-pgmL markdown-unlit'
λ> :l affine-traversal.lhs
```

Site proudly generated by Hakyll