sunet/scheme/xml/writer.scm

156 lines
5.6 KiB
Scheme
Raw Normal View History

2001-10-29 03:48:42 -05:00
;;(define empty-tag-shorthand (make-parameter #t))
;;(define empty-tag-shorthand (make-parameter void))
;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
2001-12-14 09:09:35 -05:00
(define empty-tag-shorthand
(make-parameter 'always
(lambda (x)
(if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
x
(error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~a" x)))))
2001-10-29 03:48:42 -05:00
(define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
;; var-argify : (a Output-port -> b) -> (a [Output-port] -> b)
(define (var-argify f)
(lambda (x . maybe-port)
(f x (if (null? maybe-port)
(current-output-port)
(car maybe-port)))))
;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
(define (gen-write/display-xml/content dent)
2001-12-14 09:09:35 -05:00
(var-argify (lambda (c out)
(write-xml-content c 0 dent out))))
2001-10-29 03:48:42 -05:00
;; indent : Nat Output-port -> Void
(define (indent n out)
(newline out)
(let loop ((n n))
(unless (zero? n)
(display #\space out)
(loop (sub1 n)))))
;; write-xml/content : Content [Output-port] -> Void
(define write-xml/content (gen-write/display-xml/content void))
;; display-xml/content : Content [Output-port] -> Void
(define display-xml/content (gen-write/display-xml/content indent))
;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
(define (gen-write/display-xml output-content)
(var-argify (lambda (doc out)
2001-12-14 09:09:35 -05:00
(let ((prolog (document-prolog doc)))
(display-outside-misc (prolog-misc prolog) out)
(display-dtd (prolog-dtd prolog) out)
(display-outside-misc (prolog-misc2 prolog) out))
(output-content (document-element doc) out)
(display-outside-misc (document-misc doc) out))))
; display-dtd : document-type oport -> void
(define (display-dtd dtd out)
(when dtd
(fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
(let ((external (document-type-external dtd)))
(cond
((external-dtd/public? external)
(fprintf out " PUBLIC \"~a\" \"~a\""
(external-dtd/public-public external)
(external-dtd-system external)))
((external-dtd/system? external)
(fprintf out " SYSTEM \"~a\"" (external-dtd-system external)))
((not external) (void))))
(display ">" out)
(newline out)))
2001-10-29 03:48:42 -05:00
;; write-xml : Document [Output-port] -> Void
(define write-xml (gen-write/display-xml write-xml/content))
;; display-xml : Document [Output-port] -> Void
(define display-xml (gen-write/display-xml display-xml/content))
;; display-outside-misc : (listof Misc) Output-port -> Void
(define (display-outside-misc misc out)
(for-each (lambda (x)
((cond
((comment? x) write-xml-comment)
2001-12-14 09:09:35 -05:00
((pi? x) write-xml-pi)
(else (error "bottom " x))) x 0 void out)
2001-10-29 03:48:42 -05:00
(newline out))
misc))
;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-content el over dent out)
((cond
((element? el) write-xml-element)
((pcdata? el) write-xml-pcdata)
((entity? el) write-xml-entity)
((comment? el) write-xml-comment)
((pi? el) write-xml-pi)
(else (error 'write-xml-content "received ~a" el)))
el over dent out))
;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-element el over dent out)
(let* ((name (element-name el))
(start (lambda (f) (write-xml-base (format f name) over dent out)))
(content (element-content el)))
(start "<~a")
(for-each (lambda (att)
(fprintf out " ~s=~s" (attribute-name att)
(escape (attribute-value att) escape-attribute-table)))
(element-attributes el))
(if (and (null? content)
(let ((short (empty-tag-shorthand)))
(case short
((always) #t)
((never) #f)
(else (memq name short)))))
(fprintf out " />")
(begin
(fprintf out ">")
(for-each (lambda (c) (write-xml-content c (incr over) dent out)) content)
(start "</~a")
(fprintf out ">")))))
;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-base el over dent out)
(dent over out)
(display el out))
;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-pcdata str over dent out)
(write-xml-base (escape (pcdata-string str) escape-table) over dent out))
;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-pi pi over dent out)
(write-xml-base (format "<?~a ~a?>" (pi-target-name pi) (pi-instruction pi)) over dent out))
;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-comment comment over dent out)
(write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
(define (write-xml-entity entity over dent out)
(let ((n (entity-text entity)))
(fprintf out (if (number? n) "&#~a;" "&~a;") n)))
(define escape-table
(map (lambda (x y) (cons (regexp (symbol->string x)) y))
'(< > &)
'("&lt;" "&gt;" "&amp;")))
(define escape-attribute-table
(list* (cons (regexp "'") "&apos;") (cons (regexp "\"") "&quot;") escape-table))
;; escape : String -> String
;; more here - this could be much more efficient
(define (escape x table)
(foldr (lambda (esc str) (regexp-replace* (car esc) str (cdr esc)))
x
table))
;; incr : Nat -> Nat
(define (incr n) (+ n 2))