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.
 
 
 
 
 
 

182 lines
8.7 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>")
;; 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))))