rose-ash/spec/render.sx

;; Registry of all valid HTML tag names

(define-library (sx render)
  (export
    HTML_TAGS
    VOID_ELEMENTS
    BOOLEAN_ATTRS
    *definition-form-extensions*
    definition-form?
    parse-element-args
    render-attrs
    eval-cond
    eval-cond-scheme
    eval-cond-clojure
    process-bindings
    is-render-expr?
    merge-spread-attrs
    escape-html
    escape-attr)
  (begin

(define
  HTML_TAGS
  (list
    "html"
    "head"
    "body"
    "title"
    "meta"
    "link"
    "script"
    "style"
    "noscript"
    "header"
    "nav"
    "main"
    "section"
    "article"
    "aside"
    "footer"
    "h1"
    "h2"
    "h3"
    "h4"
    "h5"
    "h6"
    "hgroup"
    "div"
    "p"
    "blockquote"
    "pre"
    "figure"
    "figcaption"
    "address"
    "details"
    "summary"
    "a"
    "span"
    "em"
    "strong"
    "small"
    "b"
    "i"
    "u"
    "s"
    "mark"
    "sub"
    "sup"
    "abbr"
    "cite"
    "code"
    "kbd"
    "samp"
    "var"
    "time"
    "br"
    "wbr"
    "hr"
    "ul"
    "ol"
    "li"
    "dl"
    "dt"
    "dd"
    "table"
    "thead"
    "tbody"
    "tfoot"
    "tr"
    "th"
    "td"
    "caption"
    "colgroup"
    "col"
    "form"
    "input"
    "textarea"
    "select"
    "option"
    "optgroup"
    "button"
    "label"
    "fieldset"
    "legend"
    "output"
    "datalist"
    "img"
    "video"
    "audio"
    "source"
    "picture"
    "canvas"
    "iframe"
    "svg"
    "math"
    "path"
    "circle"
    "ellipse"
    "rect"
    "line"
    "polyline"
    "polygon"
    "text"
    "tspan"
    "g"
    "defs"
    "use"
    "clipPath"
    "mask"
    "pattern"
    "linearGradient"
    "radialGradient"
    "stop"
    "filter"
    "feGaussianBlur"
    "feOffset"
    "feBlend"
    "feColorMatrix"
    "feComposite"
    "feMerge"
    "feMergeNode"
    "feTurbulence"
    "feComponentTransfer"
    "feFuncR"
    "feFuncG"
    "feFuncB"
    "feFuncA"
    "feDisplacementMap"
    "feFlood"
    "feImage"
    "feMorphology"
    "feSpecularLighting"
    "feDiffuseLighting"
    "fePointLight"
    "feSpotLight"
    "feDistantLight"
    "animate"
    "animateTransform"
    "foreignObject"
    "template"
    "slot"
    "dialog"
    "menu"
    ;; void elements must ALSO be here — render routes a head symbol to
    ;; the element renderer only when it's in HTML_TAGS; these five were
    ;; only in VOID_ELEMENTS and fell through to "Undefined symbol"
    "area"
    "base"
    "embed"
    "param"
    "track"))

;; Self-closing tags (br, img, hr, etc.)
(define
  VOID_ELEMENTS
  (list
    "area"
    "base"
    "br"
    "col"
    "embed"
    "hr"
    "img"
    "input"
    "link"
    "meta"
    "param"
    "source"
    "track"
    "wbr"))

;; Attrs that are true/false (checked, disabled, etc.)
(define
  BOOLEAN_ATTRS
  (list
    "async"
    "autofocus"
    "autoplay"
    "checked"
    "controls"
    "default"
    "defer"
    "disabled"
    "formnovalidate"
    "hidden"
    "inert"
    "ismap"
    "loop"
    "multiple"
    "muted"
    "nomodule"
    "novalidate"
    "open"
    "playsinline"
    "readonly"
    "required"
    "reversed"
    "selected"))

;; Extensible list of forms treated as definitions
(define *definition-form-extensions* (list))

;; Check if a symbol names a definition form
(define
  definition-form?
  :effects ()
  (fn
    ((name :as string))
    (or
      (= name "define")
      (= name "defcomp")
      (= name "defisland")
      (= name "defmacro")
      (= name "defstyle")
      (= name "deftype")
      (= name "defeffect")
      (contains? *definition-form-extensions* name))))

;; Parse keyword attrs and children from element arg list
(define
  parse-element-args
  :effects (render)
  (fn
    ((args :as list) (env :as dict))
    (let
      ((attrs (dict)) (children (list)))
      (reduce
        (fn
          ((state :as dict) arg)
          (let
            ((skip (get state "skip")))
            (if
              skip
              (assoc state "skip" false "i" (inc (get state "i")))
              (if
                (and
                  (= (type-of arg) "keyword")
                  (< (inc (get state "i")) (len args)))
                (let
                  ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
                  (dict-set! attrs (keyword-name arg) val)
                  (assoc state "skip" true "i" (inc (get state "i"))))
                (do
                  (append! children arg)
                  (assoc state "i" (inc (get state "i"))))))))
        (dict "i" 0 "skip" false)
        args)
      (list attrs children))))

;; Render attr dict to HTML attribute string
(define
  render-attrs
  :effects ()
  (fn
    ((attrs :as dict))
    (join
      ""
      (map
        (fn
          ((key :as string))
          (let
            ((val (dict-get attrs key)))
            (cond
              (and (contains? BOOLEAN_ATTRS key) val)
              (str " " key)
              (and (contains? BOOLEAN_ATTRS key) (not val))
              ""
              (nil? val)
              ""
              :else (str " " key "=\"" (escape-attr (str val)) "\""))))
        (keys attrs)))))

;; Evaluate cond expression (dispatches to scheme/clojure style)
(define
  eval-cond
  :effects ()
  (fn
    ((clauses :as list) (env :as dict))
    (if
      (cond-scheme? clauses)
      (eval-cond-scheme clauses env)
      (eval-cond-clojure clauses env))))

;; Scheme-style cond: ((test body) ...)
(define
  eval-cond-scheme
  :effects ()
  (fn
    ((clauses :as list) (env :as dict))
    (if
      (empty? clauses)
      nil
      (let
        ((clause (first clauses))
          (test (first clause))
          (body (nth clause 1)))
        (if
          (is-else-clause? test)
          body
          (if
            (trampoline (eval-expr test env))
            body
            (eval-cond-scheme (rest clauses) env)))))))

;; Clojure-style cond: (test body test body ...)
(define
  eval-cond-clojure
  :effects ()
  (fn
    ((clauses :as list) (env :as dict))
    (if
      (< (len clauses) 2)
      nil
      (let
        ((test (first clauses)) (body (nth clauses 1)))
        (if
          (is-else-clause? test)
          body
          (if
            (trampoline (eval-expr test env))
            body
            (eval-cond-clojure (slice clauses 2) env)))))))

;; Evaluate let binding pairs, extend env
(define
  process-bindings
  :effects (mutation)
  (fn
    ((bindings :as list) (env :as dict))
    (let
      ((local (env-extend env)))
      (for-each
        (fn
          ((pair :as list))
          (when
            (and (= (type-of pair) "list") (>= (len pair) 2))
            (let
              ((name (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair)))))
              (env-bind!
                local
                name
                (trampoline (eval-expr (nth pair 1) local))))))
        bindings)
      local)))

