如何为和型编写镜头

Question

我有这样的类型:

data Problem =
   ProblemFoo Foo |
   ProblemBar Bar |
   ProblemBaz Baz

Foo,Bar并Baz都对他们的名字一个镜头:

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

现在我想制作一个镜头

problemName :: Lens' Problem String

很明显,我可以使用lens构造函数和一对case语句来编写它,但是有更好的方法吗？

对于文档outside关于使用棱镜作为一种一流的格局,这听起来暗示,但我看不出如何真正做到这一点的会谈.

(编辑:添加Baz案例,因为我的真正问题不是同构的Either.)

Answer 1

你可能想要的功能是

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

被读作

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

或者在你的情况下

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

要使用它Problem,你需要Problem实际上同构的事实Either Foo Bar.既有的实存Prism' Problem Foo,并Prism' Problem Bar不足以说,因为你还可以有

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

我不认为有任何标准的TH实用程序可以使用多个构造函数来提供这样的同构,但是你可以自己编写它,这比自己将镜头写入字符串要容易一些:

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

并与此

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

精简版:

{-# 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

Answer 2

当然，这是非常机械的：

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

如果您可以想出一种方法来描述为每个分支选择正确的子镜头，那么如何将其扩展到更多的构造函数，或者甚至如何为其编写一些 TH 应该是显而易见的——也许使用类型类进行调度或类似。

Answer 3

你是对的,你可以写它outside.首先,一些定义:

{-# 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

以上就是你在你的问题中所描述的,除了我也是为了制作棱镜Problem.

outside为清晰起见,(专用于功能,简单镜头和简单棱镜)的类型是:

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

给定一个棱镜,例如一个和类型的情况,outside给你一个关于函数的镜头,来自sum类型,它定位处理案例的函数的分支.指定函数的所有分支相当于处理所有情况:

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

这是相当漂亮的,除了error由于缺乏合理的默认值而需要抛出案例.该总库提供了改进上,并提供全面性沿途检查,只要你愿意进一步扭曲你的类型有点另类:

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