ssxml.ss (5372B)
1 (define (list->html-text lst) 2 (let loop ((lst lst) 3 (res #f)) 4 (cond 5 ((null? lst) res) 6 (else 7 (let ((e (car lst))) 8 (loop (cdr lst) 9 (string-append 10 (if res res "") 11 (cond 12 ((list? e) (list->html-text e)) 13 ((and (string? e) (not res)) e) 14 ((string? e) 15 (string-append 16 (if (char=? (string-ref e 0) #\<) "" " ") 17 e)) 18 (else (format (if res " ~a" "~a") e)))))))))) 19 20 (define (escape str) 21 (let loop ((result "") 22 (last-start 0) 23 (cur 0)) 24 (if (>= cur (string-length str)) 25 (string-append result (substring str last-start cur)) 26 (let* ((ch (string-ref str cur)) 27 (entity (case ch 28 ((#\&) "&") 29 ((#\<) "<") 30 ((#\>) ">") 31 ((#\") """) 32 ((#\') "'") 33 (else #f)))) 34 (if entity 35 (loop (string-append 36 result 37 (substring str last-start cur) 38 entity) 39 (+ cur 1) 40 (+ cur 1)) 41 (loop result last-start (+ cur 1))))))) 42 43 44 (define (tag name is-void escape-needed) 45 (lambda args 46 (let loop ((attrs "") 47 (content "") 48 (attr #f) 49 (args args)) 50 (cond 51 ((null? args) 52 (string-append 53 "<"name attrs 54 (if attr 55 (string-append "=\""(symbol->string attr)"\"") 56 "") 57 (if is-void 58 " />" 59 (string-append 60 ">" 61 (if (zero? (string-length content)) 62 "" 63 (if escape-needed (escape content) content)) 64 "</"name">")))) 65 ((symbol? (car args)) 66 (loop (string-append 67 attrs 68 (if attr 69 (string-append "=\""(symbol->string attr)"\" ") 70 " ") 71 (symbol->string (car args))) 72 content 73 (car args) 74 (cdr args))) 75 (attr 76 (loop (string-append 77 attrs"=\"" 78 (escape 79 (let ((cattr (car args))) 80 (if (list? cattr) 81 (apply string-append cattr) 82 cattr))) 83 "\"") 84 content 85 #f 86 (cdr args))) 87 (is-void 88 (error "tag" (string-append "<"name attrs" />: That is void-tag, it can't have any children"))) 89 (else 90 (loop attrs 91 (string-append 92 content 93 (if (and (not (string=? content "")) 94 (not (char=? #\> (string-ref content (- (string-length content) 1))))) 95 " " 96 "") 97 (list->html-text (list (car args)))) 98 #f 99 (cdr args))))))) 100 101 (define-syntax html-tag 102 (lambda (stx) 103 (syntax-case stx () 104 ((_ name) 105 (let ((name* (datum->syntax #'name 106 (string->symbol 107 (string-append (symbol->string (syntax->datum #'name)) "*"))))) 108 #`(begin 109 (define name (tag (symbol->string 'name) #f #f)) 110 (define #,name* (tag (symbol->string 'name) #f #t)))))))) 111 112 (define-syntax html-tags 113 (syntax-rules () 114 ((_ name ...) 115 (begin (html-tag name) ...)))) 116 117 (define-syntax html-tags-void 118 (syntax-rules () 119 ((_ name ...) 120 (begin (define name (tag (symbol->string 'name) #t #f)) ...)))) 121 122 (html-tags 123 html body head title style details summary marquee textarea 124 p a i b h1 h2 h3 h4 h5 h6 sup sub div span section ul li ol 125 main footer header nav canvas button form script noscript 126 table tr td th tbody caption q s pre code label center font) 127 128 (html-tags-void 129 link meta img input br hr wbr) 130 131 (define (comment . content) 132 (string-append 133 "<!--" 134 (list->html-text (map escape content)) 135 " -->")) 136 137 ;; those tags are mostly used without any attributes 138 (define br/ "<br />") 139 (define hr/ "<hr />") 140 (define wbr/ "<wbr />") 141 142 (define (!html . content) 143 (display 144 (string-append "<!DOCTYPE html>" 145 (apply html `(,(comment "this HTML document was generated by SSXML library") ,@content))))) 146 147 (define (!xhtml . content) 148 (display 149 (string-append 150 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 151 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"" 152 " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" 153 (apply html `(xmlns "http://www.w3.org/1999/xhtml" 154 ,(comment "this XHTML document was generated by SSXML library") 155 ,@content))))) 156 157 (define (list->html-list lst) 158 (ul 159 (map (lambda (e) 160 (li 161 (if (list? e) 162 (list->html-list e) 163 e))) 164 lst))) 165 166 (define (html-list . content) 167 (list->html-list content)) 168 169 (define (map-tag tag content) 170 (map (lambda (c) (apply tag c)) content)) 171 172 (define (html-list* . content) 173 (apply html-list (map escape content)))