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

72
src/generator.lisp
View file

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