How can I write a lens for a sum type
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)
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.
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