Adding efficient Xexpr writing

collects/web-server/http/xexpr.rkt

@@ -16,12 +16,13 @@
          #:cookies [cooks empty]
          #:headers [hdrs empty]
          #:preamble [preamble #""])
-  (response/full 
+  (response
    code message seconds mime-type 
    ; rfc2109 also recommends some cache-control stuff here for cookies
    (append hdrs (map cookie->header cooks))
-   ; XXX Use a normal response and an efficient xexpr printer
-   (list preamble (string->bytes/utf-8 (xexpr->string xexpr)))))
+   (λ (out)
+     (write-bytes preamble out)
+     (write-xexpr xexpr out))))
 
 (provide/contract
  [response/xexpr 

collects/xml/private/writer.rkt

@@ -165,5 +165,11 @@
 (define (escape x table)
   (regexp-replace* table x replace-escaped))
 
+(provide escape
+         escape-table
+         escape-attribute-table
+         lowercase-symbol
+         write-xml-element)
+
 ;; incr : Nat -> Nat
 (define (incr n) (+ n 2))

collects/xml/private/xexpr.rkt

@@ -1,5 +1,7 @@
-#lang racket
+#lang racket/base
 (require racket/pretty
+         racket/list
+         racket/contract
          "structures.rkt"
          "reader.rkt"
          "writer.rkt")
@@ -249,5 +251,53 @@
  [xml->xexpr (content/c . -> . xexpr/c)]
  [xexpr->xml (xexpr/c . -> . content/c)]
  [xexpr-drop-empty-attributes (parameter/c boolean?)]
+ [write-xexpr (->* (xexpr/c) (output-port?) void)] 
  [validate-xexpr (any/c . -> . (one-of/c #t))]
  [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)])
+
+(define (write-xexpr x [out (current-output-port)])
+  (cond
+    ; Element
+    [(cons? x)
+     (define name (car x))
+     (define-values (attrs content)
+       (if (and (pair? (cdr x))
+                (or (null? (cadr x))
+                    (and (pair? (cadr x)) (pair? (caadr x)))))
+           (values (cadr x) (cddr x))
+           (values null (cdr x))))
+     ; Write opening tag
+     (display "<" out)
+     (display name out)
+     ; Write attributes
+     (for ([att (in-list attrs)])
+       (fprintf out " ~a=\"~a\"" (car att)
+                (escape (cadr att) escape-attribute-table)))
+     ; Write end of opening tag
+     (if (and (null? content)
+              (let ([short (empty-tag-shorthand)])
+                (case short
+                  [(always) #t]
+                  [(never) #f]
+                  [else (memq (lowercase-symbol name) short)])))
+         (display " />" out)
+         (begin
+           (display ">" out)
+           ; Write body
+           (for ([xe (in-list content)])
+             (write-xexpr xe out))
+           ; Write closing tag
+           (display "</" out)
+           (display name out)
+           (display ">" out)))]
+    ; PCData
+    [(string? x)
+     (display (escape x escape-table) out)]
+    ; Entities
+    [(symbol? x)
+     (fprintf out "&~a;" x)]
+    [(exact-nonnegative-integer? x)
+     (fprintf out "&#~a;" x)]
+    ; Embedded XML
+    [(source? x)
+     (write-xml-element x 0 void out)]))

collects/xml/xml.rkt

@@ -2,7 +2,12 @@
 (require "private/structures.rkt"
          "private/reader.rkt"
          "private/space.rkt"
-         "private/writer.rkt"
+         (except-in "private/writer.rkt"
+                    escape
+                    escape-table
+                    escape-attribute-table
+                    lowercase-symbol
+                    write-xml-element)
          "private/xexpr.rkt"
          "private/syntax.rkt")
 

collects/xml/xml.scrbl

@@ -242,6 +242,13 @@ Like @racket[write-xml/content], but with indentation and newlines
 like @racket[display-xml].}
                
 
+@defproc[(write-xexpr [xe xexpr/c] [out output-port? (current-output-port)])
+         void?]{
+
+Writes an X-expression to the given output port, without using an intermediate
+XML document.}
+
+
 @; ----------------------------------------------------------------------
 
 @section{XML and X-expression Conversions}