;; Check if an expression should be rendered vs evaluated
(define
  is-render-expr?
  :effects ()
  (fn
    (expr)
    (if
      (or (not (= (type-of expr) "list")) (empty? expr))
      false
      (let
        ((h (first expr)))
        (if
          (not (= (type-of h) "symbol"))
          false
          (let
            ((n (symbol-name h)))
            (or
              (= n "<>")
              (= n "raw!")
              (starts-with? n "~")
              (starts-with? n "html:")
              (contains? HTML_TAGS n)
              (and
                (> (index-of n "-") 0)
                (> (len expr) 1)
                (= (type-of (nth expr 1)) "keyword")))))))))

;; Merge spread child attrs into parent element attrs
(define
  merge-spread-attrs
  :effects (mutation)
  (fn
    ((target :as dict) (spread-dict :as dict))
    (for-each
      (fn
        ((key :as string))
        (let
          ((val (dict-get spread-dict key)))
          (if
            (= key "class")
            (let
              ((existing (dict-get target "class")))
              (dict-set!
                target
                "class"
                (if
                  (and existing (not (= existing "")))
                  (str existing " " val)
                  val)))
            (if
              (= key "style")
              (let
                ((existing (dict-get target "style")))
                (dict-set!
                  target
                  "style"
                  (if
                    (and existing (not (= existing "")))
                    (str existing ";" val)
                    val)))
              (dict-set! target key val)))))
      (keys spread-dict))))

;; Escape special chars for HTML text content
(define
  escape-html
  (fn
    (s)
    (let
      ((r (str s)))
      (set! r (replace r "&" "&amp;"))
      (set! r (replace r "<" "&lt;"))
      (set! r (replace r ">" "&gt;"))
      (set! r (replace r "\"" "&quot;"))
      r)))

;; Escape special chars for HTML attribute values
(define escape-attr (fn (s) (escape-html s)))


)) ;; end define-library

;; Re-export to global namespace for backward compatibility
(import (sx render))