Zipper Comonads，一般来说

Question

给定任何容器类型，我们可以形成（以元素为中心的）Zipper并且知道这个结构是Comonad。最近在another Stack Overflow question中详细探讨了以下类型：

data Bin a = Branch (Bin a) a (Bin a) | Leaf a deriving Functor

使用以下拉链

data Dir = L | R
data Step a = Step a Dir (Bin a)   deriving Functor
data Zip  a = Zip [Step a] (Bin a) deriving Functor
instance Comonad Zip where ...

Zip是Comonad的情况虽然它的实例构造有点毛茸茸。也就是说，Zip可以完全从Tree机械派生而且（我相信）任何以这种方式派生的类型都自动为Comonad，所以我觉得应该是我们可以的情况通用和自动地构造这些类型及其组合。

实现拉链构造的一般性的一种方法是使用以下类和类型族

data Zipper t a = Zipper { diff :: D t a, here :: a }

deriving instance Diff t => Functor (Zipper t)

class (Functor t, Functor (D t)) => Diff t where
  data D t :: * -> *
  inTo  :: t a -> t (Zipper t a)
  outOf :: Zipper t a -> t a

（或多或少）出现在Haskell Cafe主题和Conal Elliott的博客上。该类可以针对各种核心代数类型进行实例化，从而为讨论ADT的衍生物提供了一般框架。

所以，最终，我的问题是我们是否可以写

instance Diff t => Comonad (Zipper t) where ...

可用于包含上述特定的Comonad实例：

instance Diff Bin where
  data D Bin a = DBin { context :: [Step a], descend :: Maybe (Bin a, Bin a) }
  ...

不幸的是，我没有运气写这样的实例。 inTo / outOf签名是否足够？是否还需要其他东西来约束类型？这个例子甚至可能吗？

Answer 1

就像Chitty-Chitty-Bang-Bang的儿童捕捉诱惑孩子被糖果和玩具囚禁一样，本科物理学的招聘人员喜欢愚弄肥皂泡和回旋镖，但是当门砰然关上时，它就是＆ ＃34;对，孩子们，是时候学习偏微分了！＆＃34;。我也是。不要说我没有警告你。

以下是另一个警告：以下代码需要{-# LANGUAGE KitchenSink #-}，或者更确切地说是

{-# LANGUAGE TypeFamilies, FlexibleContexts, TupleSections, GADTs, DataKinds,
    TypeOperators, FlexibleInstances, RankNTypes, ScopedTypeVariables,
    StandaloneDeriving, UndecidableInstances #-}

没有特别的顺序。

可区分的仿函数给出了共同的拉链

无论如何，什么是可区别的仿函数？

class (Functor f, Functor (DF f)) => Diff1 f where
  type DF f :: * -> *
  upF      ::  ZF f x  ->  f x
  downF    ::  f x     ->  f (ZF f x)
  aroundF  ::  ZF f x  ->  ZF f (ZF f x)

data ZF f x = (:<-:) {cxF :: DF f x, elF :: x}

它是一个有衍生物的仿函数，它也是一个仿函数。该导数表示元素的单孔上下文。拉链类型ZF f x表示一对单孔上下文和孔中的元素。

Diff1的操作描述了我们可以对拉链进行的导航类型（没有任何概念＆＃34;向左＆＃34;和＆＃34;向右＆＃34;，为此我看aroundF 3}}纸）。我们可以向上＆＃34;通过将元素插入其孔中来重新组装结构。我们可以向下＆＃34;找到访问给定结构中元素的各种方法：我们用它的上下文装饰每个元素。我们可以去＆＃34;周围＆＃34;， 采用现有的拉链并用其上下文装饰每个元素，因此我们找到了重新聚焦的所有方法（以及如何保持当前的焦点）。

现在，class Functor c => Comonad c where extract :: c x -> x duplicate :: c x -> c (c x) 的类型可能会提醒你们有些人

instance Diff1 f => Functor (ZF f) where
  fmap f (df :<-: x) = fmap f df :<-: f x

instance Diff1 f => Comonad (ZF f) where
  extract    = elF
  duplicate  = aroundF

你被提醒了！我们有一个跳跃和跳过，

extract . duplicate == id
fmap extract . duplicate == id
duplicate . duplicate == fmap duplicate . duplicate

我们坚持

