haskell - ¿Es posible obtener todos los contextos de un perverso perversamente?

lens traversable

Question

lens ofrece holesOf , que es una versión algo más general y poderosa de esta función hipotética:

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

Dado un contenedor, holesList produce una lista de elementos del contenedor junto con funciones para reemplazar esos elementos.

El tipo de holesList que holesList , como el de los holesOf reales, no captura el hecho de que el número de pares producidos será igual al número de elementos del contenedor. Un tipo mucho más hermoso, por lo tanto, sería

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

Podríamos implementar holes utilizando holesList para hacer una lista y luego recorrer en State para absorber los elementos nuevamente. Pero esto no es satisfactorio por dos razones, una de las cuales tiene consecuencias prácticas:

1. El código de arrastre tendrá una llamada de error inalcanzable para manejar el caso donde la lista se queda vacía antes de que se complete el recorrido. Esto es asqueroso, pero probablemente no le importe mucho a alguien que usa la función.

2. Los contenedores que se extienden infinitamente a la izquierda, o que se mueven hacia abajo a la izquierda, no funcionarán en absoluto. Los contenedores que se extienden muy hacia la izquierda serán muy ineficientes de manejar.

Me pregunto si hay alguna forma de evitar estos problemas. Es muy posible capturar la forma del recorrido usando algo como Magma en la lente:

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)

Ahora tenemos

runFT . traverse Single = id

traverse Single crea un árbol lleno de elementos junto con las aplicaciones de función necesarias para construirlos en un contenedor. Si reemplazamos un elemento en el árbol, podemos runFT el resultado para obtener un contenedor con ese elemento reemplazado. Desafortunadamente, estoy atascado: no sé cómo será el próximo paso.

Pensamientos vagos: agregar otro parámetro de tipo podría ayudar a cambiar los tipos de elementos. El tipo Magma hace algo como esto, y se remonta al menos hasta el comentario de Zemyla en la publicación del blog de Van Laarhoven sobre FunList .

Answer 1

Aquí hay una implementación que es corta, total (si ignora la circularidad), no utiliza ninguna estructura de datos intermedia y es perezosa (funciona en cualquier tipo de recorrido infinito):

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 es un "funtor aplicativo de continuación perezoso". Si lo reemplazamos con la mónada estándar de Cont , también obtenemos una solución de trabajo que, sin embargo, no es perezosa:

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)

Answer 2

Esto realmente no responde a la pregunta original, pero muestra otro ángulo. Parece que esta pregunta está realmente vinculada a una pregunta previa que hice. Supongamos que Traversable tenía un método adicional:

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

Nota: este método puede implementarse legítimamente para cualquier tipo de datos Traversable concreto. Para rarezas como

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

Ver las formas ilegítimas en las respuestas a la pregunta vinculada.

Con eso en su lugar, podemos diseñar un tipo muy similar al de Roman, pero con un giro de 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)

Ahora todo está muerto simple:

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)

Answer 3

No he logrado encontrar una manera realmente hermosa de hacer esto. Eso podría ser porque no soy lo suficientemente inteligente, pero sospecho que es una limitación inherente del tipo de traverse . ¡Pero he encontrado una manera que es un poco fea! De hecho, la clave parece ser el argumento de tipo adicional que usa Magma , que nos da la libertad de construir un marco que espera un determinado tipo de elemento y luego rellenar los elementos más adelante.

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)

Descendemos recursivamente un valor de tipo Mag x (a, a -> ta) (t (a, a -> ta)) en paralelo con uno de tipo Mag aa (ta) utilizando este último para producir a y a -> ta valores y el primero como marco para construir t (a, a -> t) partir de esos valores. x será en realidad a ; queda polimórfico para que el "tipo tetris" sea un poco menos confuso.

-- 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!"

En realidad, producimos ambos valores Mag (¡de diferentes tipos!) Usando una sola llamada para traverse . Estos dos valores serán representados por una sola estructura en la memoria.

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

Ahora podemos jugar con divertidos valores como

holes (Reverse [1..])

donde Reverse es de Data.Functor.Reverse .

Answer 4

Su solución existente llama a runMag una vez para cada rama en el árbol definido por los constructores de Ap .

No he perfilado nada, pero como runMag es en sí mismo recursivo, esto podría ralentizar las cosas en un árbol grande.

Una alternativa sería atar el nudo para que solo (en efecto) se llame runMag una vez para todo el árbol:

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"