xml.rkt (6400B)
1 #lang racket/base 2 3 ;; XML-like objects and functions, with rendering 4 5 (require scribble/text racket/port) 6 7 ;; ---------------------------------------------------------------------------- 8 ;; Represent attribute names as `foo:' symbols. They are made self-quoting in 9 ;; the language. A different option would be to use the usual racket keyword 10 ;; arguments, but that tends to have problems like disallowing repeated uses of 11 ;; the same keyword, sorting the keywords alphabetically, and ambiguity when 12 ;; some keywords are meant to do the usual thing (customize a function) instead 13 ;; of representing an attribute. It's more convenient to just have a separate 14 ;; mechanism for this, so racket keywords are still used in the same way, and 15 ;; orthogonal to specifying attributes. Another possibility is to have a new 16 ;; type, with `foo:' evaluating to instances -- but it's often convenient to 17 ;; pass them around as quoted lists. 18 19 (define attribute->symbol 20 (let ([t (make-weak-hasheq)]) 21 (lambda (x) 22 (and (symbol? x) 23 (hash-ref! t x 24 (lambda () 25 (define m (regexp-match #rx"^(.*):$" (symbol->string x))) 26 (and m (string->symbol (cadr m))))))))) 27 28 (provide attribute?) 29 (define attribute? attribute->symbol) 30 31 (provide attributes+body) 32 (define (attributes+body xs) 33 (let loop ([xs xs] [as '()]) 34 (define a (and (pair? xs) (attribute->symbol (car xs)))) 35 (cond [(not a) (values (reverse as) xs)] 36 [(null? (cdr xs)) (error 'attributes+body 37 "missing attribute value for `~s:'" a)] 38 [else (loop (cddr xs) (cons (cons a (cadr xs)) as))]))) 39 40 ;; similar, but keeps the attributes as a list, useful to build new functions 41 ;; that accept attributes without knowing about the xml structs. 42 (provide split-attributes+body) 43 (define (split-attributes+body xs) 44 (let loop ([xs xs] [as '()]) 45 (if (and (pair? xs) (pair? (cdr xs)) (attribute->symbol (car xs))) 46 (loop (cddr xs) (list* (cadr xs) (car xs) as)) 47 (values (reverse as) xs)))) 48 49 ;; ---------------------------------------------------------------------------- 50 ;; An output that handles xml quoting, customizable 51 52 ;; TODO: make this more conveniently customizable and extensible 53 (define (write-string/xml-quote str p [start 0] [end (string-length str)]) 54 (let loop ([start start]) 55 (when (< start end) 56 (define m (regexp-match-positions #rx"[&<>\"]" str start end p)) 57 (when m 58 (write-string (case (string-ref str (caar m)) 59 [(#\&) "&"] 60 [(#\<) "<"] 61 [(#\>) ">"] 62 [(#\") """]) 63 p) 64 (loop (cdar m)))))) 65 66 (provide xml-writer) 67 (define xml-writer (make-parameter write-string/xml-quote)) 68 69 (provide output-xml) 70 (define (output-xml content [p (current-output-port)]) 71 (output (disable-prefix (with-writer (xml-writer) content)) p)) 72 73 (provide xml->string) 74 (define (xml->string content) 75 (with-output-to-string (lambda () (output-xml content)))) 76 77 ;; ---------------------------------------------------------------------------- 78 ;; Structs for xml data: elements, literals, entities 79 80 (provide make-element) 81 (struct element (tag attrs body [cache #:auto #:mutable]) 82 #:constructor-name make-element 83 #:transparent #:omit-define-syntaxes #:auto-value #f 84 #:property prop:procedure 85 (lambda (e) 86 (unless (element-cache e) (set-element-cache! e (element->output e))) 87 (element-cache e))) 88 89 (provide element) 90 (define (element tag . args) 91 (define-values [attrs body] (attributes+body args)) 92 (make-element tag attrs body)) 93 94 ;; similar to element, but will always have a closing tag instead of using the 95 ;; short syntax (see also `element->output' below) 96 (provide element/not-empty) 97 (define (element/not-empty tag . args) 98 (define-values [attrs body] (attributes+body args)) 99 (make-element tag attrs (if (null? body) '(#f) body))) 100 101 ;; convert an element to something output-able 102 (define (element->output e) 103 (define tag (element-tag e)) 104 (define attrs (element-attrs e)) 105 (define body (element-body e)) 106 ;; null body means a lone tag, tags that should always have a closer will 107 ;; have a '(#f) as their body (see below) 108 (list (with-writer #f "<" tag) 109 (map (lambda (attr) 110 (define name (car attr)) 111 (define val (cdr attr)) 112 (cond [(not val) #f] 113 ;; #t means just mention the attribute 114 [(eq? #t val) (with-writer #f (list " " name))] 115 [else (list (with-writer #f (list " " name "=\"")) 116 val 117 (with-writer #f "\""))])) 118 attrs) 119 (if (null? body) 120 (with-writer #f " />") 121 (list (with-writer #f ">") 122 body 123 (with-writer #f "</" tag ">"))))) 124 125 ;; ---------------------------------------------------------------------------- 126 ;; Literals 127 128 ;; literal "struct" for things that are not escaped 129 (provide literal) 130 (define (literal . contents) (with-writer #f contents)) 131 132 ;; entities are implemented as literals 133 (provide entity) 134 (define (entity x) (literal "&" (and (number? x) "#") x ";")) 135 136 ;; comments and cdata 137 (provide comment) 138 (define (comment #:newlines? [newlines? #f] . body) 139 (define newline (and newlines? "\n")) 140 (literal "<!--" newline body newline "-->")) 141 (provide cdata) 142 (define (cdata #:newlines? [newlines? #t] #:line-prefix [pfx #f] . body) 143 (define newline (and newlines? "\n")) 144 (literal pfx "<![CDATA[" newline body newline pfx "]]>")) 145 146 ;; ---------------------------------------------------------------------------- 147 ;; Template definition forms 148 149 (provide define/provide-elements/empty 150 define/provide-elements/not-empty 151 define/provide-entities) 152 (define-syntax-rule (define/provide-elements/empty tag ...) 153 (begin (provide tag ...) 154 (define (tag . args) (apply element 'tag args)) ...)) 155 (define-syntax-rule (define/provide-elements/not-empty tag ...) 156 (begin (provide tag ...) 157 (define (tag . args) (apply element/not-empty 'tag args)) ...)) 158 (define-syntax-rule (define/provide-entities ent ...) 159 (begin (provide ent ...) 160 (define ent ; use string-append to make it a little faster 161 (literal (string-append "&" (symbol->string 'ent) ";"))) 162 ...))