;; ;; MIT License ;; ;; Copyright (c) 2018 Thomas Chust ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to deal ;; in the Software without restriction, including without limitation the rights ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;; copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. ;; (define alist:js-escape '((#\' . #\') (#\" . #\") (#\\ . #\\) (#\backspace . #\b) (#\tab . #\t) (#\newline . #\n) (#\return . #\r))) (define char-set:no-js-escape (char-set-difference (char-set-union unicode-char-set:alphabetic char-set:digit char-set:punctuation char-set:symbol char-set:blank) (list->char-set (map car alist:js-escape)))) (define (write-js s #!optional [port (current-output-port)] [quotes #\"]) (let ([n (utf8-string-length s)]) (cond [quotes => (cut utf8-display <> port)]) (do ([i 0 (fx+ i 1)]) ((fx>= i n)) (let ([c (utf8-string-ref s i)]) (cond [(char-set-contains? char-set:no-js-escape c) (utf8-display c port)] [(assv c alist:js-escape) => (lambda (r) (utf8-display #\\ port) (utf8-display (cdr r) port))] [else (utf8-display "\\u" port) (utf8-display (string-pad (number->string (char->integer c) 16) 4 #\0) port)]))) (cond [quotes => (cut utf8-display <> port)]))) (define html-tag-rule (let ([tag-rules (make-hash-table eq? symbol-hash)]) (case-lambda [(tag) (hash-table-ref/default tag-rules tag 'normal)] [(tag rule) (cond [(not (memq rule '(void raw normal))) (error 'html-tag-rule "invalid tag rule" tag rule)] [(eq? rule 'normal) (hash-table-delete! tag-rules tag) (void)] [else (hash-table-set! tag-rules tag rule)])]))) (for-each (lambda (tag&rule) (html-tag-rule (car tag&rule) (cdr tag&rule))) '([area . void] [base . void] [br . void] [col . void] [command . void] [embed . void] [hr . void] [img . void] [input . void] [keygen . void] [link . void] [meta . void] [param . void] [source . void] [track . void] [wbr . void] [script . raw] [style . raw])) (define write-html (letrec ([write-escaped (lambda (s port) (let ([n (string-length s)]) (do ([i 0 (fx+ i 1)]) ((fx>= i n)) (let ([c (string-ref s i)]) (display (case c [(#\") """] [(#\&) "&"] [(#\<) "<"] [(#\>) ">"] [else c]) port)))))] [write-element (lambda (elt port) (unless (and (pair? elt) (symbol? (car elt)) (list? (cdr elt))) (error 'write-html "not a proper element" elt)) (let ([tag (car elt)] [attributes&contents (cdr elt)]) (when (eq? tag 'html) (display "" port) (newline port)) (let-values ([(rule) (html-tag-rule tag)] [(attributes contents) (if (and (not (eq? tag 'begin)) (pair? attributes&contents) (list? (car attributes&contents)) (every pair? (car attributes&contents))) (values (car attributes&contents) (cdr attributes&contents)) (values '() attributes&contents))]) (unless (eq? tag 'begin) (display #\< port) (display tag port) (for-each (cut write-attribute <> port) attributes) (display #\> port)) (case rule [(normal) (for-each (cut write-content #t <> port) contents)] [(raw) (for-each (cut write-content #f <> port) contents)] [(void) (unless (null? contents) (error 'write-html "void elements cannot have contents" elt))]) (unless (eq? tag 'begin) (case rule [(normal raw) (display " port)]))) (when (eq? tag 'html) (newline port))))] [write-attribute (lambda (attr port) (unless (and (pair? attr) (symbol? (car attr))) (error 'write-html "not a proper attribute" attr)) (let ([key (car attr)] [v (cdr attr)]) (cond [(not v) (void)] [(boolean? v) (display #\space port) (display key port)] [else (display #\space port) (display key port) (display "=\"" port) (if (list? v) (for-each (cut write-content #f <> port) v) (write-content #f v port)) (display #\" port)])))] [write-content (lambda (allow-elements? v port) (cond [(symbol? v) (display #\& port) (display v port) (display #\; port)] [(and (integer? v) (positive? v)) (display "&#" port) (display v port) (display #\; port)] [(string? v) (write-escaped v port)] [allow-elements? (write-element v port)] [else (error 'write-html "element not allowed in this context" v)]))]) (lambda (html #!optional [port (current-output-port)]) (write-element html port)))) ;; vim: set ai et ts=4 sts=2 sw=2 ft=scheme: ;;