是否有可能懒散地获得Traversable的所有上下文？

Posted 2021-03-31

lens提供holesOf，这是这个假设函数的一个更通用和更强大的版本：

holesList :: Traversable t
          => t a -> [(a, a -> t a)]

给定一个容器，holesList会生成容器元素列表以及替换这些元素的函数。

holesList的类型，就像真正的holesOf一样，无法捕捉到产生的对数等于容器元素数的事实。因此，更美丽的类型将是

holes :: Traversable t
      => t a -> t (a, a -> t a)

我们可以通过使用holes来制作一个列表，然后在holesList中遍历以重新插入元素来实现State。但这有两个原因令人不满意，其中一个原因具有实际后果：

1. slurping代码将有一个无法访问的错误调用来处理在遍历完成之前列表为空的情况。这很恶心，但对使用该功能的人来说可能并不重要。
2. 无限延伸到左侧或左下方的容器根本不起作用。向左延伸很远的容器处理效率非常低。

我想知道是否有任何办法解决这些问题。使用像镜头中的Magma这样的东西很有可能捕获遍历的形状：

data FT a r where
  Pure :: r -> FT a r
  Single :: a -> FT a a
  Map :: (r -> s) -> FT a r -> FT a s
  Ap :: FT a (r -> s) -> FT a r -> FT a s

instance Functor (FT a) where
  fmap = Map
instance Applicative (FT a) where
  pure = Pure
  (<*>) = Ap

runFT :: FT a t -> t
runFT (Pure t) = t
runFT (Single a) = a
runFT (Map f x) = f (runFT x)
runFT (Ap fs xs) = runFT fs (runFT xs)

现在我们有

runFT . traverse Single = id

traverse Single创建了一个充满元素的树以及将它们构建到容器中所需的函数应用程序。如果我们替换树中的元素，我们可以runFT结果来获取一个替换了该元素的容器。不幸的是，我陷入了困境：我不知道下一步可能会是什么样子。

---

模糊的想法：添加另一个类型参数可能有助于更改元素类型。 Magma类型就是这样的，它至少可以追溯到Zemyla对Van Laarhoven关于FunList的博客文章的评论。

答案

Your existing solution为runMag构造函数定义的树中的每个分支调用Ap一次。

我没有描述任何东西，但由于runMag本身是递归的，这可能会减慢大树中的速度。

另一种方法是打结，所以你只是（实际上）为整个树调用runMag一次：

data Mag a b c where
  One :: a -> Mag a b b
  Pure :: c -> Mag a b c
  Ap :: Mag a b (c -> d) -> Mag a b c -> Mag a b d

instance Functor (Mag a b) where
  fmap = Ap . Pure

instance Applicative (Mag a b) where
  pure = Pure
  (<*>) = Ap

holes :: forall t a. Traversable t => t a -> t (a, a -> t a)
holes = 	 -> 
    let m :: Mag a b (t b)
        m = traverse One t 
    in fst $ go id m m
  where
    go :: (x -> y)
       -> Mag a (a, a -> y) z
       -> Mag a a x
       -> (z, x)
    go f (One a)    (One _)    = ((a, f), a)
    go _ (Pure z)   (Pure x)   = (z, x)
    go f (Ap mg mi) (Ap mh mj) = 
      let ~(g, h) = go (f . ($j)) mg mh
          ~(i, j) = go (f .   h ) mi mj
      in (g i, h j)
    go _ _ _ = error "only called with same value twice, constructors must match"

另一答案

我没有找到一个非常漂亮的方式来做到这一点。那可能是因为我不够聪明，但我怀疑它是traverse类型的固有限制。但我找到了一种有点丑陋的方式！关键确实似乎是Magma使用的额外类型参数，这使我们可以自由地构建一个期望某种元素类型的框架，然后再填充元素。

data Mag a b t where
  Pure :: t -> Mag a b t
  Map :: (x -> t) -> Mag a b x -> Mag a b t
  Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u
  One :: a -> Mag a b b

instance Functor (Mag a b) where
  fmap = Map

instance Applicative (Mag a b) where
  pure = Pure
  (<*>) = Ap

-- We only ever call this with id, so the extra generality
-- may be silly.
runMag :: forall a b t. (a -> b) -> Mag a b t -> t
runMag f = go
  where
    go :: forall u. Mag a b u -> u
    go (Pure t) = t
    go (One a) = f a
    go (Map f x) = f (go x)
    go (Ap fs xs) = go fs (go xs)

