paku/hsx
1
0
Fork 0
Code Issues2 Pull requests Projects Releases2 Packages Wiki Activity Actions

Resetting

Browse source
This commit is contained in:
Akira Tempaku 2024-05-20 14:38:28 +09:00
commit f086e13e04
11 changed files with 8 additions and 1210 deletions

284
src/elements.lisp
View file

@ -1,284 +0,0 @@
(uiop:define-package #:piccolo/elements
(:use #:cl)
(:import-from #:assoc-utils
#:aget
#:alistp
#:delete-from-alistf
#:hash-alist)
(:import-from #:alexandria
#:make-keyword
#:plist-alist
#:symbolicate)
(:import-from #:piccolo/groups
#:non-escape-tag-p)
(:import-from #:piccolo/escape
#:escape-attrs-alist
#:escape-children
#:*escape-html*)
(:export #:html
#:%html
#:<>
#:%<>
#:define-element
#:tag
#:children
#:attrs
#:props
#:attrs-alist
#:make-attrs
#:copy-attrs
#:attr
#:delete-attr
#:element
#:builtin-element
#:builtin-element-with-prefix
#:user-element
#:fragment
#:element-tag
#:element-attrs
#:element-prefix
#:element-children
#:user-element-expand-to
#:h))
(in-package #:piccolo/elements)
;;; classes
(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 :expander
:accessor user-element-expander)))
(defclass fragment (element) ())
;;; constructors
(defun make-builtin-element (&key tag attrs children)
(make-instance 'builtin-element
:tag tag
:attrs attrs
:children (if (non-escape-tag-p tag)
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 (escape-children children)))
(defun make-user-element (&key tag attrs children expander)
(make-instance 'user-element
:tag tag
:attrs attrs
:expander expander
:children (escape-children children)))
(defmethod user-element-expand-to ((element user-element))
(funcall (user-element-expander element)
(element-tag element)
(element-attrs element)
(element-children element)))
(defun make-fragment (&key children)
(make-instance 'fragment
:tag "fragment"
:attrs (make-attrs :alist nil)
:children (escape-children children)))
;;; attributes
(defstruct (attrs (:constructor %make-attrs))
alist)
(defun make-attrs (&key alist)
(if *escape-html*
(%make-attrs :alist (escape-attrs-alist alist))
(%make-attrs :alist alist)))
(defmethod (setf attr) (value (attrs attrs) key)
(setf (aget (attrs-alist attrs) key) value))
(defmethod delete-attr ((attrs attrs) key)
(delete-from-alistf (attrs-alist attrs) key))
(defmethod attr ((attrs attrs) key)
(aget (attrs-alist attrs) key))
(defmethod (setf attr) (value (element element) key)
(setf (attr (element-attrs element) key) value))
(defmethod delete-attr ((element element) key)
(delete-attr (element-attrs element) key))
(defmethod attr ((element element) key)
(attr (element-attrs element) key))
;;; elements
(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec
(car x)
(rec (cdr x) acc))))))
(rec x nil)))
(defun split-attrs-and-children (attrs-and-children)
(cond
((attrs-p (first attrs-and-children))
(values (first attrs-and-children) (flatten (rest 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 (plist-alist (first attrs-and-children)))
(flatten (rest attrs-and-children))))
((hash-table-p (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
:for (k v) := thing
:when (and (keywordp k) v)
:collect (cons k v) :into attrs
:when (not (keywordp k))
:return (values (make-attrs :alist attrs) (flatten thing))
:finally (return (values (make-attrs :alist attrs) nil))))
(t
(values (make-attrs :alist nil) (flatten attrs-and-children)))))
(defparameter *builtin-elements* (make-hash-table))
(setf (gethash :html *builtin-elements*) t)
(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>")))
(defmacro html (&body attrs-and-children)
`(%html ,@attrs-and-children))
(defmacro define-builtin-element (element-name)
(let ((%element-name (symbolicate '% element-name)))
`(progn
(defun ,%element-name (&rest attrs-and-children)
(multiple-value-bind (attrs children)
(split-attrs-and-children attrs-and-children)
(make-builtin-element :tag (string-downcase ',element-name)
:attrs attrs
:children children)))
(defmacro ,element-name (&body attrs-and-children)
`(,',%element-name ,@attrs-and-children)))))
(defmacro define-and-export-builtin-elements (&rest element-names)
`(progn
,@(mapcan (lambda (e)
(list `(define-builtin-element ,e)
`(setf (gethash (make-keyword ',e) *builtin-elements*) t)
`(export ',e)
`(export ',(symbolicate '% e))))
element-names)))
(define-and-export-builtin-elements
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
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)
(defmacro define-element (name (&rest props) &body body)
(let ((%name (symbolicate '% name))
(attrs (gensym "attrs"))
(children (gensym "children"))
(raw-children (gensym "raw-children")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,%name (&rest attrs-and-children)
(multiple-value-bind (,attrs ,children)
(split-attrs-and-children attrs-and-children)
(make-user-element
:tag (string-downcase ',name)
:attrs ,attrs
:children ,children
:expander (lambda (tag attrs ,raw-children)
(declare (ignorable tag attrs))
(let ((children (and ,raw-children (apply #'%<> ,raw-children))))
(declare (ignorable children))
(let ,(mapcar (lambda (prop)
(list prop `(attr attrs (make-keyword ',prop))))
props)
(let ((props
(loop
:for (key . value) in (attrs-alist attrs)
:unless (member key ',(mapcar #'make-keyword props))
:append (list key value))))
(declare (ignorable props))
(progn ,@body))))))))
(defmacro ,name (&body attrs-and-children)
`(,',%name ,@attrs-and-children)))))
(defun %<> (&rest attrs-and-children)
(multiple-value-bind (attrs children)
(split-attrs-and-children attrs-and-children)
(declare (ignore attrs))
(make-fragment :children children)))
(defmacro <> (&body children)
`(%<> ,@children))
;;; h macro
(defun html-element-p (node)
(and (symbolp node)
(not (keywordp node))
(gethash (make-keyword node) *builtin-elements*)))
(defun fragment-p (node)
(string= node '<>))
(defun modify-first-leaves (tree test result)
(if tree
(cons (let ((first-node (first tree)))
(cond
((listp first-node)
(modify-first-leaves first-node test result))
((funcall test first-node)
(funcall result first-node))
(t first-node)))
(mapcar (lambda (node)
(if (listp node)
(modify-first-leaves node test result)
node))
(rest tree)))))
(defmacro h (&body body)
`(progn
,@(modify-first-leaves
body
(lambda (node)
(or (html-element-p node) (fragment-p node)))
(lambda (node)
(find-symbol (string node) :piccolo)))))

48
src/escape.lisp
View file

@ -1,48 +0,0 @@
(uiop:define-package #:piccolo/escape
(:use #:cl)
(:export #:*escape-html*
#:*html-escape-map*
#:*attr-escape-map*
#:escape-string
#:escape-attrs-alist
#:escape-children))
(in-package #:piccolo/escape)
(defparameter *escape-html* t)
(defparameter *html-escape-map*
'((#\& . "&amp;")
(#\< . "&lt;")
(#\> . "&gt;")
(#\" . "&quot;")
(#\' . "&#x27;")
(#\/ . "&#x2F;")
(#\` . "&grave;")
(#\= . "&#x3D;")))
(defparameter *attr-escape-map*
'((#\" . "&quot;")))
(defun escape-char (char escape-map)
(or (cdr (assoc char escape-map))
char))
(defun escape-string (string escape-map)
(if (stringp string)
(with-output-to-string (s)
(loop
:for c :across string
:do (write (escape-char c escape-map) :stream s :escape nil)))
string))
(defun escape-attrs-alist (alist)
(mapcar (lambda (kv)
(cons (car kv) (escape-string (cdr kv) *attr-escape-map*)))
alist))
(defun escape-children (children)
(mapcar (lambda (child)
(if (and (stringp child) *escape-html*)
(escape-string child *html-escape-map*)
child))
children))

75
src/generator.lisp
View file

@ -1,75 +0,0 @@
(uiop:define-package #:piccolo/generator
(:use #:cl)
(:import-from #:piccolo/groups
#:self-closing-tag-p)
(: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))
(in-package #:piccolo/generator)
;;; print-object
(defparameter *expand-user-element* t)
(defmethod print-object ((attrs attrs) stream)
(loop
: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 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 (if (self-closing-tag-p (element-tag element))
"<~a~a>"
"<~a~a></~a>")
(element-tag element)
(element-attrs element)
(element-tag element))))
(defmethod print-object ((element builtin-element-with-prefix) stream)
(format stream "~a~%" (element-prefix element))
(call-next-method))
(defmethod print-object ((element user-element) stream)
(if *expand-user-element*
(print-object (user-element-expand-to element) stream)
(call-next-method)))
(defmethod print-object ((element fragment) stream)
(if (element-children element)
(format stream (if (rest (element-children element))
"~<~@{~a~^~:@_~}~:>"
"~<~a~:>")
(element-children element))))
;;; helper for generate html string
(defmethod element-string ((element element))
(with-output-to-string (s)
(write element :stream s :pretty t)))
(defmethod elem-str ((element element))
(with-output-to-string (s)
(write element :stream s :pretty nil)))

30
src/groups.lisp
View file

@ -1,30 +0,0 @@
(defpackage #:piccolo/groups
(:use #:cl)
(:import-from #:alexandria
#:with-gensyms
#:symbolicate
#:make-keyword)
(:export #:self-closing-tag-p
#:non-escape-tag-p))
(in-package #:piccolo/groups)
(defun symbols-hash-table (symbols)
(let ((ht (make-hash-table)))
(mapcar (lambda (sym)
(setf (gethash (make-keyword sym) ht) t))
symbols)
ht))
(defmacro define-group (name &body symbols)
(with-gensyms (ht)
`(progn
(let ((,ht (symbols-hash-table ',symbols)))
(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
link meta param source track wbr)
(define-group non-escape-tag
style script textarea pre)

7
src/main.lisp
View file

@ -1,7 +1,4 @@
(uiop:define-package :piccolo
(defpackage :piccolo
(:nicknames #:piccolo/main)
(:use #:cl)
(:use-reexport #:piccolo/escape)
(:use-reexport #:piccolo/elements)
(:use-reexport #:piccolo/generator))
(:use #:cl))
(in-package :piccolo)