haskell - 在 Haskell 中构建组合自参照镜头

Question

包含 self 引用的数据并不少见。这肯定会出现在命令式编程中，但它也可以出现在 Haskell 中。例如，可以将 IORef 或 STRef 作为数据类型中指向数据类型本身的字段(并且可以使用 RecursiveDo 语法或 mfix 来“打结”构造)。

我想知道是否可以使用镜头做类似的事情。

假设我有一些 s 类型的状态和从 s 到该状态中包含的一些数据的镜头。我希望包含的数据自身能够访问这个镜头，或者换句话说，我希望状态中的数据类似于:

import Data.Lens

data Foo s = Foo
  { self :: Lens' s (Foo s)
  , fooData :: Int
  }

-- A silly `Show` instance so that we can print a few things
instance Show (Foo s) where
  show Foo{..} = "Foo <lens> "<>show fooData

这使用起来有点挑战，但它可以与 Fix 类型一起使用，例如:

newtype Fix f = Fix { unFix :: f (Fix f) }

fixIso :: Iso' (Fix f) (f (Fix f))
fixIso = iso unFix Fix

现在，我可以生成以下值:

myFoo :: Foo (Fix Foo)
myFoo = Foo fixIso 2

在这里，我们有一个 Foo (Fix Foo) 类型的值，带有从其状态到自身的透镜。

我还可以创建一对 Foo(通过使用 Generics 中的 :*:):

import GHC.Generics ((:*:)(..))

pairOfFoo :: (Foo :*: Foo) (Fix (Foo :*: Foo))
pairOfFoo = Foo (fixIso . _1) 2 :*: Foo (fixIso . _2) 4

这基本上是有效的，如:

> pairOfFoo ^. _1
Foo <lens> 2
> pairOfFoo ^. _2
Foo <lens> 4
> Fix pairOfFoo ^. (self $ pairOfFoo ^. _1)
Foo <lens> 2

更大的问题是，感觉我应该能够从 myFoo 创建 pairOfFoo compositionally，但我不明白如何去做吧。也就是说，我想写这样的东西:

pairOf :: (Extendable x, Extendable y) => x (Fix x) -> y (Fix y) -> (x :*: y) (Fix (x :*: y))
pairOf x y = extend x _1 :*: extend y _2

pairOfFoo = pairOf (Foo fixIso 2) (Foo fixIso 4)

class Extendable x where
  extend :: Lens' s' s -> x (Fix s) -> x (Fix s')

但这就是我被困的地方。我不知道如何创建实例 Extendable Foo(或者即使这是正确的签名)。我还认为 (Extendable x, Extendable y) => Extendable (x :*: y) 应该有一个实例(或类似的)。或者，也许还有另一种策略？

---

问题扩展

现在，假设我们有这样定义的第二种数据类型:

data Bar s = Bar
  { barSelf :: Lens' s (Bar s)
  , barFoo  :: Lens' s (Foo s)
  , barData :: String
  }

Bar (Fix Bar) 类型的值是不可能的，因为 Bar 实际上并不包含 Foo。但是，可以制作类似的东西:

fooBar :: (Foo :*: Bar) (Fix (Foo :*: Bar))
fooBar = Foo (fixIso . _1) 2 :*: Bar (fixIso . _2) (fixIso . _1) "bar"

此外，感觉应该可以有一个实例 Extendable Bar，这样我们就可以在 pairOf 中使用 fooBar 作为参数>。这种情况可能吗？

Answer 1

我想也许你想要:

class Extendable a where
  extend :: Lens' (s' (Fix s')) (a (Fix s')) -> a (Fix s) -> a (Fix s')
instance Extendable Foo where
  extend l (Foo self x) = Foo (fixIso . l) x

pairOf :: (Extendable x, Extendable y)
  => x (Fix x) -> y (Fix y) -> (x :*: y) (Fix (x :*: y))
pairOf foo1 foo2 = extend _1 foo1 :*: extend _2 foo2

pairOfFoo = pairOf (Foo fixIso 2) (Foo fixIso 4)

它似乎有效，并扩展到更复杂的组合:

instance (Extendable x, Extendable y) => Extendable (x :*: y) where
  extend l (x :*: y) = extend (l . _1) x :*: extend (l . _2) y

example2 = pairOf (pairOf (Foo fixIso 2) (Foo fixIso 3)) (Foo fixIso 4)

完整代码:

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}

import GHC.Generics ((:*:)(..))
import Control.Lens

data Foo s = Foo
  { self :: Lens' s (Foo s)
  , fooData :: Int
  }

instance Show (Foo s) where
  show Foo{..} = "Foo <lens> " <> show fooData

newtype Fix f = Fix { unFix :: f (Fix f) }

fixIso :: Iso' (Fix f) (f (Fix f))
fixIso = iso unFix Fix

class Extendable a where
  extend :: Lens' (s' (Fix s')) (a (Fix s')) -> a (Fix s) -> a (Fix s')
instance Extendable Foo where
  extend l (Foo self x) = Foo (fixIso . l) x
instance (Extendable x, Extendable y) => Extendable (x :*: y) where
  extend l (x :*: y) = extend (l . _1) x :*: extend (l . _2) y

pairOf :: (Extendable x, Extendable y)
  => x (Fix x) -> y (Fix y) -> (x :*: y) (Fix (x :*: y))
pairOf foo1 foo2 = extend _1 foo1 :*: extend _2 foo2

pairOfFoo = pairOf (Foo fixIso 2) (Foo fixIso 4)
example2 = pairOf (pairOf (Foo fixIso 2) (Foo fixIso 3)) (Foo fixIso 4)