Apply labels from a stream to a Bitraversable Labelling Traversable containers is an ancient and honorable test of skill. My task here is to create a generic labelling mechanism for a Bitraversable, such as a tuple, or a graph with vertex and edge labels.

bilabelWith
    :: Bitraversable t
    =&gt; (l -&gt;  indexl -&gt; l') -&gt; (r -&gt;  indexr -&gt; r')
    -&gt; Stream indexl        -&gt; Stream indexr
    -&gt; t l r -&gt; t l' r'
bilabelWith f g xs ys =
  let labelLeft  = fmap (withStateLens fst (\(_, y) x' -&gt; (x', y))) (labelOneWith f)
      labelRight = fmap (withStateLens snd (\(x, _) y' -&gt; (x, y'))) (labelOneWith g)
  in flip evalState (xs, ys) . bitraverse labelLeft labelRight

labelOneWith :: (a -&gt; index -&gt; b) -&gt; a -&gt; State (Stream index) b
labelOneWith f u = do
    (Stream.Cons x xs) &lt;- get
    put xs
    return (f u x)

withStateLens :: (s -&gt; t) -&gt; (s -&gt; t -&gt; s) -&gt; State t a -&gt; State s a
withStateLens thrust merge u = do
    s &lt;- get
    let t = thrust s
    let (r, t') = runState u t
    put (merge s t')
    return r


&nbsp;

Here is how it may be applied:

λ bilabelWith (+) (*) (Stream.fromList [2]) (Stream.fromList [3]) (5, 7)
(7,21)


A more complicated example requires us to obtain a Bitraversable graph.

circular :: (DynGraph gr, Bitraversable gr) =&gt; gr a b -&gt; gr (V2 Double, a) b
circular gr =
  let n = fromIntegral (Graph.noNodes gr)
      coords =
        let alpha = (pi * 2 / n)
        in Stream.prefix [ 0.8 * V2 (sin (alpha * i)) (cos (alpha * i)) | i &lt;- [1.. n] ]
            $ error "circular: Impossible error: not enough coordinates to label all points."
  in bilabelWith (flip (,)) const coords (Stream.repeat ()) gr


&nbsp;

Does this code make sense? Is there anything to make more compact or clarify?
The fmap in labelLeft should be (.). Control.Lens.Zoom provides something like withStateLens. Inline definitions that are only used once.

bilabelWith
    :: Bitraversable t
    =&gt; (l -&gt;  indexl -&gt; l') -&gt; (r -&gt;  indexr -&gt; r')
    -&gt; Stream indexl        -&gt; Stream indexr
    -&gt; t l r -&gt; t l' r'
bilabelWith f g xs ys = flip evalState (xs, ys) .
  bitraverse (zoom _1 . pops . f) (zoom _2 . pops . g)

pops :: (s -&gt; a) -&gt; State (Stream s) a
pops = flip fmap $ state $ \(Stream.Cons x xs) -&gt; (x, xs)