Part II

Example: A Namespace-aware XML Serializer

This part presents another example of passing parameters between micros: a serializer for XML. This is a deliberately "stylized" example, in that the serializer only works on elements and PCDATA. But this is enough to illustrate passing an "environment" of namespace prefix bindings between micros.

I use exactly the same technique as in Section I. The type of the micros in this example can be given as:

<micro> :: xml-node -> (namespace-env -> void)

I could have passed a port as an additional parameter, but instead, I include the stylesheet within the body of serialize, scoping the port over the whole stylesheet.

To keep things simple, if an element or attribute tag is part of a namespace, but no prefix is bound for that namespace, an error is signalled.

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

; print a qualified name or local name, as required

(define (write-resolved-name key tag namespaces port)
  (let ((binding (assoc key namespaces)))
    (cond
     ((and key (not binding))
      (error "serialize: no namespace prefix declared for" key))
     ((and binding (cdr binding) (not (eq? (cdr binding) '_)))
      (display (format "~a:~a" (cdr binding) tag) port))
     (else (display tag port)))))

; print an attribute, using write-resolved name to display
; the correct namespace prefix, if needed.

(define (write-attribute attr active-ns port)
  (display " " port)
  (write-resolved-name
    (xml-attribute-target-ns attr)
    (xml-attribute-print-tag attr)
    active-ns
    port)
  (display "=" port)
  (display (format "\"~a\"" (xml-attribute-value attr)) port))

; print namespace declarations. #f or the symbol _ designate a
; declaration of a default namespace

(define (write-ns-decl pre url port)
  (display " " port)
  (if (and pre (not (eq? pre '_)))
    (display (format "~a:~a" 'xmlns pre) port)
    (display "xmlns" port))
  (display "=" port)
  (write (symbol->string url) port))

; extend the namespace environment with any declarations 
; given by this element

(define (extend-namespaces node namespaces)
  (append
    (map
     (lambda (b) (cons (xml-ns-binding-ns-url b) (xml-ns-binding-prefix b)))
     (xml-element-ns-list node))
    namespaces))

; The *element* micro prints elements with no children as empty-elements
; serialize calls the expander with the node and an empty list of 
; namespace bindings

(define serialize
  (opt-lambda
    (node (port (current-output-port)))
    (let ((expand
            (stylesheet->expander
              (stylesheet
                (xml-micro
                  *element*
                  (lambda (node)
                    (lambda (namespaces)
                      (let ((active-namespaces
                              (extend-namespaces node namespaces)))
                        (display "<" port)
                        (write-resolved-name
                          (xml-element-target-ns node)
                          (xml-element-print-tag node)
                          active-namespaces
                          port)
                        (for-each
                          (lambda (attr)
                            (write-attribute attr active-namespaces port))
                          (xml-element-attributes node))
                        (for-each
                          (lambda (ns)
                            (write-ns-decl
                              (xml-ns-binding-prefix ns)
                              (xml-ns-binding-ns-url ns)
                              port))
                          (xml-element-ns-list node))
                        (if (null? (xml-element-contents node))
                          (display "/>" port)
                          (begin
                            (display ">" port)
                            (for-each
                              (lambda (node)
                                ((xml-expand node) active-namespaces))
                              (xml-element-contents node))
                            (display " port)
                            (write-resolved-name
                              (xml-element-target-ns node)
                              (xml-element-print-tag node)
                              active-namespaces
                              port)
                            (display ">" port)))))))
                (xml-micro
                  *text*
                  (lambda (node)
                    (lambda (namespaces)
                      (display (pcdata->string node) port))))))))
      ((expand node) '())
      (newline))))

; example with the HTML namespace declared as the default namespace

(serialize
  (bind-namespaces
    ((_ html-ns-url))
    (h4:p "This is an example, with a " (h4:a h4:href: "url" "link") ".")))

; example with the HTML namespace bound to the prefix "html"

(serialize
  (bind-namespaces
    ((html html-ns-url))
    (h4:p "This is an example, with a " (h4:a h4:href: "url" "link") ".")))