1 changed files with 168 additions and 0 deletions
@ -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)) |
Loading…
Reference in new issue