fmap extract (downF xs) == xs              -- downF decorates the element in position
fmap upF (downF xs) = fmap (const xs) xs   -- downF gives the correct context

我们还需要

data KF a x = KF a
instance Functor (KF a) where
  fmap f (KF a) = KF a

instance Diff1 (KF a) where
  type DF (KF a) = KF Void
  upF (KF w :<-: _) = absurd w
  downF (KF a) = KF a
  aroundF (KF w :<-: _) = absurd w

多项式仿函数是可微分的

常量仿函数是可区分的。

upF

无处放置元素，因此无法形成上下文。无处可去downF或downF，我们很容易找到所有方法data IF x = IF x instance Functor IF where fmap f (IF x) = IF (f x) instance Diff1 IF where type DF IF = KF () upF (KF () :<-: x) = IF x downF (IF x) = IF (KF () :<-: x) aroundF z@(KF () :<-: x) = KF () :<-: z 。

身份仿函数是可以区分的。

downF

在一个简单的上下文中有一个元素，upF找到它，aroundF重新包装它，data (f :+: g) x = LF (f x) | RF (g x) instance (Functor f, Functor g) => Functor (f :+: g) where fmap h (LF f) = LF (fmap h f) fmap h (RF g) = RF (fmap h g) instance (Diff1 f, Diff1 g) => Diff1 (f :+: g) where type DF (f :+: g) = DF f :+: DF g upF (LF f' :<-: x) = LF (upF (f' :<-: x)) upF (RF g' :<-: x) = RF (upF (g' :<-: x)) 只能保留。

总和可保持差异化。

downF

其他一些零碎的东西更是少数。要转到downF，我们必须在标记的组件内部 downF (LF f) = LF (fmap (\ (f' :<-: x) -> LF f' :<-: x) (downF f)) downF (RF g) = RF (fmap (\ (g' :<-: x) -> RF g' :<-: x) (downF g)) ，然后修复生成的拉链以在上下文中显示标记。

aroundF

要转到x，我们会删除标记，弄清楚如何绕过未标记的内容，然后在所有生成的拉链中恢复标记。焦点元素z将被其整个拉链 aroundF z@(LF f' :<-: (x :: x)) = LF (fmap (\ (f' :<-: x) -> LF f' :<-: x) . cxF $ aroundF (f' :<-: x :: ZF f x)) :<-: z aroundF z@(RF g' :<-: (x :: x)) = RF (fmap (\ (g' :<-: x) -> RF g' :<-: x) . cxF $ aroundF (g' :<-: x :: ZF g x)) :<-: z 替换。

ScopedTypeVariables

请注意，我必须使用aroundF来消除对DF的递归调用的歧义。作为类型函数，f' :: D f x不是单射函数，因此f' :<-: x :: Z f x不足以强制data (f :*: g) x = f x :*: g x instance (Functor f, Functor g) => Functor (f :*: g) where fmap h (f :*: g) = fmap h f :*: fmap h g 。

产品可保持差异化。

