webpage/include/ssxml.ss

(define (list->html-text lst)
  (let loop ((lst lst)
             (res #f))
    (cond
      ((null? lst) res)
      (else
       (let ((e (car lst)))
         (loop (cdr lst)
               (string-append
                 (if res res "")
                 (cond
                   ((list? e) (list->html-text e))
                   ((and (string? e) (not res)) e)
                   ((string? e)
                    (string-append
                      (if (char=? (string-ref e 0) #\<) "" " ")
                      e))
                   (else (format (if res " ~a" "~a") e))))))))))

(define (escape str)
  (let loop ((result "")
             (last-start 0)
             (cur 0))
    (if (>= cur (string-length str))
        (string-append result (substring str last-start cur))
        (let* ((ch (string-ref str cur))
               (entity (case ch
                         ((#\&) "&amp;")
                         ((#\<) "&lt;")
                         ((#\>) "&gt;")
                         ((#\") "&quot;")
                         ((#\') "&#x27;")
                         (else #f))))
          (if entity
              (loop (string-append
                      result
                      (substring str last-start cur)
                      entity)
                    (+ cur 1)
                    (+ cur 1))
              (loop result last-start (+ cur 1)))))))


(define (tag name is-void escape-needed)
  (lambda args
    (let loop ((attrs "")
               (content "")
               (attr #f)
               (args args))
      (cond
        ((null? args)
         (string-append
           "<"name attrs
           (if attr
               (string-append "=\""(symbol->string attr)"\"")
               "")
             (if is-void
                 " />"
                 (string-append
                   ">"
                   (if (zero? (string-length content))
                       ""
                       (if escape-needed (escape content) content))
                   "</"name">"))))
        ((symbol? (car args))
         (loop (string-append
                 attrs
                 (if attr
                     (string-append "=\""(symbol->string attr)"\" ")
                     " ")
                 (symbol->string (car args)))
               content
               (car args)
               (cdr args)))
        (attr
         (loop (string-append
                 attrs"=\""
                 (escape
                   (let ((cattr (car args)))
                     (if (list? cattr)
                         (apply string-append cattr)
                         cattr)))
                 "\"")
               content
               #f
               (cdr args)))
        (is-void
         (error "tag" (string-append "<"name attrs" />: That is void-tag, it can't have any children")))
        (else
         (loop attrs
               (string-append
                 content
                 (if (and (not (string=? content ""))
                          (not (char=? #\> (string-ref content (- (string-length content) 1)))))
                     " "
                     "")
                 (list->html-text (list (car args))))
               #f
               (cdr args)))))))

(define-syntax html-tag
  (lambda (stx)
    (syntax-case stx ()
      ((_ name)
       (let ((name* (datum->syntax #'name
                      (string->symbol
                        (string-append (symbol->string (syntax->datum #'name)) "*")))))
         #`(begin
             (define name  (tag (symbol->string 'name) #f #f))
             (define #,name* (tag (symbol->string 'name) #f #t))))))))

(define-syntax html-tags 
  (syntax-rules ()
    ((_ name ...)
     (begin (html-tag name) ...))))

(define-syntax html-tags-void
  (syntax-rules ()
    ((_ name ...)
     (begin (define name (tag (symbol->string 'name) #t #f)) ...))))

(html-tags
  html body head title style details summary marquee textarea
  p a i b h1 h2 h3 h4 h5 h6 sup sub div span section ul li ol
  main footer header nav canvas button form script noscript
  table tr td th tbody caption q s pre code label center font)

(html-tags-void
  link meta img input br hr wbr)

(define (comment . content)
  (string-append
    "<!--"
    (list->html-text (map escape content))
    " -->"))

;; those tags are mostly used without any attributes
(define br/ "<br />")
(define hr/ "<hr />")
(define wbr/ "<wbr />")

(define (!html . content)
  (display
    (string-append "<!DOCTYPE html>"
      (apply html `(,(comment "this HTML document was generated by SSXML library") ,@content)))))

(define (!xhtml . content)
  (display
    (string-append
      "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\""
                           " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
      (apply html `(xmlns "http://www.w3.org/1999/xhtml"
        ,(comment "this XHTML document was generated by SSXML library")
        ,@content)))))

(define (list->html-list lst)
  (ul
    (map (lambda (e)
           (li
             (if (list? e)
                 (list->html-list e)
                 e)))
         lst)))

(define (html-list . content)
  (list->html-list content))

(define (map-tag tag content)
  (map (lambda (c) (apply tag c)) content))

(define (html-list* . content)
  (apply html-list (map escape content)))