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

Ответ 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)