Thực hiện chức năng 'đa chức năng' đa hình cho các traversals và nếp gấp

Question

Tôi đang sử dụng lens cùng với xml-lens. Tôi muốn làm cho các chức năng sau đây đa hình hơn, do đó nó cũng làm việc cho Folds và không chỉ 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 

Chức năng này hoạt động giống như các deep chức năng từ hxt. Có thể làm cho nó đa hình hơn theo cách tôi muốn không?

Answer 1

Điều này khá phức tạp với API được hiển thị công khai hiện tại.

Tôi đã tự do mở rộng loại deepOf cũng hỗ trợ các lần lập chỉ mục và đi ngang được lập chỉ mục theo cách dễ dàng hơn không làm như vậy và thực hiện việc thực hiện đầy đủ chúng tôi muốn xuất từ ​​lens , dù sao đi nữa.

Hãy nhập các phần của lens mà chúng tôi thường không hiển thị cho người dùng.

{-# 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 

Chúng tôi sẽ cần một vài combinators nội bộ mà chúng ta không phơi bày từ Control.Lens.Traversal được sử dụng để thao tác một Traversal/Fold như một BazaarT và sụp đổ câu trả lời trở ra.

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 #-} 

Bây giờ chúng ta có điều đó, chúng tôi xây dựng phiên bản thích hợp 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 

Các ruột của deepOf là rất giống với ruột hiện của failing, mà bạn có được một cách đúng đắn cố gắng sử dụng như ngựa thồ của bạn.

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 

Điều duy nhất khác nhau là [] trường hợp, nơi thay vì rơi trên, những gì chúng ta làm được điều hành toàn bộ lồng nhau Traversal.

Tôi vừa mới đánh máy điều này và không thực sự thực thi nó, nhưng có vẻ đúng với tôi.

Vui lòng đặt sự cố vào số http://github.com/ekmett/lens/issues để thêm các bộ phối hợp này (hoặc một số đổi tên bikeshed), chúng có thể nằm trong API lens lõi, không cho phép người dùng thực hiện trong chính thư viện.

Đây là loại mã mà chúng tôi cố gắng viết một lần để người dùng cuối không phải làm như vậy.