SXML list vs vector

xsd.scm

(use-modules
 (ice-9 format)
 (ice-9 match)
 ((ice-9 pretty-print) #:select ((pretty-print . pp)))
 (srfi srfi-1)
 (sxml simple)
 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; {abstract Namespace for XMLSchema}
(define sxml:xsd-namespace '(xsd . "http://www.w3.org/2001/XMLSchema"))

(define (sxml:load-xsd-file file-name . namespaces)
  (call-with-input-file file-name
    (lambda (port)
      (xml->sxml port
                 #:namespaces
                 (cons sxml:xsd-namespace namespaces)))))

(define (sxml:call-with-root-element sxml proc)
  (proc (match sxml
          (('*TOP* ('*PI* 'xml decl) root) root)
          (root root))))

(define (sxml:return x) x)

;; {abstract Predicate for a SXML element.}
(define (sxml:element? node)
  (and (pair? node)
       (symbol? (car node))))

;; {abstract Predicate for a SXML attribute list.}
(define (sxml:attributes? node)
  (and (pair? node)
       (eqv? '@ (car node))))

;; {abstract Predicate for a SXML text.}
(define sxml:text? string?)

;; {abstract Create a normalized SXML element.}
;; Normalization means, that {argument attributes} and {argument
;; children} are omitted in the SXML element, if they are null.
;; {scheme (sxml-element 'name '((a . 1)) (list (sxml-element 'a '() '())))}
(define (sxml:element tag attributes children)
  (if (null? attributes)
      (cons tag children)
      (cons tag (cons (cons '@ attributes) children))))

;; {abstract Destructure a SXML element and call {argument proc} with
;; the arguments {code name}, {code arguments} and {code children}.}
;; Destructuring means, that if {code arguments} and {code children}
;; are missing the the SXML element, {argument proc} gets called with
;; empty lists.
;; {returns The function returns the result of {code proc}.  If the
;; {argument node} is no element, the argument gets returned without
;; calling {argument proc}.}
(define (sxml:call-with-element node proc)
  (if (sxml:element? node)
      (let ((name (car node))
            (rest (cdr node)))
        (if (pair? rest)
            (let ((maybe-attributes (car rest)))
              (if (sxml:attributes? maybe-attributes)
                  (proc name (cdr maybe-attributes) (cdr rest))
                  (proc name '() rest)))
            (proc name '() '())))
      node))

;; {abstract Macro for simple destructuring.}
;; Emacs definition for the macro:\nl
;; {elisp (scheme-add-keywords '((1 . sxml:let)))}
(define-syntax sxml:let
  (syntax-rules ()
    ((_ ((name attributes children) element) . exps)
     (sxml:call-with-element element (lambda (name attributes children) . exps)))))

;; {abstract Traverse the {argument element} and execute {argument
;; pre-proc} on all child elements before the child elements are
;; visited and call {argument post-proc} on the element after the
;; child elements have been visited.}
(define (sxml:traverse element pre-proc post-proc)
  (let ((post-proc (or post-proc sxml:element)))
    (let traverse ((element element))
      (sxml:let ((name attributes children) element)
        (let ((children (if pre-proc (pre-proc children) children)))
          (post-proc name attributes (map-in-order traverse children)))))))

(define (sxml:traverse-pre element proc)
  (sxml:traverse element proc #f))

(define (sxml:traverse-post element proc)
  (sxml:traverse element #f proc))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (vxml:element name attributes children)
  (vector name attributes children))

(define vxml:element? vector?)

#;(define (vxml:element? node)
  (and (vector? node)
       (= 3 (vector-length node))))

(define (vxml:element-name element)
  (vector-ref element 0))

(define (vxml:element-attributes element)
  (vector-ref element 1))

(define (vxml:element-children element)
  (vector-ref element 2))

(define (sxml->vxml element)
  (sxml:traverse-post element vxml:element))

(define (vxml:call-with-element node proc)
  (if (vxml:element? node)
      (proc (vxml:element-name node)
            (vxml:element-attributes node)
            (vxml:element-children node))
      node))

;; {elisp (scheme-add-keywords '((1 . vxml:let)))}
(define-syntax vxml:let
  (syntax-rules ()
    ((_ ((name attributes children) node) . exps)
     (vxml:call-with-element node (lambda (name attributes children) . exps)))))

(define (vxml:traverse element pre-proc post-proc)
  (let ((post-proc (or post-proc vxml:element)))
    (let traverse ((element element))
      (vxml:let ((name attributes children) element)
        (let ((children (if pre-proc (pre-proc children) children)))
          (post-proc name attributes (map-in-order traverse children)))))))

(define (vxml:traverse-pre element proc)
  (vxml:traverse element proc #f))

(define (vxml:traverse-post element proc)
  (vxml:traverse element #f proc))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define xcb (sxml:call-with-root-element
             (sxml:load-xsd-file "xcb.xsd")
             sxml:return))

(define (string:whitespace? str)
  (and (string? str)
       (string-every char-whitespace? str)))

(define (remove-whitespace l)
  (remove string:whitespace? l))

(define (make-measurer)
  (let ((run-time 0))
    (lambda args
      (if (null? args)
          (/ run-time internal-time-units-per-second)
          (let ((t0 (get-internal-run-time)))
            (let ((value ((car args))))
              (let ((t1 (get-internal-run-time)))
                (set! run-time (+ run-time (- t1 t0)))
                value)))))))

(define (make-repeater n)
  (lambda (proc)
    (do ((i 1 (1+ i)))
        ((> i n))
      (proc))))

(let ((sxml (make-measurer))
      (vxml (make-measurer))
      (repeat (make-repeater 50000)))
  (repeat (lambda ()
            (sxml (lambda ()
                    (sxml->vxml (sxml:traverse-pre xcb remove-whitespace))))
            (vxml (lambda ()
                    (vxml:traverse-pre (sxml->vxml xcb) remove-whitespace)))))
  (format #t "~{~a: ~1,2f seconds~%~}"
          (list "list" (sxml)
                "vector" (vxml))))