GameLib is a collection of libraries for creating applications in Cakelisp.
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

;; 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))))
(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)))
(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)
(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)
(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)
(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))))
(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)
;; 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)
((= (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"))
(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))
((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))
(define-xml-format svg
"svg" "title" "!DOCTYPE" "?xml"
"defs" "mask" "g"
"rect" "path" "circle")
(defun test--xml (&return int)
svg stderr
(?xml :version "1.0" :encoding "UTF-8" :standalone "no")
:width "100%" :height "100%"
;; This is required to get the SVG to work in Firefox
:xmlns "" :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))))