You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
268 lines
13 KiB
268 lines
13 KiB
;; 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>")
|
|
|
|
(defmacro declare-format-rules-enum ()
|
|
(tokenize-push output
|
|
;; Do not update without also updating strings-to-format-rules-enum
|
|
(defenum format-rules
|
|
separate-closing-tag ;; <element></element>
|
|
self-closing ;; <element />
|
|
no-closing-tag)) ;; <element>
|
|
(return true))
|
|
|
|
;; 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 environment xml-formats
|
|
(template (in std unordered_map) (in std string)
|
|
(template (in std pair)
|
|
;; Tag names
|
|
(template (in std vector) (addr (const char)))
|
|
;; Tag rules
|
|
(template (in std vector) int))))
|
|
(var recognized-tags (template (in std vector) (addr (const char))))
|
|
(declare-format-rules-enum)
|
|
(var format-rules (template (in std vector) int))
|
|
(var current-format-rule format-rules separate-closing-tag)
|
|
(var current-token (addr (const Token)) tags)
|
|
(while (!= (path current-token > type) TokenType_CloseParen)
|
|
(unless (or (= (path current-token > type) TokenType_String)
|
|
(= (path current-token > type) TokenType_Symbol))
|
|
(ErrorAtToken (deref current-token) "define-xml-format expects strings or symbols only")
|
|
(return false))
|
|
(when (= '&' (at 0 (path current-token > contents)))
|
|
(var strings-to-format-rules-enum (array (addr (const char)))
|
|
(array
|
|
"&separate-closing-tag"
|
|
"&self-closing"
|
|
"&no-closing-tag"))
|
|
(var found bool false)
|
|
(each-in-array strings-to-format-rules-enum i
|
|
(when (= 0 (call-on compare (path current-token > contents)
|
|
(at i strings-to-format-rules-enum)))
|
|
(set current-format-rule (type-cast i format-rules))
|
|
(set found true)
|
|
(break)))
|
|
(unless found
|
|
(ErrorAtToken (deref current-token) "define-xml-format encountered unexpected format specifier.
|
|
The following are supported:")
|
|
(each-in-array strings-to-format-rules-enum i
|
|
(Logf "\t%s\n" (at i strings-to-format-rules-enum)))
|
|
(return false))
|
|
(incr current-token)
|
|
(continue))
|
|
|
|
(call-on push_back recognized-tags (call-on c_str (path current-token > contents)))
|
|
(call-on push_back format-rules current-format-rule)
|
|
(incr current-token))
|
|
(set (at (path name > contents) (deref xml-formats))
|
|
(call (in std make_pair) recognized-tags format-rules))
|
|
(return true))
|
|
|
|
(defun-comptime is-xml-tag (environment (ref EvaluatorEnvironment)
|
|
recognized-tags (addr (template (in std vector) (addr (const char))))
|
|
token (addr (const Token)) &return bool)
|
|
(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))
|
|
|
|
(defun-comptime get-xml-tag-format-rule (recognized-tags (addr (template (in std vector) (addr (const char))))
|
|
tag-rules (addr (template (in std vector) int))
|
|
token (addr (const Token))
|
|
&return int)
|
|
(each-in-range (call-on-ptr size recognized-tags) i
|
|
(when (= 0 (call-on compare (path token > contents) (at i (deref recognized-tags))))
|
|
(return (at i (deref tag-rules)))))
|
|
;; Default rule
|
|
(return 0))
|
|
|
|
(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 (addr 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))
|
|
(get-or-create-comptime-var environment xml-formats
|
|
(template (in std unordered_map) (in std string)
|
|
(template (in std pair)
|
|
;; Tag names
|
|
(template (in std vector) (addr (const char)))
|
|
;; Tag rules
|
|
(template (in std vector) int))))
|
|
(declare-format-rules-enum)
|
|
(unless (!= (call-on-ptr find xml-formats (path format > contents))
|
|
(call-on-ptr end xml-formats))
|
|
;; Let's wait and see if the format is defined later
|
|
(return (DeferCurrentReferenceResolution environment "write-xml-in-format")))
|
|
(var recognized-tags (addr (template (in std vector) (addr (const char))))
|
|
(addr (field (at (path format > contents) (deref xml-formats)) first)))
|
|
(var tag-rules (addr (template (in std vector) int))
|
|
(addr (field (at (path format > contents) (deref xml-formats)) second)))
|
|
|
|
(var end-body-index int (FindCloseParenTokenIndex tokens startTokenIndex))
|
|
(defstruct tag
|
|
is-xml-tag bool
|
|
is-opening-tag-closed bool
|
|
format-rule int
|
|
tag-open (addr (const Token)))
|
|
(var stripped-output (template (in std vector) Token))
|
|
(call-on reserve stripped-output 100)
|
|
(var xml-open-tag-stack (template (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 (addr (const Token)) (addr (at current-token-index tokens)))
|
|
(var is-cakelisp-token bool true)
|
|
(cond
|
|
;; Open tag
|
|
((= (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 (addr tag) null)
|
|
(get-last-opened-tag exit-tag xml-open-tag-stack)
|
|
(unless exit-tag
|
|
(ErrorAtToken (deref current-token) "write-xml-in-format encountered unexpected null
|
|
token in stack.")
|
|
(return false))
|
|
(unless (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 recognized-tags (+ 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)
|
|
(set (field new-tag format-rule)
|
|
(get-xml-tag-format-rule recognized-tags tag-rules (+ 1 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))))
|
|
|
|
;; Close 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 (addr tag) (addr (call-on back xml-open-tag-stack)))
|
|
(when (path exit-tag > is-xml-tag)
|
|
(var exit-tag-name (addr (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 > format-rule) no-closing-tag)
|
|
(set (field tag-string contents) ">\n"))
|
|
((= (path exit-tag > format-rule) self-closing)
|
|
(set (field tag-string contents) "/>\n"))
|
|
((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"))
|
|
((= '!' (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 (addr (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 (addr FILE) str (addr (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))))
|
|
|