macoy
/
gamelib
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
Browse Source

Add XML macros from graph-generator

master
Macoy Madson 5 months ago
parent
0f79459935
commit
37a4caf1b5
1 changed files with 168 additions and 0 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 168
      src/XML.cake

168
src/XML.cake
View File

@ -0,0 +1,168 @@
;; 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
(fprintf stderr "compare %s and %s\n" (at i (deref recognized-tags)) (call-on c_str (path token > contents)))
(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)
(printFormattedToken stderr (deref current-token))
(fprintf stderr " (token)\n")
(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)))
(Logf "Exit %s\n"
(call-on c_str (path exit-tag-name > contents)))
(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))))
(Logf "Attribute %s\n" (call-on c_str (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))))
(prettyPrintTokens stripped-output)
(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 &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))
Write Preview
Loading…
Cancel
Save