Is it possible to get all contexts of a Traversable lazily?

Question

lens offers holesOf, which is a somewhat more general and powerful version of this hypothetical function:

holesList :: Traversable t
          =>         


        

Answer 1

Your existing solution calls runMag once for every branch in the tree defined by Ap constructors.

I haven't profiled anything, but as runMag is itself recursive, this might slow things down in a large tree.

An alternative would be to tie the knot so you're only (in effect) calling runMag once for the entire tree:

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"

Answer 2

I have not managed to find a really beautiful way to do this. That might be because I'm not clever enough, but I suspect it is an inherent limitation of the type of traverse. But I have found a way that's only a little bit ugly! The key indeed seems to be the extra type argument that Magma uses, which gives us the freedom to build a framework expecting a certain element type and then fill in the elements later.

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)

We recursively descend a value of type Mag x (a, a -> t a) (t (a, a -> t a)) in parallel with one of type Mag a a (t a) using the latter to produce the a and a -> t a values and the former as a framework for building t (a, a -> t) from those values. x will actually be a; it's left polymorphic to make the "type tetris" a little less confusing.

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

We actually produce both Mag values (of different types!) using a single call to traverse. These two values will actually be represented by a single structure in memory.

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

Now we can play with fun values like

holes (Reverse [1..])

where Reverse is from Data.Functor.Reverse.

Answer 3

Here is an implementation that is short, total (if you ignore the circularity), doesn't use any intermediate data structures, and is lazy (works on any kind of infinite traversable):

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 is a "lazy continuation applicative functor". If we replace it with the standard Cont monad, we also get a working solution, which is not lazy, however:

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 4

This doesn't really answer the original question, but it shows another angle. It looks like this question is actually tied rather deeply to a previous question I asked. Suppose that Traversable had an additional method:

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

Note: This method can actually be implemented legitimately for any concrete Traversable datatype. For oddities like

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

see the illegitimate ways in the answers to the linked question.

With that in place, we can design a type very similar to Roman's, but with a twist from rampion's:

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)

Now everything is dead 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)