Haskell 我怎样才能为求和类型写一个镜头

我有这样一种类型：

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

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

文档中提到了使用棱镜作为一种一流的模式，这听起来很有启发性，但我不知道如何真正做到这一点

（编辑：添加了

Baz

案例，因为我真正的问题不是与

同构的

）

解读为

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

还是你的情况

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

要将其用于

问题

，您需要知道

问题

实际上与

Foo-Bar

同构。同时存在

Prism'问题Foo

和

Prism'问题栏

是不够的，因为您还可以

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

---

当然，它非常机械：

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

problemName:：Lens'问题字符串
problemName f=\case
ProblemFoo foo->ProblemFoo foo foo foo foo foo名称
ProblemBar bar->ProblemBar barName f bar
ProblemBaz baz->ProblemBaz baz名称f baz

---

很明显，如何将其扩展到其他构造函数，甚至如何为其编写一点TH，前提是您可以想出一种方法来描述为每个分支选择的正确子镜头——可能使用typeclass进行分派或类似操作。

您是对的，您可以在

外部编写它。首先，有一些定义：

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

上述内容正是您在问题中所描述的，只是我也在为
问题
制作棱镜

外部的
类型（为了清晰起见，专门用于功能、简单透镜和简单棱镜）为：

给定一个棱镜，例如一个和类型的案例，
outside
为您提供一个关于和类型函数的镜头，该镜头指向处理该案例的函数分支。指定函数的所有分支相当于处理所有情况：

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

这是相当不错的，除了由于缺少合理的默认值而需要加入
错误
的情况之外。提供了一个改进的替代方案，并在过程中提供了详尽的检查，只要您愿意进一步扭曲您的类型：

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

啊，不幸的是，我的实际数据类型有5个变体，而不仅仅是2个。他们都有必要的镜头（见我编辑的版本）。然而，也有可能通过菊花链来选择Iso和
；对于每个构造函数，都需要一个向前和向后的案例。所以看起来没有一个聪明的方法可以做到这一点。如果没有人提出任何其他问题，那么我会接受这一最佳答案。TBRA是什么？谷歌是空的。@WillNess-TBRA应该被理解为。嗯，国际海事组织应该尽快成立。YMMV。不管怎样，…（咯咯笑）啊，对。我使用
镜头
组合器和单独的
goForwards
和
goBackwards
函数完成了这项工作，为每个构造函数创建了两个案例。但这只需要一个。当然更整洁，可能是最简单的解决方案。
problemName :: Problem -> String
problemName = error "Unhandled case in problemName"
    & outside _ProblemFoo .~ view fooName
    & outside _ProblemBar .~ view barName
    & outside _ProblemBaz .~ view bazName

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