├── .travis.yml
├── README.md
├── cl-syntax-lsx.asd
├── file.lisp
├── html.lisp
├── lsx.asd
├── main.lisp
├── reader.lisp
├── syntax.lisp
├── tag.lisp
├── template.lisp
└── tests
└── main.lisp
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: common-lisp
2 | sudo: false
3 |
4 | env:
5 | global:
6 | - PATH=~/.roswell/bin:$PATH
7 | - ROSWELL_INSTALL_DIR=$HOME/.roswell
8 | - COVERAGE_EXCLUDE=tests
9 | matrix:
10 | - LISP=sbcl-bin COVERAGE=true
11 | - LISP=ccl-bin
12 |
13 | install:
14 | # Roswell
15 | - curl -L https://raw.githubusercontent.com/roswell/roswell/release/scripts/install-for-ci.sh | sh
16 | # Rove
17 | - ros install fukamachi/rove
18 |
19 | script:
20 | - rove lsx.asd
21 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # LSX
2 |
3 | [](http://quickdocs.org/lsx/)
4 | [](https://travis-ci.org/fukamachi/lsx)
5 | [](https://coveralls.io/r/fukamachi/lsx)
6 |
7 | Embeddable HTML templating engine with [JSX](https://reactjs.org/docs/introducing-jsx.html)-like syntax.
8 |
9 | ## Usage
10 |
11 | ```common-lisp
12 | (ql:quickload '(:lsx :local-time))
13 |
14 | (lsx:enable-lsx-syntax)
15 |
16 |
17 | ;=> #
18 |
19 | (lsx:render-object
t)
20 | ;->
21 | ;=> NIL
22 |
23 | (lsx:render-object Say Hello t)
24 | ;-> Say Hello
25 | ;=> NIL
26 |
27 |
28 | ;;
29 | ;; Embed Lisp code in {}
30 |
31 | (lsx:render-object Say Hello at {(local-time:now)} t)
32 | ;-> Say Hello at 2018-09-14T05:04:55.009102+09:00
33 | ;=> NIL
34 | ```
35 |
36 | ### Defining custom tags
37 |
38 | ```common-lisp
39 | (lsx:deftag welcome (&key name)
40 | {name}
)
41 |
42 |
43 | ;=> #
44 |
45 | (lsx:render-object t)
46 | ;-> fukamachi
47 | ;=> NIL
48 | ```
49 |
50 | ### Defining templates
51 |
52 | ```common-lisp
53 | (lsx:deftemplate default-layout ()
54 | (title body)
55 | (:render
56 |
57 |
58 | {title}
59 |
60 |
61 | {body}
62 |
63 | ))
64 |
65 | (lsx:deftemplate index-page (default-layout)
66 | ()
67 | (:default-initargs
68 | :title "Index"
69 | :body Welcome
))
70 |
71 | (lsx:render 'index-page)
72 | ;=> "
73 | ;
74 | ;
75 | ; Index
76 | ;
77 | ;
78 | ; Welcome
79 | ;
80 | ;
81 | ; "
82 | ```
83 |
84 | ### Loading from file
85 |
86 | ```common-lisp
87 | ;; example.lsx
88 | (lambda (&key (name "Guest"))
89 |
90 |
91 | Welcome {name}
92 |
93 |
94 |
95 |
96 | )
97 | ```
98 |
99 | ```common-lisp
100 | (lsx:read-lsx-file #P"example.lsx")
101 | ;=> #
102 |
103 | (lsx:render-object (funcall * :name "fukamachi") t)
104 | ;->
105 | ;
106 | ;
107 | ; Welcome fukamachi
108 | ;
109 | ;
110 | ;
111 | ;
112 | ;
113 | ;=> NIL
114 | ```
115 |
116 | ## How it works
117 |
118 | LSX syntax is implemented as reader macro. It's able to see how it's expanded with quoting.
119 |
120 | ```common-lisp
121 | '
122 | ;=> (LSX/TAG:H 'BR (LIST))
123 |
124 | 'Say Hello
125 | ;=> (LSX/TAG:H 'A (LIST (CONS "href" "/hello")) (LIST "Say Hello"))
126 |
127 | 'Say Hello at {(local-time:now)}
128 | ;=> (LSX/TAG:H 'A (LIST (CONS "href" "/hello")) (LIST "Say Hello at " (LAMBDA () (LOCAL-TIME:NOW))))
129 | ```
130 |
131 | `h` is a function to make an element. It takes a single required argument, a `tag-name` as a string, and 2 optional arguments, attributes as an association list and children as a list of elements.
132 |
133 | ```common-lisp
134 | ;; Same as
135 | (lsx:h "br")
136 | ;=> #
137 |
138 | (lsx:h "a" '(("href" . "/hello")) '("Say Hello"))
139 | ;=> #
140 |
141 | (lsx:h "a" '(("href" . "/hello")) (list "Say Hello at " (lambda () (local-time:now))))
142 | ```
143 |
144 | ## See Also
145 |
146 | - [Introducing JSX](https://reactjs.org/docs/introducing-jsx.html)
147 | - [JSX In Depth](https://reactjs.org/docs/jsx-in-depth.html)
148 |
149 | ## Author
150 |
151 | * Eitaro Fukamachi (e.arrows@gmail.com)
152 |
153 | ## Copyright
154 |
155 | Copyright (c) 2018 Eitaro Fukamachi
156 |
157 | ## License
158 |
159 | Licensed under the BSD 2-Clause License.
160 |
--------------------------------------------------------------------------------
/cl-syntax-lsx.asd:
--------------------------------------------------------------------------------
1 | (defsystem "cl-syntax-lsx"
2 | :version "0.1.0"
3 | :author "Eitaro Fukamachi"
4 | :license "BSD 2-Clause"
5 | :description "CL-Synax reader system for LSX"
6 | :depends-on ("cl-syntax" "lsx")
7 | :components
8 | ((:file "syntax")))
9 |
--------------------------------------------------------------------------------
/file.lisp:
--------------------------------------------------------------------------------
1 | (defpackage #:lsx/file
2 | (:use #:cl)
3 | (:import-from #:lsx/reader
4 | #:enable-lsx-syntax)
5 | (:export #:with-lsx-syntax
6 | #:read-lsx-string
7 | #:read-lsx-file))
8 | (in-package #:lsx/file)
9 |
10 | (defmacro with-lsx-syntax (&body body)
11 | `(let ((*package* *package*)
12 | (*readtable* (copy-readtable)))
13 | (enable-lsx-syntax)
14 | ,@body))
15 |
16 | (defun read-lsx-string (string)
17 | (check-type string string)
18 | (with-lsx-syntax
19 | (read-from-string string)))
20 |
21 | (defun read-lsx-file (file)
22 | (check-type file pathname)
23 | (let ((*load-pathname* file)
24 | (*load-truename* file))
25 | (with-lsx-syntax
26 | (let ((*package* *package*)
27 | (*readtable* (copy-readtable))
28 | result)
29 | (dolist (form (uiop:read-file-forms file) result)
30 | (setf result (eval form)))))))
31 |
--------------------------------------------------------------------------------
/html.lisp:
--------------------------------------------------------------------------------
1 | (defpackage #:lsx/html
2 | (:use #:cl)
3 | (:export #:h*
4 | #:*auto-escape*
5 | #:void-tag-p
6 | #:render-object
7 | #:html-mode
8 | #:element
9 | #:element-list
10 | #:danger-element
11 | #:declaration-element
12 | #:make-element
13 | #:make-danger-element
14 | #:element-name
15 | #:element-attributes
16 | #:element-children
17 | #:element-self-closing
18 | #:attribute
19 | #:attribute-name
20 | #:attribute-value
21 | #:prologue))
22 | (in-package #:lsx/html)
23 |
24 | (defvar *html-mode* :html5)
25 |
26 | (defun html-mode () *html-mode*)
27 | (defun (setf html-mode) (new-value)
28 | (ecase *html-mode*
29 | ((:html :xhtml :html5) (setf *html-mode* new-value))))
30 |
31 | (defvar *escape-map*
32 | (let ((hash (make-hash-table)))
33 | (loop for (char . escaped) in '((#\& . "&")
34 | (#\< . "<")
35 | (#\> . ">")
36 | (#\" . """)
37 | (#\' . "'"))
38 | do (setf (gethash char hash) escaped))
39 | hash))
40 |
41 | (defvar *auto-escape* t)
42 |
43 | (defparameter *void-tag-map*
44 | #.(let ((ht (make-hash-table)))
45 | (loop for key in
46 | '(:area :base :br :col :hr :img :input :link :meta :param :command :keygen :source)
47 | do (setf (gethash key ht) T))
48 | ht))
49 |
50 | (defun void-tag-p (name)
51 | (let ((name-keyword (intern (symbol-name name) "KEYWORD")))
52 | (gethash name-keyword *void-tag-map*)))
53 |
54 | (defun print-escaped-text (value stream)
55 | (declare (type string value))
56 | (if *auto-escape*
57 | (loop for char of-type character across value
58 | for escaped = (gethash char *escape-map*)
59 | if escaped
60 | do (write-string escaped stream)
61 | else do (write-char char stream))
62 | (write-string value stream)))
63 |
64 | (defstruct element
65 | (name nil :type string)
66 | (attributes nil :type list)
67 | (children nil :type list)
68 | (self-closing nil :type boolean)
69 | (void-tag nil :type boolean))
70 |
71 | (defstruct element-list
72 | (elements nil :type list))
73 |
74 | (defstruct (declaration-element (:include element (name)))
75 | (content nil :type string))
76 |
77 | (defstruct danger-element
78 | element)
79 |
80 | (defstruct attribute
81 | (name nil :type string)
82 | value)
83 |
84 | (defmethod print-object ((object element) stream)
85 | (print-unreadable-object (object stream :type t :identity t)
86 | (princ (element-name object) stream)))
87 |
88 | (defmethod print-object ((object element-list) stream)
89 | (print-unreadable-object (object stream :type t :identity t)
90 | (format stream "(~D ~:*element~[s~;~:;s~])"
91 | (length (element-list-elements object)))))
92 |
93 | (defmethod print-object ((object danger-element) stream)
94 | (print-unreadable-object (object stream :type t :identity t)))
95 |
96 | (defgeneric render-object (object stream)
97 | (:method (object stream)
98 | (print-escaped-text (princ-to-string object) stream))
99 | (:method :around (object (stream (eql 't)))
100 | (render-object object *standard-output*))
101 | (:method :around (object (stream (eql 'nil)))
102 | (with-output-to-string (s)
103 | (render-object object s))))
104 |
105 | (defmethod render-object ((element element) stream)
106 | (with-slots (name attributes children void-tag) element
107 | (format stream "<~A" name)
108 | (dolist (attr attributes)
109 | (render-object attr stream))
110 | (if (element-self-closing element)
111 | (if void-tag
112 | (case (html-mode)
113 | ((:xml :xhtml)
114 | (write-string " />" stream))
115 | (otherwise
116 | (write-char #\> stream)))
117 | (format stream ">" name))
118 | (progn
119 | (write-char #\> stream)
120 | (loop for (child . rest) on children
121 | do (render-object child stream)
122 | (when (and (stringp child)
123 | (stringp (first rest)))
124 | (write-char #\Space stream)))
125 | (format stream "" name)))
126 | nil))
127 |
128 | (defmethod render-object ((attribute attribute) stream)
129 | (with-slots (name value) attribute
130 | (let ((value (typecase value
131 | (function (funcall value))
132 | (otherwise value))))
133 | (when value
134 | (write-char #\Space stream)
135 | (format stream "~A" name)
136 | (unless (eq value t)
137 | (flet ((write-value (value)
138 | (write-char #\= stream)
139 | (write-char #\" stream)
140 | (render-object value stream)
141 | (write-char #\" stream)))
142 | (write-value value)))))))
143 |
144 | (defmethod render-object ((object element-list) stream)
145 | (dolist (element (element-list-elements object))
146 | (render-object element stream)
147 | (write-char #\Newline stream)))
148 |
149 | (defmethod render-object ((object danger-element) stream)
150 | (let ((*auto-escape* nil))
151 | (render-object (danger-element-element object) stream)))
152 |
153 | (defmethod render-object ((object declaration-element) stream)
154 | (with-slots (name content) object
155 | (format stream ""
156 | name content)))
157 |
158 | (defmethod render-object ((object string) stream)
159 | (print-escaped-text object stream))
160 |
161 | (defmethod render-object ((object number) stream)
162 | (print-escaped-text (write-to-string object) stream))
163 |
164 | (defmethod render-object ((object null) stream)
165 | (declare (ignore stream)))
166 |
167 | (defmethod render-object ((object cons) stream)
168 | (dolist (object object)
169 | (render-object object stream)
170 | (fresh-line stream)))
171 |
172 | (defmethod render-object ((object (eql 't)) stream)
173 | (declare (ignore stream)))
174 |
175 | (defmethod render-object ((object function) stream)
176 | (render-object (funcall object) stream))
177 |
178 | (defun h* (tag-name &optional attributes (children nil children-specified-p))
179 | (make-element
180 | :name (let ((*print-case* :downcase))
181 | (princ-to-string tag-name))
182 | :attributes (loop for (name . value) in attributes
183 | collect (make-attribute :name name :value value))
184 | :children children
185 | :void-tag (void-tag-p (intern (princ-to-string tag-name)))
186 | :self-closing (not children-specified-p)))
187 |
188 | (defun prologue ()
189 | (make-danger-element
190 | :element
191 | (ecase *html-mode*
192 | (:html
193 | "")
194 | (:xhtml
195 | "")
196 | (:html5
197 | ""))))
198 |
--------------------------------------------------------------------------------
/lsx.asd:
--------------------------------------------------------------------------------
1 | (defsystem "lsx"
2 | :class :package-inferred-system
3 | :version "0.1.0"
4 | :author "Eitaro Fukamachi"
5 | :license "BSD 2-Clause"
6 | :description "Embeddable HTML templating engine with JSX-like syntax"
7 | :depends-on ("lsx/main")
8 | :in-order-to ((test-op (test-op "lsx/tests"))))
9 |
10 | (defsystem "lsx/tests"
11 | :class :package-inferred-system
12 | :depends-on ("rove"
13 | "lsx/tests/main")
14 | :perform (test-op (o c) (symbol-call :rove '#:run c)))
15 |
--------------------------------------------------------------------------------
/main.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lsx
2 | (:nicknames #:lsx/main)
3 | (:use #:cl)
4 | (:use-reexport #:lsx/reader
5 | #:lsx/html
6 | #:lsx/tag
7 | #:lsx/file
8 | #:lsx/template))
9 | (in-package #:lsx)
10 |
--------------------------------------------------------------------------------
/reader.lisp:
--------------------------------------------------------------------------------
1 | (defpackage #:lsx/reader
2 | (:use #:cl)
3 | (:import-from #:lsx/tag
4 | #:h)
5 | (:import-from #:lsx/html
6 | #:make-declaration-element
7 | #:void-tag-p)
8 | (:import-from #:named-readtables
9 | #:defreadtable)
10 | (:export #:enable-lsx-syntax
11 | #:disable-lsx-syntax))
12 | (in-package #:lsx/reader)
13 |
14 | (defun read-as-string (stream while)
15 | (let ((buffer (make-string 50)))
16 | (loop for i from 0
17 | for next = (peek-char nil stream)
18 | while (funcall while next)
19 | do (setf (aref buffer i) (read-char stream))
20 | when (<= (length buffer) (1+ i))
21 | do (let ((new-buffer (make-string (* 2 (length buffer)))))
22 | (replace new-buffer buffer)
23 | (setf buffer new-buffer))
24 | finally
25 | (return (subseq buffer 0 i)))))
26 |
27 | (defun read-element-name (stream)
28 | (read-from-string
29 | (read-as-string stream
30 | (lambda (char)
31 | (or (alphanumericp char)
32 | (find char '(#\- #\_ #\: #\.)))))))
33 |
34 | (defun space-char-p (char)
35 | (find char '(#\Space #\Tab #\Linefeed #\Return #\Page)))
36 |
37 | (defun skip-while (stream while)
38 | (loop while (funcall while (peek-char nil stream))
39 | do (read-char stream)))
40 |
41 | (defun read-attribute-key (stream)
42 | (skip-while stream #'space-char-p)
43 | (read-as-string stream
44 | (lambda (char)
45 | (and (not (find char '(#\Null #\" #\' #\> #\/ #\=)))
46 | (not (space-char-p char))))))
47 |
48 | (defvar *default-readtable*)
49 |
50 | (defun inline-lisp-reader (stream char)
51 | (declare (ignore char))
52 | `(lambda () ,@(let ((*readtable* (copy-readtable *default-readtable*)))
53 | (set-syntax-from-char #\} #\))
54 | (read-delimited-list #\} stream t))))
55 |
56 | (defun read-attribute-value (stream)
57 | (let ((*default-readtable* *readtable*)
58 | (*readtable* (copy-readtable)))
59 | (set-macro-character #\{ #'inline-lisp-reader)
60 | (set-syntax-from-char #\} #\))
61 | (set-syntax-from-char #\' #\")
62 | (read stream)))
63 |
64 | (defun read-attribute (stream)
65 | (list (read-attribute-key stream)
66 | (if (char= (peek-char t stream) #\=)
67 | (progn
68 | (read-char stream)
69 | (read-attribute-value stream))
70 | t)))
71 |
72 | (defvar *reading-tag*)
73 | (defvar *reading-tag-children*)
74 |
75 | (defun read-html-tag-inner (stream)
76 | (let ((next (peek-char nil stream)))
77 | (case next
78 | ((#\{ #\<)
79 | (push (read-preserving-whitespace stream) *reading-tag-children*))
80 | (otherwise
81 | (push (read-as-string stream
82 | (lambda (char)
83 | (not (find char '(#\< #\{)))))
84 | *reading-tag-children*)))
85 | (loop
86 | (push (read-html-tag-inner stream) *reading-tag-children*))))
87 |
88 | (defun read-html-tag-children (stream name attrs)
89 | (let ((*reading-tag* name)
90 | (*reading-tag-children* (list))
91 | (*default-readtable* *readtable*)
92 | (*readtable* (copy-readtable)))
93 | (assert (char= (read-char stream) #\>))
94 | (set-macro-character #\{ #'inline-lisp-reader)
95 | (set-syntax-from-char #\} #\))
96 | `(h ',name (list ,@attrs)
97 | (list ,@(progn
98 | (catch 'end-of-tag
99 | (read-html-tag-inner stream))
100 | (nreverse *reading-tag-children*))))))
101 |
102 | (defun read-html-tag (stream char)
103 | (declare (ignore char))
104 | (let ((next (peek-char nil stream)))
105 | (cond
106 | ((alphanumericp next)
107 | ;; Reading opening tag
108 | (let ((name (read-element-name stream))
109 | (attrs (loop until (find (peek-char t stream) '(#\/ #\>))
110 | collect `(cons ,@(read-attribute stream)))))
111 | (let ((next (peek-char t stream)))
112 | (if (or (void-tag-p name) (char= next #\/))
113 | ;; self closing tag
114 | (progn
115 | (when (char= next #\/) (read-char stream))
116 | (assert (char= (read-char stream) #\>))
117 | `(h ',name (list ,@attrs)))
118 | (read-html-tag-children stream name attrs)))))
119 | ((char= next #\>)
120 | (read-html-tag-children stream NIL '()))
121 | ((char= next #\!)
122 | ;; Reading declaration
123 | (read-char stream)
124 | (let ((name (read-element-name stream)))
125 | (skip-while stream #'space-char-p)
126 | (let ((content (read-as-string stream
127 | (lambda (char)
128 | (not (char= char #\>))))))
129 | (assert (char= (read-char stream) #\>))
130 | `(make-declaration-element
131 | :name ,name
132 | :content ,content))))
133 | ((char= next #\/)
134 | ;; Reading closing tag
135 | (read-char stream)
136 | (if (char= #\> (peek-char nil stream))
137 | (if (equal nil *reading-tag*)
138 | (read-char stream)
139 | (error "Unmatched fragment"))
140 | (let ((name (read-element-name stream)))
141 | (assert (char= (read-char stream) #\>))
142 | (unless (equal name *reading-tag*)
143 | (error "Unmatched closing tag: ~A" name))))
144 | (throw 'end-of-tag *reading-tag-children*))
145 |
146 | ;; Fallback rules
147 | ((or (char= next #\Space)
148 | (char= next #\)))'<)
149 | (t (intern (format nil "<~S" (read stream)))))))
150 |
151 | (defun do-nothing (stream char)
152 | (declare (ignore stream char)))
153 |
154 | (defvar *previous-readtables* '())
155 |
156 | (defun %enable-lsx-syntax ()
157 | (push *readtable* *previous-readtables*)
158 | (setf *readtable* (copy-readtable))
159 | (set-macro-character #\< #'read-html-tag t)
160 | (set-macro-character #\> #'do-nothing)
161 | (values))
162 |
163 | (defun %disable-lsx-syntax ()
164 | (if *previous-readtables*
165 | (setf *readtable* (pop *previous-readtables*))
166 | (setf *readtable* (copy-readtable nil)))
167 | (values))
168 |
169 | (defmacro enable-lsx-syntax ()
170 | `(eval-when (:compile-toplevel :load-toplevel :execute)
171 | (%enable-lsx-syntax)))
172 |
173 | (defmacro disable-lsx-syntax ()
174 | `(eval-when (:compile-toplevel :load-toplevel :execute)
175 | (%disable-lsx-syntax)))
176 |
177 | (defreadtable :lsx-syntax
178 | (:merge :standard)
179 | (:macro-char #\< #'read-html-tag t))
180 |
--------------------------------------------------------------------------------
/syntax.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:cl-user)
2 |
3 | (syntax:define-package-syntax :lsx
4 | (:merge :standard)
5 | (:macro-char #\< #'lsx/reader::read-html-tag t))
6 |
--------------------------------------------------------------------------------
/tag.lisp:
--------------------------------------------------------------------------------
1 | (defpackage #:lsx/tag
2 | (:use #:cl)
3 | (:import-from #:lsx/html
4 | #:make-element-list
5 | #:h*
6 | #:prologue)
7 | (:export #:deftag
8 | #:h))
9 | (in-package #:lsx/tag)
10 |
11 | (defvar *user-tags*
12 | (make-hash-table :test 'eq))
13 |
14 | (defmacro deftag (name lambda-list &body body)
15 | (check-type name symbol)
16 | `(eval-when (:compile-toplevel :load-toplevel :execute)
17 | (setf (gethash ',name *user-tags*)
18 | (lambda ,lambda-list
19 | ,@body))))
20 |
21 | (defun html-attributes-to-plist (attributes)
22 | (loop for (name . value) in attributes
23 | append (list (read-from-string (format nil ":~A" name)) value)))
24 |
25 | (defun h (tag-name &optional attributes (children nil children-specified-p))
26 | (cond
27 | ((gethash tag-name *user-tags*)
28 | (apply (gethash tag-name *user-tags*)
29 | :children children
30 | :allow-other-keys t
31 | (html-attributes-to-plist attributes)))
32 | ((string-equal tag-name "html")
33 | (make-element-list
34 | :elements (list (prologue) (h* tag-name attributes children))))
35 | (tag-name
36 | (if children-specified-p
37 | (h* tag-name attributes children)
38 | (h* tag-name attributes)))
39 | (t
40 | children)))
41 |
--------------------------------------------------------------------------------
/template.lisp:
--------------------------------------------------------------------------------
1 | (defpackage #:lsx/template
2 | (:use #:cl)
3 | (:import-from #:lsx/html
4 | #:render-object)
5 | (:import-from #:closer-mop)
6 | (:export #:template
7 | #:template-class
8 | #:deftemplate
9 | #:render))
10 | (in-package #:lsx/template)
11 |
12 | (defclass template () ())
13 |
14 | (defmethod render-object ((object template) stream)
15 | (let ((class (class-of object)))
16 | (funcall (slot-value class 'render) stream object)))
17 |
18 | (defclass template-slot-class (c2mop:standard-direct-slot-definition)
19 | ())
20 |
21 | (defmacro define-initialize-instance (method-qualifier lambda-list &body body)
22 | `(progn
23 | (defmethod initialize-instance ,method-qualifier ,lambda-list ,@body)
24 | (defmethod reinitialize-instance ,method-qualifier ,lambda-list ,@body)))
25 |
26 | (define-initialize-instance :around ((class template-slot-class) &rest args &key name &allow-other-keys)
27 | (push
28 | (intern (princ-to-string name) :keyword)
29 | (getf args :initargs))
30 | (apply #'call-next-method class args))
31 |
32 | (defclass template-class (standard-class)
33 | ((render :initarg :render
34 | :initform nil)))
35 |
36 | (defmethod c2mop:direct-slot-definition-class ((class template-class) &key &allow-other-keys)
37 | 'template-slot-class)
38 |
39 | (defmethod c2mop:validate-superclass ((class template-class) (super standard-class))
40 | t)
41 |
42 | (define-initialize-instance :after ((class template-class) &rest initargs &key direct-slots render &allow-other-keys)
43 | (declare (ignore initargs))
44 | (when render
45 | (let* ((stream (gensym "STREAM"))
46 | (object (gensym "OBJECT"))
47 | (slot-names (mapcar (lambda (slot) (getf slot :name))
48 | direct-slots))
49 | (generic-function (ensure-generic-function 'render-object :lambda-list '(object stream)))
50 | (main-fn (eval
51 | `(lambda (,stream ,object)
52 | (with-slots (,@slot-names) ,object
53 | (declare (ignorable ,@slot-names))
54 | (mapc (lambda (element)
55 | (render-object element ,stream))
56 | (list ,@render))
57 | (values))))))
58 | (add-method generic-function
59 | (make-instance 'standard-method
60 | :lambda-list '(object stream)
61 | :qualifiers ()
62 | :specializers (list class (find-class 't))
63 | :function
64 | (lambda (args &rest ignore)
65 | (declare (ignore ignore))
66 | (destructuring-bind (object stream) args
67 | (funcall main-fn stream object))))))))
68 |
69 | (defmacro deftemplate (name superclasses slot-definitions &rest class-options)
70 | `(defclass ,name (,@superclasses template)
71 | ,slot-definitions
72 | (:metaclass template-class)
73 | ,@class-options))
74 |
75 | (defgeneric render (template &rest args)
76 | (:method ((template template-class) &rest args)
77 | (render-object (apply #'make-instance template
78 | :allow-other-keys t
79 | args)
80 | nil))
81 | (:method ((template symbol) &rest args)
82 | (apply #'render (find-class template) args)))
83 |
--------------------------------------------------------------------------------
/tests/main.lisp:
--------------------------------------------------------------------------------
1 | (defpackage #:lsx/tests/main
2 | (:use #:cl
3 | #:rove
4 | #:lsx/tag
5 | #:lsx/html
6 | #:lsx/file)
7 | (:import-from #:lsx/html
8 | #:print-escaped-text)
9 | (:import-from #:local-time
10 | #:now)
11 | (:import-from #:cl-ppcre))
12 | (in-package #:lsx/tests/main)
13 |
14 | (defun esc (v)
15 | (with-output-to-string (s)
16 | (print-escaped-text v s)))
17 |
18 | (deftest escaped-text-tests
19 | (ok (equal (esc "Hello") "Hello")
20 | "Normal string")
21 | (ok (equal (esc "Tiffany & Co.") "Tiffany & Co.")
22 | "Escape &")
23 | (ok (equal (esc "") "<danger>")
24 | "Escape <, >")
25 | (ok (equal (esc "\"LEVI'S\"") ""LEVI'S"")
26 | "Escape \", \'"))
27 |
28 | (deftest element-tests
29 | (testing "Normal element"
30 | (let ((br (eval (read-lsx-string "
"))))
31 | (ok (typep br 'element))
32 | (ok (equal (element-name br) "br"))
33 | (ok (outputs (render-object br t) "
"))))
34 | (testing "Void element"
35 | (let ((br (eval (read-lsx-string "
"))))
36 | (ok (typep br 'element))
37 | (ok (equal (element-name br) "br"))
38 | (ok (outputs (render-object br t) "
"))))
39 | (testing "Fragments"
40 | (let ((frag (eval (read-lsx-string "<>1
2
"))))
41 | (ok (outputs (render-object frag t) (format NIL "1
~%2
~%")))))
42 | (testing "Self closing tags"
43 | (let ((br (eval (read-lsx-string ""))))
44 | (ok (typep br 'element))
45 | (ok (equal (element-name br) "div"))
46 | (ok (outputs (render-object br t) ""))))
47 | (testing "With attributes & children"
48 | (let ((a (eval (read-lsx-string "Say Hello"))))
49 | (ok (typep a 'element))
50 | (ok (equal (element-name a) "a"))
51 | (ok (outputs (render-object a t) "Say Hello"))))
52 | (testing "Embed Lisp code"
53 | (let ((a (eval (read-lsx-string "Say Hello at {(local-time:now)}"))))
54 | (ok (typep a 'element))
55 | (ok (equal (element-name a) "a"))
56 | (ok (ppcre:scan
57 | "^Say Hello at \\d{4}-\\d{2}-\\d{2}T\\d{2}:\\d{2}:\\d{2}(\\.\\d{6})?.*$"
58 | (with-output-to-string (s)
59 | (render-object a s)))))))
60 |
61 | (deftest custom-tag-tests
62 | (deftag welcome (&key name)
63 | (h "h1" () (list (lambda () name))))
64 |
65 | (let ((welcome (eval (read-lsx-string ""))))
66 | (ok (outputs (render-object welcome t) "fukamachi
"))))
67 |
--------------------------------------------------------------------------------