5 Combining the Techniques of "Passing Parameters" and "Threading State"

It can be useful to combine the techniques of parameter passing and this monadic threading of state. To show how this can be done, I will add parameter-passing to this example. Suppose that instead of the depth-first labelling above, I want a label that consists of a pair of the depth-first label and an integer representing the "depth" of that XML node in the tree. I will add "depth" as a parameter which will be passed between xml-micros--while retaining the monad to construct the depth-first labelling.

In this example, invoking

(label/depth (h4:ul (h4:li "item 1") (h4:li "item 2")))

will result in:

((0 . 0) ((1 . 1) (2 . 2)) ((3 . 1) (4 . 2)))

where the first number in each pair is the depth-first label, as in the above example. But the second number in each pair is the "depth" of that node in the tree.

Recalling from Section I of this article, when parameters are passed between micros, the type of the xml-micro may be given as:

<micro> :: xml-node -> (parameters -> result)

Combining the passing of a "depth" parameter with the threading of a depth-first-label state, the type of the micro becomes:

<micro> :: xml-node -> (int -> (st -> Cons val st))

In other words, we pass an integer "depth" parameter around in the usual style, but the result is itself a function: from state to the pair of value and state.

No change to unit or bind are required, but I modify unit-label to take both an xml-node (the "value") and the depth parameter. It uses the depth parameter to construct the pair of depth-first-label + depth-level.

The call to xml-expand in the *element* micro is now passed a depth parameter:

((xml-expand ) depth)

The full code for example is given below.

(require (lib "xml.ss" "webit"))

(define label-ext-ss
  (stylesheet
    (define unit (lambda (v) (lambda (s) (values v s))))
    (define unit-label
      (lambda (v depth) (lambda (s) (values (cons s depth) (+ s 1)))))
    (define bind
      (lambda (m w) (lambda (s) (let-values (((a b) (m s))) ((w a) b)))))
    (xml-micro
      *element*
      (lambda (t)
        (lambda (depth)
          (letrec ((label-contents
                     (lambda (lst)
                       (cond
                        ((null? lst) (unit '()))
                        (else
                         (bind
                          ((xml-expand (car lst)) (+ depth 1))
                          (lambda (a)
                            (bind
                             (label-contents (cdr lst))
                             (lambda (d) (unit (cons a d)))))))))))
            (bind
             (unit-label (xml-element-tag t) depth)
             (lambda (a)
               (bind
                (label-contents (xml-element-contents t))
                (lambda (d) (unit (cons a d))))))))))
    (xml-micro *text* (lambda (t) (lambda (depth) (unit-label t depth))))
    (xml-micro *data* (lambda (t) (lambda (depth) (unit-label t depth))))))

(define traverse (stylesheet->expander label-ext-ss))

(define (label/depth t) (let-values (((res st) (((traverse t) 0) 0))) res))