Oleg's gists — Archive

Affine Traversal

Posted on 2017-03-20 by Oleg Grenrus lens

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 #-}
module AffineTraversal where
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.

#Profunctor approach

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!

#Equivalence

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

#Traversing

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

#Lens with Maybe

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!)

#Appendix

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

#Forgotten instances

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))

See discussion in r/haskell

You can run this file with

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

fetch the source from https://gist.github.com/phadej/0280d0748c7f3205daf7de07cc4dd7d0

2024-06-24 – hashable arch native
2024-05-28 – cabal fields
2024-04-21 – A note about coercions
2024-04-18 – What makes a good compiler warning?
2024-04-12 – Core Inspection

This work is licensed under a “CC BY SA 4.0” license.

Oleg's gists — Archive

twitter github email linkedin stackoverflow

Site proudly generated by Hakyll