我们递归地下降类型Mag x (a, a -> t a) (t (a, a -> t a))的值与Mag a a (t a)类型的并行使用后者生成a和a -> t a值，前者作为从这些值构建t (a, a -> t)的框架。 x实际上将是a;它留下了多态性，使“类型俄罗斯方块”不那么令人困惑。

-- Precondition: the arguments should actually be the same;
-- only their types will differ. This justifies the impossibility
-- of non-matching constructors.
smash :: forall a x t u.
         Mag x (a, a -> t) u
      -> Mag a a t
      -> u
smash = go id
  where
    go :: forall r b.
          (r -> t)
       -> Mag x (a, a -> t) b
       -> Mag a a r
       -> b
    go f (Pure x) _ = x
    go f (One x) (One y) = (y, f)
    go f (Map g x) (Map h y) = g (go (f . h) x y)
    go f (Ap fs xs) (Ap gs ys) =
      (go (f . ($ runMag id ys)) fs gs)
      (go (f . runMag id gs) xs ys)
    go _ _ _ = error "Impossible!"

我们实际上只使用Mag生成两个traverse值（不同类型！）。这两个值实际上将由内存中的单个结构表示。

holes :: forall t a. Traversable t => t a -> t (a, a -> t a)
holes t = smash mag mag
  where
    mag :: Mag a b (t b)
    mag = traverse One t

现在我们可以玩有趣的价值观了

holes (Reverse [1..])

Reverse来自Data.Functor.Reverse。

另一答案

这是一个简短的实现，总计（如果忽略循环），不使用任何中间数据结构，并且是懒惰的（适用于任何类型的无限遍历）：

import Control.Applicative
import Data.Traversable

holes :: Traversable t => t a -> t (a, a -> t a)
holes t = flip runKA id $ for t $ a ->
  KA $ k ->
    let f a' = fst <$> k (a', f)
    in (a, f)

newtype KA r a = KA { runKA :: (a -> r) -> a }

instance Functor (KA r) where fmap f a = pure f <*> a
instance Applicative (KA r) where
  pure a = KA (\_ -> a)
  liftA2 f (KA ka) (KA kb) = KA $ cr ->
    let
      a = ka ar
      b = kb br
      ar a' = cr $ f a' b
      br b' = cr $ f a b'
    in f a b

KA是一个“懒惰的延续应用函子”。如果我们用标准的Cont monad替换它，我们也会得到一个非常懒的工作解决方案：

import Control.Monad.Cont
import Data.Traversable

holes :: Traversable t => t a -> t (a, a -> t a)
holes t = flip runCont id $ for t $ a ->
  cont $ k ->
    let f a' = fst <$> k (a', f)
    in k (a, f)

另一答案

这并没有真正回答原始问题，但它显示了另一个角度。看起来这个问题实际上与我问过的previous question相关。假设Traversable有另外一种方法：

traverse2 :: Biapplicative f
           => (a -> f b c) -> t a -> f (t b) (t c)

注意：对于任何具体的Traversable数据类型，实际上可以合法地实现此方法。对于奇怪的事情

newtype T a = T (forall f b. Applicative f => (a -> f b) -> f (T b))

看到相关问题答案中的非法方式。

有了这个，我们可以设计一个非常类似于罗马的类型，但有一个扭曲来自rampion：

newtype Holes t m x = Holes { runHoles :: (x -> t) -> (m, x) }

instance Bifunctor (Holes t) where
  bimap f g xs = Holes $ xt ->
    let
      (qf, qv) = runHoles xs (xt . g)
    in (f qf, g qv)

instance Biapplicative (Holes t) where
  bipure x y = Holes $ \_ -> (x, y)
  fs <<*>> xs = Holes $ xt ->
    let
      (pf, pv) = runHoles fs (cd -> xt (cd qv))
      (qf, qv) = runHoles xs (c -> xt (pv c))
    in (pf qf, pv qv)

现在一切都很简单：

holedOne :: a -> Holes (t a) (a, a -> t a) a
holedOne x = Holes $ xt -> ((x, xt), x)

holed :: Traversable t => t a -> t (a, a -> t a)
holed xs = fst (runHoles (traverse2 holedOne xs) id)