instance (Diff1 f, Diff1 g) => Diff1 (f :*: g) where
  type DF (f :*: g) = (DF f :*: g) :+: (f :*: DF g)
  upF (LF (f' :*: g) :<-: x) = upF (f' :<-: x) :*: g
  upF (RF (f :*: g') :<-: x) = f :*: upF (g' :<-: x)

要专注于一对中的元素，您要么专注于左侧，要么单独留下，反之亦然。莱布尼茨的着名产品规则对应于简单的空间直觉！

downF

现在， downF (f :*: g) = fmap (\ (f' :<-: x) -> LF (f' :*: g) :<-: x) (downF f) :*: fmap (\ (g' :<-: x) -> RF (f :*: g') :<-: x) (downF g) 的工作方式与sums的工作方式类似，不同之处在于我们不仅需要使用标记（以显示我们的方式）来修复拉链上下文，还要使用未触及的其他组件

aroundF

但aroundF是一大堆笑声。无论我们目前访问哪一方，我们都有两种选择：

1. 在那边移动upF。
2. 将downF移出另一侧，将 aroundF z@(LF (f' :*: g) :<-: (x :: x)) = LF (fmap (\ (f' :<-: x) -> LF (f' :*: g) :<-: x) (cxF $ aroundF (f' :<-: x :: ZF f x)) :*: fmap (\ (g' :<-: x) -> RF (f :*: g') :<-: x) (downF g)) :<-: z where f = upF (f' :<-: x) aroundF z@(RF (f :*: g') :<-: (x :: x)) = RF (fmap (\ (f' :<-: x) -> LF (f' :*: g) :<-: x) (downF f) :*: fmap (\ (g' :<-: x) -> RF (f :*: g') :<-: x) (cxF $ aroundF (g' :<-: x :: ZF g x))) :<-: z where g = upF (g' :<-: x) 移到另一侧。

每个案例都要求我们使用子结构的操作，然后修复上下文。

deriving Show

唷！多项式都是可微分的，因此给了我们共生。

嗯。它有点抽象。所以我尽可能地添加deriving instance (Show (DF f x), Show x) => Show (ZF f x) 并投入

> downF (IF 1 :*: IF 2)
IF (LF (KF () :*: IF 2) :<-: 1) :*: IF (RF (IF 1 :*: KF ()) :<-: 2)

> fmap aroundF it
IF  (LF (KF () :*: IF (RF (IF 1 :*: KF ()) :<-: 2)) :<-: (LF (KF () :*: IF 2) :<-: 1))
:*:
IF  (RF (IF (LF (KF () :*: IF 2) :<-: 1) :*: KF ()) :<-: (RF (IF 1 :*: KF ()) :<-: 2))

允许以下互动（手工整理）

Bifunctor

练习使用链规则显示可微分仿函数的组合是可微分的。

甜！我们现在可以回家吗？当然不是。我们还没有区分任何递归结构。

从bifunctors创建递归仿函数

A class Bifunctor b where bimap :: (x -> x') -> (y -> y') -> b x y -> b x' y' ，作为关于数据类型泛型编程的现有文献（参见Patrik Jansson和Johan Jeuring的着作，或Jeremy Gibbons的优秀讲义），详细解释了一个带有两个参数的类型构造函数，对应于两个各种子结构。我们应该能够＆＃34;映射＆＃34;两者。

Bifunctor

我们可以使用data Mu b y = In (b (Mu b y) y) 来给出递归容器的节点结构。每个节点都有子节点和元素。这些可能只是两种子结构。

b

请参阅？我们将递归结结合起来＃34;在y的第一个参数中，并将参数instance Bifunctor b => Functor (Mu b) where fmap f (In b) = In (bimap (fmap f) f b) 保留在第二个参数中。因此，我们一劳永逸地获得

Bifunctor

要使用此功能，我们需要一套newtype K a x y = K a instance Bifunctor (K a) where bimap f g (K a) = K a 个实例。

Bifunctor Kit

常量是bifunctorial。

data Var = X | Y

data V :: Var -> * -> * -> * where
  XX :: x -> V X x y
  YY :: y -> V Y x y

你可以告诉我先写了这个位，因为标识符较短，但这很好，因为代码较长。

变量是bifunctorial。

我们需要对应于一个参数或另一个参数的bifunctors，所以我做了一个数据类型来区分它们，然后定义了一个合适的GADT。

V X x y

这使x V Y x y和y的副本成为instance Bifunctor (V v) where bimap f g (XX x) = XX (f x) bimap f g (YY y) = YY (g y) 的副本。因此

data (:++:) f g x y = L (f x y) | R (g x y) deriving Show

instance (Bifunctor b, Bifunctor c) => Bifunctor (b :++: c) where
  bimap f g (L b) = L (bimap f g b)
  bimap f g (R b) = R (bimap f g b)

data (:**:) f g x y = f x y :**: g x y deriving Show

instance (Bifunctor b, Bifunctor c) => Bifunctor (b :**: c) where
  bimap f g (b :**: c) = bimap f g b :**: bimap f g c

bifunctors的

Sums 和产品是bifunctors

List = Mu (K () :++: (V Y :**: V X))

Bin = Mu (V Y :**: (K () :++: (V X :**: V X)))

到目前为止，所以样板，但现在我们可以定义像

这样的东西

Mu b

如果你想将这些类型用于实际数据而不是在Georges Seurat的点画传统中失明，请使用模式同义词。

但拉链是什么？我们如何证明b是可区分的？我们需要证明{em} 变量中的data Vary :: Var -> * where VX :: Vary X VY :: Vary Y 是可区分的。铛！现在是了解偏微分化的时候了。

bifunctors的部分衍生物

因为我们有两个变量，所以我们需要能够在其他时间有时和单独地共同讨论它们。我们需要单身家庭：

class (Bifunctor b, Bifunctor (D b X), Bifunctor (D b Y)) => Diff2 b where
  type D b (v :: Var) :: * -> * -> *
  up      :: Vary v -> Z b v x y -> b x y
  down    :: b x y -> b (Z b X x y) (Z b Y x y)
  around  :: Vary v -> Z b v x y -> Z b v (Z b X x y) (Z b Y x y)

data Z b v x y = (:<-) {cxZ :: D b v x y, elZ :: V v x y}

现在我们可以说一个Bifunctor在每个变量上都有偏导数的含义，并给出相应的拉链概念。

D

此Z b v操作需要知道要定位的变量。相应的拉链v告诉我们必须关注哪个变量x。当我们用上下文＆＃34;装饰时，我们必须用X - 上下文和y - 带有Y的元素 - 上下文来装饰Diff2 b - 元素。但除此之外，它是同一个故事。

我们还有两个任务：第一，表明我们的bifunctor套件是可区分的;其次，要表明Diff1 (Mu b)允许我们建立instance Diff2 (K a) where type D (K a) v = K Void up _ (K q :<- _) = absurd q down (K a) = K a around _ (K q :<- _) = absurd q 。

区分Bifunctor套件

我担心这一点很狡猾，而不是教化。随意跳过。

常数和以前一样。

instance Diff2 (V X) where
  type D (V X) X = K ()
  type D (V X) Y = K Void
  up VX (K () :<- XX x)  = XX x
  up VY (K q :<- _)      = absurd q
  down (XX x) = XX (K () :<- XX x)
  around VX z@(K () :<- XX x)  = K () :<- XX z
  around VY (K q :<- _)        = absurd q

instance Diff2 (V Y) where
  type D (V Y) X = K Void
  type D (V Y) Y = K ()
  up VX (K q :<- _)      = absurd q
  up VY (K () :<- YY y)  = YY y
  down (YY y) = YY (K () :<- YY y)
  around VX (K q :<- _)        = absurd q
  around VY z@(K () :<- YY y)  = K () :<- YY z

在这种情况下，生命太短暂，无法发展Kronecker-delta类型水平的理论，所以我只是单独处理变量。

vV :: Vary v -> Z b v x y -> V v (Z b X x y) (Z b Y x y)
vV VX z = XX z
vV VY z = YY z

对于结构案例，我发现引入一个帮助程序可以让我统一处理变量很有用。

down

然后，我构建了小工具以促进＆＃34;重新标记＆＃34;我们需要around和zimap :: (Bifunctor c) => (forall v. Vary v -> D b v x y -> D b' v x y) -> c (Z b X x y) (Z b Y x y) -> c (Z b' X x y) (Z b' Y x y) zimap f = bimap (\ (d :<- XX x) -> f VX d :<- XX x) (\ (d :<- YY y) -> f VY d :<- YY y) dzimap :: (Bifunctor (D c X), Bifunctor (D c Y)) => (forall v. Vary v -> D b v x y -> D b' v x y) -> Vary v -> Z c v (Z b X x y) (Z b Y x y) -> D c v (Z b' X x y) (Z b' Y x y) dzimap f VX (d :<- _) = bimap (\ (d :<- XX x) -> f VX d :<- XX x) (\ (d :<- YY y) -> f VY d :<- YY y) d dzimap f VY (d :<- _) = bimap (\ (d :<- XX x) -> f VX d :<- XX x) (\ (d :<- YY y) -> f VY d :<- YY y) d 。 （当然，我在工作时看到了我需要的小工具。）

instance (Diff2 b, Diff2 c) => Diff2 (b :++: c) where
  type D (b :++: c) v = D b v :++: D c v
  up v (L b' :<- vv) = L (up v (b' :<- vv))
  down (L b) = L (zimap (const L) (down b))
  down (R c) = R (zimap (const R) (down c))
  around v z@(L b' :<- vv :: Z (b :++: c) v x y)
    = L (dzimap (const L) v ba) :<- vV v z
    where ba = around v (b' :<- vv :: Z b v x y)
  around v z@(R c' :<- vv :: Z (b :++: c) v x y)
    = R (dzimap (const R) v ca) :<- vV v z
    where ca = around v (c' :<- vv :: Z c v x y)

随着这一批准备就绪，我们可以研究细节。总和很简单。

instance (Diff2 b, Diff2 c) => Diff2 (b :**: c) where
  type D (b :**: c) v = (D b v :**: c) :++: (b :**: D c v)
  up v (L (b' :**: c) :<- vv) = up v (b' :<- vv) :**: c
  up v (R (b :**: c') :<- vv) = b :**: up v (c' :<- vv)
  down (b :**: c) =
    zimap (const (L . (:**: c))) (down b) :**: zimap (const (R . (b :**:))) (down c)
  around v z@(L (b' :**: c) :<- vv :: Z (b :**: c) v x y)
    = L (dzimap (const (L . (:**: c))) v ba :**:
        zimap (const (R . (b :**:))) (down c))
      :<- vV v z where
      b = up v (b' :<- vv :: Z b v x y)
      ba = around v (b' :<- vv :: Z b v x y)
  around v z@(R (b :**: c') :<- vv :: Z (b :**: c) v x y)
    = R (zimap (const (L . (:**: c))) (down b):**:
        dzimap (const (R . (b :**:))) v ca)
      :<- vV v z where
      c = up v (c' :<- vv :: Z c v x y)
      ca = around v (c' :<- vv :: Z c v x y)

产品很辛苦，这就是我成为数学家而不是工程师的原因。

undefined

从概念上讲，它与以前一样，但官僚主义更多。我使用pre-type-hole技术构建了这些技术，在我不准备工作的地方使用b作为存根，并在一个地方（在任何给定时间）引入故意类型错误想从typechecker那里获得有用的暗示。即使在Haskell中，您也可以将视频游戏作为视频游戏体验。

递归容器的子节点拉链

X相对于data MuZpr b y = MuZpr { aboveMu :: [D b X (Mu b y) y] , hereMu :: Mu b y } 的偏导数告诉我们如何在节点内找到一个子节点，因此我们得到了传统的拉链概念。

X

我们可以通过重复插入muUp :: Diff2 b => MuZpr b y -> Mu b y muUp (MuZpr {aboveMu = [], hereMu = t}) = t muUp (MuZpr {aboveMu = (dX : dXs), hereMu = t}) = muUp (MuZpr {aboveMu = dXs, hereMu = In (up VX (dX :<- XX t))}) 位置来一直缩放到根目录。

X

但我们需要元素 -zippers。

用于bifunctors固定点的元素拉链

每个元素都在节点内。该节点位于Y - 衍生物的堆栈下。但是该节点中元素的位置由data MuCx b y = MuCx { aboveY :: [D b X (Mu b y) y] , belowY :: D b Y (Mu b y) y } instance Diff2 b => Functor (MuCx b) where fmap f (MuCx { aboveY = dXs, belowY = dY }) = MuCx { aboveY = map (bimap (fmap f) f) dXs , belowY = bimap (fmap f) f dY } - 导数给出。我们得到

instance Diff2 b => Diff1 (Mu b) where
  type DF (Mu b) = MuCx b

大胆地，我声称

zAboveY :: ZF (Mu b) y -> [D b X (Mu b y) y]  -- the stack of `X`-derivatives above me
zAboveY (d :<-: y) = aboveY d

zZipY :: ZF (Mu b) y -> Z b Y (Mu b y) y      -- the `Y`-zipper where I am
zZipY (d :<-: y) = belowY d :<- YY y

但在开发操作之前，我需要一些零碎的东西。

我可以在functor-zippers和bifunctor-zippers之间交换数据，如下所示：

  upF z  = muUp (MuZpr {aboveMu = zAboveY z, hereMu = In (up VY (zZipY z))})

这足以让我定义：

  downF  = yOnDown []

也就是说，我们首先重新组装元素所在的节点，将元素拉链转换为子节点拉链，然后一直缩放，如上所述。

接下来，我说

down

从空堆栈开始向下，并定义从任何堆栈下方反复执行yOnDown :: Diff2 b => [D b X (Mu b y) y] -> Mu b y -> Mu b (ZF (Mu b) y) yOnDown dXs (In b) = In (contextualize dXs (down b)) 的辅助函数：

down b

现在，contextualise只将我们带入节点。我们需要的拉链也必须带有节点的上下文。这是contextualize :: (Bifunctor c, Diff2 b) => [D b X (Mu b y) y] -> c (Z b X (Mu b y) y) (Z b Y (Mu b y) y) -> c (Mu b (ZF (Mu b) y)) (ZF (Mu b) y) contextualize dXs = bimap (\ (dX :<- XX t) -> yOnDown (dX : dXs) t) (\ (dY :<- YY y) -> MuCx {aboveY = dXs, belowY = dY} :<-: y) 的作用：

Y

对于每个dXs - 位置，我们必须给出一个元素拉链，所以我们知道整个上下文dY回到根，以及X描述元素如何位于其节点中。对于每个 aroundF z@(MuCx {aboveY = dXs, belowY = dY} :<-: _) = MuCx { aboveY = yOnUp dXs (In (up VY (zZipY z))) , belowY = contextualize dXs (cxZ $ around VY (zZipY z)) } :<-: z - 位置，还有一个要探索的子树，所以我们增加了堆栈并继续前进！

只留下转移焦点的业务。我们可能会留下来，或者从我们所处的地方走下去，或者往上走，或者往上走，然后走另一条路。到此为止。

belowY

与以往一样，现有元素被其整个拉链取代。对于Y部分，我们会查看现有节点中的其他位置：我们将找到替代元素X - 位置或进一步contextualise - 要探索的子节点，因此我们{{ 1}}他们。对于aboveY部分，我们必须在重新组装我们正在访问的节点后，重新构建X - 衍生堆栈。

yOnUp :: Diff2 b => [D b X (Mu b y) y] -> Mu b y ->
         [D b X (Mu b (ZF (Mu b) y)) (ZF (Mu b) y)]
yOnUp [] t = []
yOnUp (dX : dXs) (t :: Mu b y)
  =  contextualize dXs (cxZ $ around VX (dX :<- XX t))
  :  yOnUp dXs (In (up VX (dX :<- XX t)))

在每一步，我们都可以转到around的其他地方，或继续上升。

那就是它！我还没有给出正式的法律证据，但它让我看起来好像操作在爬行结构时仔细维护上下文。

我们学到了什么？

可区分性引发了在其上下文中的事物的概念，诱导了一个comonadic结构，其中extract为您提供了事物，duplicate探索了寻找其他事物的上下文。如果我们有适当的节点差分结构，我们可以为整棵树开发差分结构。

哦，分别对待每个类型构造函数的arity是公然可怕的。更好的方法是在索引集之间使用仿函数

f :: (i -> *) -> (o -> *)

我们使o种不同种类的结构存储i不同种类的元素。这些是雅可比构造下的关闭

J f :: (i -> *) -> ((o, i) -> *)

其中每个结果(o, i) - 结构都是偏导数，告诉您如何在i - 结构中创建o - 元素孔。但是，这又取决于其他时间。

Answer 2

拉链的Comonad实例不

instance (Diff t, Diff (D t)) => Comonad (Zipper t) where
    extract = here
    duplicate = fmap outOf . inTo

其中outOf和inTo来自Diff本身Zipper t的实例。上述情况违反了Comonad法律fmap extract . duplicate == id。相反，它表现得像：

fmap extract . duplicate == \z -> fmap (const (here z)) z

Diff（拉链t）

Diff Zipper实例是通过将其标识为产品并重复使用产品代码（下方）而提供的。

-- Zippers are themselves products
toZipper :: (D t :*: Identity) a -> Zipper t a
toZipper (d :*: (Identity h)) = Zipper d h

fromZipper :: Zipper t a -> (D t :*: Identity) a
fromZipper (Zipper d h) = (d :*: (Identity h))

鉴于数据类型之间的同构，以及它们的衍生物之间的同构，我们可以为另一个重用一种类型的inTo和outOf。

inToFor' :: (Diff r) =>
            (forall a.   r a ->   t a) ->
            (forall a.   t a ->   r a) ->
            (forall a. D r a -> D t a) ->
            (forall a. D t a -> D r a) ->
            t a -> t (Zipper t a)
inToFor' to from toD fromD = to . fmap (onDiff toD) . inTo . from

outOfFor' :: (Diff r) =>
            (forall a.   r a ->   t a) ->
            (forall a.   t a ->   r a) ->
            (forall a. D r a -> D t a) ->
            (forall a. D t a -> D r a) ->
            Zipper t a -> t a
outOfFor' to from toD fromD = to . outOf . onDiff fromD

对于仅为现有Diff实例的newTypes的类型，它们的派生类型相同。如果我们告诉类型检查器关于类型相等D r ~ D t，我们可以利用它而不是为衍生物提供同构。

inToFor :: (Diff r, D r ~ D t) =>
           (forall a. r a -> t a) ->
           (forall a. t a -> r a) ->
           t a -> t (Zipper t a)
inToFor to from = inToFor' to from id id

outOfFor :: (Diff r, D r ~ D t) =>
            (forall a. r a -> t a) ->
            (forall a. t a -> r a) ->
            Zipper t a -> t a
outOfFor to from = outOfFor' to from id id

配备这些工具，我们可以重复使用Diff实例来实现Diff (Zipper t)

-- This requires undecidable instances, due to the need to take D (D t)
instance (Diff t, Diff (D t)) => Diff (Zipper t) where
    type D (Zipper t) = D ((D t) :*: Identity)
    -- inTo :: t        a -> t        (Zipper  t         a)
    -- inTo :: Zipper t a -> Zipper t (Zipper (Zipper t) a)
    inTo = inToFor toZipper fromZipper
    -- outOf :: Zipper  t         a -> t        a
    -- outOf :: Zipper (Zipper t) a -> Zipper t a
    outOf = outOfFor toZipper fromZipper

样板

为了实际使用此处提供的代码，我们需要一些语言扩展，导入和重新提出的问题。

{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}

import Control.Monad.Identity
import Data.Proxy
import Control.Comonad

data Zipper t a = Zipper { diff :: D t a, here :: a }

onDiff :: (D t a -> D u a) -> Zipper t a -> Zipper u a
onDiff f (Zipper d a) = Zipper (f d) a

deriving instance Diff t => Functor (Zipper t)
deriving instance (Eq (D t a), Eq a) => Eq (Zipper t a)
deriving instance (Show (D t a), Show a) => Show (Zipper t a)

class (Functor t, Functor (D t)) => Diff t where
  type D t :: * -> *
  inTo  :: t a -> t (Zipper t a)
  outOf :: Zipper t a -> t a

产品，总和和常数

Diff (Zipper t)实例依赖于Diff对产品:*:，总和:+:，常量Identity和零Proxy的实施。< / p>

data (:+:) a b x = InL (a x) | InR (b x)
    deriving (Eq, Show)
data (:*:) a b x = a x :*: b x
    deriving (Eq, Show)

infixl 7 :*:
infixl 6 :+:

deriving instance (Functor a, Functor b) => Functor (a :*: b)

instance (Functor a, Functor b) => Functor (a :+: b) where
    fmap f (InL a) = InL . fmap f $ a
    fmap f (InR b) = InR . fmap f $ b


instance (Diff a, Diff b) => Diff (a :*: b) where
    type D (a :*: b) = D a :*: b :+: a :*: D b
    inTo (a :*: b) = 
        (fmap (onDiff (InL . (:*: b))) . inTo) a :*:
        (fmap (onDiff (InR . (a :*:))) . inTo) b
    outOf (Zipper (InL (a :*: b)) x) = (:*: b) . outOf . Zipper a $ x
    outOf (Zipper (InR (a :*: b)) x) = (a :*:) . outOf . Zipper b $ x

instance (Diff a, Diff b) => Diff (a :+: b) where
    type D (a :+: b) = D a :+: D b
    inTo (InL a) = InL . fmap (onDiff InL) . inTo $ a
    inTo (InR b) = InR . fmap (onDiff InR) . inTo $ b
    outOf (Zipper (InL a) x) = InL . outOf . Zipper a $ x
    outOf (Zipper (InR a) x) = InR . outOf . Zipper a $ x

instance Diff (Identity) where
    type D (Identity) = Proxy
    inTo = Identity . (Zipper Proxy) . runIdentity
    outOf = Identity . here

instance Diff (Proxy) where
    type D (Proxy) = Proxy
    inTo = const Proxy
    outOf = const Proxy

Bin示例

我将Bin示例作为产品总和的同构。我们不仅需要它的衍生物，还需要它的二阶导数

newtype Bin   a = Bin   {unBin   ::      (Bin :*: Identity :*: Bin :+: Identity)  a}
    deriving (Functor, Eq, Show)
newtype DBin  a = DBin  {unDBin  ::    D (Bin :*: Identity :*: Bin :+: Identity)  a}
    deriving (Functor, Eq, Show)
newtype DDBin a = DDBin {unDDBin :: D (D (Bin :*: Identity :*: Bin :+: Identity)) a}
    deriving (Functor, Eq, Show)

instance Diff Bin where
    type D Bin = DBin
    inTo  = inToFor'  Bin unBin DBin unDBin
    outOf = outOfFor' Bin unBin DBin unDBin

instance Diff DBin where
    type D DBin = DDBin
    inTo  = inToFor'  DBin unDBin DDBin unDDBin
    outOf = outOfFor' DBin unDBin DDBin unDDBin

previous answer的示例数据是

aTree :: Bin Int    
aTree =
    (Bin . InL) (
        (Bin . InL) (
            (Bin . InR) (Identity 2)
            :*: (Identity 1) :*:
            (Bin . InR) (Identity 3)
        )
        :*: (Identity 0) :*:
        (Bin . InR) (Identity 4)
    )

不是Comonad实例

上面的Bin示例提供了一个反例，fmap outOf . inTo是duplicate Zipper t的正确实现。特别是，它提供了fmap extract . duplicate = id法律的反例：

fmap ( \z -> (fmap extract . duplicate) z == z) . inTo $ aTree

评估为（注意到它到处都是False，任何False都足以反驳法律）

Bin {unBin = InL ((Bin {unBin = InL ((Bin {unBin = InR (Identity False)} :*: Identity False) :*: Bin {unBin = InR (Identity False)})} :*: Identity False) :*: Bin {unBin = InR (Identity False)})}

inTo aTree是一个与aTree具有相同结构的树，但是在任何地方都有一个值，而是一个带有值的拉链，以及所有原始值完整的树的其余部分。 fmap (fmap extract . duplicate) . inTo $ aTree也是一个与aTree具有相同结构的树，但是每个都有一个值而不是带有值的拉链，而的其余部分都替换了所有值具有相同的值。换句话说：

fmap extract . duplicate == \z -> fmap (const (here z)) z

适用于所有三个Comonad法律，extract . duplicate == id，fmap extract . duplicate == id和duplicate . duplicate == fmap duplicate . duplicate的完整测试套件

main = do
    putStrLn "fmap (\\z -> (extract . duplicate) z == z) . inTo $ aTree"
    print   . fmap ( \z -> (extract . duplicate) z == z) . inTo $ aTree    
    putStrLn ""
    putStrLn  "fmap (\\z -> (fmap extract . duplicate) z == z) . inTo $ aTree"
    print    . fmap ( \z -> (fmap extract . duplicate) z == z) . inTo $ aTree    
    putStrLn ""
    putStrLn "fmap (\\z -> (duplicate . duplicate) z) == (fmap duplicate . duplicate) z) . inTo $ aTree"
    print   . fmap ( \z -> (duplicate . duplicate) z == (fmap duplicate . duplicate) z) . inTo $ aTree

Answer 3

给出一个无限可微的Diff类：

class (Functor t, Functor (D t)) => Diff t where
    type D t :: * -> *
    up :: Zipper t a -> t a
    down :: t a -> t (Zipper t a)  
    -- Require that types be infinitely differentiable
    ddiff :: p t -> Dict (Diff (D t))

around可以up和down Zipper diff的{​​{1}}来源写出如

around z@(Zipper d h) = Zipper ctx z
    where
        ctx = fmap (\z' -> Zipper (up z') (here z')) (down d)

Zipper t a由D t a和a组成。我们转down D t a，在每个洞中获得一个带有拉链的D t (Zipper (D t) a)。这些拉链包含D (D t) a和洞中的a。我们每个人up，获得D t a并将其与洞中的a一起使用。 D t a和a生成Zipper t a，为我们提供D t (Zipper t a)，这是Zipper t (Zipper t a)所需的上下文。

Comonad实例就是

instance Diff t => Comonad (Zipper t) where
    extract   = here
    duplicate = around

捕获派生词Diff词典需要一些额外的管道，可以使用Data.Constraint或the method presented in a related answer

来完成

around :: Diff t => Zipper t a -> Zipper t (Zipper t a)
around z = Zipper (withDict d' (fmap (\z' -> Zipper (up z') (here z')) (down (diff z)))) z
    where
        d' = ddiff . p' $ z
        p' :: Zipper t x -> Proxy t
        p' = const Proxy