gamelib/src/XML.cake

;; XML.cake: Assistance in generating XML with Cakelisp
(add-cakelisp-search-directory "Dependencies/cakelisp/runtime")
(import "ComptimeHelpers.cake")

(c-import "<stdlib.h>"
          ;; Due to FILE* in global function
          &with-decls "<stdio.h>")

;; XML formats define which things should be interpreted as XML tags rather than Cakelisp invocations
(defmacro define-xml-format (name symbol &rest tags string)
  (get-or-create-comptime-var xml-formats (<> (in std unordered_map) (in std string)
                                              (<> (in std vector) (* (const char)))))
  (var recognized-tags (<> (in std vector) (* (const char))))
  (var current-token (* (const Token)) tags)
  (while (!= (path current-token > type) TokenType_CloseParen)
    (call-on push_back recognized-tags (call-on c_str (path current-token > contents)))
    (incr current-token))
  (set (at (path name > contents) (deref xml-formats)) recognized-tags)
  (return true))

(defun-comptime is-xml-tag (environment (& EvaluatorEnvironment)
                            format (* (const (in std string))) token (* (const Token)) &return bool)
  (get-or-create-comptime-var xml-formats (<> (in std unordered_map) (in std string)
                                              (<> (in std vector) (* (const char)))))
  (var recognized-tags (* (<> (in std vector) (* (const char))))
    (addr (at (deref format) (deref xml-formats))))
  (each-in-range (call-on-ptr size recognized-tags) i
    (when (= 0 (strcmp (at i (deref recognized-tags)) (call-on c_str (path token > contents))))
      (return true)))
  (return false))

(defmacro get-last-opened-tag (out-tag any tags any)
  (tokenize-push output
    (each-in-closed-interval-descending (- (call-on size (token-splice tags)) 1) 0 i
      (var get-last-tag (* tag) (addr (at i (token-splice tags))))
      (when (path get-last-tag > is-xml-tag)
        (set (token-splice out-tag) get-last-tag)
        (break))))
  (return true))

