How can I write a lens for a sum type

Question

I have a type like this:

data Problem =
   ProblemFoo Foo |
   ProblemBar Bar |
   ProblemBaz Baz

Foo, Bar and Baz all have a lens for their names:

fooName :: Lens' Foo String
barName :: Lens' Bar String
bazName :: Lens' Baz String

Now I'd like to create a lens

problemName :: Lens' Problem String

Clearly I can write this using the lens construction function and a pair of case statements, but is there a better way?

The documentation for outside talks about using a Prism as a kind of first-class pattern, which sounds suggestive, but I can't see how to actually make it happen.

(Edit: added Baz case because my real problem isn't isomorphic with Either.)

duplode · Accepted Answer · 2018-10-16T16:13:07.757

You are right in that you can write it with outside. To begin with, some definitions:

{-# LANGUAGE TemplateHaskell #-}

import Control.Lens

newtype Foo = Foo { _fooName :: String }
    deriving (Eq, Ord, Show)
makeLenses ''Foo

newtype Bar = Bar { _barName :: String }
    deriving (Eq, Ord, Show)
makeLenses ''Bar

newtype Baz = Baz { _bazName :: String }
    deriving (Eq, Ord, Show)
makeLenses ''Baz

data Problem =
    ProblemFoo Foo |
    ProblemBar Bar |
    ProblemBaz Baz
    deriving (Eq, Ord, Show)
makePrisms ''Problem

The above is just what you described in your question, except that I'm also making prisms for Problem.

The type of outside (specialised to functions, simple lenses, and simple prisms, for the sake of clarity) is:

outside :: Prism' s a -> Lens' (s -> r) (a -> r)

Given a prism for e.g. a case of a sum type, outside gives you a lens on functions from the sum type which targets the branch of the function that handles the case. Specifying all branches of the function amounts to handling all cases:

problemName :: Problem -> String
problemName = error "Unhandled case in problemName"
    & outside _ProblemFoo .~ view fooName
    & outside _ProblemBar .~ view barName
    & outside _ProblemBaz .~ view bazName

That is rather pretty, except for the need to throw in the error case due to the lack of a sensible default. The total library offers an alternative that improves on that and provides exhaustiveness checking along the way, as long as you are willing to contort your types a bit further:

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}

import Control.Lens
import GHC.Generics (Generic)
import Lens.Family.Total    

-- etc.

-- This is needed for total's exhaustiveness check.
data Problem_ a b c =
    ProblemFoo a |
    ProblemBar b |
    ProblemBaz c
    deriving (Generic, Eq, Ord, Show)
makePrisms ''Problem_

instance (Empty a, Empty b, Empty c) => Empty (Problem_ a b c)

type Problem = Problem_ Foo Bar Baz

problemName :: Problem -> String
problemName = _case
    & on _ProblemFoo (view fooName)
    & on _ProblemBar (view barName)
    & on _ProblemBaz (view bazName)

leftaroundabout · Answer 2 · 2018-10-16T22:31:04.837

The function you probably want is

choosing :: Functor f => LensLike f s t a b -> LensLike f s' t' a b -> LensLike f (Either s s') (Either t t') a b

to be read as

choosing :: Lens' s   a      -> Lens' s'  a      -> Lens' (Either s s')    a

or in your case

choosing :: Lens' Foo String -> Lens' Bar String -> Lens' (Either Foo Bar) String

To use that with Problem, you'll need the fact that Problem is actually isomorphic to Either Foo Bar. Existance of both a Prism' Problem Foo and Prism' Problem Bar isn't sufficient for that, because you could also have

data Problem' = Problem'Foo Foo
              | Spoilsport
              | Problem'Bar Bar

I don't think there's any standard TH utility for giving such an isomorphism using more than one constructor, but you can write it yourself, which is somewhat easier than writing the lens onto the string yourself:

delegateProblem :: Iso' Problem (Either Foo Bar)
delegateProblem = iso p2e e2p
 where p2e (ProblemFoo foo) = Left foo
       p2e (ProblemBar bar) = Right bar
       e2p (Left foo) = ProblemFoo foo
       e2p (Right bar) = ProblemBar bar

and with that

problemName :: Lens' Problem String
problemName = delegateProblem . choosing fooName barName

Short version:

{-# LANGUAGE LambdaCase #-}
problemName = iso (\case ProblemFoo foo -> Left foo
                         ProblemBar bar -> Right bar)
                  (\case Left foo -> ProblemFoo foo
                         Right bar -> ProblemBar bar)
            . choosing fooName barName

Ahh, unfortunately my actual data type has 5 variants, not just 2. They all have the necessary lens though (see my edited version). However it might be possible to daisy-chain Eithers and `choosing`. — Paul Johnson, Oct 16 '18 at 13:02
It turns out that writing the Iso is exactly as much code as writing the lens getter and setter functions; both need a forwards and backwards case for each constructor. So it looks like there isn't a clever way of doing this. If nobody comes up with anything else then I'll accept this as the best available answer. — Paul Johnson, Oct 16 '18 at 13:20
@WillNess TBRA is to be read as _to be read as_. Hm, IMO that should be established ASAP. YMMV. _Anyway,.._ — leftaroundabout, Oct 16 '18 at 22:33

score 6 · Answer 3 · answered Oct 16 '18 at 13:42

6

Sure, it's very mechanical:

problemName :: Lens' Problem String
problemName f = \case
    ProblemFoo foo -> ProblemFoo <$> fooName f foo
    ProblemBar bar -> ProblemBar <$> barName f bar
    ProblemBaz baz -> ProblemBaz <$> bazName f baz

It should be obvious how to extend this to further constructors, or even how to write a bit of TH for it provided you can think of a way to describe the right sub-lens to pick for each branch -- perhaps using a typeclass for dispatch or similar.

answered Oct 16 '18 at 13:42

Daniel Wagner

145,880
9
220
380

Ahh, right. I've done it using the `lens` combinator with separate `goForwards` and `goBackwards` functions, making two cases for each constructor. But this does it with only one. Definitely neater, and probably the simplest possible solution. – Paul Johnson Oct 16 '18 at 14:24

How can I write a lens for a sum type

3 Answers3

Linked