diff options
Diffstat (limited to 'who.tl')
| -rw-r--r-- | who.tl | 56 |
1 files changed, 55 insertions, 1 deletions
@@ -83,7 +83,31 @@ (if (keywordp (first rest)) (push (cons (first rest) (second rest)) attr))) (set body (rest sexp))))) - (convert-tag-to-string-list tag attr-list body body-fn))) + ;; tag macro expansion + (flet ((finish () + (convert-tag-to-string-list tag attr-list body body-fn)) + (alist-to-plist (al) + (mappend (tb ((a . b)) (list a b)) al)) + (process-elem (elem) + (match-case elem + (@(or @(keywordp) + (@(keywordp) . @nil) + ((@(keywordp) . @nil) . @nil)) + [process-tag elem body-fn]) + (@else (compile-error sexp "produced non-tag form ~s" + else))))) + (iflet ((fn [*tag-macro* tag])) + ;; macro found + (let* ((attr-plist (alist-to-plist attr-list)) + (new-tag-elem [fn body . attr-plist])) + (match-case new-tag-elem + ;; returned keyword form + ((progn . @stuff) + (append-each ((elem stuff)) + (process-elem elem))) + (@else (process-elem else)))) + ;; no macro: convert to string list + (finish))))) (defun attr-warning-macrolet (form) (with-gensyms (warn) @@ -291,3 +315,33 @@ ^(with-output-to-string (,var ,string-form) (with-html-output (,var nil :prologue ,prologue :indent ,indent) ,*body))) + +(defun scrub-kw-args (key-params args) + (let* ((kwp (find-package "keyword")) + (keys [mapcar (op intern + (symbol-name + (tree-case @1 + ((prop t) prop) + (prop prop))) + kwp) + key-params])) + (build + (for ((iter args)) (iter) ((set iter (cddr iter))) + (tree-bind (prop val . t) iter + (unless (memq prop keys) + (add prop val))))))) + +(defmacro deftag (:form f keyword attr-param-list tag-body . body) + (unless (keywordp keyword) + (compile-error f "~s argument must be a keyword" keyword)) + (let ((rest-param (if (consp attr-param-list) + (last attr-param-list 0) + attr-param-list)) + (key-params (if (consp attr-param-list) + (butlast attr-param-list 0)))) + ^(set [*tag-macro* ,keyword] + (lambda (:key ,tag-body -- ,*attr-param-list) + ,*(if (and rest-param key-params) + ^((set ,rest-param + (scrub-kw-args ',key-params ,rest-param)))) + ,*body)))) |