├── .gitignore
├── flute-test.asd
├── flute.asd
├── src
    ├── package.lisp
    ├── element-belongs-to.lisp
    ├── util.lisp
    └── flute.lisp
├── README.md
└── t
    └── flute.lisp


/.gitignore:
--------------------------------------------------------------------------------
1 | .DS_Store
2 | 


--------------------------------------------------------------------------------
/flute-test.asd:
--------------------------------------------------------------------------------
1 | (defsystem flute-test
2 |   :author "Bo Yao <icerove@gmail.com>"
3 |   :license "MIT"
4 |   :depends-on (:flute :fiveam)
5 |   :components ((:module "t"
6 |                 :serial t
7 |                 :components
8 |                 ((:file "flute")))))
9 | 


--------------------------------------------------------------------------------
/flute.asd:
--------------------------------------------------------------------------------
 1 | (defsystem flute
 2 |   :author "Bo Yao <icerove@gmail.com>"
 3 |   :license "MIT"
 4 |   :version "0.2-dev"
 5 |   :components ((:module "src"
 6 |                 :serial t
 7 |                 :components
 8 |                 ((:file "package")
 9 |                  (:file "util")
10 |                  (:file "flute"))))
11 |   :description "A beautiful, easilly composable HTML5 generation library"
12 |   :long-description
13 |   #.(uiop:read-file-string
14 |      (uiop:subpathname *load-pathname* "README.md"))
15 |   :in-order-to ((test-op (test-op flute-test)))
16 |   :depends-on (:assoc-utils
17 |                :let-over-lambda))
18 | 


--------------------------------------------------------------------------------
/src/package.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :cl-user)
 2 | (defpackage flute
 3 |   (:use :cl)
 4 |   (:import-from :assoc-utils
 5 |                 :alist
 6 |                 :alistp
 7 |                 :hash-alist
 8 |                 :aget
 9 |                 :delete-from-alistf)
10 |   (:import-from :let-over-lambda
11 |                 :defmacro!
12 |                 :mkstr
13 |                 :flatten)
14 |   (:import-from :alexandria
15 |                 :make-keyword
16 |                 :if-let)
17 |   (:export
18 |    ;;; builtin HTML elements
19 |    ;;; all html5 elements, e.g. div, nav, media, export in code except
20 |    ;;; <time> and <map> conflicts with cl symbol, are defined and
21 |    ;;; exported as |time|, |map|
22 |    :html
23 | 
24 |    ;;; user defined elements
25 |    :define-element
26 |    :*expand-user-element*
27 |    ;; for reference tag name, attributes and children elements in user
28 |    ;; element definition
29 |    :tag
30 |    :children
31 |    :attrs
32 | 
33 |    ;;; attribute accessing utilility
34 |    :attrs-alist
35 |    :make-attrs
36 |    :copy-attrs
37 |    :attr
38 |    :delete-attr
39 | 
40 |    ;;; element slots
41 |    :element-tag
42 |    :element-attrs
43 |    :element-children
44 |    :user-element-expand-to
45 | 
46 |    ;;; the h macro for avoiding import all builtin html element functions
47 |    :h
48 | 
49 |    ;;; escape utility
50 |    :*escape-html*
51 |    :escape-string
52 |    :utf8-html-escape-char-p
53 |    :ascii-html-escape-char-p
54 |    :attr-value-escape-char-p
55 | 
56 |    ;;; helper for generate html string
57 |    :element-string
58 |    :elem-str))
59 | 


--------------------------------------------------------------------------------
/src/element-belongs-to.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :flute)
  2 | 
  3 | (defparameter *attribute-belongs-to*
  4 |   '((accept	input)
  5 |     (accept-charset	form)
  6 |     (accesskey	*)
  7 |     (action	form)
  8 |     (alt	area img input)
  9 |     (async	script)
 10 |     (autocomplete	form input)
 11 |     (autofocus	button input select textarea)
 12 |     (autoplay	audio video)
 13 |     (charset	meta script)
 14 |     (checked	input)
 15 |     (cite	blockquote del ins q)
 16 |     (class	*)
 17 |     (cols	textarea)
 18 |     (colspan	td th)
 19 |     (content	meta)
 20 |     (contenteditable	*)
 21 |     (controls	audio video)
 22 |     (coords	area)
 23 |     (data	object)
 24 |     (data-*	*)
 25 |     (datetime	del ins time)
 26 |     (default	track)
 27 |     (defer	script)
 28 |     (dir	*)
 29 |     (dirname	input textarea)
 30 |     (disabled	button fieldset input optgroup option select textarea)
 31 |     (download	a area)
 32 |     (draggable	*)
 33 |     (dropzone	*)
 34 |     (enctype	form)
 35 |     (for	label output)
 36 |     (form	button fieldset input label meter object output select textarea)
 37 |     (formaction	button input)
 38 |     (headers	td th)
 39 |     (height	canvas embed iframe img input object video)
 40 |     (hidden	*)
 41 |     (high	meter)
 42 |     (href	a area base link)
 43 |     (hreflang	a area link)
 44 |     (http-equiv	meta)
 45 |     (id	*)
 46 |     (ismap	img)
 47 |     (kind	track)
 48 |     (label	track option optgroup)
 49 |     (lang	*)
 50 |     (list	input)
 51 |     (loop	audio video)
 52 |     (low	meter)
 53 |     (max	input meter progress)
 54 |     (maxlength	input textarea)
 55 |     (media	a area link source style)
 56 |     (method	form)
 57 |     (min	input meter)
 58 |     (multiple	input select)
 59 |     (muted	video audio)
 60 |     (name	button fieldset form iframe input map meta object output param select textarea)
 61 |     (novalidate	form)
 62 |     (onabort	audio embed img object video)
 63 |     (onafterprint	body)
 64 |     (onbeforeprint	body)
 65 |     (onbeforeunload	body)
 66 |     (onblur	All visible elements.)
 67 |     (oncanplay	audio embed object video)
 68 |     (oncanplaythrough	audio video)
 69 |     (onchange	All visible elements.)
 70 |     (onclick	All visible elements.)
 71 |     (oncontextmenu	All visible elements.)
 72 |     (oncopy	All visible elements.)
 73 |     (oncuechange	track)
 74 |     (oncut	+)
 75 |     (ondblclick	+)
 76 |     (ondrag	+)
 77 |     (ondragend	+)
 78 |     (ondragenter	+)
 79 |     (ondragleave	+)
 80 |     (ondragover	+)
 81 |     (ondragstart	+)
 82 |     (ondrop	+)
 83 |     (ondurationchange	audio video)
 84 |     (onemptied	audio video)
 85 |     (onended	audio video)
 86 |     (onerror	audio body embed img object script style video)
 87 |     (onfocus	+)
 88 |     (onhashchange	body)
 89 |     (oninput	+)
 90 |     (oninvalid	+)
 91 |     (onkeydown	+)
 92 |     (onkeypress	+)
 93 |     (onkeyup	+)
 94 |     (onload	body iframe img input link script style)
 95 |     (onloadeddata	audio video)
 96 |     (onloadedmetadata	audio video)
 97 |     (onloadstart	audio video)
 98 |     (onmousedown	+)
 99 |     (onmousemove	+)
100 |     (onmouseout	+)
101 |     (onmouseover	+)
102 |     (onmouseup	+)
103 |     (onmousewheel	+)
104 |     (onoffline	body)
105 |     (ononline	body)
106 |     (onpagehide	body)
107 |     (onpageshow	body)
108 |     (onpaste	+)
109 |     (onpause	audio video)
110 |     (onplay	audio video)
111 |     (onplaying	audio video)
112 |     (onpopstate	body)
113 |     (onprogress	audio video)
114 |     (onratechange	audio video)
115 |     (onreset	form)
116 |     (onresize	body)
117 |     (onscroll	+)
118 |     (onsearch	input)
119 |     (onseeked	audio video)
120 |     (onseeking	audio video)
121 |     (onselect	+)
122 |     (onstalled	audio video)
123 |     (onstorage	body)
124 |     h(onsubmit	form)
125 |     (onsuspend	audio video)
126 |     (ontimeupdate	audio video)
127 |     (ontoggle	details)
128 |     (onunload	body)
129 |     (onvolumechange	audio video)
130 |     (onwaiting	audio video)
131 |     (onwheel	+)
132 |     (open	details)
133 |     (optimum	meter)
134 |     (pattern	input)
135 |     (placeholder	input textarea)
136 |     (poster	video)
137 |     (preload	audio video)
138 |     (readonly	input textarea)
139 |     (rel	a area link)
140 |     (required	input select textarea)
141 |     (reversed	ol)
142 |     (rows	textarea)
143 |     (rowspan	td th)
144 |     (sandbox	iframe)
145 |     (scope	th)
146 |     (selected	option)
147 |     (shape	area)
148 |     (size	input select)
149 |     (sizes	img link source)
150 |     (span	col colgroup)
151 |     (spellcheck	*)
152 |     (src	audio embed iframe img input script source track video)
153 |     (srcdoc	iframe)
154 |     (srclang	track)
155 |     (srcset	img source)
156 |     (start	ol)
157 |     (step	input)
158 |     (style	*)
159 |     (tabindex	*)
160 |     (target	a area base form)
161 |     (title	*)
162 |     (translate	*)
163 |     (type	button embed input link menu object script source style)
164 |     (usemap	img object)
165 |     (value	button input li option meter progress param)
166 |     (width	canvas embed iframe img input object video)
167 |     (wrap	textarea)))
168 | 


