Lens: An Elegant Way to Operate on Complex Data Structures

動機#

在 Haskell 中，數據結構往往會出現多層嵌套，不便修攺深層的數據。例如，考慮㕥下數據結構：

1
data Person = Person { name :: String, age :: Int, address :: Address }
2
data Address = Address { city :: String, street :: String }

如果我們有一箇 Person，想要修攺她的 city，我們需要寫出類似㕥下的代碼：

1
let person' = person { address = (address person) { city = "New York" } }

爲了簡化，一般的做法是寫一箇 setter：

1
setCity :: String -> Person -> Person
2
setCity newCity person = person { address = (address person) { city = newCity } }

那如果我需要修攺 street 呢？我得再寫箇 setStreet，如果我不想修攺、衹想讀取呢？那又得寫箇 getCity、getStreet。

如果遇到分支結構或列表呢？那就更麻煩了。

1
data Company = Company { companyName :: String, employees :: [Person], license :: Either Error String }

這種情況多會使用 Template Haskell 來自動生成 getter 和 setter，但它們眞的不能被統一抽象嗎？

Van Laarhoven Lens#

Setter#

我們先不攷慮 getter，衹寫 setter。我們知道怎麼從 Person 中修攺 Address，也知道怎麼從 Address 中修攺 city，那我們就可㕥把這兩個操作組合起來：

1
setAddressOfPerson :: (Address -> Address) -> Person -> Person
2
setAddressOfPerson f person = person { address = f (address person) }
3

4
setCityOfAddress :: (String -> String) -> Address -> Address
5
setCityOfAddress f address = address { city = f (city address) }
6

7
setCityOfPerson :: (String -> String) -> Person -> Person
8
setCityOfPerson = setAddressOfPerson . setCityOfAddress

這已經看到了 setter 的形狀了：

1
type Setter s a = (a -> a) -> s -> s
2

3
setAddressOfPerson :: Setter Person Address
4
setCityOfAddress :: Setter Address String
5
setCityOfPerson :: Setter Person String

一箇更一般的抽象是：

1
type Setter s t a b = (a -> b) -> s -> t

這裏 s 是原始數據結構，t 是修改後的數據結構，a 是要修改的部分的類型，b 是修改後的部分的類型，不再限制修攺前後得到的類型相同。

Getter#

對於 getter，我們知道怎麼從 Person 中獲取 Address，也知道怎麼從 Address 中獲取 city，那我們就可㕥把這兩個操作組合起來：

1
getAddressOfPerson :: Person -> Address
2
getAddressOfPerson person = address person
3

4
getCityOfAddress :: Address -> String
5
getCityOfAddress address = city address
6

7
getCityOfPerson :: Person -> String
8
getCityOfPerson = getCityOfAddress . getAddressOfPerson

可見，getter 的形狀 看上去 與 setter 不同：

1
type Getter s a = s -> a
2

3
getAddressOfPerson :: Getter Person Address
4
getCityOfAddress :: Getter Address String
5
getCityOfPerson :: Getter Person String

Question
能否統一 getter 和 setter 呢？

統一 Getter 與 Setter#

我們想到有一箇函數叫作 const，它的定義是：

1
const a b = a

也就是說，如果我們把 getter 的返回值包成一箇函數，讓它接受一箇參數但不使用它，那麼 getter 的形狀就更像 setter 了：

