130 lines
4.8 KiB
Scheme
130 lines
4.8 KiB
Scheme
|
|
;;(define empty-tag-shorthand (make-parameter #t))
|
|
;;(define empty-tag-shorthand (make-parameter void))
|
|
|
|
;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
|
|
(define empty-tag-shorthand (make-parameter 'always))
|
|
|
|
(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)
|
|
(var-argify (lambda (c out) (write-xml-content c 0 dent out))))
|
|
|
|
;; 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)
|
|
(display-outside-misc (prolog-misc (document-prolog doc)) out)
|
|
(output-content (document-element doc) out)
|
|
(display-outside-misc (document-misc doc) out))))
|
|
|
|
;; 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)
|
|
((pi? x) write-xml-pi)) x 0 void out)
|
|
(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))
|
|
'(< > &)
|
|
'("<" ">" "&")))
|
|
|
|
(define escape-attribute-table
|
|
(list* (cons (regexp "'") "'") (cons (regexp "\"") """) 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))
|