paku/hsx
1
0
Fork 0
Code Issues Pull requests Projects Releases 1 Packages Wiki Activity Actions

h macro

Browse source
This commit is contained in:
Bo Yao 2018-06-27 09:32:41 -04:00
parent c1dddcac52
commit 89421640da
1 changed files with 56 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
src/flute.lisp
View file

@ -15,8 +15,18 @@
(:export (:export
;; all html5 elements, e.g. div, nav, media, export in code ;; all html5 elements, e.g. div, nav, media, export in code
;; except <time> and <map> conflicts with cl symbol, are defined and exported as |time|, |map| ;; except <time> and <map> conflicts with cl symbol, are defined and exported as |time|, |map|
:define-element
)) :attrs
:attrs-alist
:make-attrs
:copy-attrs
:html
:element-tag
:element-attrs
:element-children
:user-element-expand-to
:*expand-user-element*
:h))
(in-package :flute) (in-package :flute)
(defclass element () (defclass element ()
@ -43,6 +53,9 @@
(defun make-builtin-element-with-prefix (&rest args &key tag attrs children prefix) (defun make-builtin-element-with-prefix (&rest args &key tag attrs children prefix)
(apply #'make-instance 'builtin-element-with-prefix args)) (apply #'make-instance 'builtin-element-with-prefix args))
(defun make-user-element (&rest args &key tag attrs children expand-to)
(apply #'make-instance 'user-element args))
(defstruct attrs alist) (defstruct attrs alist)
(defun split-attrs-and-children (attrs-and-children) (defun split-attrs-and-children (attrs-and-children)
@ -79,12 +92,15 @@
(cdr kv))) (cdr kv)))
alist)) alist))
(defvar *builtin-elements* (make-hash-table))
(defun html (&rest attrs-and-children) (defun html (&rest attrs-and-children)
(multiple-value-bind (attrs children) (multiple-value-bind (attrs children)
(split-attrs-and-children attrs-and-children) (split-attrs-and-children attrs-and-children)
(make-builtin-element-with-prefix :tag "html" :attrs attrs (make-builtin-element-with-prefix :tag "html" :attrs attrs
:children children :children children
:prefix "<!DOCTYPE html>"))) :prefix "<!DOCTYPE html>")))
(setf (gethash :html *builtin-elements*) t)
(defmacro define-builtin-element (element-name) (defmacro define-builtin-element (element-name)
`(defun ,element-name (&rest attrs-and-children) `(defun ,element-name (&rest attrs-and-children)
@ -97,6 +113,7 @@
`(progn `(progn
,@(mapcan (lambda (e) ,@(mapcan (lambda (e)
(list `(define-builtin-element ,e) (list `(define-builtin-element ,e)
`(setf (gethash (make-keyword ',e) *builtin-elements*) t)
`(export ',e))) `(export ',e)))
element-names))) element-names)))
@ -128,7 +145,7 @@
(format stream "<~a~a>" (element-tag element) (element-attrs element)))) (format stream "<~a~a>" (element-tag element) (element-attrs element))))
(defmethod print-object ((element builtin-element-with-prefix) stream) (defmethod print-object ((element builtin-element-with-prefix) stream)
(format stream "~a~%" prefix) (format stream "~a~%" (element-prefix element))
(call-next-method)) (call-next-method))
(defmacro! define-element (name (&rest args) &body body) (defmacro! define-element (name (&rest args) &body body)
@ -138,4 +155,39 @@
(let ,(mapcar (lambda (arg) (let ,(mapcar (lambda (arg)
(list arg `(cdr (assoc (make-keyword ',arg) (attrs-alist ,g!attrs))))) (list arg `(cdr (assoc (make-keyword ',arg) (attrs-alist ,g!attrs)))))
args) args)
,@body)))) (make-user-element :tag (string-downcase ',name) :attrs ,g!attrs
:children children :expand-to (progn ,@body))))))
(defvar *expand-user-element* t)
(defmethod print-object ((element user-element) stream)
(if *expand-user-element*
(print-object (user-element-expand-to element) stream)
(call-next-method)))
(defun tree-leaves%% (tree test result)
(if tree
(if (listp tree)
(cons
(tree-leaves%% (car tree) test result)
(tree-leaves%% (cdr tree) test result))
(if (funcall test tree)
(funcall result tree)
tree))))
(defmacro tree-leaves (tree test result)
`(tree-leaves%%
,tree
(lambda (x)
(declare (ignorable x))
,test)
(lambda (x)
(declare (ignorable x))
,result)))
(defmacro h (&body body)
`(progn
,@(tree-leaves
body
(and (symbolp x) (not (keywordp x)) (gethash (make-keyword x) *builtin-elements*))
(find-symbol (string x) :flute))))