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!

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

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

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