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

Remove local-nicknames

Browse source
This commit is contained in:
paku 2024-04-15 19:57:28 +09:00
parent cd0d74a4b1
commit a92d3e9ea2
2 changed files with 74 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

52
src/elements.lisp
View file

@ -1,8 +1,18 @@
(uiop:define-package #:piccolo/elements
(:use #:cl)
(:local-nicknames (#:asu #:assoc-utils))
(:local-nicknames (#:alx #:alexandria))
(:local-nicknames (#:esc #:piccolo/escape))
(:import-from #:assoc-utils
#:aget
#:alistp
#:delete-from-alistf
#:hash-alist)
(:import-from #:alexandria
#:make-keyword
#:plist-alist
#:symbolicate)
(:import-from #:piccolo/escape
#:escape-attrs-alist
#:escape-children
#:*escape-html*)
(:export #:html
#:<>
#:define-element
@ -56,21 +66,21 @@
(make-instance 'builtin-element
:tag tag
:attrs attrs
:children (esc:escape-children children)))
:children (escape-children children)))
(defun make-builtin-element-with-prefix (&key tag attrs children prefix)
(make-instance 'builtin-element-with-prefix
:tag tag
:attrs attrs
:prefix prefix
:children (esc:escape-children children)))
:children (escape-children children)))
(defun make-user-element (&key tag attrs children expander)
(make-instance 'user-element
:tag tag
:attrs attrs
:expander expander
:children (esc:escape-children children)))
:children (escape-children children)))
(defmethod user-element-expand-to ((element user-element))
(funcall (user-element-expander element)
@ -82,7 +92,7 @@
(make-instance 'fragment
:tag "fragment"
:attrs (make-attrs :alist nil)
:children (esc:escape-children children)))
:children (escape-children children)))
;;; attributes
@ -90,18 +100,18 @@
alist)
(defun make-attrs (&key alist)
(if esc:*escape-html*
(%make-attrs :alist (esc:escape-attrs-alist alist))
(if *escape-html*
(%make-attrs :alist (escape-attrs-alist alist))
(%make-attrs :alist alist)))
(defmethod (setf attr) (value (attrs attrs) key)
(setf (asu:aget (attrs-alist attrs) key) value))
(setf (aget (attrs-alist attrs) key) value))
(defmethod delete-attr ((attrs attrs) key)
(asu:delete-from-alistf (attrs-alist attrs) key))
(delete-from-alistf (attrs-alist attrs) key))
(defmethod attr ((attrs attrs) key)
(asu:aget (attrs-alist attrs) key))
(aget (attrs-alist attrs) key))
(defmethod (setf attr) (value (element element) key)
(setf (attr (element-attrs element) key) value))
@ -127,15 +137,15 @@
(cond
((attrs-p (first attrs-and-children))
(values (first attrs-and-children) (flatten (rest attrs-and-children))))
((asu:alistp (first attrs-and-children))
((alistp (first attrs-and-children))
(values (make-attrs :alist (first attrs-and-children))
(flatten (rest attrs-and-children))))
((and (listp (first attrs-and-children))
(keywordp (first (first attrs-and-children)))) ;plist
(values (make-attrs :alist (alx:plist-alist (first attrs-and-children)))
(values (make-attrs :alist (plist-alist (first attrs-and-children)))
(flatten (rest attrs-and-children))))
((hash-table-p (first attrs-and-children))
(values (make-attrs :alist (asu:hash-alist (first attrs-and-children)))
(values (make-attrs :alist (hash-alist (first attrs-and-children)))
(flatten (rest attrs-and-children))))
((keywordp (first attrs-and-children)) ;inline-plist
(loop :for thing :on attrs-and-children :by #'cddr
@ -163,7 +173,7 @@
`(%html ,@attrs-and-children))
(defmacro define-builtin-element (element-name)
(let ((%element-name (alx:symbolicate '% element-name)))
(let ((%element-name (symbolicate '% element-name)))
`(progn
(defun ,%element-name (&rest attrs-and-children)
(multiple-value-bind (attrs children)
@ -178,7 +188,7 @@
`(progn
,@(mapcan (lambda (e)
(list `(define-builtin-element ,e)
`(setf (gethash (alx:make-keyword ',e) *builtin-elements*) t)
`(setf (gethash (make-keyword ',e) *builtin-elements*) t)
`(export ',e)))
element-names)))
@ -194,7 +204,7 @@
thead |time| title tr track u ul var video wbr)
(defmacro define-element (name (&rest props) &body body)
(let ((%name (alx:symbolicate '% name))
(let ((%name (symbolicate '% name))
(attrs (gensym "attrs"))
(children (gensym "children"))
(raw-children (gensym "raw-children")))
@ -211,12 +221,12 @@
(let ((children (and ,raw-children (apply #'%<> ,raw-children))))
(declare (ignorable children))
(let ,(mapcar (lambda (prop)
(list prop `(attr attrs (alx:make-keyword ',prop))))
(list prop `(attr attrs (make-keyword ',prop))))
props)
(let ((...props
(loop :for (key . value) in (attrs-alist attrs)
:unless (member key
',(mapcar #'alx:make-keyword
',(mapcar #'make-keyword
props))
:append (list key value))))
(declare (ignorable ...props))
@ -238,7 +248,7 @@
(defun html-element-p (node)
(and (symbolp node)
(not (keywordp node))
(gethash (alx:make-keyword node) *builtin-elements*)))
(gethash (make-keyword node) *builtin-elements*)))
(defun fragment-p (node)
(string= node '<>))

72
src/generator.lisp
View file

@ -1,7 +1,21 @@
(uiop:define-package #:piccolo/generator
(:use #:cl)
(:local-nicknames (#:alx #:alexandria))
(:local-nicknames (#:elm #:piccolo/elements))
(:import-from #:alexandria
#:with-gensyms
#:make-keyword
#:symbolicate)
(:import-from #:piccolo/elements
#:attrs
#:attrs-alist
#:element
#:element-tag
#:element-attrs
#:element-children
#:element-prefix
#:builtin-element-with-prefix
#:user-element
#:user-element-expand-to
#:fragment)
(:export #:*expand-user-element*
#:element-string
#:elem-str))
@ -12,16 +26,16 @@
(defun symbols-hash-table (symbols)
(let ((ht (make-hash-table)))
(mapcar (lambda (sym)
(setf (gethash (alx:make-keyword sym) ht) t))
(setf (gethash (make-keyword sym) ht) t))
symbols)
ht))
(defmacro define-group (name &body symbols)
(alx:with-gensyms (ht)
(with-gensyms (ht)
`(progn
(let ((,ht (symbols-hash-table ',symbols)))
(defun ,(alx:symbolicate name '-p) (symbol)
(gethash (alx:make-keyword (string-upcase symbol)) ,ht))))))
(defun ,(symbolicate name '-p) (symbol)
(gethash (make-keyword (string-upcase symbol)) ,ht))))))
(define-group self-closing-tag
area base br col embed hr img input keygen
@ -31,53 +45,53 @@
(defparameter *expand-user-element* t)
(defmethod print-object ((attrs elm:attrs) stream)
(defmethod print-object ((attrs attrs) stream)
(loop
:for (key . value) :in (elm:attrs-alist attrs)
:for (key . value) :in (attrs-alist attrs)
:do (format stream (if (typep value 'boolean)
"~@[ ~a~]"
" ~a=~s")
(string-downcase key)
value)))
(defmethod print-object ((element elm:element) stream)
(if (elm:element-children element)
(format stream (if (rest (elm:element-children element))
(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>~:>")
(elm:element-tag element)
(elm:element-attrs element)
(elm:element-children element)
(elm:element-tag element))
(format stream (if (self-closing-tag-p (elm:element-tag element))
(element-tag element)
(element-attrs element)
(element-children element)
(element-tag element))
(format stream (if (self-closing-tag-p (element-tag element))
"<~a~a>"
"<~a~a></~a>")
(elm:element-tag element)
(elm:element-attrs element)
(elm:element-tag element))))
(element-tag element)
(element-attrs element)
(element-tag element))))
(defmethod print-object ((element elm:builtin-element-with-prefix) stream)
(format stream "~a~%" (elm:element-prefix element))
(defmethod print-object ((element builtin-element-with-prefix) stream)
(format stream "~a~%" (element-prefix element))
(call-next-method))
(defmethod print-object ((element elm:user-element) stream)
(defmethod print-object ((element user-element) stream)
(if *expand-user-element*
(print-object (elm:user-element-expand-to element) stream)
(print-object (user-element-expand-to element) stream)
(call-next-method)))
(defmethod print-object ((element elm:fragment) stream)
(if (elm:element-children element)
(format stream (if (rest (elm:element-children element))
(defmethod print-object ((element fragment) stream)
(if (element-children element)
(format stream (if (rest (element-children element))
"~<~@{~a~^~:@_~}~:>"
"~<~a~:>")
(elm:element-children element))))
(element-children element))))
;;; helper for generate html string
(defmethod element-string ((element elm:element))
(defmethod element-string ((element element))
(with-output-to-string (s)
(write element :stream s :pretty t)))
(defmethod elem-str ((element elm:element))
(defmethod elem-str ((element element))
(with-output-to-string (s)
(write element :stream s :pretty nil)))