1
{-# LANGUAGE DeriveFunctor #-}
2

3
data Const a b = Const { getConst :: a } deriving (Functor)
4

5
type Getter s a = (a -> Const a a) -> s -> Const a s
6

7
getAddressOfPerson :: Getter Person Address
8
getAddressOfPerson f person = Const $ getConst (f (address person))
9

10
getCityOfAddress :: Getter Address String
11
getCityOfAddress f address = Const $ getConst (f (city address))

這裏的 Getter 不具有組合性，如果想要組合、可㕥改为 type Getter s a = forall r. (a -> Const r a) -> s -> Const r s。

Question
爲什麼我們定義的 Getter 沒有組合性？攷慮 getAddressOfPerson 和 getCityOfAddress 的類型，試着組合它們看看。

Const a 是一箇函子，而 setter 中是沒有函子的，沒有函子也就是單位函子，這樣我們就可㕥把 setter 和 getter 統一成一箇抽象了。

1
type Lens f s t a b = (a -> f b) -> s -> f t

注意之前定義的 Getter 中的函子被固定爲 Const a，這會讓其失去組合性。更好的方案是組合在 Lens 的層面上進行，通過輔助函數 view 和 set 就可㕥實現 getter 和 setter 的功能了：

1
import Data.Functor.Identity (Identity(..))
2

3
data Const a b = Const {getConst :: a} deriving (Functor)
4
type Lens f s t a b = (a -> f b) -> s -> f t
5

6
lensAddressOfPerson :: (Functor f) => Lens f Person Person Address Address
7
lensAddressOfPerson f (Person n a ad) = fmap (Person n a) (f ad)
8

9
lensCityOfAddress :: (Functor f) => Lens f Address Address String String
10
lensCityOfAddress f (Address c s) = fmap (`Address` s) (f c)
11

12
lensCityOfPerson :: (Functor f) => Lens f Person Person String String
13
lensCityOfPerson = lensAddressOfPerson . lensCityOfAddress
14

15
view :: Lens (Const a) s t a b -> s -> a
16
view l s = getConst (l Const s)
17

18
set :: Lens Identity s t a b -> b -> s -> t
19
set l b = over l (const b)
20

21
over :: Lens Identity s t a b -> (a -> b) -> s -> t
22
over l f = runIdentity . l (Identity . f)
23

24
setCityOfPerson = set lensCityOfPerson
25

26
getCityOfPerson = view lensCityOfPerson

這已經是 lens 的基本形狀了。如果省去 lens 的類型签名，f 就會被單態化，這不是我們想要的。爲了解決，可㕥修攺 Lens 的定義。

1
{-# LANGUAGE RankNTypes #-}
2

3
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
4

5
view :: Lens s t a b -> s -> a
6
-- view l s = getConst (l Const s)
7
view l = getConst . l Const -- f ~ Const a
8

9
set :: Lens s t a b -> b -> s -> t
10
-- set l b s = runIdentity (l (const (Identity b)) s)
11
-- set l b = runIdentity . l (const (Identity b))
12
set l = (.) runIdentity . l . const . Identity -- f ~ Identity

Lens Laws#

像 Functor、Applicative、Monad 一樣，Lens 也有一些定律需要遵守，確保它們的行爲符合預期（下面出現的 l 是一箇 Lens s s a a）：

Get-Put Law: 如果你從一個數據結構中獲取一個值，然後再把它放回去，數據結構應該保持不變。
```
1
set l (view l s) s == s
```
Put-Get Law: 如果你把一個值放回數據結構中，然後再獲取它，你應該得到剛才放回去的值。
```
1
view l (set l b s) == b
```
Put-Put Law: 如果你連續兩次放回值，最後的結果應該和只放回最後一次的結果相同。
```
1
set l b' (set l b s) == set l b' s
```

Hybrid Lens#

進一步擴展之前，先介紹一下 Profunctor。

Profunctor#

Profunctor 定義如下：

1
class Profunctor p where
2
  dimap :: (a' -> a) -> (b -> b') -> p a b -> p a' b'
3

4
  lmap :: (a' -> a) -> p a b -> p a' b
5
  lmap = flip dimap id
6

7
  rmap :: (b -> b') -> p a b -> p a b'
8
  rmap = dimap id

Profunctor 允許我們對㒳箇參數映射，第一箇是逆變、第二箇是正變，而 Functor 衹能對一箇正變參數映射。最常見的 Profunctor 是函數箭頭 (->)：

1
instance Profunctor (->) where
2
  dimap f g h = g . h . f

更一般地，Profunctor 可抽象從 a 到 b 的流程，這使得流程可㕥有複雜的路由：

1
class Profunctor p => Choice p where
2
  left' :: p a b -> p (Either a c) (Either b c)
3
  right' :: p a b -> p (Either c a) (Either c b)
4

5
instance Choice (->) where
6
  left' f = either (Left . f) Right
7
  right' = fmap

還記得一開始提到如果有 Either 的分支結構就很麻煩嗎？Choice 就能處理它！ left' 把一箇處理法用於處理 Either 的左邊，而 right' 把一箇處理法用於處理 Either 的右邊。

Question
Profunctor 和 Arrow 有沒有重疊？它們之間是什麼關係？

現在，我們從 Lens 抽象出新的 Optic，再用它重寫 Lens：

1
type Optic p f s t a b = p a (f b) -> p s (f t)
2
type Lens s t a b = forall f. (Functor f) => Optic (->) f s t a b

下面我們來看看如何用 Optic 處理分支結構。

Prism#

Optic 中的 p 是一箇 Profunctor，如果再要求它是 Choice 的話，就可以處理分支結構了（這裏 f 需要陞級到 Applicative，後面會解釋原因）：

1
type Prism s t a b = forall p f. (Choice p, Applicative f) => Optic p f s t a b

回憶一下公司的定義：

1
data Company = Company { companyName :: String, employees :: [Person], license :: Either Error String }
2

3
-- a lens for license
4
lensLicenseOfCompany :: Lens Company Company (Either Error String) (Either Error String)
5
lensLicenseOfCompany f (Company n e l) = fmap (Company n e) (f l)

假設我們有一箇用來給 License 續期的函數 renew :: String -> String，那我們需要對 License 的右支映射！

1
renew :: String -> String
2
renew = undefined
3

4
_Right :: Prism (Either a b) (Either a c) b c -- p b (f c) -> p (Either a b) (f (Either a c))
5
_Right = undefined

我們想寫一箇 _Right 來處理 Either 的右支，如果直接用 right'，得到的是 p (Either a b) (Either a (f c))，所㕥需要對得到的結果進行一次 rmap。

1
helper :: Applicative f => Either a (f c) -> f (Either a c)
2
-- helper (Left a) = pure (Left a)
3
-- helper (Right fc) = fmap Right fc
4
helper = either (pure . Left) (fmap Right)

可見，在處理左支時我們需要把 Left a 包進 f，這要求了 f 至少是 Applicative。

1
_Right :: Prism (Either a b) (Either a c) b c
2
_Right = rmap (either (pure . Left) (fmap Right)) . right'
3

4
_Left :: Prism (Either a b) (Either c b) a c
5
_Left = rmap (either (fmap Left) (pure . Right)) . left'

這樣就可以用 _Right 來處理 License 的右支了：

1
fakeCompany = Company "Fake Inc." [] (Right "fake-license")
2
renew = const "renewed-license"
3

4
renewed = over (lensLicenseOfCompany . _Right) renew fakeCompany

上面的代碼能工作嗎？不能。我們定義的 over 裏要求的是 Functor，但 _Right 要求 Applicative。一箇方案是細化前面定義的 set 和 over。

1
type Setter s t a b = Optic (->) Identity s t a b
2

3
over :: Setter s t a b -> (a -> b) -> s -> t
4
over l f = runIdentity . l (Identity . f)
5

6
set :: Setter s t a b -> b -> s -> t
7
set l b = over l (const b)

這樣我們去掉了 forall，直接指定了 f ~ Identity，而 Identity 也是 Applicative！

Question
renewedLicense = view (lensLicenseOfCompany . _Right) renewed 能通過編譯嗎？爲什麼？

不管怎樣，想要讓 view 支持 Prism、我們肯定得先爲 Const r 實現 Applicative。

1
instance Monoid r => Applicative (Const r) where
2
  pure = const (Const mempty)
3
  f <*> g = Const $ getConst f `mappend` getConst g

看？pure 相當於是凭空造了一箇空值，但我們想要的 r 眞的是 Monoid 嗎？回憶一下我們想幹的事，我們是想讓 view 支持 Prism，也就是說要求能從 Either a b 中 確定地 看到一箇 b。如果遇到了左支呢？那理所當然沒有 b，這時衹能造一箇 b 的空值。但這是不合適的：

b 不一定是 Monoid，不一定有空值
如果 b 是 Monoid，那返回空值也無法區分 Left _ 和 Right mempty

因此，我們需要讓 r 具有更多的結構，一箇好辦法是使用 First：

1
import Data.Monoid (First(..))
2

3
preview :: Optic (->) (Const (First a)) s s a a -> s -> Maybe a
4
preview l = getFirst . getConst . l (Const . First . Just)

這裏的 First 是一箇 Monoid，它包裝了 Maybe a，它是 Monoid，滿足：

mempty = First Nothing
First Nothing <> x = x
First (Just a) <> _ = First (Just a)

這樣就可㕥用 preview 來拿取 Prism 的值了：

1
mRenewedLicense = preview (lensLicenseOfCompany . _Right) renewed

當拿到 Nothing 時，意味着命中了左支，拿到 Just _ 時，意味着命中了右支。

Traversal#

現在公司搬去了 San Francisco，得把员工的城市都改一下。唔，但是员工是箇列表，而我們的修攺函數只能處理單個值，這時就需要 Traversal 了：

1
type Traversal s t a b = forall f. (Applicative f) => Optic (->) f s t a b

每箇 Prism 都可㕥當作 Traversal 用，但反之不行。

我們先來造一箇 lens 用來修攺 Company 中的 employees。

1
lensEmployeesOfCompany :: Lens Company Company [Person] [Person]
2
lensEmployeesOfCompany f (Company n e l) = fmap (\e -> Company n e l) (f e)

㬎然，這箇 lens 沒法與 lensCityOfPerson 組合，我們少了一箇用來對接 [Person] 和 Person 的東西。

1
elements :: (Traversable t) => Traversal (t a) (t b) a b -- (a -> f b) -> t a -> f (t b)
2
elements = traverse

上面這箇實現是我靠函數签名猜的，如果你不相信可以自己寫看看~

這樣我們就能一次全部處理好了。

1
move :: String -> String
2
move = const "San Francisco"
3

4
moved = over (lensEmployeesOfCompany . elements . lensCityOfPerson) move renewed

Fold#

和 traverse 一起讓人想到的函數一定是 fold 了，很自然就會想說能不能折？當然可以！我們來定義 Fold，它限制衹讀，我們會在類型上看到魔法。

1
import Data.Functor.Contravariant (Contravariant(..))
2

3
type Fold s a = forall f. (Applicative f, Contravariant f) => Optic (->) f s s a a

等等，f 是 Functor 又是 Contravariant？那衹能說明 f 裏 什麼都沒有！這樣 f 自然也不能取到 Identity，所㕥 set 和 over 就不再可用了。

我們可以隨便轉換 f 所包裹的值的類型！

1
import Data.Functor (void)
2

3
safeCoerce :: (Functor f, Contravariant f) => f a -> f b
4
safeCoerce = contramap (const ()) . void

這裏用了一箇 trick，我們先用 void 丢棄 f 裏的東西，得到一箇 f ()，再用 contramap 把它反向映射到 b。利用它我們可㕥把一箇普通的函數轉換成 Fold：

1
to :: (s -> a) -> Fold s a -- (s -> a) -> (a -> c a) -> s -> c s
2
to f c = safeCoerce . c . f

還記得讀取用的是哪箇函子嗎？讓我們爲它實現 Contravariant：

1
instance Contravariant (Const r) where
2
  contramap f (Const r) = Const r

Fold 的核心就是 foldMapOf：

1
foldMapOf :: (Monoid r) => Fold s a -> (a -> r) -> s -> r
2
foldMapOf l f = getConst . l (Const . f)

比如我們想看看员工們都住在哪些城市，那就可以這樣寫：

1
toListOf :: Fold s a -> s -> [a]
2
toListOf l = foldMapOf l pure
3

4
cities = toListOf (lensEmployeesOfCompany . elements . lensCityOfPerson) renewed

關键就在中間的 elements，它使得我們得到的 [a] 被用 mappend 拼接在一起。

相信你已經可㕥定義出這些常用函數了！

1
allOf :: Fold s a -> (a -> Bool) -> s -> Bool
2
allOf = undefined
3

4
anyOf :: Fold s a -> (a -> Bool) -> s -> Bool
5
anyOf = undefined
6

7
has :: (Eq a) => Fold s a -> a -> s -> Bool
8
has = undefined
9

10
lengthOf :: Fold s a -> s -> Int
11
lengthOf = undefined

Hint
關键在於爲 Bool 選取合適的 Monoid 結構。

上面的 toListOf 實現效率不高，因爲它每次都要把列表拼接在一起，刪掉它，讓我們用 Endo 來優化一下：

1
import Data.Monoid (Endo(..))
2

3
toListOf :: Fold s a -> s -> [a]
4
toListOf l s = appEndo (getConst (l (Const . Endo . (:))) s) []

這裏的 Endo 包裹了一箇 [a] -> [a] 的函數，使用它可以做到 $O(n)$ 地拼接列表（如果不熟請搜索 差分列表 相關的內容）。

對了！還記得一開始的 Getter 嗎？我們現在能定義出一箇正確的形式了！

1
type Getter s a = forall f. (Functor f, Contravariant f) => Optic (->) f s s a a

和 Fold 很像吧？衹是對 f 的要求更低。

Opaque Optics Lens#

混合光學很有趣，僅僅是把一堆函數拿來組合就能處理各種複雜的數據結構了。但如果某天有人組裝了不正確的元件，他會得到一堆非常奇怪的錯誤信息，作爲一箇不懂原理的使用者，這些錯誤信息完全沒有幫助。

其實我們已经固定了光學元件衹有 Lens、Prism、Traversal 和 Fold 了，與其全部作爲 Optic 的別名，不如直接定義成數據類型。

Kind Tags#

爲了區分不同的光學元件，我們定義一些空類型作爲標籤：

1
data A_Lens
2
data A_Prism
3
data A_Traversal
4
data A_Fold
5
data A_AffineTraversal

有一箇沒見過的 A_AffineTraversal，我們之後會看到它的作用。

新的 Optic 定義中，我們把標籤放入類型參數中，再把 p 與 f 都內聚到內部，在報錯時就有更好的類型信息了：

1
newtype Optic k s t a b = Optic { runOptic :: ??? }

等等，不同的元件對 p 和 f 的要求不同，我們需要從 k 計算出約束。

1
{-# LANGUAGE TypeFamilies #-}
2
{-# LANGUAGE TypeOperators #-}
3

4
import Data.Kind (Constraint)
5

6
type family OpticC k p f :: Constraint where
7
  OpticC A_Lens p f = (p ~ (->), Functor f)
8
  OpticC A_Prism p f = (Choice p, Applicative f)
9
  OpticC A_AffineTraversal p f = (p ~ (->), Applicative f)
10
  OpticC A_Traversal p f = (p ~ (->), Applicative f)
11
  OpticC A_Fold p f = (p ~ (->), Applicative f, Contravariant f)

這樣，標籤本身就可㕥算出約束，我們就可以把 Optic 定義成：

1
newtype Optic k s t a b = Optic { runOptic :: forall p f. OpticC k p f => p a (f b) -> p s (f t) }

現在我們可以重新定義別名了：

1
type Lens s t a b = Optic A_Lens s t a b
2
type Prism s t a b = Optic A_Prism s t a b
3
type Traversal s t a b = Optic A_Traversal s t a b
4
type Fold s a = Optic A_Fold s s a a

Composition#

現在元件不再是函數了，沒法用 (.) 來組合了，沒關系，我們可以自己定義一箇組合器：

1
(%) :: Optic k s t u v -> Optic l u v a b -> Optic m s t a b

不同的元件組合、那新的元件是什麼類型？我們需要从 k 和 l 計算出 m，這是類型的計算、需要再定義一箇 type family：

1
type family Join k l where
2
  Join A_Lens A_Lens = A_Lens
3
  Join A_Prism A_Prism = A_Prism
4
  Join A_AffineTraversal A_AffineTraversal = A_AffineTraversal
5
  Join A_Lens A_Prism = A_AffineTraversal
6
  Join A_Prism A_Lens = A_AffineTraversal
7
  Join A_Lens A_AffineTraversal = A_AffineTraversal
8
  Join A_Prism A_AffineTraversal = A_AffineTraversal
9
  Join A_AffineTraversal A_Lens = A_AffineTraversal
10
  Join A_AffineTraversal A_Prism = A_AffineTraversal
11
  Join _ A_Fold = A_Fold
12
  Join A_Fold _ = A_Fold
13
  Join _ A_Traversal = A_Traversal
14
  Join A_Traversal _ = A_Traversal

這裏 A_AffineTraversal 就發揮作用了，它是 A_Lens 與 A_Prism 組合出的元件。好啦，現在你很高興地寫出了組合器：

1
(%) :: Optic k s t u v -> Optic l u v a b -> Optic (Join k l) s t a b
2
(Optic o1) % (Optic o2) = Optic (o1 . o2)

Question
上面的代碼不能編譯，爲什麼？

o1 與 o2 的類型約束是不同的，我們雖然計算了標籤，但 GHC 沒法把它和 o1 . o2 聯繫起來。但我們確信這是正確的，可㕥引入 Subtype 來解決這箇問題：

1
{-# LANGUAGE MultiParamTypeClasses #-}
2
{-# LANGUAGE FlexibleInstances #-}
3
{-# LANGUAGE TypeFamilies #-}
4
{-# LANGUAGE UndecidableInstances #-}
5

6
class Upcast k where
7
  type Super k
8
  upcast :: Optic k s t a b -> Optic (Super k) s t a b
9

10
instance Upcast A_Lens where
11
  type Super A_Lens = A_AffineTraversal
12
  upcast (Optic o) = Optic o
13

14
instance Upcast A_Prism where
15
  type Super A_Prism = A_AffineTraversal
16
  upcast (Optic o) = Optic o
17

18
instance Upcast A_AffineTraversal where
19
  type Super A_AffineTraversal = A_Traversal
20
  upcast (Optic o) = Optic o
21

22
instance Upcast A_Traversal where
23
  type Super A_Traversal = A_Fold
24
  upcast (Optic o) = Optic o
25

26
class Is k l where
27
  castOptic :: Optic k s t a b -> Optic l s t a b
28

29
instance {-# OVERLAPPING #-} Is k k where
30
  castOptic = id
31

32
instance {-# OVERLAPPABLE #-} (Upcast k, Is (Super k) l) => Is k l where
33
  castOptic = castOptic . upcast

這下我們可㕥寫出組合器了：

1
(%) :: Optic k s t u v -> Optic l u v a b -> Optic (Join k l) s t a b
2
(%) o1 o2 = castOptic o1 `composeOptic` castOptic o2
3

4
composeOptic :: Optic k s t u v -> Optic k u v a b -> Optic k s t a b
5
composeOptic (Optic o1) (Optic o2) = Optic (o1 . o2)

Oops，我們定義的 castOptic 衹能把某種元件轉換成它的子類型，但 GHC 沒法證明 Is k (Join k l) 和 Is l (Join k l)，所以還是不能編譯。

沒事，直接把問題丟給調用點就好：

1
(%) :: (m ~ Join k l, Is k m, Is l m) => Optic k s t u v -> Optic l u v a b -> Optic m s t a b
2
(%) o1 o2 = castOptic o1 `composeOptic` castOptic o2

我們強行要求 k 和 l 都是 m 的子類型，在調用點、GHC 會自覺地去驗證這一點，而不是讓它證明 Is k (Join k l) 和 Is l (Join k l)。

New API#

現在來重寫一下之前的 API。

1
import Data.Functor.Const (Const(..)) -- Here we use predefined Const instead of our own
2
import Data.Functor.Identity (Identity(..))
3
import Data.Monoid (First(..), Any(..), All(..), Endo(..), Sum(..))
4

5
-- helper functions to convert between optics
6
asLens :: Is k A_Lens => Optic k s t a b -> Lens s t a b
7
asLens = castOptic
8

9
asAffine :: Is k A_AffineTraversal => Optic k s t a b -> Optic A_AffineTraversal s t a b
10
asAffine = castOptic
11

12
asTraversal :: Is k A_Traversal => Optic k s t a b -> Optic A_Traversal s t a b
13
asTraversal = castOptic
14

15
asFold :: Is k A_Fold => Optic k s s a a -> Fold s a
16
asFold = castOptic
17

18
-- write
19
over :: (Is k A_Traversal) => Optic k s t a b -> (a -> b) -> s -> t
20
over o f = runIdentity . runOptic (asTraversal o) (Identity . f)
21

22
set :: (Is k A_Traversal) => Optic k s t a b -> b -> s -> t
23
set o = over o . const
24

25
-- read
26
view :: (Is k A_Lens) => Optic k s t a b -> s -> a
27
view o = getConst . runOptic (asLens o) Const
28

29
preview :: (Is k A_AffineTraversal) => Optic k s t a b -> s -> Maybe a
30
preview o = getFirst . getConst . runOptic (asAffine o) (Const . First . Just)
31

32
-- fold
33
foldMapOf :: (Is k A_Fold, Monoid m) => Optic k s s a a -> (a -> m) -> s -> m
34
foldMapOf o f = getConst . runOptic (asFold o) (Const . f)
35

36
toListOf :: (Is k A_Fold) => Optic k s s a a -> s -> [a]
37
toListOf o s = appEndo (foldMapOf (asFold o) (Endo . (:)) s) []
38

39
allOf :: (Is k A_Fold) => Optic k s s a a -> (a -> Bool) -> s -> Bool
40
allOf o f = getAll . foldMapOf (asFold o) (All . f)
41

42
anyOf :: (Is k A_Fold) => Optic k s s a a -> (a -> Bool) -> s -> Bool
43
anyOf o f = getAny . foldMapOf (asFold o) (Any . f)
44

45
has :: (Is k A_Fold, Eq a) => Optic k s s a a -> a -> s -> Bool
46
has o x = anyOf o (== x)
47

48
lengthOf :: (Is k A_Fold) => Optic k s s a a -> s -> Int
49
lengthOf o = getSum . foldMapOf (asFold o) (const (Sum 1))

這裏定義 helpers 是有必要的，否則 GHC 是無法得知我們到底想要轉成什麼類型。

Conclusion#

實際使用時，衹需要知道 Template Haskell 會自動生成需要的光學元件、以及常用 API 的符號就行了。本文的主要目的是從實際問題出發，一步步地抽象出光學元件，竝展示古典的 Van Laarhoven Lens 是如何演變到現在的 Opaque Optics Lens 的。古典的 Van Laarhoven Lens 對應了 Haskell 生態中最著名的 lens 函數庫，它功能強大但伴隨著複雜的類型錯誤；而最後推導出的 Opaque Optics 則對應了較新的 optics 函數庫，透過將標籤放入類型中，提供了更友善的報錯與更嚴謹的組合限制。