hsx/src/flute.lisp

194 lines
6.8 KiB
Common Lisp
Raw Normal View History

2018-06-24 13:08:30 -04:00
(in-package :cl-user)
(defpackage flute
(:use :cl)
(:import-from :assoc-utils
:alist
:alistp
:hash-alist
:alist-plist)
(:import-from :let-over-lambda
:defmacro!
2018-06-24 20:42:55 -04:00
:mkstr
:flatten)
(:import-from :alexandria
:make-keyword)
2018-06-24 13:08:30 -04:00
(:export
;; 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|
2018-06-27 09:32:41 -04:00
:define-element
:attrs
:attrs-alist
:make-attrs
:copy-attrs
:html
:element-tag
:element-attrs
:element-children
:user-element-expand-to
:*expand-user-element*
:h))
2018-06-24 13:08:30 -04:00
(in-package :flute)
(defclass element ()
((tag :initarg :tag
:accessor element-tag)
(attrs :initarg :attrs
:accessor element-attrs)
(children :initarg :children
:accessor element-children)))
(defclass builtin-element (element) ())
(defclass builtin-element-with-prefix (builtin-element)
((prefix :initarg :prefix
:accessor element-prefix)))
(defclass user-element (element)
((expand-to :initarg :expand-to
:accessor user-element-expand-to)))
(defun make-builtin-element (&rest args &key tag attrs children)
(apply #'make-instance 'builtin-element args))
(defun make-builtin-element-with-prefix (&rest args &key tag attrs children prefix)
(apply #'make-instance 'builtin-element-with-prefix args))
2018-06-24 13:08:30 -04:00
2018-06-27 09:32:41 -04:00
(defun make-user-element (&rest args &key tag attrs children expand-to)
(apply #'make-instance 'user-element args))
2018-06-24 13:08:30 -04:00
(defstruct attrs alist)
2018-06-24 20:42:55 -04:00
(defun split-attrs-and-children (attrs-and-children)
2018-06-24 13:08:30 -04:00
(cond
((attrs-p (first attrs-and-children))
2018-06-24 20:42:55 -04:00
(values (first attrs-and-children) (flatten (rest attrs-and-children))))
2018-06-24 13:08:30 -04:00
((alistp (first attrs-and-children))
(values (make-attrs :alist (first attrs-and-children))
2018-06-24 20:42:55 -04:00
(flatten (rest attrs-and-children))))
2018-06-24 13:08:30 -04:00
((listp (first attrs-and-children))
(values (make-attrs :alist (plist-alist (first attrs-and-children)))
2018-06-24 20:42:55 -04:00
(flatten (rest attrs-and-children))))
2018-06-24 13:08:30 -04:00
((hash-table-p (first attrs-and-children))
(values (make-attrs :alist (hash-alist (first attrs-and-children)))
2018-06-24 20:42:55 -04:00
(flatten (rest attrs-and-children))))
2018-06-24 13:08:30 -04:00
((keywordp (first attrs-and-children))
(loop for thing on attrs-and-children by #'cddr
for (k v) = thing
2018-06-24 20:42:55 -04:00
when (and (keywordp k) v)
2018-06-24 13:08:30 -04:00
collect (cons k v) into attrs
when (not (keywordp k))
2018-06-24 20:42:55 -04:00
return (values (make-attrs :alist attrs) (flatten thing))
2018-06-24 13:08:30 -04:00
finally (return (values (make-attrs :alist attrs) nil))))
(t
2018-06-24 20:42:55 -04:00
(values (make-attrs :alist nil) (flatten attrs-and-children)))))
2018-06-24 13:08:30 -04:00
(defun plist-alist (plist)
(loop for (k v) on plist by #'cddr
collect (cons k v)))
(defun alist-plist* (alist)
(mapcan (lambda (kv)
(list (string-downcase (car kv))
(cdr kv)))
alist))
2018-06-27 09:32:41 -04:00
(defvar *builtin-elements* (make-hash-table))
(defun html (&rest attrs-and-children)
(multiple-value-bind (attrs children)
(split-attrs-and-children attrs-and-children)
(make-builtin-element-with-prefix :tag "html" :attrs attrs
:children children
:prefix "<!DOCTYPE html>")))
2018-06-27 09:32:41 -04:00
(setf (gethash :html *builtin-elements*) t)
2018-06-24 13:08:30 -04:00
(defmacro define-builtin-element (element-name)
`(defun ,element-name (&rest attrs-and-children)
2018-06-24 20:42:55 -04:00
(multiple-value-bind (attrs children)
(split-attrs-and-children attrs-and-children)
(make-builtin-element :tag (string-downcase (mkstr ',element-name))
:attrs attrs :children children))))
2018-06-24 13:08:30 -04:00
(defmacro define-and-export-builtin-elements (&rest element-names)
`(progn
,@(mapcan (lambda (e)
(list `(define-builtin-element ,e)
2018-06-27 09:32:41 -04:00
`(setf (gethash (make-keyword ',e) *builtin-elements*) t)
2018-06-24 13:08:30 -04:00
`(export ',e)))
element-names)))
2018-06-24 20:42:55 -04:00
(define-and-export-builtin-elements
2018-06-24 13:08:30 -04:00
a abbr address area article aside audio b base bdi bdo blockquote
body br button canvas caption cite code col colgroup data datalist
dd del details dfn dialog div dl dt em embed fieldset figcaption
figure footer form h1 h2 h3 h4 h5 h6 head header hr i iframe
2018-06-24 13:08:30 -04:00
img input ins kbd label legend li link main |map| mark meta meter nav
noscript object ol optgroup option output p param picture pre progress
q rp rt ruby s samp script section select small source span strong
style sub summary sup svg table tbody td template textarea tfoot th
thead |time| title tr track u ul var video wbr)
(defmethod print-object ((attrs attrs) stream)
(if (attrs-alist attrs)
(format stream " ~{~a=~s~^ ~}" (alist-plist* (attrs-alist attrs)))
(format stream "")))
(defmethod print-object ((element element) stream)
(if (element-children element)
(format stream (if (rest (element-children element))
"~@<<~a~a>~2I~:@_~<~@{~a~^~:@_~}~:>~0I~:@_</~a>~:>"
"~@<<~a~a>~2I~:_~<~a~:>~0I~:_</~a>~:>")
(element-tag element)
(element-attrs element)
(element-children element)
(element-tag element))
(format stream "<~a~a>" (element-tag element) (element-attrs element))))
(defmethod print-object ((element builtin-element-with-prefix) stream)
2018-06-27 09:32:41 -04:00
(format stream "~a~%" (element-prefix element))
(call-next-method))
2018-06-24 20:42:55 -04:00
(defmacro! define-element (name (&rest args) &body body)
`(defun ,name (&rest ,g!attrs-and-children)
(multiple-value-bind (,g!attrs children)
(split-attrs-and-children ,g!attrs-and-children)
(let ,(mapcar (lambda (arg)
(list arg `(cdr (assoc (make-keyword ',arg) (attrs-alist ,g!attrs)))))
args)
2018-06-27 09:32:41 -04:00
(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))))