rose-ash/spec/render.sx

(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"))

(define
  VOID_ELEMENTS
  (list
    "area"
    "base"
    "br"
    "col"
    "embed"
    "hr"
    "img"
    "input"
    "link"
    "meta"
    "param"
    "source"
    "track"
    "wbr"))

(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"))

(define *definition-form-extensions* (list))

(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))))

(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))))

(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)))))

(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))))

(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)))))))

(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)))))))

(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)))

(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")))))))))

(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))))

(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)))

(define escape-attr (fn (s) (escape-html s)))