haskell - 为遍历和折叠实现多态 'deep' 函数

Question

我正在使用 lens连同 xml-lens .我想让以下函数更具多态性，以便它也适用于 Folds不仅Traversals :

-- | Traverse a plated structure recursively, trying to match a fold at each level. Don't recurse
-- if the fold matches.
deep :: forall s a. Plated s => Traversal' s a -> Traversal' s a
deep f = let go :: Traversal' s a; go = cloneTraversal $ failing f (plate . go) in go

这个函数的作用类似于 deep函数来自 hxt .是否可以按照我想要的方式使其更具多态性？

Answer 1

鉴于当前公开的 API，这一点相当棘手。

我冒昧地扩展了deepOf的类型同时支持索引折叠和索引遍历，因为这样做比不这样做更容易，并使实现成为我们想要从 lens 导出的完整实现， 无论如何。

让我们导入 lens 的部分我们通常不会向用户展示。

{-# LANGUAGE RankNTypes #-}

import Control.Applicative
import Control.Lens
import Control.Lens.Internal.Bazaar
import Control.Lens.Internal.Context
import Control.Lens.Traversal
import Control.Monad.State
import Data.Profunctor.Rep
import Data.Profunctor.Unsafe

我们需要一些不会从 Control.Lens.Traversal 公开的内部组合子。用于操作 Traversal/ Fold作为 BazaarT并将答案折叠回来。

pins :: (Bizarre p w, Corepresentable p) => w a b t -> [Corep p a]
pins = getConst #. bazaar (cotabulate $ \ra -> Const [ra])
{-# INLINE pins #-}

unsafeOuts :: (Bizarre p w, Corepresentable p) => w a b t -> [b] -> t
unsafeOuts = evalState `rmap` bazaar (cotabulate (\_ -> state (unconsWithDefault fakeVal)))
  where fakeVal = error "unsafePartsOf': not enough elements were supplied"
{-# INLINE unsafeOuts #-}

unconsWithDefault :: a -> [a] -> (a,[a])
unconsWithDefault d []     = (d,[])
unconsWithDefault _ (x:xs) = (x,xs)
{-# INLINE unconsWithDefault #-}

现在我们有了它，我们构建了一个正确的 deep 版本。 .

-- |
-- @
-- 'deep' :: 'Plated' s => 'Fold' s a                 -> 'Fold' s a
-- 'deep' :: 'Plated' s => 'Traversal' s s a b        -> 'Traversal' s s a b
-- 'deep' :: 'Plated' s => 'IndexedFold' i s a        -> 'IndexedFold' i s a
-- 'deep' :: 'Plated' s => 'IndexedTraversal' s s a b -> 'Traversal' i s s a b
-- @
deep :: (Plated s, Conjoined p, Applicative f) => Traversing p f s s a b -> Over p f s s a b
deep = deepOf plate

-- |
-- @
-- 'deepOf' :: 'Fold s s'       -> 'Fold' s a                 -> 'Fold' s a
-- 'deepOf' :: 'Traversal' s s' -> 'Traversal' s s a b        -> 'Traversal' s s a b
-- 'deepOf' :: 'Fold s s'       -> 'IndexedFold' i s a        -> 'IndexedFold' i s a
-- 'deepOf' :: 'Traversal' s s' -> 'IndexedTraversal' s s a b -> 'Traversal' i s s a b
-- @
deepOf :: (Plated s, Conjoined p, Applicative f) => LensLike' f s s -> Traversing p f s s a b -> Over p f s s a b
deepOf r l pafb s = case pins b of
  [] -> r (deep l pafb) s
  xs -> unsafeOuts b <$> traverse (corep pafb) xs
  where b = l sell s

deepOf的胆量|与 failing 的现有胆量非常相似，您正确地尝试将其用作主力。

failing :: (Conjoined p, Applicative f) => Traversing p f s t a b -> Traversing p f s t a b -> Over p f s t a b
failing l r pafb s = case pins b of
  [] -> runBazaarT (r sell s) pafb
  xs -> unsafeOuts b <$> traverse (corep pafb) xs
  where b = l sell s

唯一不同的是 [] 情况，我们所做的不是跌倒，而是运行整个嵌套的 Traversal .

我只是对它进行了类型检查，并没有实际执行它，但它看起来对我来说是正确的。

随时在 http://github.com/ekmett/lens/issues 上提出问题要添加这些组合器(或对它们进行一些重命名)，它们可能属于核心 lens API，以免这样的代码落在用户身上，而在库本身内实现是微不足道的。

这是我们尝试编写一次的代码，因此最终用户不必这样做。