(defmacro write-xml-in-format (format symbol output-file any &rest body (index array))
  (var end-body-index int (FindCloseParenTokenIndex tokens startTokenIndex))
  (defstruct tag
    is-xml-tag bool
    is-opening-tag-closed bool
    tag-open (* (const Token)))
  (var stripped-output (<> (in std vector) Token))
  (call-on reserve stripped-output 100)
  (var xml-open-tag-stack (<> (in std vector) tag))
  (var tag-attribute-mode bool false)
  (var attribute-value-nesting int 0)
  (each-in-interval body end-body-index current-token-index
    (var current-token (* (const Token)) (addr (at current-token-index tokens)))
    (var is-cakelisp-token bool true)
    (cond
      ((= (path current-token > type) TokenType_OpenParen)
       (when tag-attribute-mode
         (incr attribute-value-nesting))
       ;; Close whatever existing tag's opening
       (unless (or attribute-value-nesting (call-on empty xml-open-tag-stack))
         (var exit-tag (* tag) null)
         (get-last-opened-tag exit-tag xml-open-tag-stack)
         (unless (and exit-tag (path exit-tag > is-opening-tag-closed))
           ;; Weird special case
           (when (= '?' (at 0 (path (+ 1 (path exit-tag > tag-open)) > contents)))
             (tokenize-push stripped-output
               (output-xml (token-splice output-file) "?")))
           (tokenize-push stripped-output
             (output-xml (token-splice output-file) ">\n"))
           (set (path exit-tag > is-opening-tag-closed) true)))
       (if (is-xml-tag environment (addr (path format > contents)) (+ 1 current-token))
           (scope ;; Output tag
            (var new-tag tag (array 0))
            (set (field new-tag is-xml-tag) true)
            (set (field new-tag tag-open) current-token)
            (call-on push_back xml-open-tag-stack new-tag)
            (var tag-string Token (deref (+ 1 current-token)))
            (set (field tag-string type) TokenType_String)
            (token-contents-snprintf tag-string "<%s"
                                     (call-on c_str (path (+ 1 current-token) > contents)))
            (tokenize-push stripped-output
              (output-xml (token-splice output-file) (token-splice-addr tag-string)))

            (set is-cakelisp-token false)
            ;; Absorb the name
            (incr current-token-index))
           (scope ;; Cakelisp invocation
            (var new-tag tag (array 0))
            (set (field new-tag is-xml-tag) false)
            (set (field new-tag tag-open) current-token)
            (call-on push_back xml-open-tag-stack new-tag))))
      ((= (path current-token > type) TokenType_CloseParen)
       (when tag-attribute-mode
         (decr attribute-value-nesting)
         (when (= attribute-value-nesting 0)
           (set tag-attribute-mode false)))
       (when (call-on empty xml-open-tag-stack)
         (Log "write-xml-in-format stack is missing matching opening and closing tags (code error?)\n")
         (return false))
       (var exit-tag (* tag) (addr (call-on back xml-open-tag-stack)))
       (when (path exit-tag > is-xml-tag)
         (var exit-tag-name (* (const Token)) (+ 1 (path exit-tag > tag-open)))
         (var tag-string Token (deref (+ 1 current-token)))
         (set (field tag-string type) TokenType_String)
         (cond
           ((path exit-tag > is-opening-tag-closed)
            (token-contents-snprintf tag-string "</%s>\n"
                                     (call-on c_str (path exit-tag-name > contents))))
           ;; Special case self-closing tag
           ((= '?' (at 0 (path exit-tag-name > contents)))
            (set (field tag-string contents) "?>\n"))
           (true
            (token-contents-snprintf tag-string ">\n</%s>\n"
                                     (call-on c_str (path exit-tag-name > contents)))))
         (tokenize-push stripped-output
           (output-xml (token-splice output-file) (token-splice-addr tag-string)))
         (set is-cakelisp-token false))
       (call-on pop_back xml-open-tag-stack))
      ;; Denote XML attributes with :
      ((and (= (path current-token > type) TokenType_Symbol)
            (> (call-on size (path current-token > contents)) 1)
            (= ':' (at 0 (path current-token > contents))))
       (var attribute-string Token (deref current-token))
       (set (field attribute-string type) TokenType_String)
       (token-contents-snprintf attribute-string " %s="
                                (+ 1 (call-on c_str (path current-token > contents))))
       (tokenize-push stripped-output
         (output-xml (token-splice output-file) (token-splice-addr attribute-string)))
       (set is-cakelisp-token false)
       (var next-token (* (const Token)) (+ 1 current-token))
       (cond
         ((or (= (path next-token > type) TokenType_String)
              (= (path next-token > type) TokenType_Symbol))
          (var value-token Token (deref next-token))
          (set (field value-token type) TokenType_String)
          (token-contents-snprintf value-token "\"%s\""
                                   (call-on c_str (path next-token > contents)))
          (tokenize-push stripped-output
            (output-xml (token-splice output-file) (token-splice-addr value-token)))
          ;; Absorb the argument value
          (incr current-token-index))
         ((= (path next-token > type) TokenType_OpenParen)
          (set tag-attribute-mode true)
          (set attribute-value-nesting 0)))))

    (when is-cakelisp-token
      (call-on push_back stripped-output (deref current-token))))
  (tokenize-push output
    (token-splice-array stripped-output))
  (return true))

(defun output-xml (output-file (* FILE) str (* (const char)))
  (fputs str output-file))

(defmacro format-quote (output-file any format-str string &optional &rest format-arguments any)
  (var quoted-format-str Token (deref format-str))
  (token-contents-snprintf quoted-format-str "\"%s\"" (call-on c_str (path format-str > contents)))
  (tokenize-push output
    (fprintf (token-splice output-file) (token-splice-addr quoted-format-str)
             (token-splice-rest format-arguments tokens)))
  (return true))

(comptime-cond
 ('auto-test
  (define-xml-format svg
      "svg" "title" "!DOCTYPE" "?xml"
      "defs" "mask" "g"
      "rect" "path" "circle")
  (defun test--xml (&return int)
    (write-xml-in-format
     svg stderr
     (?xml :version "1.0" :encoding "UTF-8" :standalone "no")
     (svg
      :width "100%" :height "100%"
      ;; This is required to get the SVG to work in Firefox
      :xmlns "http://www.w3.org/2000/svg" :version "1.1"
      ;; Background
      (rect :x 0 :y 0 :width "100%" :height "100%" :fill "#333333")
      (each-in-range 3 i
        (rect :x (format-quote stderr "%din" (* i 2)) :y (format-quote stderr "%fin" (* i 3.5f))
              :width "5in" :height "2in" :fill "#aaaaaa"))))
    (return 0))))