Можно ли лениво получить все контексты "Траверсируемого"?

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 holes, чтобы составить список, а затем пересечься в State чтобы сломать элементы обратно. Но это неудовлетворительно по двум причинам, одно из которых имеет практические последствия:

  1. Код разрыва будет иметь недостижимый вызов ошибки для обработки случая, когда список пуст до завершения обхода. Это отвратительно, но, вероятно, не имеет большого значения для тех, кто использует эту функцию.

  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 FunList о FunList.

Ответ 1

Ваше существующее решение вызывает 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 = \t -> 
    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"

Ответ 2

Мне не удалось найти действительно красивый способ сделать это. Это может быть потому, что я недостаточно умен, но я подозреваю, что это неотъемлемое ограничение типа 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 → ta) (t (a, a → ta)) параллельно с одним из типов Mag aa (ta) используя последнее, чтобы получить a и a → ta и первое в качестве основы для построения 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.

Ответ 3

Вот краткая, полная (если вы игнорируете округлость) реализацию, не использует промежуточных структур данных и ленива (работает на любом бесконечном пересечении):

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, мы также получим рабочее решение, которое не является ленивым:

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)

Ответ 4

Это на самом деле не отвечает на исходный вопрос, но он показывает другой угол. Похоже, этот вопрос на самом деле очень привязан к предыдущему вопросу, который я задал. Предположим, что у 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))

см. незаконные пути ответов на связанный вопрос.

С этим на месте мы можем спроектировать тип, очень похожий на римский, но с завихрением от пандиона:

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)