--------------------------------------------------------------------------------
/src/util.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :flute)
  2 | 
  3 | (defun plist-alist (plist)
  4 |   (loop for (k v) on plist by #'cddr
  5 |      collect (cons k v)))
  6 | 
  7 | (defun alist-plist* (alist)
  8 |   (mapcan (lambda (kv)
  9 |             (list (string-downcase (car kv))
 10 |                   (cdr kv)))
 11 |           alist))
 12 | 
 13 | (defstruct !expanded list)
 14 | 
 15 | (defun tree-leaves%% (tree test result)
 16 |   (if tree
 17 |       (if (listp tree)
 18 |           (let ((car-result (tree-leaves%% (car tree) test result))
 19 |                 (cdr-result (tree-leaves%% (cdr tree) test result)))
 20 |             (if (!expanded-p car-result)
 21 |              (append (!expanded-list car-result) cdr-result)
 22 |              (cons car-result cdr-result)))
 23 |           (if (funcall test tree)
 24 |               (funcall result tree)
 25 |               tree))))
 26 | 
 27 | (defmacro tree-leaves (tree test result)
 28 |   `(tree-leaves%%
 29 |      ,tree
 30 |      (lambda (x)
 31 |        (declare (ignorable x))
 32 |        ,test)
 33 |      (lambda (x)
 34 |        (declare (ignorable x))
 35 |        ,result)))
 36 | 
 37 | (defun utf8-html-escape-char-p (char)
 38 |   (find char "<>&"))
 39 | 
 40 | (defun ascii-html-escape-char-p (char)
 41 |   (or (utf8-html-escape-char-p char)
 42 |       (> (char-code char) 127)))
 43 | 
 44 | (defun attr-value-escape-char-p (char)
 45 |   (eql char #\"))
 46 | 
 47 | (defun escape-char (char)
 48 |   (case char
 49 |     (#\< "&lt;")
 50 |     (#\> "&gt;")
 51 |     (#\& "&amp;")
 52 |     (#\' "&#039;")
 53 |     (#\" "&quot;")
 54 |     (t (format nil "&#~d;" (char-code char)))))
 55 | 
 56 | (defun escape-string (string &optional (test #'utf8-html-escape-char-p))
 57 |   (if (stringp string)
 58 |       (with-output-to-string (s)
 59 |         (loop
 60 |            for c across string
 61 |            do (write (if (funcall test c) (escape-char c) c) :stream s :escape nil)))
 62 |       string))
 63 | 
 64 | (defun escape-attrs-alist (alist)
 65 |   (mapcar (lambda (kv)
 66 |             (cons (car kv)
 67 |                   (escape-string (cdr kv) #'attr-value-escape-char-p)))
 68 |           alist))
 69 | 
 70 | (defun escape-children (children)
 71 |   (mapcar (lambda (child)
 72 |             (if (stringp child)
 73 |                 (case *escape-html*
 74 |                   (:utf8 (escape-string child))
 75 |                   (:ascii (escape-string child #'ascii-html-escape-char-p))
 76 |                   (otherwise child))
 77 |                 child))
 78 |           children))
 79 | 
 80 | (defun split-attrs-and-children (attrs-and-children)
 81 |   (cond
 82 |     ((attrs-p (first attrs-and-children))
 83 |      (values (first attrs-and-children) (flatten (rest attrs-and-children))))
 84 |     ((alistp (first attrs-and-children))
 85 |      (values (make-attrs :alist (first attrs-and-children))
 86 |              (flatten (rest attrs-and-children))))
 87 |     ((listp (first attrs-and-children))
 88 |      (values (make-attrs :alist (plist-alist (first attrs-and-children)))
 89 |              (flatten (rest attrs-and-children))))
 90 |     ((hash-table-p (first attrs-and-children))
 91 |      (values (make-attrs :alist (hash-alist (first attrs-and-children)))
 92 |              (flatten (rest attrs-and-children))))
 93 |     ((and (vectorp (first attrs-and-children))
 94 |           (keywordp (aref (first attrs-and-children) 0)))
 95 |      (append-inline-attrs attrs-and-children))
 96 |     ((keywordp (first attrs-and-children))
 97 |      (loop for thing on attrs-and-children by #'cddr
 98 |         for (k v) = thing
 99 |         when (and (keywordp k) v)
100 |           collect (cons k v) into attrs
101 |         when (not (keywordp k))
102 |           return (values (make-attrs :alist attrs) (flatten thing))
103 |         finally (return (values (make-attrs :alist attrs) nil))))
104 |     (t
105 |      (values (make-attrs :alist nil) (flatten attrs-and-children)))))
106 | 
107 | (defun append-inline-attrs (attrs-and-children)
108 |   (let* ((inline-attrs (coerce (first attrs-and-children) 'list))
109 |          (id (getf inline-attrs :id))
110 |          (class (getf inline-attrs :class)))
111 |     (multiple-value-bind (attrs children)
112 |         (split-attrs-and-children (rest attrs-and-children))
113 |       (when (and id (not (attr attrs :id)))
114 |         (setf (attr attrs :id) id))
115 |       (when class
116 |         (if-let (other-class (attr attrs :class))
117 |           (setf (attr attrs :class) (format nil "~a ~a" class other-class))
118 |           (setf (attr attrs :class) class)))
119 |       (values attrs children))))
120 | 
121 | (defun collect-until-dot-or-sharp (string)
122 |   (let ((pos (position-if (lambda (c) (or (char= c #\.) (char= c #\#))) string)))
123 |     (if pos
124 |         (cons (subseq string 0 pos) (subseq string pos))
125 |         (cons string ""))))
126 | 
127 | (defun collect-name-as-keyword (symbol)
128 |   (make-keyword (car (collect-until-dot-or-sharp (string symbol)))))
129 | 
130 | (defun collect-id-and-class (symbol)
131 |   (let (name id class next-is)
132 |     (do ((current-and-remains (collect-until-dot-or-sharp (string-downcase (string symbol)))
133 |                               (collect-until-dot-or-sharp (cdr current-and-remains))))
134 |         ((string= "" (car current-and-remains))
135 |          (values name id (when class (format nil "~{~a~^ ~}" (nreverse class)))))
136 |       (case next-is
137 |         (:id (setf id (car current-and-remains)))
138 |         (:class (push (car current-and-remains) class))
139 |         (otherwise (setf name (car current-and-remains))))
140 |       (unless (string= "" (cdr current-and-remains))
141 |         (setf next-is (ecase (aref (cdr current-and-remains) 0)
142 |                         (#\# :id)
143 |                         (#\. :class))
144 |               (cdr current-and-remains) (subseq (cdr current-and-remains) 1))))))
145 | 


--------------------------------------------------------------------------------
/src/flute.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :flute)
  2 | 
  3 | (defclass element ()
  4 |   ((tag :initarg :tag
  5 |         :accessor element-tag)
  6 |    (attrs :initarg :attrs
  7 |           :accessor element-attrs)
  8 |    (children :initarg :children
  9 |              :accessor element-children)))
 10 | 
 11 | (defclass builtin-element (element) ())
 12 | 
 13 | (defclass builtin-element-with-prefix (builtin-element)
 14 |   ((prefix :initarg :prefix
 15 |            :accessor element-prefix)))
 16 | 
 17 | (defclass user-element (element)
 18 |   ((expand-to :initarg :expander
 19 |               :accessor user-element-expander)))
 20 | 
 21 | (defun make-builtin-element (&key tag attrs children)
 22 |   (make-instance 'builtin-element :tag tag :attrs attrs
 23 |                  :children (escape-children children)))
 24 | 
 25 | (defun make-builtin-element-with-prefix (&key tag attrs children prefix)
 26 |   (make-instance 'builtin-element-with-prefix :tag tag :attrs attrs :prefix prefix
 27 |                  :children (escape-children children)))
 28 | 
 29 | (defun make-user-element (&rest args &key tag attrs children expander)
 30 |   (make-instance 'user-element :tag tag :attrs attrs :expander expander
 31 |                  :children (escape-children children)))
 32 | 
 33 | (defmethod user-element-expand-to ((element user-element))
 34 |   (funcall (user-element-expander element)
 35 |            (element-tag element)
 36 |            (element-attrs element)
 37 |            (element-children element)))
 38 | 
 39 | (defstruct (attrs (:constructor %make-attrs))
 40 |   alist)
 41 | 
 42 | (defvar *escape-html* :utf8
 43 |   "Specify the escape option when generate html, can be :UTF8, :ASCII, :ATTR or NIL.
 44 | If :UTF8, escape only #\<, #\> and #\& in body, and \" in attribute keys. #\' will
 45 | in attribute keys will not be escaped since flute will always use double quote for
 46 | attribute keys.
 47 | If :ASCII, besides what escaped in :UTF8, also escape all non-ascii characters.
 48 | If :ATTR, only #\" in attribute values will be escaped.
 49 | If NIL, nothing is escaped and programmer is responsible to escape elements properly.
 50 | When given :ASCII and :ATTR, it's possible to insert html text as a children, e.g.
 51 | (div :id \"container\" \"Some <b>text</b>\")")
 52 | 
 53 | (defun make-attrs (&key alist)
 54 |   (if *escape-html*
 55 |       (%make-attrs :alist (escape-attrs-alist alist))
 56 |       (%make-attrs :alist alist)))
 57 | 
 58 | (defmethod (setf attr) (value (attrs attrs) key)
 59 |   (setf (aget (attrs-alist attrs) key) value))
 60 | 
 61 | (defmethod delete-attr ((attrs attrs) key)
 62 |   (delete-from-alistf (attrs-alist attrs) key))
 63 | 
 64 | (defmethod attr ((attrs attrs) key)
 65 |   (aget (attrs-alist attrs) key))
 66 | 
 67 | (defmethod (setf attr) (value (element element) key)
 68 |   (setf (attr (element-attrs element) key) value))
 69 | 
 70 | (defmethod delete-attr ((element element) key)
 71 |   (delete-attr (element-attrs element) key))
 72 | 
 73 | (defmethod attr ((element element) key)
 74 |   (attr (element-attrs element) key))
 75 | 
 76 | (defvar *builtin-elements* (make-hash-table))
 77 | 
 78 | (defun html (&rest attrs-and-children)
 79 |   (multiple-value-bind (attrs children)
 80 |       (split-attrs-and-children attrs-and-children)
 81 |     (make-builtin-element-with-prefix :tag "html" :attrs attrs
 82 |                                       :children children
 83 |                                       :prefix "<!DOCTYPE html>")))
 84 | (setf (gethash :html *builtin-elements*) t)
 85 | 
 86 | (defmacro define-builtin-element (element-name)
 87 |   `(defun ,element-name (&rest attrs-and-children)
 88 |      (multiple-value-bind (attrs children)
 89 |          (split-attrs-and-children attrs-and-children)
 90 |        (make-builtin-element :tag (string-downcase (mkstr ',element-name))
 91 |                              :attrs attrs :children children))))
 92 | 
 93 | (defmacro define-and-export-builtin-elements (&rest element-names)
 94 |   `(progn
 95 |      ,@(mapcan (lambda (e)
 96 |                  (list `(define-builtin-element ,e)
 97 |                        `(setf (gethash (make-keyword ',e) *builtin-elements*) t)
 98 |                        `(export ',e)))
 99 |                element-names)))
100 | 
101 | (define-and-export-builtin-elements
102 |     a abbr address area article aside audio b base bdi bdo blockquote
103 |     body br button canvas caption cite code col colgroup data datalist
104 |     dd del details dfn dialog div dl dt em embed fieldset figcaption
105 |     figure footer form h1 h2 h3 h4 h5 h6 head header hr i iframe
106 |     img input ins kbd label legend li link main |map| mark meta meter nav
107 |     noscript object ol optgroup option output p param picture pre progress
108 |     q rp rt ruby s samp script section select small source span strong
109 |     style sub summary sup svg table tbody td template textarea tfoot th
110 |     thead |time| title tr track u ul var video wbr)
111 | 
112 | (defmethod print-object ((attrs attrs) stream)
113 |   (if (attrs-alist attrs)
114 |       (format stream " ~{~a=~s~^ ~}" (alist-plist* (attrs-alist attrs)))
115 |       (format stream "")))
116 | 
117 | (defmethod print-object ((element element) stream)
118 |   (if (element-children element)
119 |       (format stream (if (rest (element-children element))
120 |                          "~@<<~a~a>~2I~:@_~<~@{~a~^~:@_~}~:>~0I~:@_</~a>~:>"
121 |                          "~@<<~a~a>~2I~:_~<~a~:>~0I~:_</~a>~:>")
122 |               (element-tag element)
123 |               (element-attrs element)
124 |               (element-children element)
125 |               (element-tag element))
126 |       (format stream "<~a~a>" (element-tag element) (element-attrs element))))
127 | 
128 | (defmethod print-object ((element builtin-element-with-prefix) stream)
129 |   (format stream "~a~%" (element-prefix element))
130 |   (call-next-method))
131 | 
132 | (defmacro! define-element (name (&rest args) &body body)
133 |   `(defun ,name (&rest ,g!attrs-and-children)
134 |      (multiple-value-bind (,g!attrs ,g!children)
135 |          (split-attrs-and-children ,g!attrs-and-children)
136 |        (let ((,g!element
137 |               (make-user-element :tag (string-downcase ',name) :attrs ,g!attrs
138 |                                  :children ,g!children)))
139 |          (setf (user-element-expander ,g!element)
140 |                (lambda (tag attrs children)
141 |                  (declare (ignorable tag attrs children))
142 |                  (let ,(mapcar (lambda (arg)
143 |                                  (list arg `(attr attrs (make-keyword ',arg))))
144 |                                args)
145 |                    (progn ,@body))))
146 |          ,g!element))))
147 | 
148 | (defvar *expand-user-element* t)
149 | 
150 | (defmethod print-object ((element user-element) stream)
151 |   (if *expand-user-element*
152 |       (print-object (user-element-expand-to element) stream)
153 |       (call-next-method)))
154 | 
155 | (defun html-element-p (x)
156 |   (and (symbolp x) (not (keywordp x)) (gethash (collect-name-as-keyword x) *builtin-elements*)))
157 | 
158 | (defmacro h (&body body)
159 |   `(progn
160 |      ,@(tree-leaves
161 |         body
162 |         (html-element-p x)
163 |         (multiple-value-bind (name id class) (collect-id-and-class x)
164 |           (if (or id class)
165 |               (make-!expanded :list (list (find-symbol (string-upcase name) :flute)
166 |                                           (coerce (append (when id (list :id id))
167 |                                                           (when class (list :class class)))
168 |                                                   'vector)))
169 |               (find-symbol (string-upcase name) :flute))))))
170 | 
171 | ;;; Experimental
172 | ;; (when (find :illusion *features*)
173 | ;;   (illusion:set-paren-reader
174 | ;;    :flute
175 | ;;    #'html-element-p
176 | ;;    (lambda (stream indicator)
177 | ;;      (multiple-value-bind (name id class) (collect-id-and-class indicator)
178 | ;;        (if (or id class)
179 | ;;            (list* (find-symbol (string-upcase name) :flute)
180 | ;;                   (coerce (append (when id (list :id))
181 | ;;                                  (when class (list :class class)))
182 | ;;                           'vector)
183 | ;;                   (illusion:cl-read-list stream))
184 | ;;            (cons (find-symbol (string-upcase name) :flute)
185 | ;;                  (illusion:cl-read-list stream)))))))
186 | 
187 | (defmethod element-string ((element element))
188 |   (with-output-to-string (s)
189 |     (write element :stream s)))
190 | 
191 | (defmethod elem-str ((element element))
192 |   (with-output-to-string (s)
193 |     (write element :stream s :pretty nil)))
194 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # Flute
  2 | 
  3 | Flute is a beautiful, easily composable HTML5 generation library in Common Lisp. It's
  4 | 
  5 | - Simple: the most simplistic syntax, for builtin and customized elements;
  6 | - Easy to debug: pretty print generated html snippet in REPL;
  7 | - Powerful: help you define reusable and composable components, like that in React
  8 | - Modern: focus only on HTML5
  9 | 
 10 | # Getting started
 11 | 
 12 | ## Install and run tests
 13 | 
 14 | ```lisp
 15 | (ql:quickload :flute)
 16 | (ql:quickload :flute-test)
 17 | ```
 18 | 
 19 | Then define a new package specifically for HTML generation, in its definition:
 20 | ```lisp
 21 | (defpackage flute-user
 22 |   (:use :cl :flute))
 23 | ```
 24 | If you don't want to import all symbols, see [H Macro](#h-macro), which provide a similar interface as a tranditional Lisp HTML generation library.
 25 | 
 26 | ## Using html elements
 27 | ```
 28 | (html
 29 |   (head
 30 |     (link :rel "...")
 31 |     (script :src "..."))
 32 |   (body
 33 |     (div :id "a" :class "b"
 34 |       (p :style "color: red"
 35 |         "Some text")
 36 |       "Some text in div"
 37 |       (img :src "/img/dog.png")
 38 |       (a '(:href "/cat")
 39 |         (img '((:src . "/img/cat.png")))))))
 40 | ```
 41 | 
 42 | These `html`, `div`, etc. are just functions. Element attribute can be given inline as the above example, or as alist/plist/attrs object as the first argument, like the last `a` and `img` in the above example. In this case they can be variables that calculated programmatically.
 43 | 
 44 | The remaining argument will be recognized as the children of this element. Each child can be:
 45 | 1. string;
 46 | 2. element, builtin or user defined;
 47 | 3. list of 1, 2 and 3. Can also be NIL.
 48 | All children will be flattened as if they're given inline.
 49 | 
 50 | ## Define new element
 51 | ```lisp
 52 | (define-element dog (id size)
 53 |   (if (and (realp size) (> size 10))
 54 |       (div :id id :class "big-dog"
 55 |               children
 56 |               "dog")
 57 |       (div :id id :class "small-dog"
 58 |               children
 59 |               "dog")))
 60 | ```
 61 | `dog` will be defined as a function that takes `:id` and `:size` keyword arguments. `dog` returns an user-defined element object. Inside it, `children` will be replaced with the children elements you provided when creating this `dog`:
 62 | ```
 63 | FLUTE-USER> (defparameter *dog1* (dog :id "dog1" :size 20))
 64 | *DOG1*
 65 | FLUTE-USER> *dog1*
 66 | <div id="dog1" class="big-dog">dog</div>
 67 | FLUTE-USER> (dog :id "dog2" "I am a dog" *)
 68 | <div id="dog2" class="small-dog">
 69 |   I am a dog
 70 |   <div id="dog1" class="big-dog">dog</div>
 71 |   dog
 72 | </div>
 73 | ```
 74 | 
 75 | All elements, both builtin and user defined ones are objects, although they're printed as html snippet in REPL. Their attribute can be accessed by `(element-attrs element)`. Their children can be accessed by `(element-children elements)` and tag name by `(element-tag element)`. You can modify an exising element's attrs and children. If you modify a user defined element, the body you defined in it's `define-element` also re-executed to take effect of the the attrs and children change:
 76 | ```
 77 | FLUTE-USER> *dog1*
 78 | <div id="dog1" class="big-dog">dog</div>
 79 | FLUTE-USER> (setf (attr *dog1* :size) 10
 80 |                   ;; attr is a helper method to set (flute:element-attrs *dog1*)
 81 |                   (attr *dog1* :id) "dooooog1"
 82 |                   (element-children *dog1*) (list "i'm small now"))
 83 | ("i'm small now")
 84 | FLUTE-USER> *dog1*
 85 | <div id="dooooog1" class="small-dog">
 86 |   i'm small now
 87 |   dog
 88 | </div>
 89 | ```
 90 | 
 91 | By default user element is printed as what it expand to. If you have a lot of user defined element nested deeply, you probably want to have a look at the high level:
 92 | ```
 93 | FLUTE-USER> (let ((*expand-user-element* nil))
 94 |               (print *dog1*)
 95 |               (values))
 96 | 
 97 | <dog id="dooooog1" size=10>i'm small now</dog>
 98 | ; No value
 99 | FLUTE-USER>
100 | ```
101 | 
102 | ## Generate HTML
103 | To generate a piece of HTML string that probably used in a response of a backend service:
104 | ```lisp
105 | (elem-str element)
106 | ```
107 | To generate HTML string that has nice indent as that in REPL:
108 | ```lisp
109 | (element-string element)
110 | ```
111 | To generate that and write to file, just create a stream, then `(write element :stream stream)` for human or `(write element :stream stream :pretty nil)` for production.
112 | 
113 | ## H macro
114 | If you don't want to import all the symbols, you can use the `h` macro:
115 | ```lisp
116 | (defpackage flute-min
117 |   (:use :cl)
118 |   (:import-from :flute
119 |                 :h
120 |                 :define-element))
121 | ```
122 | Then just wrap `h` for all html generation part. In the same examples above, it becomes:
123 | ``` lisp
124 | (in-package :flute-min)
125 | (h (html
126 |      (head
127 |        (link :rel "...")
128 |        (script :src "..."))
129 |      (body
130 |        (div :id "a" :class "b"
131 |          (p :style "color: red"
132 |            "Some text")
133 |          "Some text in div"
134 |          (img :src "/img/dog.png")
135 |          (a '(:href "/cat")
136 |            (img '((:src . "/img/cat.png"))))))))
137 | 
138 | (define-element dog (id size)
139 |   (if (and (realp size) (> size 10))
140 |       (h (div :id id :class "big-dog"
141 |               flute:children
142 |               "dog"))
143 |       (h (div :id id :class "small-dog"
144 |               flute:children
145 |               "dog"))))
146 | 
147 | (defparameter *dog2* (dog :id "dog2" :size 20 "some children"))
148 | ```
149 | From version 0.2 (available in Aug 2018 Quicklisp), flute supports css style id and class attribute for builtin elements. For example `div#id-name.class1.class2`, So you can also write:
150 | ```lisp
151 | (h (div#a.b "..."))
152 | ;; Provide additional class and attributes
153 | (h (div#a.b :class "c" :onclick "fun()"))
154 | ```
155 | 
156 | ## Inline CSS and JavaScript
157 | With help of [cl-css](https://github.com/Inaimathi/cl-css) (available in Quicklisp), You can write inline CSS for the `style` attribute, in a similar syntax like flute:
158 | ```lisp
159 | (div :style (inline-css '(:margin 5px :padding 0px)))
160 | ```
161 | `cl-css:inline-css` is a function taking plist and returns the result css string, so it can be safely used inside or outside of `H` macro and with variable arguments.
162 | 
163 | With help of [Parenscript](https://github.com/vsedach/Parenscript) (available in Quicklisp), You can write inline JavaScript for `onclick`, etc. attribute:
164 | ```lisp
165 | (button :onclick (ps-inline (func)))
166 | ```
167 | 
168 | That's all you need to know to define elements and generate html. Please reference the [API Reference](#api-reference) Section for detailed API.
169 | 
170 | # Change Logs
171 | ## 2018/07/28 Version 0.2-dev
172 | - Support `element#id.class1.class2` in `H` macro for builtin elements;
173 | - Suggestions on inline CSS and JavaScript in lispy way;
174 | - Jon Atack fix an error example in README.
175 | ## 2018/07/11 Version 0.1
176 | - Current features, APIs and Tests.
177 | 
178 | # Motivation
179 | Currently there're a few HTML generation library in Common Lisp, like [CL-WHO](https://edicl.github.io/cl-who/), [CL-MARKUP](https://github.com/arielnetworks/cl-markup) and [Spinneret](https://github.com/ruricolist/spinneret). They both have good features for generating standard HTML, but not very good at user element (components) that currently widely used in frontend: you need to define all of them as macros and to define components on top of these components, you'll have to make these components more complex macros to composite them. [Spinneret](https://github.com/ruricolist/spinneret) has a `deftag` feature, but `deftag` is still expand to a `defmacro`.
180 | 
181 | I'd also want to modify the customer component attribute after create it and incorporate it with it's own logic (like the dog size example above), this logic should be any lisp code. This requires provide all element as object, not plain HTML text generation. With this approach, all elements have a same name function to create it, and returns element that you can modify later. These objects are virtual doms and it's very pleasant to write html code and frontend component by just composite element objects as arguments in element creation function calls. Flute's composite feature inspired by [Hiccup](https://github.com/weavejester/hiccup) and [Reagent](https://github.com/reagent-project/reagent) but more powerful -- in flute, user defined elements is real object with attributes and it's own generation logic.
182 | 
183 | # Limitation
184 | With the function name approach, it's not possible to support `div.id#class1#class2` style function names. I'm working on some tweak of reader macros in [illusion](https://github.com/ailisp/illusion) library to detect this and convert it to `(div :id "id" :class "class1 class2" ...)` call
185 | 
186 | The most and major limitation is we don't have a substential subset of Common Lisp in browser so flute can be used in frontend. [Parenscript](https://github.com/vsedach/Parenscript) is essentially a JavaScript semantic in Lisp like syntax. [JSCL](https://github.com/jscl-project/jscl) is promosing, but by now it seems focus on creating a CL REPL on Web and doesn't support `format` or CLOS. Also we lack enough infrastructure to build Common Lisp to JavaScript (might be an asdf plugin) and connect to a browser "Swank" via WebSocket from Emacs. I'll be working these: a full or at least substential subset of Common Lisp to JavaScript Compiler to eventually have a full frontend development environment in Common Lisp. Any help or contribution is welcome.
187 | 
188 | # API Reference
189 | Here is a draft version of API Reference, draft means it will be better organized and moved to a separate HTML doc, but it's content is already quite complete.
190 | 
191 | ## Builtin HTML elements
192 | ```
193 |     a abbr address area article aside audio b base bdi bdo blockquote
194 |     body br button canvas caption cite code col colgroup data datalist
195 |     dd del details dfn dialog div dl dt em embed fieldset figcaption
196 |     figure footer form h1 h2 h3 h4 h5 h6 head header hr i iframe html
197 |     img input ins kbd label legend li link main |map| mark meta meter nav
198 |     noscript object ol optgroup option output p param picture pre progress
199 |     q rp rt ruby s samp script section select small source span strong
200 |     style sub summary sup svg table tbody td template textarea tfoot th
201 |     thead |time| title tr track u ul var video wbr
202 | ```
203 | All of above HTML5 elements are functions, which support same kinds of parameters, take `A` as example:
204 | ``` lisp
205 | ;; Function A &REST ATTRS-AND-CHILREN
206 | ;;
207 | ;; Create and return an <a> element object
208 | ;; ATTRS-AND-CHILDREN can be the following:
209 | 
210 | ;; 1. an empty <a> tag
211 | (a)
212 | 
213 | ;; 2. attributes of alist, plist or ATTRS object
214 | ;; The following creates: <a id="aa" customer-attr="bb">
215 | (a :id "aa" :customer-attr "bb")
216 | (a '(:id "aa" :customer-attr "bb"))
217 | (a '((:id . "aa") (:customer-attr . "bb")))
218 | ;; or assume we have the above one in variable a1
219 | (a (element-attrs a1)) ; to share the same attrs with a1
220 | (a (copy-attrs (element-attrs a1)))
221 | 
222 | ;; 3. any of above format attributes with children
223 | (a :id "aa" :customer-attr "bb"
224 |   "Some children"
225 |   (div '(:id "an element children"))
226 |   ; list of any depth containing elements and texts, will be flattened
227 |   (list a1 a2 (a '((:id . "aaa")) "some text")
228 |         (list (h1 "aaa")))
229 |   "some other text")
230 | ```
231 | The `HTML` element is a little special, it's with `<!DOCTYPE html>` prefix to make sure browser recognize it correctly.
232 | 
233 | ## User defined elements
234 | ```lisp
235 | ;; Macro DEFINE-ELEMENT NAME (&REST ARGS) &BODY BODY
236 | ;;
237 | ;; Define a user element with NAME as its tag name and function
238 | ;; NAME. After DEFINE-ELEMENT, a FUNCTION of NAME in current package
239 | ;; is defined. ARGS specified the possible keyword ARGS it can take as
240 | ;; it's ATTRS. You can either use these ARGS as Lisp arguments in the
241 | ;; BODY of its definition and plug in them to the BODY it expand to.
242 | ;; You can use FLUTE:CHILDREN to get or set it's children that you give
243 | ;; when call function NAME, FLUTE:ATTRS to get or set it's attributes
244 | ;; and FLUTE:TAG to get or set it's tag name.
245 | 
246 | ;; Variable *EXPAND-USER-ELEMENT*
247 | ;;
248 | ;; Bind this variable to specify whether the user elements are print in
249 | ;; a high level (NIL), or expand to HTML elements (T). T by default.
250 | ```
251 | 
252 | ## Attribute accessing utility
253 | ``` lisp
254 | ;; Function ATTRS-ALIST ATTRS
255 | ;; Function (SETF ATTRS-ALIST) ATTRS
256 | ;;
257 | ;; Return or set the attrs object in alist format
258 | 
259 | ;; Function MAKE-ATTRS &KEYS ALIST
260 | ;;
261 | ;; Create a attrs aoject, given an alist of (:attr . "attr-value") pair.
262 | ;; Attribute values (cdr of each element in alist) will be escaped if
263 | ;; *ESCAPE-HTML* is not NIL
264 | 
265 | ;; Function COPY-ATTRS ATTRS
266 | ;;
267 | ;; Make a copy and return the copy of ATTRS object
268 | 
269 | ;; Method ATTR ATTRS KEY
270 | ;; Method (SETF ATTR) ATTRS KEY
271 | ;; Method ATTR ELEMENT KEY
272 | ;; Method (SETF ATTR) ELEMENT KEY
273 | ;;
274 | ;; Get or set the attribute value of given KEY. KEY should be an keyword.
275 | ;; If KEY does not exist, ATTR method will return NIL. (SETF ATTR) method
276 | ;; will create the (KEY . VALUE) pair. Don't use (SETF (ATTR ATTRS :key) NIL)
277 | ;; or (SETF (ATTR ELEMENT :key) NIL) to remove an attr, use DELETE-ATTR.
278 | 
279 | ;; Method DELETE-ATTR ATTRS KEY
280 | ;; Method DELETE-ATTR ELEMENT KEY
281 | ;;
282 | ;; Delete the attribute key value pair from ATTRS or ELEMENT's ELEMENT-ATTRS,
283 | ;; will ignore if KEY doesn't exist.
284 | 
285 | ```
286 | 
287 | ## Element slots
288 | ```lisp
289 | ;; Method ELEMENT-TAG ELEMENT
290 | ;; Method (SETF ELEMENT-TAG) ELEMENT
291 | ;;
292 | ;; Get or set the ELEMENT-TAG STRING. For example <html>'s ELEMENT-TAG is "html"
293 | 
294 | ;; Method ELEMENT-ATTRS ELEMENT
295 | ;; Method (SETF ELEMENT-ATTRS) ELEMENT
296 | ;;
297 | ;; Get or set the ELEMENT-ATTRS. When set this, must be an ATTRS object
298 | 
299 | ;; Method ELEMENT-CHILDREN ELEMENT
300 | ;; Method (SETF ELEMENT-CHILDREN) ELEMENT
301 | ;;
302 | ;; Get or set element children. When set this manually, must given a flatten list
303 | ;; of ELEMENT or STRING.
304 | 
305 | ;; Method USER-ELEMENT-EXPAND-TO USER-ELEMENT
306 | ;;
307 | ;; Get what this USER-ELEMENT-TO. Returns the root ELEMENT after it expands.
308 | ```
309 | 
310 | ## The H macro
311 | ```lisp
312 | ;; Macro H &BODY CHILDREN
313 | ;;
314 | ;; Like a PROGN, except it will replace all html tag SYMBOLs with the same name one
315 | ;; in FLUTE PACKAGE, so you don't need to import all of them. As an alternative you
316 | ;; can import all or part of html element functions in FLUTE PACKAGE to use them
317 | ;; without H macro
318 | 
319 | ```
320 | 
321 | ## Escape utility
322 | ```lisp
323 | ;; Variable *ESCAPE-HTML*
324 | ;;
325 | ;; Specify the escape option when generate html, can be :UTF8, :ASCII, :ATTR or NIL.
326 | ;; If :UTF8, escape only #\<, #\> and #\& in body, and \" in attribute keys. #\' will
327 | ;; in attribute keys will not be escaped since flute will always use double quote for
328 | ;; attribute keys.
329 | ;; If :ASCII, besides what escaped in :UTF8, also escape all non-ascii characters.
330 | ;; If :ATTR, only #\" in attribute values will be escaped.
331 | ;; If NIL, nothing is escaped and programmer is responsible to escape elements properly.
332 | ;; When given :ASCII and :ATTR, it's possible to insert html text as a children, e.g.
333 | ;; (div :id "container" "Some <b>text</b>")
334 | ;; All the escapes are done in element creation time.
335 | 
336 | ;; Function ESCAPE-STRING STRING TEST
337 | ;;
338 | ;; Escape the STRING if it's a STRING and escaping all charaters C that satisfied
339 | ;; (FUNCALL TEST C). Return the new STRING after escape.
340 | 
341 | ;; Function UTF8-HTML-ESCAPE-CHAR-P CHAR
342 | ;;
343 | ;; Return T if CHAR is a CHARACTER that need to be escaped when HTML is UTF-8 encoded.
344 | ;; Return NIL otherwise.
345 | 
346 | ;; Function ASCII-HTML-ESCAPE-CHAR-P CHAR
347 | ;;
348 | ;; Return T if CHAR is a CHARACTER that need to be escaped when HTML is ASCII encoded.
349 | ;; Return NIL otherwise.
350 | 
351 | 
352 | ;; Function ATTR-VALUE-ESCAPE-CHAR-P CHAR
353 | ;;
354 | ;; Return T if CHAR is a CHARACTER that need to be escaped when as an attribute value.
355 | ;; Return NIL otherwise.
356 | 
357 | ```
358 | 
359 | ## Generate HTML string
360 | 
361 | ``` lisp
362 | ;; Method ELEMENT-STRING ELEMENT
363 | ;;
364 | ;; Return human readable, indented HTML string for ELEMENT
365 | 
366 | ;; Method ELEM-STR ELEMENT
367 | ;;
368 | ;; Return minify HTML string for ELEMENT
369 | ```
370 | 
371 | 
372 | # License
373 | Licensed under MIT License.
374 | Copyright (c) 2018, Bo Yao. All rights reserved.
375 | 


--------------------------------------------------------------------------------
/t/flute.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :cl-user)
  2 | (defpackage flute.test
  3 |   (:use :cl :flute :fiveam))
  4 | (in-package :flute.test)
  5 | 
  6 | (def-suite builtin-element)
  7 | (def-suite escape)
  8 | (def-suite attr-access)
  9 | (def-suite user-element)
 10 | (def-suite h-macro)
 11 | 
 12 | (in-suite builtin-element)
 13 | 
 14 | (test empty-attr
 15 |   (let* ((div1 (div))
 16 |          (div2 (div "the children text"))
 17 |          (div3 (div "text 1" "text 2"))
 18 |          (div4 (div (h1 "text 0") "text 01"
 19 |                     (list (list "text 3" div2) div3) "text 4")))
 20 |     (is (eql nil (attrs-alist (element-attrs div1))))
 21 |     (is (eql nil (element-children div1)))
 22 |     (is (eql nil (attrs-alist (element-attrs div2))))
 23 |     (is (equal (list "the children text") (element-children div2)))
 24 |     (is (eql nil (attrs-alist (element-attrs div3))))
 25 |     (is (equal (list "text 1" "text 2") (element-children div3)))
 26 |     (is (eql nil (attrs-alist (element-attrs div4))))
 27 |     (is (= 6 (length (element-children div4))))
 28 |     (let ((child1 (first (element-children div4)))
 29 |           (child2 (second (element-children div4)))
 30 |           (child3 (third (element-children div4)))
 31 |           (child4 (fourth (element-children div4)))
 32 |           (child5 (fifth (element-children div4)))
 33 |           (child6 (sixth (element-children div4))))
 34 |       (is (equal "h1" (element-tag child1)))
 35 |       (is (equal "text 01" child2))
 36 |       (is (equal "text 3" child3))
 37 |       (is (eql div2 child4))
 38 |       (is (eql div3 child5))
 39 |       (is (equal "text 4" child6)))))
 40 | 
 41 | (test attr-given-by-inline-args
 42 |   (let* ((div1 (div :id "container"))
 43 |          (div2 (div :id "cat" :class "happy"))
 44 |          (div3 (div :id "container" "some children text" div1))
 45 |          (div4 (div :id "dog" :class "happy" (list (list div1) div2) (list div3))))
 46 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div1))))
 47 |     (is (eql nil (element-children div1)))
 48 |     (is (equal '((:id . "cat") (:class . "happy")) (attrs-alist (element-attrs div2))))
 49 |     (is (eql nil (element-children div2)))
 50 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div3))))
 51 |     (is (equal (list "some children text" div1) (element-children div3)))
 52 |     (is (equal '((:id . "dog") (:class . "happy")) (attrs-alist (element-attrs div4))))
 53 |     (is (equal (list div1 div2 div3) (element-children div4)))))
 54 | 
 55 | (test attr-given-by-attrs
 56 |   (let* ((div00 (div (make-attrs)))
 57 |          (div01 (div (make-attrs :alist nil) "some text"))
 58 |          (div1 (div (make-attrs :alist '((:id . "container")))))
 59 |          (div2 (div (make-attrs :alist '((:id . "cat") (:class . "happy")))))
 60 |          (div3 (div (make-attrs :alist '((:id . "container"))) "some children text" div1))
 61 |          (div4 (div (make-attrs :alist '((:id . "dog") (:class . "happy"))) (list (list div1) div2) (list div3))))
 62 |     (is (eql nil (attrs-alist (element-attrs div00))))
 63 |     (is (eql nil (element-children div00)))
 64 |     (is (eql nil (attrs-alist (element-attrs div01))))
 65 |     (is (equal (list "some text") (element-children div01)))
 66 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div1))))
 67 |     (is (eql nil (element-children div1)))
 68 |     (is (equal '((:id . "cat") (:class . "happy")) (attrs-alist (element-attrs div2))))
 69 |     (is (eql nil (element-children div2)))
 70 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div3))))
 71 |     (is (equal (list "some children text" div1) (element-children div3)))
 72 |     (is (equal '((:id . "dog") (:class . "happy")) (attrs-alist (element-attrs div4))))
 73 |     (is (equal (list div1 div2 div3) (element-children div4)))))
 74 | 
 75 | (test attr-given-by-alist
 76 |   (let* ((div00 (div nil))
 77 |          (div01 (div nil "some text"))
 78 |          (div1 (div '((:id . "container"))))
 79 |          (div2 (div '((:id . "cat") (:class . "happy"))))
 80 |          (div3 (div '((:id . "container")) "some children text" div1))
 81 |          (div4 (div '((:id . "dog") (:class . "happy")) (list (list div1) div2) (list div3))))
 82 |     (is (eql nil (attrs-alist (element-attrs div00))))
 83 |     (is (eql nil (element-children div00)))
 84 |     (is (eql nil (attrs-alist (element-attrs div01))))
 85 |     (is (equal (list "some text") (element-children div01)))
 86 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div1))))
 87 |     (is (eql nil (element-children div1)))
 88 |     (is (equal '((:id . "cat") (:class . "happy")) (attrs-alist (element-attrs div2))))
 89 |     (is (eql nil (element-children div2)))
 90 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div3))))
 91 |     (is (equal (list "some children text" div1) (element-children div3)))
 92 |     (is (equal '((:id . "dog") (:class . "happy")) (attrs-alist (element-attrs div4))))
 93 |     (is (equal (list div1 div2 div3) (element-children div4)))))
 94 | 
 95 | (test attr-given-by-plist
 96 |   (let* ((div00 (div nil))
 97 |          (div01 (div nil "some text"))
 98 |          (div1 (div '(:id "container")))
 99 |          (div2 (div '(:id "cat" :class "happy")))
100 |          (div3 (div '(:id "container") "some children text" div1))
101 |          (div4 (div '(:id "dog" :class "happy") (list (list div1) div2) (list div3))))
102 |     (is (eql nil (attrs-alist (element-attrs div00))))
103 |     (is (eql nil (element-children div00)))
104 |     (is (eql nil (attrs-alist (element-attrs div01))))
105 |     (is (equal (list "some text") (element-children div01)))
106 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div1))))
107 |     (is (eql nil (element-children div1)))
108 |     (is (equal '((:id . "cat") (:class . "happy")) (attrs-alist (element-attrs div2))))
109 |     (is (eql nil (element-children div2)))
110 |     (is (equal '((:id . "container")) (attrs-alist (element-attrs div3))))
111 |     (is (equal (list "some children text" div1) (element-children div3)))
112 |     (is (equal '((:id . "dog") (:class . "happy")) (attrs-alist (element-attrs div4))))
113 |     (is (equal (list div1 div2 div3) (element-children div4)))))
114 | 
115 | (test builtin-element-html-generation
116 |   (let* ((html (html))
117 |          (div0 (div))
118 |          (div1 (div "some text"))
119 |          (div2 (div :id "2"))
120 |          (div3 (div :id "3" div1 div2 "some other text"))
121 |          (div4 (div :id "4" div3 (div :id "5" (a :href "a.html" "a")))))
122 |     (is (string= "<!DOCTYPE html>
123 | <html>" (element-string html)))
124 |     (is (string= "<div>" (element-string div0)))
125 |     (is (string= "<div>some text</div>" (element-string div1)))
126 |     (is (string= "<div id=\"2\">" (element-string div2)))
127 |     (is (string= "<div id=\"3\">
128 |   <div>some text</div>
129 |   <div id=\"2\">
130 |   some other text
131 | </div>" (element-string div3)))
132 |     (is (string= "<div id=\"4\">
133 |   <div id=\"3\">
134 |     <div>some text</div>
135 |     <div id=\"2\">
136 |     some other text
137 |   </div>
138 |   <div id=\"5\"><a href=\"a.html\">a</a></div>
139 | </div>" (element-string div4)))
140 | 
141 |     (is (string= "<!DOCTYPE html>
142 | <html>" (elem-str html)))
143 |     (is (string= "<div>" (element-string div0)))
144 |     (is (string= "<div>some text</div>" (elem-str div1)))
145 |     (is (string= "<div id=\"2\">" (elem-str div2)))
146 |     (is (string= "<div id=\"3\"><div>some text</div><div id=\"2\">some other text</div>"
147 |                  (elem-str div3)))
148 |     (is (string= "<div id=\"4\"><div id=\"3\"><div>some text</div><div id=\"2\">some other text</div><div id=\"5\"><a href=\"a.html\">a</a></div></div>"
149 |                  (elem-str div4)))))
150 | 
151 | (in-suite escape)
152 | 
153 | (defparameter *a-attrs*
154 |   '((:id . "nothing-to-escape")
155 |     (:class . "something-with-\"-in-value")
156 |     (:href . "http://localhost:3000/id=3&name=foo")
157 |     (:data . "'<>")))
158 | 
159 | (defun new-a ()
160 |   (a *a-attrs*
161 |      "child text 1"
162 |      "child text 2 <br> &"
163 |      (a :href "child'<>\".html" "child'<>\"" (string (code-char 128)))
164 |      (string (code-char 128))))
165 | 
166 | (test escape-attr
167 |   (let ((escaped-attrs-alist '((:id . "nothing-to-escape")
168 |                                (:class . "something-with-&quot;-in-value")
169 |                                (:href . "http://localhost:3000/id=3&name=foo")
170 |                                (:data . "'<>")) ))
171 |     (is (equal escaped-attrs-alist (attrs-alist (element-attrs (new-a)))))
172 |     (let ((*escape-html* nil))
173 |       (is (equal *a-attrs* (attrs-alist (element-attrs (new-a))))))
174 |     (let ((*escape-html* :attr))
175 |       (is (equal escaped-attrs-alist (attrs-alist (element-attrs (new-a))))))
176 |     (let ((*escape-html* :ascii))
177 |       (is (equal escaped-attrs-alist (attrs-alist (element-attrs (new-a))))))))
178 | 
179 | (test escape-children
180 |   (let ((a (new-a)))
181 |     (is (string= "child text 1" (first (element-children a))))
182 |     (is (string= "child text 2 &lt;br&gt; &amp;" (second (element-children a))))
183 |     (is (string= "child'<>&quot;.html" (attr (element-attrs (third (element-children a))) :href)))
184 |     (is (string= "child'&lt;&gt;\"" (first (element-children (third (element-children a))))))
185 |     (is (string= (string (code-char 128)) (second (element-children (third (element-children a))))))
186 |     (is (string= (string (code-char 128)) (fourth (element-children a)))))
187 |   (let* ((*escape-html* :ascii)
188 |          (a (new-a)))
189 |     (is (string= "child text 1" (first (element-children a))))
190 |     (is (string= "child text 2 &lt;br&gt; &amp;" (second (element-children a))))
191 |     (is (string= "child'<>&quot;.html" (attr (element-attrs (third (element-children a))) :href)))
192 |     (is (string= "child'&lt;&gt;\"" (first (element-children (third (element-children a))))))
193 |     (is (string= "&#128;" (second (element-children (third (element-children a))))))
194 |     (is (string= "&#128;" (fourth (element-children a))))))
195 | 
196 | (in-suite attr-access)
197 | 
198 | (test attr-get
199 |   (is (eql nil (attr (a) :id)))
200 |   (is (eql nil (attr (new-a) :foo)))
201 |   (is (equal "nothing-to-escape" (attr (new-a) :id)))
202 |   (is (equal "'<>" (attr (element-attrs (new-a)) :data))))
203 | 
204 | (test attr-set
205 |   (let ((a (new-a)))
206 |     (setf (attr a :id) "a")
207 |     (setf (attr a :foo) "b")
208 |     (setf (attr (element-attrs a) :class) "c")
209 |     (setf (attr (element-attrs a) :bar) "d")
210 |     (is (equal "a" (attr a :id)))
211 |     (is (equal "b" (attr a :foo)))
212 |     (is (equal "c" (attr a :class)))
213 |     (is (equal "d" (attr a :bar)))))
214 | 
215 | (test attr-delete
216 |   (let ((a (new-a)))
217 |     (delete-attr a :id)
218 |     (delete-attr a :foo)
219 |     (delete-attr a :class)
220 |     (delete-attr (element-attrs a) :bar)
221 |     (delete-attr a :href)
222 |     (is (equal '((:data . "'<>")) (attrs-alist (element-attrs a))))))
223 | 
224 | (in-suite user-element)
225 | 
226 | (define-element cat ()
227 |   (div :id "cat"
228 |        (img :src "cat.png")
229 |        "I'm a cat"))
230 | 
231 | (test user-element-simple
232 |   (let ((cat (cat)))
233 |     (is (string= "cat" (attr (user-element-expand-to cat) :id)))
234 |     (is (string= "cat.png" (attr (first (element-children (user-element-expand-to cat))) :src)))
235 |     (is (string= "I'm a cat" (car (last (element-children (user-element-expand-to cat))))))))
236 | 
237 | (define-element dog (id size)
238 |   (if (and (realp size) (> size 10))
239 |       (div :id id :class "big-dog"
240 |        children
241 |        "dog")
242 |       (div :id id :class "small-dog"
243 |        children
244 |        "dog")))
245 | 
246 | (test user-element-with-attrs
247 |   (let ((dog1 (dog))
248 |         (dog2 (dog :size 15))
249 |         (dog3 (dog (img :src "dog.png")))
250 |         (dog4 (dog :id "dog" :size 10 (img :src "dog4.png") "woo")))
251 |     (is (eql nil (attrs-alist (element-attrs dog1))))
252 |     (is (string= "dog" (first (element-children (user-element-expand-to dog1)))))
253 |     (is (string= "small-dog" (attr (user-element-expand-to dog1) :class)))
254 |     (is (eql nil (element-children dog1)))
255 |     (is (string= "dog" (element-tag dog1)))
256 | 
257 |     (is (equal '((:size . 15)) (attrs-alist (element-attrs dog2))))
258 |     (is (equal '((:class . "big-dog")) (attrs-alist (element-attrs (user-element-expand-to dog2)))))
259 |     (is (string= "dog" (first (element-children (user-element-expand-to dog2)))))
260 |     (is (eql nil (element-children dog2)))
261 | 
262 |     (is (eql nil (attrs-alist (element-attrs dog3))))
263 |     (is (string= "dog" (second (element-children (user-element-expand-to dog3)))))
264 |     (is (string= "dog.png" (attr (first (element-children (user-element-expand-to dog3))) :src)))
265 |     (is (string= "dog.png" (attr (first (element-children dog3)) :src)))
266 | 
267 |     (is (equal '((:id . "dog") (:size . 10)) (attrs-alist (element-attrs dog4))))
268 |     (is (= 10 (attr dog4 :size)))
269 |     (is (string= "img" (element-tag (first (element-children dog4)))))
270 |     (is (string= "dog4.png" (attr (first (element-children (user-element-expand-to dog4))) :src)))
271 |     (is (string= "woo" (second (element-children dog4))))
272 | 
273 |     (setf (attr dog4 :size) 16)
274 |     (is (string= "big-dog" (attr (user-element-expand-to dog4) :class)))
275 |     (setf (element-children dog4) (list dog1 dog2 dog3))
276 |     (is (equal (list dog1 dog2 dog3 "dog") (element-children (user-element-expand-to dog4))))))
277 | 
278 | (test user-element-html-generation
279 |   (LET* ((dog1 (dog))
280 |          (dog2 (dog :size 15))
281 |          (dog3 (dog (img :src "dog.png")))
282 |          (dog4 (dog :id "dog" :size 10 (img :src "dog4.png") "woo"))
283 |          (home (div :id "home"
284 |                     (cat)
285 |                     ;; dog4 below is ignored because cat not accepting children
286 |                     (cat dog4)
287 |                     (dog :id "doge" (cat)))))
288 |     (is (string= "<div class=\"small-dog\">dog</div>" (element-string dog1)))
289 |     (is (string= "<div class=\"big-dog\">dog</div>" (element-string dog2)))
290 |     (is (string= "<div class=\"small-dog\">
291 |   <img src=\"dog.png\">
292 |   dog
293 | </div>" (element-string dog3)))
294 |     (is (string= "<div id=\"dog\" class=\"small-dog\">
295 |   <img src=\"dog4.png\">
296 |   woo
297 |   dog
298 | </div>" (element-string dog4)))
299 |     (is (string= "<div id=\"home\">
300 |   <div id=\"cat\">
301 |     <img src=\"cat.png\">
302 |     I'm a cat
303 |   </div>
304 |   <div id=\"cat\">
305 |     <img src=\"cat.png\">
306 |     I'm a cat
307 |   </div>
308 |   <div id=\"doge\" class=\"small-dog\">
309 |     <div id=\"cat\">
310 |       <img src=\"cat.png\">
311 |       I'm a cat
312 |     </div>
313 |     dog
314 |   </div>
315 | </div>" (element-string home)))
316 | 
317 |     (let ((*expand-user-element* nil))
318 |       (is (string= "<dog>" (element-string dog1)))
319 |       (is (string= "<dog size=15>" (element-string dog2)))
320 |       (is (string= "<dog><img src=\"dog.png\"></dog>" (element-string dog3)))
321 |       (is (string= "<dog id=\"dog\" size=10>
322 |   <img src=\"dog4.png\">
323 |   woo
324 | </dog>" (element-string dog4)))
325 |       (is (string= "<div id=\"home\">
326 |   <cat>
327 |   <cat>
328 |     <dog id=\"dog\" size=10>
329 |       <img src=\"dog4.png\">
330 |       woo
331 |     </dog>
332 |   </cat>
333 |   <dog id=\"doge\"><cat></dog>
334 | </div>" (element-string home))))))
335 | 
336 | (in-suite h-macro)
337 | 
338 | (in-package :cl-user)
339 | (defpackage flute.h-macro.test
340 |   (:use :cl :fiveam)
341 |   (:import-from :flute
342 |                 :h
343 |                 :element-string
344 |                 :define-element))
345 | (in-package :flute.h-macro.test)
346 | 
347 | (define-element duck (id color)
348 |   (h (div :id (format nil "duck~a" id)
349 |           :style (format nil "color:~a" color)
350 |           "ga ga ga"
351 |           flute:children)))
352 | 
353 | (test h-macro
354 |   (let ((some-var 3))
355 |     (is (string=
356 |          "<div id=\"a\">
357 |   <img href=\"a.png\">
358 |   <div id=\"b\">foo</div>
359 |   some text
360 | </div>" (element-string
361 |           (h (div :id "a"
362 |                   (img :href "a.png")
363 |                   (div (if (> some-var 0)
364 |                            '(:id "b")
365 |                            '(:id "c"))
366 |                        "foo")
367 |                   "some text")))))
368 |     (is (string= "<div id=\"duck5\" style=\"color:blue\">
369 |   ga ga ga
370 |   <img href=\"duck.png\">
371 | </div>"
372 |          (element-string
373 |           (h (duck :id 5 :color "blue"
374 |                    (img :href "duck.png"))))))
375 |     (is (string=
376 |          "<div class=\"class1 class2\" id=\"has-id\">child</div>"
377 |          (element-string
378 |           (h (div#has-id.class1.class2 "child")))))
379 |     (is (string=
380 |          "<div class=\"class1 class2\" id=\"has-id\" onclick=\"func()\">child</div>"
381 |          (element-string
382 |           (h (div#has-id.class1.class2 :onclick "func()" "child")))))
383 |     (is (string=
384 |          "<div class=\"class1 class2\" id=\"has-id\" onclick=\"func()\">child</div>"
385 |          (element-string
386 |           (h (div#has-id.class1.class2 '(:onclick "func()") "child")))))
387 |     (is (string=
388 |          "<div id=\"has-id\" class=\"class1 class2 additional-class\">child</div>"
389 |          (element-string
390 |           (h (div.class1#has-id.class2 ':class "additional-class" "child")))))))
391 | 
392 | (run-all-tests)
393 | 


--------------------------------------------------------------------------------