path: root/web/sxml.scm

;;; Copyright © 2016, 2017  Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015  David Thompson <davet@gnu.org>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
;;; as published by the Free Software Foundation, either version 3 of
;;; the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; SXML to HTML conversion.
;;
;;; Code:

(define-module (web sxml)
  #:use-module (sxml simple)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 hash-table)
  #:export (sxml->html))

(define %self-closing-tags
  '(area
    base
    br
    col
    command
    embed
    hr
    img
    input
    keygen
    link
    meta
    param
    source
    track
    wbr))

(define (self-closing-tag? tag)
  "Return #t if TAG is self-closing."
  (pair? (memq tag %self-closing-tags)))

(define %escape-chars
  (alist->hash-table
   '((#\" . "quot")
     (#\& . "amp")
     (#\' . "apos")
     (#\< . "lt")
     (#\> . "gt")
     (#\¡ . "iexcl")
     (#\¢ . "cent")
     (#\£ . "pound")
     (#\¤ . "curren")
     (#\¥ . "yen")
     (#\¦ . "brvbar")
     (#\§ . "sect")
     (#\¨ . "uml")
     (#\© . "copy")
     (#\ª . "ordf")
     (#\« . "laquo")
     (#\¬ . "not")
     (#\® . "reg")
     (#\¯ . "macr")
     (#\° . "deg")
     (#\± . "plusmn")
     (#\² . "sup2")
     (#\³ . "sup3")
     (#\´ . "acute")
     (#\µ . "micro")
     (#\¶ . "para")
     (#\· . "middot")
     (#\¸ . "cedil")
     (#\¹ . "sup1")
     (#\º . "ordm")
     (#\» . "raquo")
     (#\¼ . "frac14")
     (#\½ . "frac12")
     (#\¾ . "frac34")
     (#\¿ . "iquest")
     (#\À . "Agrave")
     (#\Á . "Aacute")
     (#\Â . "Acirc")
     (#\Ã . "Atilde")
     (#\Ä . "Auml")
     (#\Å . "Aring")
     (#\Æ . "AElig")
     (#\Ç . "Ccedil")
     (#\È . "Egrave")
     (#\É . "Eacute")
     (#\Ê . "Ecirc")
     (#\Ë . "Euml")
     (#\Ì . "Igrave")
     (#\Í . "Iacute")
     (#\Î . "Icirc")
     (#\Ï . "Iuml")
     (#\Ð . "ETH")
     (#\Ñ . "Ntilde")
     (#\Ò . "Ograve")
     (#\Ó . "Oacute")
     (#\Ô . "Ocirc")
     (#\Õ . "Otilde")
     (#\Ö . "Ouml")
     (#\× . "times")
     (#\Ø . "Oslash")
     (#\Ù . "Ugrave")
     (#\Ú . "Uacute")
     (#\Û . "Ucirc")
     (#\Ü . "Uuml")
     (#\Ý . "Yacute")
     (#\Þ . "THORN")
     (#\ß . "szlig")
     (#\à . "agrave")
     (#\á . "aacute")
     (#\â . "acirc")
     (#\ã . "atilde")
     (#\ä . "auml")
     (#\å . "aring")
     (#\æ . "aelig")
     (#\ç . "ccedil")
     (#\è . "egrave")
     (#\é . "eacute")
     (#\ê . "ecirc")
     (#\ë . "euml")
     (#\ì . "igrave")
     (#\í . "iacute")
     (#\î . "icirc")
     (#\ï . "iuml")
     (#\ð . "eth")
     (#\ñ . "ntilde")
     (#\ò . "ograve")
     (#\ó . "oacute")
     (#\ô . "ocirc")
     (#\õ . "otilde")
     (#\ö . "ouml")
     (#\÷ . "divide")
     (#\ø . "oslash")
     (#\ù . "ugrave")
     (#\ú . "uacute")
     (#\û . "ucirc")
     (#\ü . "uuml")
     (#\ý . "yacute")
     (#\þ . "thorn")
     (#\ÿ . "yuml")
     (#\Π. "OElig")
     (#\œ . "oelig")
     (#\Š . "Scaron")
     (#\š . "scaron")
     (#\Ÿ . "Yuml")
     (#\ƒ . "fnof")
     (#\ˆ . "circ")
     (#\˜ . "tilde")
     (#\Α . "Alpha")
     (#\Β . "Beta")
     (#\Γ . "Gamma")
     (#\Δ . "Delta")
     (#\Ε . "Epsilon")
     (#\Ζ . "Zeta")
     (#\Η . "Eta")
     (#\Θ . "Theta")
     (#\Ι . "Iota")
     (#\Κ . "Kappa")
     (#\Λ . "Lambda")
     (#\Μ . "Mu")
     (#\Ν . "Nu")
     (#\Ξ . "Xi")
     (#\Ο . "Omicron")
     (#\Π . "Pi")
     (#\Ρ . "Rho")
     (#\Σ . "Sigma")
     (#\Τ . "Tau")
     (#\Υ . "Upsilon")
     (#\Φ . "Phi")
     (#\Χ . "Chi")
     (#\Ψ . "Psi")
     (#\Ω . "Omega")
     (#\α . "alpha")
     (#\β . "beta")
     (#\γ . "gamma")
     (#\δ . "delta")
     (#\ε . "epsilon")
     (#\ζ . "zeta")
     (#\η . "eta")
     (#\θ . "theta")
     (#\ι . "iota")
     (#\κ . "kappa")
     (#\λ . "lambda")
     (#\μ . "mu")
     (#\ν . "nu")
     (#\ξ . "xi")
     (#\ο . "omicron")
     (#\π . "pi")
     (#\ρ . "rho")
     (#\ς . "sigmaf")
     (#\σ . "sigma")
     (#\τ . "tau")
     (#\υ . "upsilon")
     (#\φ . "phi")
     (#\χ . "chi")
     (#\ψ . "psi")
     (#\ω . "omega")
     (#\ϑ . "thetasym")
     (#\ϒ . "upsih")
     (#\ϖ . "piv")
     (#\  . "ensp")
     (#\  . "emsp")
     (#\  . "thinsp")
     (#\– . "ndash")
     (#\— . "mdash")
     (#\‘ . "lsquo")
     (#\’ . "rsquo")
     (#\‚ . "sbquo")
     (#\“ . "ldquo")
     (#\” . "rdquo")
     (#\„ . "bdquo")
     (#\† . "dagger")
     (#\‡ . "Dagger")
     (#\• . "bull")
     (#\… . "hellip")
     (#\‰ . "permil")
     (#\′ . "prime")
     (#\″ . "Prime")
     (#\‹ . "lsaquo")
     (#\› . "rsaquo")
     (#\‾ . "oline")
     (#\⁄ . "frasl")
     (#\€ . "euro")
     (#\ℑ . "image")
     (#\℘ . "weierp")
     (#\ℜ . "real")
     (#\™ . "trade")
     (#\ℵ . "alefsym")
     (#\← . "larr")
     (#\↑ . "uarr")
     (#\→ . "rarr")
     (#\↓ . "darr")
     (#\↔ . "harr")
     (#\↵ . "crarr")
     (#\⇐ . "lArr")
     (#\⇑ . "uArr")
     (#\⇒ . "rArr")
     (#\⇓ . "dArr")
     (#\⇔ . "hArr")
     (#\∀ . "forall")
     (#\∂ . "part")
     (#\∃ . "exist")
     (#\∅ . "empty")
     (#\∇ . "nabla")
     (#\∈ . "isin")
     (#\∉ . "notin")
     (#\∋ . "ni")
     (#\∏ . "prod")
     (#\∑ . "sum")
     (#\− . "minus")
     (#\∗ . "lowast")
     (#\√ . "radic")
     (#\∝ . "prop")
     (#\∞ . "infin")
     (#\∠ . "ang")
     (#\∧ . "and")
     (#\∨ . "or")
     (#\∩ . "cap")
     (#\∪ . "cup")
     (#\∫ . "int")
     (#\∴ . "there4")
     (#\∼ . "sim")
     (#\≅ . "cong")
     (#\≈ . "asymp")
     (#\≠ . "ne")
     (#\≡ . "equiv")
     (#\≤ . "le")
     (#\≥ . "ge")
     (#\⊂ . "sub")
     (#\⊃ . "sup")
     (#\⊄ . "nsub")
     (#\⊆ . "sube")
     (#\⊇ . "supe")
     (#\⊕ . "oplus")
     (#\⊗ . "otimes")
     (#\⊥ . "perp")
     (#\⋅ . "sdot")
     (#\⋮ . "vellip")
     (#\⌈ . "lceil")
     (#\⌉ . "rceil")
     (#\⌊ . "lfloor")
     (#\⌋ . "rfloor")
     (#\〈 . "lang")
     (#\〉 . "rang")
     (#\◊ . "loz")
     (#\♠ . "spades")
     (#\♣ . "clubs")
     (#\♥ . "hearts")
     (#\♦ . "diams"))))

(define (string->escaped-html s port)
  "Write the HTML escaped form of S to PORT."
  (define (escape c)
    (let ((escaped (hash-ref %escape-chars c)))
      (if escaped
          (format port "&~a;" escaped)
          (display c port))))
  (string-for-each escape s))

(define (object->escaped-html obj port)
  "Write the HTML escaped form of OBJ to PORT."
  (string->escaped-html
   (call-with-output-string (cut display obj <>))
   port))

(define (attribute-value->html value port)
  "Write the HTML escaped form of VALUE to PORT."
  (if (string? value)
      (string->escaped-html value port)
      (object->escaped-html value port)))

(define (attribute->html attr value port)
  "Write ATTR and VALUE to PORT."
  (format port "~a=\"" attr)
  (attribute-value->html value port)
  (display #\" port))

(define (element->html tag attrs body port)
  "Write the HTML TAG to PORT, where TAG has the attributes in the
list ATTRS and the child nodes in BODY."
  (format port "<~a" tag)
  (for-each (match-lambda
             ((attr value)
              (display #\space port)
              (attribute->html attr value port)))
            attrs)
  (if (and (null? body) (self-closing-tag? tag))
      (display " />" port)
      (begin
        (display #\> port)
        (for-each (cut sxml->html <> port) body)
        (format port "</~a>" tag))))

(define (doctype->html doctype port)
  (format port "<!DOCTYPE ~a>" doctype))

(define* (sxml->html tree #:optional (port (current-output-port)))
  "Write the serialized HTML form of TREE to PORT."
  (match tree
    (() *unspecified*)
    (('doctype type)
     (doctype->html type port))
    ;; Unescaped, raw HTML output
    (('raw html)
     (display html port))
    (((? symbol? tag) ('@ attrs ...) body ...)
     (element->html tag attrs body port))
    (((? symbol? tag) body ...)
     (element->html tag '() body port))
    ((nodes ...)
     (for-each (cut sxml->html <> port) nodes))
    ((? string? text)
     (string->escaped-html text port))
    ;; Render arbitrary Scheme objects, too.
    (obj (object->escaped-html obj port))))