4 An Example Transformation with Threaded State

I give a very simple application of this technique: given an XML tree, I construct a tree of s-expressions having the same "shape", but replacing the XML nodes with integers, representing a depth-first numbering of the XML nodes. An XML element is converted into a list whose head is the depth-first number of that element, and whose tail is a list of the depth-first labellings of its children nodes.

An fragment of HTML such as:

(h4:ul (h4:li "item 1") (h4:li "item 2"))

will be transformed into (0 (1 2) (3 4)).

To thread state between micros, we use a simple state monad, with three operations unit, unit-label, and bind.

The operations unit and unit-label have type:

unit :: val -> st -> (Cons val st))

Where unit simple packages up the given value and the (unchanged) state resulting from the computation it wraps, unit-label returns the values of the computation plus a new state. unit-label does the "real work" of labeling. It replaces the value it is given (an XML node) with a new depth-first label--the label in the currrent state. It then updates the state, adding 1 to the label counter. These are then packaged up with cons.

Bind has the type:

bind :: (st -> (Cons val st)) x (val -> st -> Cons val st)) ->  
            (st -> Cons val st)

Bind threads the value and state returned by the function "m" to the "next" function "w".

The micros themselves have type

<micro> :: node -> st -> Cons val st

The "real" work in this example is done by the *element* micro, which uses bind to sequence the depth-first traversal of this given element using bind. Because of the use of bind, calls to xml-expand appearing in this micro has the form (xml-expand <some-node>). It is bind which arranges to invoke the function returned by this micro with the threaded state.

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

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

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

We run the transformation by invoking the expander with an XML node and the initial state, the initial node number, 0.

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

Invoking

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

gives the expected result: (0 (1 2) (3 4)).