├── .gitattributes
├── cl-markdown.lisp
├── dynamic.lisp
├── .github
    └── workflows
    │   └── ci.yml
├── spinneret.lisp
├── LICENSE.txt
├── special.lisp
├── interpret.lisp
├── spinneret.asd
├── syntax.lisp
├── package.lisp
├── deftag.lisp
├── stream.lisp
├── ps.lisp
├── functions.lisp
├── compile.lisp
├── run.lisp
├── tags.lisp
├── README.md
└── tests.lisp


/.gitattributes:
--------------------------------------------------------------------------------
1 | # CRLF breaks the tilde-newline format directive.
2 | *.lisp text eol=lf
3 | 


--------------------------------------------------------------------------------
/cl-markdown.lisp:
--------------------------------------------------------------------------------
 1 | ;; We define this package to make ASDF package-inferred
 2 | ;; systems happy
 3 | (defpackage #:spinneret/cl-markdown
 4 |   (:use #:cl))
 5 | (in-package #:spinneret/cl-markdown)
 6 | 
 7 | ;; Here we redefine a function inside of the main
 8 | ;; package, to change it's behavior
 9 | (defun spinneret::parse-as-markdown (string)
10 |   "Expand STRING as markdown only if it contains markdown."
11 |   (declare (string string))
12 |   (let ((expansion
13 |           (with-output-to-string (s)
14 |             (let (markdown:*parse-active-functions*
15 |                   markdown:*render-active-functions*)
16 |               (markdown:markdown string
17 |                                  :stream s
18 |                                  :format :html)))))
19 |     (if (search string expansion)
20 |         string
21 |         (if (find #\Newline string)
22 |             expansion
23 |             (spinneret::trim-ends "<p>" expansion "</p>")))))
24 | 


--------------------------------------------------------------------------------
/dynamic.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :spinneret)
 2 | 
 3 | (defun expand-dynamic-tag (&rest args)
 4 |   `(dynamic-tag ,@args))
 5 | 
 6 | (deftag dynamic-tag (body attrs &key name)
 7 |   (unless name
 8 |     (error "No tag name"))
 9 |   (let ((empty? (null body))
10 |         (thunk (gensym (string 'dynamic-tag-thunk)))
11 |         (attrs (escape-attrs nil attrs)))
12 |     `(prog1 nil
13 |        (flet ((,thunk ()
14 |                 ,@(loop for expr in body
15 |                         collect `(catch-output ,expr))))
16 |          (declare (dynamic-extent #',thunk))
17 |          (dynamic-tag* ,name
18 |                        (list ,@attrs)
19 |                        #',thunk
20 |                        ,empty?)))))
21 | 
22 | (defun expand-h* (&rest args)
23 |   (if *interpret*
24 |       (cons (heading-depth-heading)
25 |             args)
26 |       `(h* ,@args)))
27 | 
28 | (deftag h* (body attrs &key)
29 |   `(dynamic-tag
30 |      :name (heading-depth-heading)
31 |      ,@attrs
32 |      ,@body))
33 | 


--------------------------------------------------------------------------------
/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
 1 | name: CI
 2 | 
 3 | on: [push, pull_request]
 4 | 
 5 | env:
 6 |   GITHUB_WORKSPACE: $HOME/common-lisp/spinneret
 7 | 
 8 | jobs:
 9 |   test:
10 |     name: ${{ matrix.lisp }} on ${{ matrix.os }}
11 |     runs-on: ${{ matrix.os }}
12 |     strategy:
13 |       matrix:
14 |         lisp: [sbcl-bin, ccl-bin/1.12.1]
15 |         os: [ubuntu-latest, macOS-13] # macos-latest when Clozure supports arm64?
16 | 
17 |     steps:
18 |       - uses: actions/checkout@v1
19 |       - name: Install Roswell
20 |         env:
21 |           LISP: ${{ matrix.lisp }}
22 |         run: |
23 |           curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh
24 |       - name: Install ci-utils
25 |         run: ros install ci-utils
26 |       - name: Run tests
27 |         run: |
28 |           PATH="~/.roswell/bin:$PATH"
29 |           run-fiveam -l spinneret/tests 'spinneret.tests::run-tests'
30 |       - name: Run compile-bundle-op
31 |         run: |
32 |           ros run
33 | 


--------------------------------------------------------------------------------
/spinneret.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; spinneret.lisp
 2 | 
 3 | (in-package #:spinneret)
 4 | 
 5 | (define-condition spinneret-error (error)
 6 |   ())
 7 | 
 8 | (define-condition no-such-tag (spinneret-error)
 9 |   ((name :initarg :name))
10 |   (:report (lambda (c s)
11 |              (with-slots (name) c
12 |                (format s "No such HTML tag: ~a" name)))))
13 | 
14 | ;;;; The exported macros.
15 | 
16 | (defun get-html-path ()
17 |   "Return a copy of *HTML-PATH*.
18 | This is necessary because *HTML-PATH* itself is stack-allocated."
19 |   (copy-list *html-path*))
20 | 
21 | (defmacro with-html (&body body &environment env)
22 |   "Interpret BODY as HTML. Consult README.txt for the syntax."
23 |   `(let ((*html* (ensure-html-stream *html*)))
24 |      ,(if (and (null (cdr body)) (atom (car body)))
25 |           (car body)
26 |           `(progn ,@(parse-html body env)))))
27 | 
28 | (defmacro with-html-string (&body body)
29 |   "Like WITH-HTML, but capture the output as a string."
30 |   `(with-output-to-string (*html*)
31 |      (with-html ,@body)))
32 | 


--------------------------------------------------------------------------------
/LICENSE.txt:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2011 Paul M. Rodriguez
 2 | 
 3 | Permission is hereby granted, free of charge, to any person obtaining
 4 | a copy of this software and associated documentation files (the
 5 | "Software"), to deal in the Software without restriction, including
 6 | without limitation the rights to use, copy, modify, merge, publish,
 7 | distribute, sublicense, and/or sell copies of the Software, and to
 8 | permit persons to whom the Software is furnished to do so, subject to
 9 | the following conditions:
10 | 
11 | The above copyright notice and this permission notice shall be
12 | included in all copies or substantial portions of the Software.
13 | 
14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21 | 


--------------------------------------------------------------------------------
/special.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:spinneret)
 2 | 
 3 | (declaim (stream *html*))
 4 | 
 5 | (defparameter *html* (make-synonym-stream '*standard-output*)
 6 |   "Output stream for HTML generation.")
 7 | 
 8 | (declaim (string *html-lang* *html-charset*))
 9 | 
10 | (defparameter *html-lang* "en")
11 | 
12 | (defparameter *html-charset* "UTF-8")
13 | 
14 | (declaim (type (integer -1 #.(1- most-positive-fixnum)) *depth*))
15 | 
16 | (defvar *depth* -1
17 |   "Depth of the tag being output.")
18 | 
19 | (defvar *indent*)
20 | 
21 | (defun get-indent ()
22 |   (or (bound-value '*indent*)
23 |       *depth*))
24 | 
25 | (defvar *pre* nil)
26 | 
27 | (defparameter *fill-column* 80
28 |   "Column at which to wrap text.
29 | This is always measured from the start of the tag.")
30 | 
31 | (declaim (boolean *pending-space* *suppress-inserted-spaces*))
32 | 
33 | (defvar *pending-space* nil)
34 | 
35 | (defvar *suppress-inserted-spaces* nil
36 |   "When set to non-nil, spaces will never be inserted automatically.")
37 | 
38 | (defvar *html-path* nil
39 |   "List (in ascending order) of parent nodes.")
40 | (assert (null *html-path*))
41 | 
42 | (defvar *html-style* :human
43 |   "How should we pretty-print HTML?")
44 | (declaim (type (member :human :tree) *html-style*))
45 | 
46 | (defvar *always-quote* nil
47 |   "Add quotes to all attributes.")
48 | (declaim (type boolean *always-quote*))
49 | 


--------------------------------------------------------------------------------
/interpret.lisp:
--------------------------------------------------------------------------------
 1 | (in-package :spinneret)
 2 | 
 3 | (defun interpret-html-tree (tree &key
 4 |                                    (stream *html*)
 5 |                                    ((:style *html-style*) :tree))
 6 |   "Interpet TREE as HTML.
 7 | The syntax used is roughly that of Spinneret.
 8 | "
 9 |   (let ((*html* stream))
10 |     (labels ((interpret-html-tree (tree &optional expanded)
11 |                (match tree
12 |                  ;; Handle the (:tag :name "mytag") syntax for dynamic tags.
13 |                  ((list* (and _ (eql :tag)) attrs-and-body)
14 |                   (multiple-value-bind (attrs body)
15 |                       (parse-leading-keywords attrs-and-body)
16 |                     (let ((name (getf attrs :name)))
17 |                       (unless name
18 |                         (error "No name for dynamic tag: ~a" tree))
19 |                       (interpret-html-tree
20 |                        `(,name ,@(remove-from-plist attrs :name)
21 |                                ,@body)))))
22 |                  ((list* (and tag (type keyword)) attrs-and-body)
23 |                   (if-let (expander
24 |                            (and (not expanded)
25 |                                 (pseudotag-expander tag)))
26 |                     ;; Handle interpreting a pseudotag.
27 |                     (interpret-html-tree
28 |                      (let ((*interpret* t))
29 |                        (apply expander attrs-and-body))
30 |                      t)
31 |                     (receive (tag attrs body)
32 |                         (tag-parts tree)
33 |                       (dynamic-tag :name tag :attrs attrs
34 |                         (mapc #'interpret-html-tree body)
35 |                         nil))))
36 |                  (otherwise
37 |                   (html tree)))))
38 |       (interpret-html-tree tree))))
39 | 


--------------------------------------------------------------------------------
/spinneret.asd:
--------------------------------------------------------------------------------
 1 | (defsystem "spinneret"
 2 |   :description "Common Lisp HTML5 generator."
 3 |   :version "3.0"
 4 |   :author "Paul M. Rodriguez <pmr@ruricolist.com>"
 5 |   :license "MIT"
 6 |   :in-order-to ((test-op (test-op "spinneret/tests")))
 7 |   :serial t
 8 |   :depends-on ("alexandria"
 9 |                "cl-ppcre"
10 |                "global-vars"
11 |                "serapeum"
12 |                "trivia"
13 |                "trivial-gray-streams"
14 |                "in-nomine")
15 |   :components ((:file "package")
16 |                (:file "special")
17 |                (:file "stream")
18 |                (:file "syntax")
19 |                (:file "tags")
20 |                (:file "spinneret")
21 |                (:file "run")
22 |                (:file "functions")
23 |                (:file "compile")
24 |                (:file "deftag")
25 |                (:file "dynamic")
26 |                (:file "interpret")))
27 | 
28 | (defsystem "spinneret/cl-markdown"
29 |   :description "Integration with cl-markdown"
30 |   :version "3.0"
31 |   :author "Paul M. Rodriguez <pmr@ruricolist.com>"
32 |   :license "MIT"
33 |   :serial t
34 |   :depends-on ("cl-markdown"
35 |                "spinneret")
36 |   :components ((:file "cl-markdown")))
37 | 
38 | (defsystem "spinneret/ps"
39 |   :description "Integration with Parenscript."
40 |   :author "Paul M. Rodriguez <pmr@ruricolist.com>"
41 |   :license "MIT"
42 |   :serial t
43 |   :depends-on ("spinneret" "parenscript")
44 |   :components ((:file "ps")))
45 | 
46 | (defsystem "spinneret/tests"
47 |   :description "Test suite for Spinneret"
48 |   :author "Paul M. Rodriguez <pmr@ruricolist.com>"
49 |   :license "MIT"
50 |   :depends-on ("fiveam"
51 |                "spinneret"
52 |                "spinneret/cl-markdown"
53 |                "spinneret/ps")
54 |   :perform (test-op (o c) (symbol-call :spinneret.tests :run-tests))
55 |   :components ((:file "tests")))
56 | 


--------------------------------------------------------------------------------
/syntax.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:spinneret)
 2 | 
 3 | (declaim (inline whitespace must-quote?
 4 |                  escape-string escape-attribute-value
 5 |                  escape-cdata escape-comment))
 6 | 
 7 | (deftype index () '(integer 0 #.array-total-size-limit))
 8 | 
 9 | (defconst no-break-space
10 |   #+lispworks #\No-break-space
11 |   #-lispworks #\No-break_space)
12 | 
13 | ;; See 2.5.1.
14 | ;; http://www.w3.org/TR/html5/common-microsyntaxes.html#space-character
15 | 
16 | (declaim (inline whitespace))
17 | (defun whitespace (char)
18 |   (declare (character char))
19 |   (case char
20 |     ((#\Space #\Tab #\Newline #\Page #\Return) t)))
21 | 
22 | ;; See 8.1.2.3.
23 | ;; http://www.w3.org/TR/html5/syntax.html#syntax-attribute-value
24 | 
25 | (defun must-quote? (char)
26 |   (declare (character char))
27 |   (or (whitespace char)
28 |       (case char
29 |         ;; NB The HTML spec only requires escaping trailing slashes,
30 |         ;; but not all parsers implement that.
31 |         ((#\" #\' #\` #\= #\< #\> #\/) t))))
32 | 
33 | (defun needs-quotes? (string)
34 |   (declare (string string))
35 |   (or *always-quote*
36 |       (some #'must-quote? string)
37 |       ;; See docstring for must-quote.
38 |       ;; (string$= "/" string)
39 |       ))
40 | 
41 | ;; See 8.3.
42 | ;; http://www.w3.org/TR/html5/the-end.html#serializing-html-fragments
43 | 
44 | (defun escape-string-char (c)
45 |   (declare (character c)
46 |            (optimize (speed 3) (safety 1) (debug 0)))
47 |   (case c
48 |     (#\& "&amp;")
49 |     (#.no-break-space "&nbsp;")
50 |     (#\< "&lt;")
51 |     (#\> "&gt;")
52 |     (#\" "&quot;")
53 |     (#\' "&#39;")))
54 | 
55 | (defun escape-string (string)
56 |   "Escape STRING as HTML."
57 |   (escape-with-table string #'escape-string-char))
58 | 
59 | (defun escape-to-string (object)
60 |   (if (stringp object)
61 |       (escape-string object)
62 |       (escape-string (princ-to-string object))))
63 | 
64 | (defun escape-attribute-value (string)
65 |   (escape-with-table string
66 |                      (lambda (c)
67 |                        (case c
68 |                          (#\& "&amp;")
69 |                          (#.no-break-space "&nbsp;")
70 |                          (#\" "&quot;")
71 |                          (#\' "&#39;")))))
72 | 
73 | (defun escape-to-stream (string table stream)
74 |   (escape string table :stream stream))
75 | 
76 | (defun escape-with-table (string table)
77 |   (escape string table))
78 | 
79 | ;; See 8.1.5
80 | ;; http://www.w3.org/TR/html5/syntax.html#cdata-sections
81 | 
82 | (defconst cdata-start "<![CDATA[")
83 | 
84 | (defconst cdata-end "]]>")
85 | 
86 | (defun escape-cdata (text)
87 |   (remove-substring text cdata-end))
88 | 
89 | ;; See 8.1.6
90 | ;; http://www.w3.org/TR/html5/syntax.html#comments
91 | 
92 | (defun escape-comment (text)
93 |   (remove-substring (string-trim ">-" text) "--"))
94 | 
95 | (defun remove-substring (string substring)
96 |   (string-replace-all substring string ""))
97 | 


--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; package.lisp
 2 | 
 3 | (defpackage #:spinneret
 4 |   (:use #:cl)
 5 |   (:export #:with-html #:with-html-string #:html
 6 |            #:*html*
 7 |            #:*html-lang* #:*html-charset*
 8 |            #:*html-path*
 9 |            #:html-stream
10 |            #:get-html-path
11 |            #:do-elements
12 |            #:deftag
13 |            #:*unvalidated-attribute-prefixes*
14 |            #:*boolean-attributes*
15 |            #:*fill-column*
16 |            #:html-length
17 |            #:dynamic-tag
18 |            #:*html-style*
19 |            #:spinneret-error
20 |            #:no-such-tag
21 |            #:*suppress-inserted-spaces*
22 |            #:interpret-html-tree
23 |            #:escape-string
24 | 	   #:*always-quote*)
25 |   (:import-from #:trivial-gray-streams
26 |                 #:fundamental-character-output-stream
27 |                 #:stream-write-char #:stream-write-string
28 |                 #:stream-terpri
29 |                 #:stream-fresh-line
30 |                 #:stream-finish-output
31 |                 #:stream-force-output
32 |                 #:stream-advance-to-column
33 |                 #:stream-start-line-p
34 |                 #:stream-line-column)
35 |   (:import-from #:alexandria
36 |                 #:array-index
37 |                 #:clamp
38 |                 #:string-designator
39 |                 #:make-keyword
40 |                 #:parse-body #:parse-ordinary-lambda-list
41 |                 #:with-gensyms #:with-unique-names
42 |                 #:remove-from-plist
43 |                 #:starts-with-subseq
44 |                 #:when-let #:if-let
45 |                 #:assoc-value
46 |                 #:disjoin
47 |                 #:doplist
48 | 		#:hash-table-keys
49 |                 #:alist-hash-table
50 |                 #:once-only
51 |                 #:first-elt)
52 |   (:import-from #:serapeum
53 |                 #:fmt #:eif #:econd
54 |                 #:define-do-macro #:defconst
55 |                 #:nlet #:nix #:assure
56 |                 #:find-keyword
57 |                 #:-> #:with-thunk
58 |                 #:and-let* #:op #:string-prefix-p
59 |                 #:memq
60 |                 #:string$=
61 |                 #:string^=
62 |                 #:escape
63 |                 #:defconst
64 |                 #:defconstructor
65 |                 #:string-replace-all
66 |                 #:local*
67 |                 #:fbind
68 |                 #:fbind*
69 |                 #:bound-value
70 |                 #:defmethods
71 |                 #:eval-if-constant
72 |                 #:parse-leading-keywords
73 |                 #:car+cdr
74 |                 #:mvlet*
75 |                 #:receive
76 |                 #:set-hash-table
77 |                 #:do-hash-table
78 |                 #:eval-always
79 |                 #:lret
80 |                 #:do-hash-table
81 |                 #:whitespacep)
82 |   (:import-from #:cl-ppcre
83 |                 #:split)
84 |   (:import-from #:trivia
85 |                 #:match)
86 |   (:import-from #:global-vars
87 |                 #:define-global-parameter))
88 | 
89 | (defpackage #:spinneret-user
90 |   (:use #:cl #:spinneret))
91 | 


--------------------------------------------------------------------------------
/deftag.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:spinneret)
  2 | 
  3 | (in-nomine:define-namespace deftag
  4 |   :name-type symbol
  5 |   :value-type (function (list) list))
  6 | 
  7 | (defun parse-deftag-body (body)
  8 |   (multiple-value-bind (name attrs body)
  9 |       (tag-parts (cons :tag body))
 10 |     (declare (ignore name))
 11 |     (multiple-value-bind (body decls)
 12 |         (parse-body body)
 13 |       (values body attrs decls))))
 14 | 
 15 | (defun splice-allow-other-keys (lambda-list)
 16 |   (let ((keys (member '&key lambda-list)))
 17 |     (if (null keys)
 18 |         lambda-list
 19 |         (let ((end-of-keys (member-if (lambda (x)
 20 |                                         (and (symbolp x)
 21 |                                              (starts-with-subseq "&" (string x))))
 22 |                                       (cdr keys))))
 23 |           (append (ldiff lambda-list keys)
 24 |                   (ldiff keys end-of-keys)
 25 |                   '(&allow-other-keys)
 26 |                   end-of-keys)))))
 27 | 
 28 | (defun allow-other-keys (lambda-list)
 29 |   (cond ((null lambda-list)
 30 |          '(&key &allow-other-keys))
 31 |         ((find '&allow-other-keys lambda-list)
 32 |          lambda-list)
 33 |         (t (splice-allow-other-keys lambda-list))))
 34 | 
 35 | (defun extract-lambda-list-keywords (lambda-list)
 36 |   "Get the actual keywords from the lambda list."
 37 |   (mapcar #'caar (nth-value 3 (parse-ordinary-lambda-list lambda-list))))
 38 | 
 39 | (defun lambda-list-vars (lambda-list)
 40 |   (multiple-value-bind (req opt rest key aok aux)
 41 |       (parse-ordinary-lambda-list lambda-list)
 42 |     (declare (ignore aok))
 43 |     (remove nil
 44 |             (append req
 45 |                     (mapcar #'car opt)
 46 |                     (list rest)
 47 |                     (mapcar #'cadar key)
 48 |                     (mapcar #'car aux)))))
 49 | 
 50 | (defmacro deftag/keyword (name (body attrs-var &rest ll) &body tag)
 51 |   "Base case for a deftag that does not define a macro."
 52 |   (when (eql attrs-var '&key)
 53 |     (error "Missing attributes variable."))
 54 |   (mvlet* ((tag decls docstring
 55 |             (parse-body tag :documentation t))
 56 |            ;; Remove the keywords from the attributes.
 57 |            (attrs
 58 |             `(remove-from-plist ,attrs-var ,@(extract-lambda-list-keywords ll))))
 59 |     (with-gensyms (tmp-body)
 60 |       `(progn
 61 |          (eval-always
 62 |            (setf (symbol-deftag ',name)
 63 |                  (lambda (,tmp-body)
 64 |                    ,docstring
 65 |                    (multiple-value-bind  (,tmp-body ,attrs-var)
 66 |                        (parse-deftag-body ,tmp-body)
 67 |                      (destructuring-bind ,(if (symbolp body) `(&rest ,body) body)
 68 |                          ,tmp-body
 69 |                        ,@decls
 70 |                        ;; Bind the keywords to the provided arguments.
 71 |                        (destructuring-bind ,(allow-other-keys ll)
 72 |                            ,attrs-var
 73 |                          (let ((,attrs-var ,attrs))
 74 |                            (list 'with-html ,@tag))))))))
 75 |          ',name))))
 76 | 
 77 | (defmacro deftag/macro (name (body attrs-var &rest ll) &body tag)
 78 |   "A deftag that also defined a macro."
 79 |   (mvlet* ((tag decls docstring
 80 |             (parse-body tag :documentation t)))
 81 |     (declare (ignore decls))
 82 |     `(progn
 83 |        (deftag/keyword ,name (,body ,attrs-var ,@ll) ,@tag)
 84 |        (defmacro ,name (&body ,body)
 85 |          ,@(and docstring (list docstring))
 86 |          (deftag-expand ',name ,body :error t)))))
 87 | 
 88 | (defmacro deftag (name (body attrs-var &rest ll) &body tag)
 89 |   "Define NAME as a tag.
 90 | If NAME is not a keyword, it will also be defined as a macro with an
 91 | implicit `with-html'."
 92 |   (let ((definer
 93 |           (if (keywordp name)
 94 |               'deftag/keyword
 95 |               'deftag/macro)))
 96 |     `(,definer ,name (,body ,attrs-var ,@ll) ,@tag)))
 97 | 
 98 | (defun deftag-expand (element args &key error)
 99 |   (cond ((deftag-boundp element)
100 |          (funcall (symbol-deftag element) args))
101 |         (error (symbol-deftag element))
102 |         (t (cons element args))))
103 | 


--------------------------------------------------------------------------------
/stream.lisp:
--------------------------------------------------------------------------------
  1 | (in-package :spinneret)
  2 | 
  3 | (defgeneric html-stream.base-stream (stream)
  4 |   (:method ((stream stream))
  5 |     stream))
  6 | 
  7 | (defgeneric html-stream-column (stream)
  8 |   (:method ((x stream))
  9 |     0))
 10 | 
 11 | (defclass html-stream (fundamental-character-output-stream)
 12 |   ((col :type (integer 0 *) :initform 0
 13 |         :reader html-stream-column
 14 |         :reader stream-line-column)
 15 |    (line :type (integer 0 *) :initform 0)
 16 |    (last-char :type character
 17 |               ;; The last char defaults to newline to get reasonable
 18 |               ;; behavior from fresh-line.
 19 |               :initform #\Newline)
 20 |    (elastic-newline :type boolean
 21 |                     :initform nil)
 22 |    (base-stream :type stream
 23 |                 :initarg :base-stream
 24 |                 :reader html-stream.base-stream))
 25 |   (:default-initargs))
 26 | 
 27 | (defun make-html-stream (base-stream)
 28 |   (make-instance 'html-stream
 29 |                  :base-stream (assure stream base-stream)))
 30 | 
 31 | (defgeneric html-stream? (x)
 32 |   (:method ((x t)) nil))
 33 | 
 34 | (defgeneric ensure-html-stream (x)
 35 |   (:method ((x stream))
 36 |     (if *print-pretty*
 37 |         (make-html-stream x)
 38 |         (assure stream x))))
 39 | 
 40 | (defgeneric elastic-newline (stream)
 41 |   (:method ((x t))
 42 |     (values)))
 43 | 
 44 | (defun newline (&optional s)
 45 |   (when *print-pretty*
 46 |     (terpri s)))
 47 | 
 48 | (defmethods html-stream (s col line last-char base-stream elastic-newline)
 49 |   (:method ensure-html-stream (s)
 50 |     s)
 51 | 
 52 |   (:method html-stream? (s)
 53 |     t)
 54 | 
 55 |   (:method stream-start-line-p (s)
 56 |     (= col 0))
 57 | 
 58 |   (:method fire-elastic-newline (s (char (eql #\Newline)))
 59 |     (nix elastic-newline))
 60 | 
 61 |   (:method fire-elastic-newline (s (char character))
 62 |     (when (nix elastic-newline)
 63 |       (unless *pre*
 64 |         (write-char #\Newline s))))
 65 | 
 66 |   (:method stream-write-char (s (char (eql #\Newline)))
 67 |     (nix elastic-newline)
 68 |     ;; Remember the starting value is -1.
 69 |     (let ((indent (max 0 (get-indent))))
 70 |       (write-char #\Newline base-stream)
 71 |       (incf line)
 72 |       ;; (PRINC INDENT)
 73 |       (setf col indent)
 74 |       (loop repeat indent do
 75 |         (write-char #\Space base-stream)))
 76 |     (setf last-char #\Newline))
 77 | 
 78 |   (:method stream-write-char (s char)
 79 |     (fire-elastic-newline s char)
 80 |     (incf col 1)
 81 |     (write-char char base-stream)
 82 |     (setf last-char char))
 83 | 
 84 |   (:method stream-write-string (s string &optional (start 0) end)
 85 |     (declare (type (or null array-index) start end))
 86 |     (prog1 string
 87 |       (let* ((end (or end (length string)))
 88 |              (start (or start 0))
 89 |              (len (assure array-index (- end start))))
 90 |         (cond ((= len 0))
 91 |               ((= len 1)
 92 |                (write-char (aref string start) s))
 93 |               (t
 94 |                (fire-elastic-newline s (aref string start))
 95 |                (setf last-char (aref string (1- end)))
 96 |                (multiple-value-bind (newline-count chars)
 97 |                    (nlet rec ((i start)
 98 |                               (lines 0)
 99 |                               (chars 0))
100 |                      (eif (= i end)
101 |                           (values lines chars)
102 |                           (let ((c (aref string i)))
103 |                             (eif (eql c #\Newline)
104 |                                  (rec (1+ i)
105 |                                       (1+ lines)
106 |                                       0)
107 |                                  (rec (1+ i)
108 |                                       lines
109 |                                       (1+ chars))))))
110 |                  (declare (array-index newline-count chars))
111 |                  (write-string string base-stream :start start :end end)
112 |                  (eif (> newline-count 0)
113 |                       (progn
114 |                         (incf line newline-count)
115 |                         (setf col chars))
116 |                       (incf col chars))))))))
117 | 
118 |   (:method stream-terpri (s)
119 |     (write-char #\Newline s))
120 | 
121 |   (:method stream-fresh-line (s)
122 |     (prog1 (unless (eql last-char #\Newline)
123 |              (terpri s))
124 |       (assert (eql last-char #\Newline))))
125 | 
126 |   (:method stream-finish-output (s)
127 |     (finish-output base-stream))
128 | 
129 |   (:method stream-force-output (s)
130 |     (force-output base-stream))
131 | 
132 |   (:method stream-advance-to-column (s c)
133 |     (loop while (< col c) do
134 |       (write-char #\Space s))
135 |     (assert (>= col c))
136 |     t)
137 | 
138 |   (:method elastic-newline (s)
139 |     (setf elastic-newline t)))
140 | 


--------------------------------------------------------------------------------
/ps.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:spinneret)
  2 | 
  3 | (defparameter *props*
  4 |   '("acceptCharset" "accessKey" "allowTransparency" "bgColor" "cellPadding"
  5 |     "cellSpacing" "className" "className" "colSpan" "style" "defaultChecked"
  6 |     "defaultSelected" "defaultValue" "htmlFor" "frameBorder" "hSpace" "htmlFor"
  7 |     "longDesc" "maxLength" "marginWidth" "marginHeight" "noResize" "noShade"
  8 |     "readOnly" "rowSpan" "tabIndex" "vAlign" "vSpace"))
  9 | 
 10 | (defparameter *ie-attr-props*
 11 |   '(("for"   . "htmlfor")
 12 |     ("class" . "classname")))
 13 | 
 14 | (ps:define-ps-symbol-macro *html* (ps:@ window spinneret))
 15 | 
 16 | (ps:define-ps-symbol-macro *html-charset* (lisp *html-charset*))
 17 | 
 18 | (ps:define-ps-symbol-macro *html-lang* (lisp *html-lang*))
 19 | 
 20 | (ps:defpsmacro ch (&rest args)
 21 |   `(ps:chain ,@args))
 22 | 
 23 | (ps:defpsmacro with-html (&rest html-forms)
 24 |   (ps:with-ps-gensyms (node d)
 25 |     `(let ((,node (or *html*
 26 |                       (setf *html* (ch document (create-document-fragment)))))
 27 |            (,d document))
 28 |        (symbol-macrolet ((*html* ,node)
 29 |                          (document ,d))
 30 |          ,@(with-standard-io-syntax
 31 |              (parse-html html-forms nil)))
 32 |        (unless (ps:@ ,node parent-node)
 33 |          (prog1 ,node
 34 |            (setf *html* nil))))))
 35 | 
 36 | (ps:defpsmacro with-tag ((name &rest attributes) &body body)
 37 |   `(progn
 38 |      (setf *html*
 39 |            (ch *html*
 40 |                (append-child
 41 |                 (ch document (create-element ,(string-downcase name))))))
 42 |      ,@(loop for (attr val . nil) on attributes by #'cddr
 43 |              collect (make-attr-setter (string-downcase attr) val))
 44 |      ,@(when body
 45 |          (loop for form in body
 46 |                if (and (consp form) (eql (car form) 'with-tag))
 47 |                  collect form
 48 |                else collect `(ch *html* (append-child
 49 |                                          (ch document
 50 |                                              (create-text-node
 51 |                                               (ps:stringify ,form)))))))
 52 |      (setf *html* (ps:@ *html* parent-node))
 53 |      nil))
 54 | 
 55 | (defun make-attr-setter (attr val)
 56 |   ;; Compatibility hacks from Laconic.js 0.2.2.
 57 |   (let ((attr (or (find
 58 |                    (or (cdr (assoc attr *ie-attr-props* :test #'string-equal))
 59 |                        attr)
 60 |                    *props* :test #'string-equal)
 61 |                   attr))
 62 |         (sval `(ps:stringify ,val)))
 63 |     (flet ((set-or-remove (object attr val)
 64 |              (ps:with-ps-gensyms (actual-val)
 65 |                `(let ((,actual-val ,val))
 66 |                   (if ,actual-val
 67 |                       (ch ,object (set-attribute ,attr (ps:stringify ,actual-val)))
 68 |                       (ch ,object (remove-attribute ,attr)))))))
 69 |       (cond
 70 |         ((event? attr)
 71 |          ;; Set events as properties, ensuring a href.
 72 |          `(setf (ps:@ *html* ,attr) ,sval
 73 |                 (ps:@ *html* href)
 74 |                 (or (ps:@ *html* href) "#")))
 75 |         ;; Style requires special handling for IE.
 76 |         ((string-equal attr "style")
 77 |          `(if (ps:@ *html* style set-attribute)
 78 |               (ch *html* style (set-attribute 'css-text ,sval))
 79 |               (ch *html* (set-attribute ,attr ,sval))))
 80 |         ((rassoc attr *ie-attr-props* :test #'string-equal)
 81 |          ;; Other special cases for IE.
 82 |          `(setf (ps:@ *html* ,attr) ,sval))
 83 |         ((data-attr? attr)
 84 |          `(setf (ps:@ *html* dataset ,(data-attr-prop attr)) ,sval))
 85 |         ((string-equal attr "attrs")
 86 |          (ps:with-ps-gensyms (attrs attr)
 87 |            `(let ((,attrs ,val))
 88 |               (ps:for-in (,attr ,attrs)
 89 |                          ,(set-or-remove '*html* attr `(ps:@ ,attrs ,attr))))))
 90 |         (t (set-or-remove '*html* attr val))))))
 91 | 
 92 | (defun event? (attr)
 93 |   (starts-with-subseq "on" (string attr)))
 94 | 
 95 | (defun data-attr? (attr)
 96 |   (starts-with-subseq "data-" (string attr) :test #'char-equal))
 97 | 
 98 | (defun data-attr-prop (attr)
 99 |   (substitute #\_ #\-
100 |               (subseq (string-downcase attr)
101 |                       #.(length "data-"))))
102 | 
103 | (ps:defpsmacro comment (text safe?)
104 |   (declare (ignore safe?))
105 |   `(ps:stringify
106 |     ,(ps::concat-constant-strings
107 |       (list "<!-- " text " -->"))))
108 | 
109 | (ps:defpsmacro cdata (text safe?)
110 |   (declare (ignore safe?))
111 |   `(ps:stringify
112 |     ,(ps::concat-constant-strings
113 |       (list cdata-start text cdata-end))))
114 | 
115 | (ps:defpsmacro format-text (formatter &rest args)
116 |   (let ((control-string
117 |           (if (listp formatter)
118 |               (second formatter)
119 |               formatter)))
120 |     (prog1 control-string
121 |       (when args
122 |         (cerror
123 |          "Discard arguments and print \"~A\" literally."
124 |          "Parenscript doesn't have FORMAT."
125 |          control-string)))))
126 | 
127 | (ps:defpsmacro join-tokens (&rest classes)
128 |   `(ps:stringify
129 |     ,@(ps::concat-constant-strings
130 |        (intersperse " "
131 |                     (remove-duplicates (remove nil classes)
132 |                                        :test #'equal)))))
133 | 
134 | (defun intersperse (new-elt list)
135 |   (cons (car list)
136 |         (mapcan
137 |          (lambda (elt)
138 |            (list new-elt elt))
139 |          (cdr list))))
140 | 


--------------------------------------------------------------------------------
/functions.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:spinneret)
  2 | 
  3 | (defpackage #:spinneret.tag
  4 |   ;; This package should not import any symbols.
  5 |   (:use))
  6 | 
  7 | (eval-when (:compile-toplevel :load-toplevel :execute)
  8 |   (defparameter *tags-pkg* (find-package :spinneret.tag))
  9 | 
 10 |   (defun tag-fn (tag &key intern)
 11 |     (let ((tag (string tag)))
 12 |       (if intern
 13 |           (intern tag *tags-pkg*)
 14 |           (find-symbol tag *tags-pkg*))))
 15 | 
 16 |   (-> tag-open (string-designator) (simple-array character (*)))
 17 |   (defun tag-open (tag)
 18 |     (coerce (fmt "<~(~A~)" tag)
 19 |             '(simple-array character (*))))
 20 | 
 21 |   (-> tag-close (string-designator) (simple-array character (*)))
 22 |   (defun tag-close (tag)
 23 |     (if (void? tag)
 24 |         ""
 25 |         (coerce (fmt "</~(~A~)>" tag)
 26 |                 '(simple-array character (*))))))
 27 | 
 28 | (defmacro define-tag (tag)
 29 |   (let* ((inline? (inline? tag))
 30 |          (paragraph? (paragraph? tag))
 31 |          (fn-name (tag-fn tag :intern t))
 32 |          (open (tag-open tag))
 33 |          (close (tag-close tag))
 34 |          (needs-close? (needs-close? tag)))
 35 |     `(progn
 36 |        (declaim (notinline ,fn-name))
 37 |        (declaim (ftype (function (list function t t) (values))
 38 |                        ,fn-name))
 39 |        (defun ,fn-name (attrs body pre? empty?)
 40 |          (let* ((html *html*)
 41 |                 (pretty *print-pretty*)
 42 |                 (style *html-style*)
 43 |                 (*pre* (or *pre* pre?))
 44 |                 (*depth* (1+ *depth*))
 45 |                 (*html-path* (cons ,(make-keyword tag) *html-path*)))
 46 |            (declare (dynamic-extent *html-path*))
 47 |            ,(econd
 48 |               (inline?
 49 |                `(print-inline-tag html pretty style
 50 |                                   ,open ,(length open)
 51 |                                   attrs
 52 |                                   empty? body
 53 |                                   ,close
 54 |                                   ,needs-close?))
 55 |               (paragraph?
 56 |                `(print-par-tag html pretty style
 57 |                                ,open attrs
 58 |                                empty? body
 59 |                                ,close
 60 |                                ,needs-close?))
 61 |               (t
 62 |                `(print-block-tag html pretty style
 63 |                                  ,open attrs
 64 |                                  empty? body
 65 |                                  ,close
 66 |                                  ,needs-close?)))
 67 |            (values))))))
 68 | 
 69 | (defmacro define-all-tags ()
 70 |   `(progn
 71 |      ,@(loop for tag in (hash-table-keys *html5-elements*)
 72 |              collect `(define-tag ,tag))))
 73 | 
 74 | ;;; The auxiliary functions are block-compiled for speed.
 75 | 
 76 | (local*
 77 |   (declaim (optimize (speed 3) (safety 0) (debug 0)
 78 |                      (compilation-speed 0)))
 79 | 
 80 |   (declaim (inline close-inline close-block))
 81 | 
 82 |   (defun open-block (html pretty open attrs)
 83 |     (when pretty
 84 |       (fresh-line html))
 85 |     (write-string open html)
 86 |     (when attrs
 87 |       (if pretty
 88 |           (format-attributes-pretty/block attrs html)
 89 |           (format-attributes-plain attrs html)))
 90 |     (write-char #\> html))
 91 | 
 92 |   (defun open-par (html pretty open attrs)
 93 |     (open-block html pretty open attrs))
 94 | 
 95 |   (defun open-inline (html pretty open offset attrs)
 96 |     (when pretty
 97 |       (maybe-wrap offset html))
 98 |     (write-string open html)
 99 |     (when attrs
100 |       (if pretty
101 |           (format-attributes-pretty/inline attrs html)
102 |           (format-attributes-plain attrs html)))
103 |     (write-char #\> html))
104 | 
105 |   (defun block-body (html body pretty)
106 |     (declare (type function body))
107 |     (when pretty
108 |       (elastic-newline html))
109 |     (let ((*indent* (1+ *depth*)))
110 |       (without-trailing-space
111 |         (funcall body)))
112 |     (when (and pretty (not *pre*))
113 |       (terpri html)))
114 | 
115 |   (defun inline-body (body)
116 |     (declare (type function body))
117 |     (let ((*indent* (1+ *depth*)))
118 |       (without-trailing-space
119 |         (funcall body)))
120 |     (values))
121 | 
122 |   (defun par-body (body)
123 |     (inline-body body))
124 | 
125 |   (defun close-inline (html close needs-close?)
126 |     (when needs-close?
127 |       (write-string close html)))
128 | 
129 |   (defun close-block (html close needs-close?)
130 |     (when needs-close?
131 |       (write-string close html)))
132 | 
133 |   (defun close-par (html close needs-close?)
134 |     (when needs-close?
135 |       (write-string close html))
136 |     (elastic-newline html))
137 | 
138 |   (defun print-inline-tag (html pretty style open offset attrs empty? body close needs-close?)
139 |     (when (eql style :tree)
140 |       (return-from print-inline-tag
141 |         (print-block-tag html pretty style open attrs empty? body close t)))
142 | 
143 |     (open-inline html pretty open offset attrs)
144 |     (unless empty?
145 |       (inline-body body))
146 |     (close-inline html close needs-close?))
147 | 
148 |   (defun print-par-tag (html pretty style open attrs empty? body close needs-close?)
149 |     (when (eql style :tree)
150 |       (return-from print-par-tag
151 |         (print-block-tag html pretty style open attrs empty? body close t)))
152 | 
153 |     (open-par html pretty open attrs)
154 |     (unless empty?
155 |       (par-body body))
156 |     (close-par html close needs-close?))
157 | 
158 |   (defun print-block-tag (html pretty style open attrs empty? body close needs-close?)
159 |     (when (eql style :tree)
160 |       (setq needs-close? t))
161 |     (open-block html pretty open attrs)
162 |     (unless empty?
163 |       (block-body html body pretty))
164 |     (close-block html close needs-close?))
165 | 
166 |   (progn
167 |     (defun custom-elt-fn (open close attrs body empty?)
168 |       (print-block-tag *html*
169 |                        *print-pretty*
170 |                        *html-style*
171 |                        open
172 |                        attrs
173 |                        empty?
174 |                        body
175 |                        close t))
176 | 
177 |     (defun resolve-tag-embedded-attributes (tag attrs)
178 |       (mvlet* ((tag tag-attrs (dissect-tag tag))
179 |                (tag (or (and-let* ((kw (find-keyword (string-upcase tag)))
180 |                                    ((valid? kw))))
181 |                         (error 'no-such-tag :name tag)))
182 |                (attrs (append tag-attrs attrs)))
183 |         (values tag attrs)))
184 | 
185 |     (defun dynamic-tag* (tag attrs body empty?)
186 |       "Dynamically select a tag at runtime.
187 | Note that TAG must be a known tag."
188 |       (mvlet* ((tag attrs (resolve-tag-embedded-attributes tag attrs))
189 |                (open (tag-open tag))
190 |                ;; Note that dynamic tags always print the closing tag --
191 |                ;; not worth the effort to check.
192 |                (close (tag-close tag))
193 |                (*pre* (or *pre* (and (preformatted? tag) t)))
194 |                (*depth* (1+ *depth*))
195 |                (*html-path* (cons tag *html-path*))
196 |                (pretty *print-pretty*)
197 |                (style *html-style*))
198 |         (declare (dynamic-extent *html-path*))
199 |         (cond ((inline? tag)
200 |                (print-inline-tag
201 |                 *html*
202 |                 pretty style
203 |                 open (length open) attrs
204 |                 empty?
205 |                 body
206 |                 close t))
207 |               ((paragraph? tag)
208 |                (print-par-tag
209 |                 *html*
210 |                 pretty style
211 |                 open attrs
212 |                 empty? body
213 |                 close t))
214 |               (t
215 |                (print-block-tag
216 |                 *html*
217 |                 pretty style
218 |                 open
219 |                 attrs
220 |                 empty?
221 |                 (assure function body)
222 |                 close t)))
223 |         (values)))
224 | 
225 |     (define-all-tags)))
226 | 


--------------------------------------------------------------------------------
/compile.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Functions used only at compile time.
  2 | 
  3 | (in-package #:spinneret)
  4 | 
  5 | (defun live-deftag-form? (form)
  6 |   "If FORM starts with a deftag, return non-nil."
  7 |   (and (symbolp (car form))
  8 |        (deftag-boundp (car form))))
  9 | 
 10 | (defun parse-html (form env)
 11 |   (labels ((rec (form)
 12 |              (cond
 13 |                ;; There's nothing we can do with an atom.
 14 |                ((atom form) form)
 15 |                ;; There's nothing we can do with an improper list, either.
 16 |                ((dotted-list? form) form)
 17 |                ;; If the form is constant, leave it to be inlined.
 18 |                ((ignore-errors (constantp form env)) form)
 19 |                ;; Don't descend into nested with-tag forms.
 20 |                ((eql (car form) 'with-tag) form)
 21 |                ((eql (car form) :disable-html)
 22 |                 (if (null (cddr form))
 23 |                     (cadr form)
 24 |                     `(progn ,@(cdr form))))
 25 |                ;; Compile as a tag.
 26 |                ((keywordp (car form))
 27 |                 (mvlet* ((name attrs body (tag-parts form))
 28 |                          ;; Canonical form, without inline ids or tags.
 29 |                          (form (append (list name) attrs body))
 30 |                          (form (pseudotag-expand (car form) (cdr form)))
 31 |                          (form (deftag-expand (car form) (cdr form))))
 32 |                   (if (not (keywordp (car form))) form
 33 |                       (mvlet* ((name attrs body (tag-parts form)))
 34 |                         (if (live-deftag-form? form) form
 35 |                             (if (valid? name)
 36 |                                 (let ((body (mapcar #'rec body)))
 37 |                                   (if (valid-custom-element-name? name)
 38 |                                       `(with-custom-element (,name ,@attrs)
 39 |                                          ,@body)
 40 |                                       `(with-tag (,name ,@attrs)
 41 |                                          ,@body)))
 42 |                                 (cons (car form)
 43 |                                       (mapcar #'rec (cdr form)))))))))
 44 |                ;; Don't descend into non-keyword deftags.
 45 |                ((live-deftag-form? form) form)
 46 |                ;; Compile as a format string (possibly using Markdown).
 47 |                ((stringp (car form))
 48 |                 (destructuring-bind (control-string . args)
 49 |                     form
 50 |                   (let ((cs (parse-as-markdown control-string)))
 51 |                     `(format-text
 52 |                       ,@(if (and args (every (lambda (arg) (constantp arg env)) args))
 53 |                             (list (format nil "~?" cs
 54 |                                           (mapcar #'escape-to-string args)))
 55 |                             `((formatter ,cs)
 56 |                               ,@(loop for arg in args
 57 |                                       ;; Escape literal strings at
 58 |                                       ;; compile time.
 59 |                                       if (typep arg 'string env)
 60 |                                         collect (escape-to-string arg)
 61 |                                       else collect `(xss-escape ,arg))))))))
 62 |                ;; Keep going.
 63 |                (t (cons (rec (car form))
 64 |                         (mapcar #'rec (cdr form)))))))
 65 |     (rec form)))
 66 | 
 67 | (defun dotted-list? (list)
 68 |   (declare (cons list))
 69 |   (not (null (cdr (last list)))))
 70 | 
 71 | (defun dissect-tag (tag)
 72 |   "Dissect a tag like `:div.class#id' into the tag itself and a plist
 73 | of attributes."
 74 |   (if (notany (lambda (c)
 75 |                 (member c '(#\# #\.)))
 76 |               (string tag))
 77 |       (values tag nil)
 78 |       (destructuring-bind (tag . parts)
 79 |           (split "([.#])" (string-downcase tag) :with-registers-p t)
 80 |         (values (make-keyword (string-upcase tag))
 81 |                 (sublis '(("." . :class)
 82 |                           ("#" . :id))
 83 |                         parts
 84 |                         :test #'equal)))))
 85 | 
 86 | (defun simplify-tokenized-attributes (attrs)
 87 |   "Return an alist of the tokenized attributes (like :class) and a
 88 | plist of the regular attributes."
 89 |   (let ((tokenized ()))
 90 |     (loop for (k v . nil) on attrs by #'cddr
 91 |           if (tokenized-attribute? k)
 92 |             do (push v (assoc-value tokenized k))
 93 |           else append (list k v) into regular
 94 |           finally (return
 95 |                     (append (tokenized-attributes-plist tokenized)
 96 |                             regular)))))
 97 | 
 98 | (defun tokenized-attributes-plist (alist)
 99 |   "When possible, join tokenized attributes at compile time."
100 |   (loop for (tag . tokens) in alist
101 |         append (let ((tokens (reverse tokens)))
102 |                  `(,tag
103 |                    ,(if (every (disjoin #'stringp #'null #'keywordp) tokens)
104 |                         (apply #'join-tokens tokens)
105 |                         `(join-tokens ,@tokens))))))
106 | 
107 | (defun join-tokens (&rest tokens)
108 |   (when-let (tokens (remove-duplicates (remove nil tokens) :test #'equal))
109 |     (with-output-to-string (s)
110 |       (loop for (token . rest) on tokens do
111 |         (eif (keywordp token)
112 |              (format s "~(~a~)" token)
113 |              (format s "~a" token))
114 |         (when rest (write-char #\Space s))))))
115 | 
116 | (define-compiler-macro join-tokens (&whole call &rest tokens)
117 |   (cond ((null tokens) nil)
118 |         ((null (rest tokens))
119 |          (let ((token (car tokens)))
120 |            (once-only (token)
121 |              `(and ,token (princ-to-string ,token)))))
122 |         (t call)))
123 | 
124 | (defun tag-parts (form)
125 |   "Parse a form into an element, attributes, and a body. Provided
126 | the form qualifies as a tag, the element is the car, the attributes
127 | are all the following key-value pairs, and the body is what remains."
128 |   (when (keywordp (car form))
129 |     (mvlet* ((tag-name body (car+cdr form))
130 |              (tag tag-attrs (dissect-tag tag-name))
131 |              (attrs body
132 |               (parse-leading-keywords (append tag-attrs body))))
133 |       (values tag (simplify-tokenized-attributes attrs) body))))
134 | 
135 | (defun tag-thunk-name (name attrs)
136 |   "Produce a helpful name for a thunk from NAME and ATTRS."
137 |   (let ((id (getf attrs :id)))
138 |     (fmt "<~a~@[#~a~]>" name id)))
139 | 
140 | (defun wrap-body-as-stack-thunk (thunk-name body form)
141 |   `(prog1 nil
142 |      (flet ((,thunk-name ()
143 |               ,@(loop for expr in body
144 |                       collect `(catch-output ,expr))))
145 |        (declare (dynamic-extent (function ,thunk-name)))
146 |        ,form)))
147 | 
148 | (defmacro with-tag ((name &rest attributes) &body body)
149 |   (let* ((empty? (not body))
150 |          (pre? (not (null (preformatted? name))))
151 |          (tag-fn (or (tag-fn name) (error 'no-such-tag :name name)))
152 |          (thunk (gensym (tag-thunk-name name attributes))))
153 |     (wrap-body-as-stack-thunk
154 |      thunk body
155 |      `(,tag-fn
156 |        (macrolet ((:raw (s)
157 |                     `(escaped-string ,s)))
158 |          (list ,@(escape-attrs name attributes)))
159 |        #',thunk
160 |        ,pre?
161 |        ,empty?))))
162 | 
163 | (defmacro with-custom-element ((name &rest attrs) &body body)
164 |   (check-type name keyword)
165 |   (let* ((open (tag-open name))
166 |          (close (tag-close name))
167 |          (thunk (gensym (tag-thunk-name name attrs)))
168 |          (empty? (null body)))
169 |     (wrap-body-as-stack-thunk
170 |      thunk body
171 |      `(custom-elt-fn ,open ,close
172 |                      (list ,@(escape-attrs name attrs))
173 |                      #',thunk
174 |                      ,empty?))))
175 | 
176 | (defun escape-attrs (tag attrs)
177 |   (let ((attrs
178 |           (loop for (attr val . nil) on attrs by #'cddr
179 |                 if (eql attr :dataset)
180 |                   append (escape-attrs
181 |                           tag
182 |                           (loop for (attr val . nil) on val by #'cddr
183 |                                 collect (make-keyword (fmt "~:@(data-~A~)" attr))
184 |                                 collect val))
185 |                 else if (eql attr :attrs)
186 |                        collect attr and collect val
187 |                 else if (or (stringp val)
188 |                             (numberp val)
189 |                             (characterp val))
190 |                        collect attr and collect (escape-value val)
191 |                 else
192 |                   collect attr and collect `(escape-value ,val))))
193 |     (loop for (attr nil . nil) on attrs by #'cddr
194 |           unless (valid-attribute? tag attr)
195 |             do (warn "~A is not a valid attribute for <~A>"
196 |                      attr tag))
197 |     attrs))
198 | 
199 | (declaim (notinline parse-as-markdown))
200 | (defun parse-as-markdown (string)
201 |   "Placeholder, load spinneret/cl-markdown system if you want to expand
202 |   markdown."
203 |   string)
204 | 
205 | (defun trim-ends (prefix string suffix)
206 |   (declare (string prefix string suffix))
207 |   (let ((pre (mismatch string prefix))
208 |         (suf (mismatch string suffix :from-end t)))
209 |     (subseq string
210 |             (if (= pre (length prefix)) pre 0)
211 |             (if (= suf (- (length string) (length suffix)))
212 |                 suf
213 |                 (length string)))))
214 | 


--------------------------------------------------------------------------------
/run.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; Functions used at run time or compile time.
  2 | 
  3 | (in-package #:spinneret)
  4 | 
  5 | (defun fast-format (stream control-string &rest args)
  6 |   "Like `format', but bind `*print-pretty*' to nil."
  7 |   (declare (dynamic-extent args))
  8 |   (let ((*print-pretty* nil))
  9 |     (format stream "~?" control-string args)))
 10 | 
 11 | (define-compiler-macro fast-format (&whole call stream control-string &rest args)
 12 |   (if (stringp control-string)
 13 |       (if (equalp control-string "~a")
 14 |           (destructuring-bind (arg) args
 15 |             `(princ ,arg ,stream))
 16 |           `(fast-format ,stream (formatter ,control-string) ,@args))
 17 |       call))
 18 | 
 19 | (-> call-without-trailing-space (function) t)
 20 | (defun call-without-trailing-space (fn)
 21 |   (let ((*pending-space* nil))
 22 |     (funcall fn)))
 23 | 
 24 | (defmacro without-trailing-space (&body body)
 25 |   (with-thunk (body)
 26 |     `(call-without-trailing-space ,body)))
 27 | 
 28 | (-> call-with-space (function) t)
 29 | (defun call-with-space (fn)
 30 |   (flush-space)
 31 |   (multiple-value-prog1 (funcall fn)
 32 |     (buffer-space)))
 33 | 
 34 | (defmacro with-space (&body body)
 35 |   (with-thunk (body)
 36 |     `(call-with-space ,body)))
 37 | 
 38 | (declaim (inline buffer-space flush-space cancel-space))
 39 | 
 40 | (defun buffer-space ()
 41 |   (setf *pending-space* t))
 42 | 
 43 | (defun flush-space ()
 44 |   (when *pending-space*
 45 |     (setf *pending-space* nil)
 46 |     (unless (or *pre* *suppress-inserted-spaces*)
 47 |       (write-char #\Space *html*))))
 48 | 
 49 | (defun cancel-space ()
 50 |   (when *pending-space*
 51 |     (setf *pending-space* nil)))
 52 | 
 53 | (defconstructor escaped-string
 54 |   (value string))
 55 | 
 56 | (defmacro catch-output (arg &environment env)
 57 |   (labels ((print-escaped (x)
 58 |              `(html ,(escaped-string (escape-string x))))
 59 |            (punt (&optional (x arg))
 60 |              `(html ,x))
 61 |            (rec (arg)
 62 |              (typecase arg
 63 |                (null nil)
 64 |                (string (print-escaped arg))
 65 |                (escaped-string (punt))
 66 |                ((or character number
 67 |                     ;; not symbol, because not evaluated.
 68 |                     keyword (member t nil))
 69 |                 (print-escaped (princ-to-string arg)))
 70 |                (t (multiple-value-bind (val constant?)
 71 |                       (eval-if-constant arg env)
 72 |                     (if (and constant?
 73 |                              (not (equal val arg)))
 74 |                         (rec val)
 75 |                         (punt)))))))
 76 |     (rec arg)))
 77 | 
 78 | ;;; Why not use a wrapper function for `html' to avoid generic
 79 | ;;; dispatch on built-in types? Simple: we want users who write
 80 | ;;; methods on `html' to be able to call `html' within their methods.
 81 | 
 82 | (defgeneric html (object)
 83 |   (:method (object)
 84 |     (declare (ignore object))
 85 |     (values))
 86 |   (:method ((nada null))
 87 |     (values))
 88 |   (:method :around ((nada null))
 89 |     (values))
 90 |   (:documentation "Handle writing OBJECT as HTML (for side-effects only)."))
 91 | 
 92 | (define-compiler-macro html (object)
 93 |   `(locally (declare (notinline html))
 94 |      ,(if (typep object '(or string character number null keyword escaped-string))
 95 |           `(html ,object)
 96 |           (with-unique-names (temp)
 97 |             `(let ((,temp ,object))
 98 |                (and ,temp (html ,temp)))))))
 99 | 
100 | (defmethod html :around (object)
101 |   (declare (ignore object))
102 |   (with-space
103 |     (call-next-method))
104 |   (values))
105 | 
106 | (defmethod html :around ((string string))
107 |   (when (string^= " " string)
108 |     (cancel-space))
109 |   (call-next-method)
110 |   (values))
111 | 
112 | (defmethod html ((string string))
113 |   (if *print-pretty*
114 |       (fill-text (escape-string string) t)
115 |       (escape-to-stream string #'escape-string-char *html*)))
116 | 
117 | (defmethod html :around ((string escaped-string))
118 |   (let ((string (escaped-string-value string)))
119 |     (when (or (string^= " " string)
120 |               ;; Don't insert spaces before punctuation.
121 |               (and (not (alexandria:emptyp string))
122 |                    (not (alpha-char-p (alexandria:first-elt string)))))
123 |       (cancel-space)))
124 |   (call-next-method)
125 |   (values))
126 | 
127 | (defmethod html ((string escaped-string))
128 |   (let ((string (escaped-string-value string)))
129 |     (if *print-pretty*
130 |         (fill-text string t)
131 |         (write-string string *html*))))
132 | 
133 | (defmethod html ((char character))
134 |   (if-let (escape (escape-string-char char))
135 |     (write-string escape *html*)
136 |     (write-char char *html*)))
137 | 
138 | (defmethod html ((n number))
139 |   (fast-format *html* "~d" n))
140 | 
141 | (defmethod html ((sym symbol))
142 |   (fast-format *html* "~a" sym))
143 | 
144 | (defun call/words (thunk string)
145 |   "Function that implements `do-words'."
146 |   (fbind (thunk)
147 |     (let ((window (make-array 0
148 |                               :element-type (array-element-type string)
149 |                               :adjustable t
150 |                               :displaced-to string
151 |                               :displaced-index-offset 0)))
152 |       (loop with len = (length string)
153 |             for left = 0 then (+ right 1)
154 |             for right = (or (position-if #'whitespace string :start left) len)
155 |             unless (= left right)
156 |               do (adjust-array window (- right left)
157 |                                :displaced-to string
158 |                                :displaced-index-offset left)
159 |                  ;; NB In terms of *words*, this might seem wrong: the
160 |                  ;; remainder of the string might just be whitespace.
161 |                  ;; However, this is the behavior we want: the presence
162 |                  ;; of trailing whitespace *should* be preserved.
163 |                  (thunk window (= right len) (= left 0))
164 |             until (= right len)))))
165 | 
166 | (define-do-macro do-words ((var at-end? first-iteration? string &optional return)
167 |                            &body body)
168 |   (with-thunk (body var at-end? first-iteration?)
169 |     `(call/words ,body ,string)))
170 | 
171 | (defun maybe-wrap (&optional (offset 0) (stream *html*))
172 |   (when *print-pretty*
173 |     (let* ((indent (get-indent))
174 |            (fill *fill-column*)
175 |            (goal (+ fill indent))
176 |            (col (+ offset (html-stream-column stream))))
177 |       (when (> col goal)
178 |         (terpri stream)))))
179 | 
180 | (defun fill-text (string &optional safe?
181 |                   &aux (html *html*)
182 |                     (pretty? *print-pretty*)
183 |                     (pre? *pre*))
184 |   (check-type string string)
185 |   (cond
186 |     ((= (length string) 0))
187 |     (pre?
188 |      (let ((stream (html-stream.base-stream html)))
189 |        (write-string string stream)))
190 |     (pretty?
191 |      (let* ((start-col (get-indent))
192 |             (fill *fill-column*)
193 |             (goal (+ fill start-col)))
194 |        (when (eql *html-style* :tree)
195 |          (fresh-line html))
196 |        (when (whitespace (aref string 0))
197 |          (write-char #\Space html))
198 |        (flet ((wrap () (terpri html)))
199 |          (declare (inline wrap))
200 |          (do-words (word at-end? first-iteration? string)
201 |            (let* ((word (if safe? word (escape-string word)))
202 |                   (len (length word)))
203 |              (cond
204 |                ;; Don't wrap after the opening of an inline element
205 |                ;; unless whitespace is already present.
206 |                ((and first-iteration?
207 |                      (inline? (car *html-path*)))
208 |                 (when (and (> (length word) 0)
209 |                            (whitespacep (aref word 0)))
210 |                   (wrap))
211 |                 (write-string word html))
212 |                ((> len fill)
213 |                 (wrap)
214 |                 (write-string word html)
215 |                 (wrap))
216 |                ((> (+ len (html-stream-column html))
217 |                    goal)
218 |                 (wrap)
219 |                 (write-string word html))
220 |                (t (write-string word html))))
221 |            (unless at-end?
222 |              (write-char #\Space html))))))
223 |     (t
224 |      (with-space
225 |        (if safe?
226 |            (write-string string *html*)
227 |            (escape-to-stream string #'escape-string-char *html*)))))
228 |   (values))
229 | 
230 | (defun format-attribute-value (value)
231 |   (cond ((equal value "") "\"\"")
232 |         ((keywordp value) (string-downcase value))
233 |         ((eql value t) "true")
234 |         (t value)))
235 | 
236 | (defun format-attributes-with (attrs print-boolean print-value)
237 |   "Format ATTRS, uses the unary function PRINT-BOOLEAN to print
238 | Boolean attributes, and the binary function PRINT-VALUE to print
239 | ordinary attributes."
240 |   (fbind (print-boolean print-value)
241 |     (let ((seen '()))
242 |       ;; Ensure that the leftmost keyword has priority,
243 |       ;; as in function lambda lists.
244 |       (labels ((seen? (name)
245 |                  (declare (optimize speed)
246 |                           (symbol name))
247 |                  (or (memq name seen)
248 |                      (progn
249 |                        (push name seen)
250 |                        nil)))
251 |                (format-attr (attr value)
252 |                  (unless (or (null value) (seen? attr))
253 |                    (if (boolean? attr)
254 |                        (print-boolean attr)
255 |                        (let ((value (format-attribute-value value)))
256 |                          (print-value attr value)))))
257 |                (dynamic-attrs (attrs)
258 |                  (doplist (a v attrs)
259 |                    (format-attr a (escape-value v)))))
260 |         (declare (inline seen?))
261 |         (doplist (attr value attrs)
262 |           (if (eql attr :attrs)
263 |               (dynamic-attrs value)
264 |               (format-attr attr value)))))))
265 | 
266 | (defun format-attributes-plain (attrs &optional (stream *html*))
267 |   (flet ((format-boolean (attr)
268 |            (format stream " ~(~a~)" attr))
269 |          (format-value (attr value)
270 |            (format stream " ~(~a~)=~a" attr value)))
271 |     (declare (dynamic-extent #'format-boolean #'format-value))
272 |     (format-attributes-with attrs #'format-boolean #'format-value)))
273 | 
274 | (defgeneric html-length (x)
275 |   (:documentation "The length of X when printed as an HTML string.
276 | 
277 | This is provided so you can give Spinneret the information it needs to
278 | make reasonable decisions about line wrapping.")
279 |   (:method ((x t)) 0))
280 | 
281 | (defun html-length* (x)
282 |   (typecase x
283 |     ((eql t) 4)
284 |     (string (length x))
285 |     (symbol (length (symbol-name x)))
286 |     (character 1)
287 |     (integer
288 |      (eif (zerop x) 1
289 |           (let ((x (abs x))
290 |                 ;; Single precision is not enough.
291 |                 (base (coerce *print-base* 'double-float)))
292 |             (1+ (floor (log x base))))))
293 |     (otherwise
294 |      (assure unsigned-byte (html-length x)))))
295 | 
296 | (defun format-attributes-pretty/inline (attrs &optional (stream *html*))
297 |   (declare (stream stream))
298 |   (let* ((start-col (get-indent))
299 |          (fill *fill-column*)
300 |          (goal (+ start-col fill)))
301 |     (fbind* ((too-long?
302 |               (if *print-pretty*
303 |                   (lambda (len)
304 |                     (> (+ len (html-stream-column stream))
305 |                        goal))
306 |                   (constantly nil)))
307 |              (print-prefix
308 |               (lambda (len attr)
309 |                 (let ((prefix (if (too-long? len) #\Newline #\Space)))
310 |                   (write-char prefix stream)
311 |                   ;; XXX Work around
312 |                   ;; <https://abcl.org/trac/ticket/166>
313 |                   #+abcl (write-string (string-downcase attr) stream)
314 |                   #-abcl (format stream "~(~a~)" attr))))
315 |              (print-boolean
316 |               (lambda (attr)
317 |                 (let ((len (length (symbol-name attr))))
318 |                   ;; No valid attribute is longer than 80. (I
319 |                   ;; suppose a data attribute could be.)
320 |                   (print-prefix len attr))))
321 |              (print-attr
322 |               (lambda (attr value)
323 |                 (let ((len (+ (length (symbol-name attr))
324 |                               1 ;for the equals sign
325 |                               (html-length* value))))
326 |                   (print-prefix len attr))
327 |                 (write-char #\= stream)
328 |                 (format stream "~a" value))))
329 |       (declare (dynamic-extent #'print-prefix #'print-boolean #'print-attr))
330 |       (format-attributes-with attrs
331 |                               #'print-boolean
332 |                               #'print-attr))))
333 | 
334 | (defun format-attributes-pretty/block (attrs &optional (stream *html*))
335 |   (declare (html-stream stream))
336 |   (let ((*fill-column* (truncate *fill-column* 2))
337 |         ;; Force the attributes to line up.
338 |         (*indent* (1+ (html-stream-column stream))))
339 |     (format-attributes-pretty/inline attrs stream)))
340 | 
341 | (defun escape-value (value)
342 |   (if (or (eq value t)
343 |           (eq value nil)
344 |           (keywordp value))
345 |       value
346 |       (let ((string
347 |               (if (typep value 'escaped-string)
348 |                   (escaped-string-value value)
349 |                   (escape-attribute-value
350 |                    (princ-to-string value)))))
351 |         (if (needs-quotes? string)
352 |             (concatenate 'string "\"" string "\"")
353 |             string))))
354 | 
355 | (defun format-text (control-string &rest args)
356 |   (when (and *print-pretty* (not *pre*))
357 |     (terpri *html*))
358 |   (fill-text (format nil "~?" control-string args) t)
359 |   (values))
360 | 
361 | (defun xss-escape (arg)
362 |   "Possibly escape ARG for use with FORMAT.
363 | 
364 | We don't want to leave ourselves open to XSS, but we also want to be
365 | able to use directives like ~c, ~d, ~{~} &c."
366 |   (typecase arg
367 |     ((or number character symbol)
368 |      arg)
369 |     (list
370 |      (mapcar #'xss-escape arg))
371 |     (t
372 |      (escape-to-string arg))))
373 | 
374 | (defun make-doctype (&rest args)
375 |   (declare (ignore args))
376 |   (if *interpret*
377 |       (doctype)
378 |       `(doctype)))
379 | 
380 | (defun doctype (&rest args)
381 |   (declare (ignore args))
382 |   (format *html* "<!DOCTYPE html>~%"))
383 | 
384 | (defun make-comment (text)
385 |   (if *interpret*
386 |       (comment text nil)
387 |       `(comment ,(if (stringp text)
388 |                      (escape-comment text)
389 |                      text)
390 |          ,(stringp text))))
391 | 
392 | (defun comment (text safe? &aux (html *html*))
393 |   (if *print-pretty*
394 |       (let ((*depth* (+ *depth* 1)))
395 |         (format html "~&~v,0T<!-- " *depth*)
396 |         (fill-text (if safe?
397 |                        text
398 |                        (escape-comment text))
399 |                    t)
400 |         (format html " -->~%"))
401 |       (progn
402 |         (write-string "<!-- " html)
403 |         (write-string
404 |          (if safe?
405 |              text
406 |              (escape-comment text))
407 |          html)
408 |         (write-string " -->" html)))
409 |   (values))
410 | 
411 | (defun make-cdata (text)
412 |   (if *interpret*
413 |       (cdata text nil)
414 |       `(cdata ,(if (stringp text)
415 |                    (escape-cdata text)
416 |                    text)
417 |               ,(stringp text))))
418 | 
419 | (defun cdata (text safe? &aux (html *html*))
420 |   (write-string cdata-start html)
421 |   (write-string (if safe?
422 |                     text
423 |                     (escape-cdata text))
424 |                 html)
425 |   (write-string cdata-end html)
426 |   (values))
427 | 
428 | (defun make-html (&rest args)
429 |   (let ((lang (if *interpret* *html-lang* '*html-lang*)))
430 |     (multiple-value-bind (attrs body)
431 |         (parse-leading-keywords args)
432 |       (if (getf attrs :lang)
433 |           `(:html ,@args)
434 |           `(:html
435 |              :lang ,lang
436 |              ,@attrs
437 |              ,@body)))))
438 | 
439 | (defun make-head (&rest args)
440 |   (let ((charset (if *interpret* *html-charset* '*html-charset*)))
441 |     (multiple-value-bind (attrs body)
442 |         (parse-leading-keywords args)
443 |       (declare (ignore attrs))
444 |       (let ((meta-charset
445 |               (some (lambda (elt)
446 |                       (trivia:match elt
447 |                         ((list :meta :charset _)
448 |                          elt)))
449 |                     body)))
450 |         (if meta-charset
451 |             `(:head ,@args)
452 |             `(:head
453 |                (:meta :charset ,charset)
454 |                ,@args))))))
455 | 
456 | (defun write-raw (&rest args)
457 |   (if *interpret*
458 |       (let ((*pre* t))
459 |         (dolist (arg args)
460 |           (fill-text arg t))
461 |         nil)
462 |       `(let ((*pre* t))
463 |          ,@(loop for arg in args
464 |                  collect `(fill-text ,arg t))
465 |          nil)))
466 | 
467 | (-> heading-depth () (integer 1 6))
468 | (defun heading-depth ()
469 |   "Return the current dynamic heading depth.
470 | This follows the convention for the XHTML <h/> element, where the top
471 | level is level 1, inside the first section is level 2, and so forth."
472 |   (clamp (1+ (count :section *html-path*)) 1 6))
473 | 
474 | (defun heading-depth-heading ()
475 |   (ecase (heading-depth)
476 |     (1 :h1)
477 |     (2 :h2)
478 |     (3 :h3)
479 |     (4 :h4)
480 |     (5 :h5)
481 |     (6 :h6)))
482 | 


--------------------------------------------------------------------------------
/tags.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:spinneret)
  2 | 
  3 | ;; These are the only functions that are called at run time.
  4 | (declaim (inline
  5 |           void?
  6 |           boolean?
  7 |           ;; These are only called at run time by dynamic-tag.
  8 |           inline?
  9 |           paragraph?
 10 |           preformatted?))
 11 | 
 12 | (eval-when (:compile-toplevel :load-toplevel :execute)
 13 |   (defmacro keyword-set (&body body)
 14 |     (assert (every #'keywordp body))
 15 |     `(load-time-value (set-hash-table ',body :test 'eq) t)))
 16 | 
 17 | (define-global-parameter *void-elements*
 18 |     (keyword-set
 19 |      :!doctype :area :base :br :col :command :embed :hr :img
 20 |      :input :keygen :link :meta :param :source :track :wbr))
 21 | 
 22 | (defun void? (element)
 23 |   (declare (inline memq))
 24 |   (gethash element *void-elements*))
 25 | 
 26 | (define-global-parameter *literal-elements*
 27 |   '(:pre :script :style))
 28 | 
 29 | (defun literal? (element)
 30 |   (memq element *literal-elements*))
 31 | 
 32 | (define-global-parameter *inline-elements*
 33 |     (keyword-set
 34 |      :a :abbr :address :bdo :small :code :samp :kbd
 35 |      :cite :strong :dfn :br :em :q :data :time :var
 36 |      :sub :sup :i :b :s :u :mark :ruby :rt :rp :bdi :span :wbr
 37 |      :ins :del :col :meter :output :tt :strike :font :big))
 38 | 
 39 | (defun inline? (element)
 40 |   (declare (inline memq))
 41 |   (gethash element *inline-elements*))
 42 | 
 43 | (define-global-parameter *paragraph-elements*
 44 |     (keyword-set
 45 |       :meta :title :button :label :li :h1 :h2 :h3 :h4 :h5 :h6 :p :legend :option
 46 |       :dt :dd :figcaption :iframe :colgroup :td :th :output :summary :command))
 47 | 
 48 | (defun paragraph? (element)
 49 |   (declare (inline memq))
 50 |   (gethash element *paragraph-elements*))
 51 | 
 52 | (define-global-parameter *end-tag-optional*
 53 |     ;; html head body
 54 |     (keyword-set
 55 |       :li :dt :dd :p :rt :rp :optgroup
 56 |       :option :colgroup :thead :tbody :tfoot :tr :td :th
 57 |       :meta))
 58 | 
 59 | (defun unmatched? (element)
 60 |   (gethash element *end-tag-optional*))
 61 | 
 62 | (define-global-parameter *preformatted*
 63 |     '(:pre :textarea :script :style))
 64 | 
 65 | (defun preformatted? (element)
 66 |   (declare (inline memq))
 67 |   (memq element *preformatted*))
 68 | 
 69 | (defun needs-close? (element)
 70 |   (not (or (void? element)
 71 |            (unmatched? element))))
 72 | 
 73 | (defparameter *interpret* nil)
 74 | 
 75 | (define-global-parameter *pseudotag-expanders*
 76 |   ;; NB `:disable-html' is handled by `parse-html' directly.
 77 |   (load-time-value
 78 |    (alist-hash-table
 79 |     '((:doctype . make-doctype)
 80 |       (:!doctype . make-doctype)
 81 |       (:cdata . make-cdata)
 82 |       (:!-- . make-comment)
 83 |       (:comment . make-comment)
 84 |       (:html . make-html)
 85 |       (:head . make-head)
 86 |       (:raw . write-raw)
 87 |       (:h* . expand-h*)
 88 |       (:tag . expand-dynamic-tag))
 89 |     :test 'eq)
 90 |    t))
 91 | 
 92 | (defun pseudotag-expander (element)
 93 |   (gethash element *pseudotag-expanders*))
 94 | 
 95 | (defun pseudotag-expand (element args)
 96 |   (let ((expander (pseudotag-expander element)))
 97 |     (if expander
 98 |         (apply expander args)
 99 |         (cons element args))))
100 | 
101 | (define-global-parameter *html5-elements*
102 |     (keyword-set
103 |       :a :abbr :address :area :article :aside :audio :b :base :bdi :bdo :blockquote
104 |       :body :br :button :canvas :caption :cite :code :col :colgroup :command :data
105 |       :datalist :dd :del :details :dfn :dialog :div :dl :dt :em :embed :fieldset
106 |       :figcaption :figure :footer :form :head :h1 :h2 :h3 :h4 :h5 :h6 :header
107 |       :hgroup :hr :html :i :iframe :img :input :ins :kbd :keygen :label :legend :li
108 |       :link :main :map :mark :math :menu :meta :meter :nav :noscript :object :ol
109 |       :optgroup :option :output :p :param :picture :pre :progress :q :rp :rt :ruby :s :samp
110 |       :script :section :select :small :source :span :strong :style :sub :svg :summary
111 |       :sup :table :tbody :td :template :textarea :tfoot :th :thead :time :title :tr
112 |       :track :u :ul :var :video :wbr
113 |       ;; SVG elements
114 |       :animate :animatemotion :animatetransform :circle :clippath :cursor :defs
115 |       :desc :ellipse :feblend :fecolormatrix :fecomponenttransfer :fecomposite
116 |       :feconvolvematrix :fediffuselighting :fedisplacementmap :fedistantlight
117 |       :fedropshadow :feflood :fefunca :fefuncb :fefuncg :fefuncr :fegaussianblur
118 |       :feimage :femerge :femergenode :femorphology :feoffset :fepointlight
119 |       :fespecularlighting :fespotlight :fetile :feturbulence :filter :font
120 |       :font-face :font-face-format :font-face-name :font-face-src :font-face-uri
121 |       :foreignobject :g :glyph :glyphref :hkern :image :line :lineargradient :marker
122 |       :mask :metadata :missing-glyph :mpath :path :pattern :polygon :polyline
123 |       :radialgradient :rect :set :stop :switch :symbol :text :textpath :tref :tspan
124 |       :use :view :vkern))
125 | 
126 | (define-global-parameter *html3-elements*
127 |     (keyword-set
128 |       :plaintext :big :strike :tt :applet :font :basefont :isindex))
129 | 
130 | (-> valid? (keyword) (values (or keyword null) &optional))
131 | (defun valid? (element)
132 |   (or (gethash element *html5-elements*)
133 |       (gethash element *html3-elements*)
134 |       (valid-custom-element-name? element)))
135 | 
136 | (defun invalid? (element)
137 |   (not (valid? element)))
138 | 
139 | (define-global-parameter *embedded-content*
140 |   '(:math :svg))
141 | 
142 | (defun embedded? (element)
143 |   (memq element *embedded-content*))
144 | 
145 | (define-global-parameter *boolean-attributes*
146 |     (keyword-set
147 |       :async :autofocus :autoplay :checked :controls
148 |       :default :defer :disabled :download :formnovalidate :hidden
149 |       :ismap :itemscope :loop :multiple :muted :novalidate
150 |       :open :readonly :required :reversed :scoped
151 |       :seamless :selected :typemustmatch
152 |       :allowfullscreen :allowpaymentrequest))
153 | 
154 | (defun boolean? (attr)
155 |   (declare (inline memq))
156 |   (gethash attr *boolean-attributes*))
157 | 
158 | (defvar *unvalidated-attribute-prefixes* '("data-" "aria-" "hx-")
159 |   "A list of prefixes for attributes that should not be validated.")
160 | 
161 | (defun unvalidated-attribute? (attribute)
162 |   (some (op (string-prefix-p _ attribute))
163 |         *unvalidated-attribute-prefixes*))
164 | 
165 | ;; http://www.w3.org/TR/wai-aria/states_and_properties
166 | (define-global-parameter *aria-attributes*
167 |     '(:role))
168 | 
169 | (eval-always
170 |   (define-global-parameter *core-attributes*
171 |       '(:accesskey :autocapitalize :autofocus
172 |         :class :contenteditable :contextmenu
173 |         :dir :draggable :dropzone
174 |         :enterkeyhint :exportparts
175 |         :hidden :id :inert :inputmode :is
176 |         :lang :nonce :part :popover
177 |         :slot :spellcheck :style
178 |         :tabindex :title :translate :virtualkeyboardpolicy))
179 | 
180 |   (define-global-parameter *html3-attributes*
181 |       '(:background :bgcolor :text :link :vlink :alink ;; Decoration
182 |         :align :valign :compact :width :height :size)) ;; Layout
183 | 
184 |   (define-global-parameter *microdata-attributes*
185 |       '(:itemid :itemprop :itemref :itemscope :itemtype))
186 | 
187 |   (define-global-parameter *event-handler-attributes*
188 |       '(:onabort :onblur :oncanplay :oncanplaythrough :onchange :onclick
189 |         :oncontextmenu :ondblclick :ondrag :ondragend :ondragenter
190 |         :ondragleave :ondragover :ondragstart :ondrop :ondurationchange
191 |         :onemptied :onended :onerror :onfocus :onfocusout :oninput :oninvalid :onkeydown
192 |         :onkeypress :onkeyup :onload :onloadeddata :onloadedmetadata
193 |         :onloadstart :onmousedown :onmousemove :onmouseout :onmouseover
194 |         :onmouseup :onmousewheel :onpause :onplay :onplaying :onprogress
195 |         :onratechange :onreadystatechange :onreset :onscroll :onseeked
196 |         :onseeking :onselect :onshow :onstalled :onsubmit :onsuspend
197 |         :ontimeupdate :onvolumechange :onwaiting)))
198 | 
199 | (define-global-parameter *global-attributes*
200 |   (load-time-value
201 |    (set-hash-table
202 |     (append *core-attributes*
203 |             *html3-attributes*
204 |             *microdata-attributes*
205 |             *event-handler-attributes*)
206 |     :test 'eq)
207 |    t))
208 | 
209 | (define-global-parameter *space-separated-attributes*
210 |   '(:accesskey :class :for :headers :rel :sandbox :sizes))
211 | 
212 | (defun tokenized-attribute? (attr)
213 |   (memq attr *space-separated-attributes*))
214 | 
215 | (eval-always
216 |   (defun parse-permitted-attributes-alist (alist)
217 |     (lret ((table (alist-hash-table alist :test 'eq)))
218 |       (serapeum:do-hash-table (k v table)
219 |         (setf (gethash k table)
220 |               (set-hash-table v :key #'string :test #'equal))))))
221 | 
222 | (define-global-parameter *permitted-attributes*
223 |   (load-time-value
224 |    (parse-permitted-attributes-alist
225 |     '((:a :href :target :rel :hreflang :media :type :download :ping)
226 |       (:applet :codebase :code :alt :name :hspace :vspace)
227 |       (:area :alt :href :target :rel :media :hreflang :type :shape :coords  :nohref)
228 |       (:audio :autoplay :preload :controls :loop :mediagroup :muted :src)
229 |       (:base :href :target)
230 |       (:blockquote :cite)
231 |       (:body :onafterprint :onbeforeprint :onbeforeunload :onblur :onerror
232 |              :onfocus :onhashchange :onload :onmessage :onoffline :ononline
233 |              :onpopstate :onresize :onstorage :onunload)
234 |       (:br :clear)
235 |       (:button :name :disabled :form :type :value
236 |                :formaction :formenctype :formmethod :formtarget
237 |                :formnovalidate
238 |                :popovertarget :popovertargetaction :autofocus)
239 |       (:col :span)
240 |       (:colgroup :span)
241 |       (:command :type :label :icon :disabled
242 |                 :radiogroup :checked)
243 |       (:del :cite :datetime)
244 |       (:details :open)
245 |       (:dialog :open)
246 |       (:dl :compact)
247 |       (:embed :src :type *)
248 |       (:fieldset :name :disabled :form)
249 |       (:font :color)
250 |       (:form :action :method :enctype :name :accept-charset
251 |              :novalidate :target :autocomplete)
252 |       (:html :manifest :version :xmlns :prefix)
253 |       (:head :prefix :profile)
254 |       (:hr :noshade)
255 |       (:iframe :src :srcdoc :name :sandbox :seamless :allowfullscreen
256 |                :allowpaymentrequest :allow :frameborder :csp :fetchpriority :loading
257 |                :referrerpolicy)
258 |       (:img :src :alt  :loading :usemap :ismap :border :crossorigin
259 |             :srcset :sizes :hspace :vspace)
260 |       (:isindex :prompt)
261 |       (:input :name :disabled :form :type :minlength :maxlength :readonly :value
262 |               :autocomplete :autofocus :list :pattern :required :placeholder
263 |               :checked :accept :capture :multiple :src  :alt :inputmode
264 |               :min :max :step :dirname
265 |               :formaction :formenctype :formmethod :formtarget
266 |               :formnovalidate
267 |               :onfocus :onfocusout
268 |               :popovertarget :popovertargetaction)
269 |       (:ins :cite :datetime)
270 |       (:keygen :challenge :keytype :autofocus :name :disabled :form)
271 |       (:label :for :form)
272 |       (:li :type :value)
273 |       (:link :href :rel :hreflang :media :type :sizes :integrity :crossorigin :referrerpolicy :as)
274 |       (:map :name)
275 |       (:menu :type :label)
276 |       (:meta :name :content :http-equiv :charset :property :media)
277 |       (:meter :value :min :low :high :max :optimum)
278 |       (:object :data :type :height :width :usemap :name :form)
279 |       (:ol :start :reversed :type)
280 |       (:optgroup :label :disabled)
281 |       (:option :disabled :selected :label :value)
282 |       (:output :name :form :for)
283 |       (:param :name :value)
284 |       (:progress :value :max)
285 |       (:q :cite)
286 |       (:script :type :language :src :defer :async :charset :integrity
287 |                :crossorigin)
288 |       (:select :name :disabled :form :size :multiple :autofocus :required)
289 |       (:source :src :srcset :sizes :type :media)
290 |       (:style :type :media :scoped)
291 |       (:table :border :cellspacing :cellpadding)
292 |       (:td :colspan :rowspan
293 |            :headers :nowrap)
294 |       (:textarea :name :disabled :form :readonly :maxlength :autofocus :required
295 |                  :placeholder :dirname :rows :wrap :cols)
296 |       (:th :scope :colspan :rowspan :headers :nowrap)
297 |       (:time :datetime)
298 |       (:track :kind :src :srclang :label :default)
299 |       (:ul :type)
300 |       (:video :autoplay :preload :controls :loop :poster
301 |               :mediagroup :muted :src :crossorigin)
302 |       ;; SVG attributes
303 |       (:circle :id :class :style :transform :cx :cy :r)
304 |       (:ellipse :id :class :style :transform :cx :cy :rx :ry)
305 |       (:line :id :class :style :transform :x1 :y1 :x2 :y2)
306 |       (:path :id :class :style :transform :d)
307 |       (:polygon :id :class :style :transform :points)
308 |       (:polyline :id :class :style :transform :points)
309 |       (:rect :id :class :style :transform :x :y :width :height :rx :ry)
310 |       (:mesh :id :class :style :transform)
311 |       (:text :id :class :style :transform :x :y :dx :dy :rotate :textLength :lengthAdjust)
312 |       (:tspan :id :class :style :transform :x :y :dx :dy :rotate)
313 |       (:textPath :id :class :style :transform :href :startOffset :method :spacing :side :path)
314 |       (:defs :id :class :style :transform)
315 |       (:g :id :class :style :transform)
316 |       (:image :id :class :style :transform :href :x :y :width :height :preserveAspectRatio :externalResourceRequired :corssorigin )
317 |       (:svg :id :class :style :transform :x :y :width :height :viewBox :preserveAspectRatio
318 |             :linecap :fill :stroke :stroke-width :stroke-linecap :stroke-linejoin)
319 |       (:symbol :id :class :style :transform :x :y :width :height :viewBox :preserveAspectRatio :refX :refY)
320 |       (:use :id :class :style :transform :x :y :width :height)
321 |       (:view :id :class :style :transform :viewBox :preserveAspectRatio :viewTarget)))
322 |    t)
323 |   "Alist of (tag . attributes). These are the element-specific
324 | attributes, beyond the global attributes.")
325 | 
326 | (defun valid-attribute? (tag name)
327 |   (or (null tag)                        ;A dynamic tag.
328 |       (unvalidated-attribute? name)
329 |       ;; Don't try to validate attributes on custom elements.
330 |       (valid-custom-element-name? tag)
331 |       (eql name :attrs)
332 |       (global-attribute? name)
333 |       (aria-attribute? name)
334 |       (when-let ((permitted (permitted-attributes tag)))
335 |         (or (gethash (string name) permitted)
336 |             (gethash "*" permitted)))))
337 | 
338 | (defun permitted-attributes (tag)
339 |   (gethash tag *permitted-attributes*))
340 | 
341 | (defun global-attribute? (name)
342 |   (gethash name *global-attributes*))
343 | 
344 | (defun aria-attribute? (name)
345 |   (memq name *aria-attributes*))
346 | 
347 | (define-global-parameter *invalid-custom-element-names*
348 |     (keyword-set
349 |       :annotation-xml
350 |       :color-profile
351 |       :font-face
352 |       :font-face-src
353 |       :font-face-uri
354 |       :font-face-format
355 |       :font-face-name
356 |       :missing-glyph)
357 |   "Names that are not allowed for custom elements.")
358 | 
359 | (-> pcen-char? (character) boolean)
360 | (defun pcen-char? (char)
361 |   "Is CHAR a valid character for a Potential Custom Element Name?"
362 |   (declare (character char))
363 |   (let ((code (char-code (char-downcase char))))
364 |     (declare (optimize speed))
365 |     (or (= code (char-code #\-))
366 |         (= code (char-code #\.))
367 |         (<= (char-code #\0) code (char-code #\9))
368 |         (= code (char-code #\_))
369 |         (<= (char-code #\a) code (char-code #\z))
370 |         (= code #xB7)
371 |         (<= #xC0 code #xD6)
372 |         (<= #xD8 code #xF6)
373 |         (<= #xF8 code #x37D)
374 |         (<= #x37F code #x1FFF)
375 |         (<= #x200C code #x200D)
376 |         (<= #x203F code #x2040)
377 |         (<= #x2070 code #x218F)
378 |         (<= #x2C00 code #x2FEF)
379 |         (<= #x3001 code #xD7FF)
380 |         (<= #xF900 code #xFDCF)
381 |         (<= #xFDF0 code #xFFFD)
382 |         (<= #x10000 code #xEFFFF))))
383 | 
384 | ;; <https://html.spec.whatwg.org/multipage/custom-elements.html#valid-custom-element-name>
385 | (-> valid-custom-element-name? (keyword) (or keyword null))
386 | (defun valid-custom-element-name? (tag)
387 |   "Does TAG satisfy the requirements for a custom element name?"
388 |   (declare (keyword tag)
389 |            (optimize speed))
390 |   (labels ((ascii-alpha? (char)
391 |              (or (char<= #\A char #\Z)
392 |                  (char<= #\a char #\z)))
393 |            (valid-string? (s)
394 |              ;; "These requirements ensure a number of goals for valid
395 |              ;; custom element names:"
396 |              (and
397 |               (>= (length s) 2)
398 |               ;; "They contain a hyphen, used for namespacing and to
399 |               ;; ensure forward compatibility (since no elements will be
400 |               ;; added to HTML, SVG, or MathML with hyphen-containing
401 |               ;; local names in the future)."
402 |               (find #\- s :start 1)
403 |               ;; "They start with an ASCII lower alpha, ensuring that
404 |               ;; the HTML parser will treat them as tags instead of as
405 |               ;; text."
406 |               (ascii-alpha? (aref s 0))
407 |               ;; "They do not contain any ASCII upper alphas, ensuring
408 |               ;; that the user agent can always treat HTML elements
409 |               ;; ASCII-case-insensitively." But Spinneret is not
410 |               ;; case-sensitive...
411 |               t
412 |               ;; "They can always be created with createElement() and
413 |               ;; createElementNS(), which have restrictions that go
414 |               ;; beyond the parser's."
415 |               (every #'pcen-char? s))))
416 |     (and (not (gethash tag *invalid-custom-element-names*))
417 |          (valid-string? (symbol-name tag))
418 |          tag)))
419 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | <!-- markdown-toc start - Don't edit this section. Run M-x markdown-toc-refresh-toc -->
  2 | **Table of Contents**
  3 | 
  4 | - [Spinneret](#spinneret)
  5 |     - [Printing style](#printing-style)
  6 |     - [Inserted spaces](#inserted-spaces)
  7 |     - [Line wrapping](#line-wrapping)
  8 |     - [Syntax](#syntax)
  9 |         - [Dynamic output](#dynamic-output)
 10 |         - [Interpreting trees](#interpreting-trees)
 11 |         - [Markdown](#markdown)
 12 |     - [`get-html-path`](#get-html-path)
 13 |         - [`*html-path*`](#html-path)
 14 |     - [`deftag`](#deftag)
 15 |     - [Parenscript](#parenscript)
 16 |     - [Validation](#validation)
 17 | 
 18 | <!-- markdown-toc end -->
 19 | # Spinneret
 20 | 
 21 | In the crowded space of Common Lisp HTML generators, Spinneret
 22 | occupies the following coordinates:
 23 | 
 24 | - Modern. Targets HTML5. Does not treat XML and HTML as the same
 25 |   problem. Assumes you will be serving your documents as UTF-8.
 26 | 
 27 | - Composable. Makes it easy to refactor HTML generation into separate
 28 |   functions and macros.
 29 | 
 30 | - Pretty. Treats HTML as a document format, not a serialization.
 31 |   Output is idiomatic and readable, following the coding style of the
 32 |   HTML5 specification.
 33 | 
 34 | - Aggressive. If something can be interpreted as HTML, then it will
 35 |   be, meaning that some Lisp forms can't be mixed with HTML syntax. In
 36 |   the trade-off between 90% convenience and 10% correctness Spinneret
 37 |   is on the side of convenience. (But see below on `:disable-html`.)
 38 | 
 39 | - Bilingual. Spinneret (after loading `spinneret/ps`) has the same semantics in Lisp and [Parenscript][].
 40 | 
 41 | HTML generation with Spinneret looks like this:
 42 | 
 43 | ```common-lisp
 44 |      (in-package #:spinneret)
 45 | 
 46 |      (defparameter *shopping-list*
 47 |        '("Atmospheric ponds"
 48 |          "Electric gumption socks"
 49 |          "Mrs. Leland's embyronic television combustion"
 50 |          "Savage gymnatic aggressors"
 51 |          "Pharmaceutical pianos"
 52 |          "Intravenous retribution champions"))
 53 | 
 54 |      (defparameter *user-name* "John Q. Lisper")
 55 | 
 56 |      (defparameter *last-login* "12th Never")
 57 | 
 58 |      (defmacro with-page ((&key title) &body body)
 59 |        `(with-html
 60 |           (:doctype)
 61 |           (:html
 62 |             (:head
 63 |              (:title ,title))
 64 |             (:body ,@body))))
 65 | 
 66 |      (defun shopping-list ()
 67 |        (with-page (:title "Home page")
 68 |          (:header
 69 |           (:h1 "Home page"))
 70 |          (:section
 71 |           ("~A, here is *your* shopping list: " *user-name*)
 72 |           (:ol (dolist (item *shopping-list*)
 73 |                  (:li (1+ (random 10)) item))))
 74 |          (:footer ("Last login: ~A" *last-login*))))
 75 | ```
 76 | 
 77 | Which produces:
 78 | 
 79 | ```html
 80 |      <!DOCTYPE html>
 81 |      <html lang=en>
 82 |       <head>
 83 |        <meta charset=UTF-8>
 84 |        <title>Home page</title>
 85 |       </head>
 86 |       <body>
 87 |        <header>
 88 |         <h1>Home page</h1>
 89 |        </header>
 90 |        <section>
 91 |         John Q. Lisper, here is <em>your</em> shopping list:
 92 |         <ol>
 93 |          <li>10 Atmospheric ponds
 94 |          <li>6 Electric gumption socks
 95 |          <li>4 Mrs. Leland's embyronic television combustion
 96 |          <li>9 Savage gymnatic aggressors
 97 |          <li>6 Pharmaceutical pianos
 98 |          <li>9 Intravenous retribution champions
 99 |         </ol>
100 |        </section>
101 |        <footer>
102 |         Last login: 12th Never
103 |        </footer>
104 |       </body>
105 |      </html>
106 | 
107 | ```
108 | (Pretty-printing is pretty fast, but Spinneret obeys `*print-pretty*`
109 | should you want to turn it off.)
110 | 
111 | ### Printing style
112 | 
113 | Spinneret tries hard to produce human-writable output – output that
114 | looks like a human being wrote it. Sometimes, however, you may have
115 | markup to render that there is no human-writable way to render,
116 | because no human being would ever write it.
117 | 
118 | In these cases you can set or bind the `*html-style*` variable to
119 | control Spinneret’s print style. The default is `:human`, which means
120 | to attempt to produce human-writable output. It can also be set to
121 | `:tree`, which simply prints every element as if it were a block
122 | element, and every run of text on a new line.
123 | 
124 | ```common-lisp
125 |     (let ((*html-style* :human))
126 |       (with-html
127 |         (:div
128 |           (:p "Text " (:a "link text") " more text"))))
129 |     => <div>
130 |         <p>Text <a>link text</a> more text
131 |        </div>"
132 | 
133 |     (let ((*html-style* :tree))
134 |       (with-html-string
135 |         (:div
136 |           (:p "Text " (:a "link text") " more text"))))
137 |     => <div>
138 |         <p>
139 |          Text
140 |          <a>
141 |           link text
142 |          </a>
143 |           more text
144 |         </p>
145 |        </div>
146 | ```
147 | 
148 | With `*html-style*` bound to `:tree`, and `*print-pretty*` bound to
149 | nil, output is verbose but predictable:
150 | 
151 | ```common-lisp
152 |     (let ((*html-style* :tree)
153 |           (*print-pretty* nil))
154 |       (with-html-string
155 |         (:div
156 |           (:p "Text " (:a "link text") " more text"))))
157 |     => "<div><p>Text <a>link text</a>  more text</p></div>"
158 | ```
159 | 
160 | Notice that binding `*html-style*` to `:tree` ensures that all tags are
161 | closed.
162 | 
163 | ### Inserted spaces
164 | 
165 | By default, when objects are output to HTML, spaces are inserted betweeen them. This is nearly always the right thing to do, but in some special cases, the spaces may be a problem. They can be turned off by setting the flag `*suppress-inserted-spaces*` to `t`.
166 | 
167 | ### Line wrapping
168 | 
169 | When pretty-printing, Spinneret makes the best decisions about line
170 | wrapping that it can, given the information it has about how to get
171 | the print length of various types. But, in the case of user-defined
172 | types, it has no way to tell in advance how long they will be when
173 | printed. If you find Spinneret is making bad line-breaking decisions
174 | with your types, you can help it out by specializing `html-length`.
175 | For example, if you use PURI, you could help Spinneret pretty-print
176 | PURI URIs by teaching it how to get their length:
177 | 
178 | ```common-lisp
179 |     (defmethod html-length ((uri puri:uri))
180 |       ;; Doesn't cons.
181 |       (length (puri:render-uri uri nil)))
182 | ```
183 | 
184 | ## Syntax
185 | 
186 | The rules for WITH-HTML are these:
187 | 
188 | - All generated forms write to `*html*`.
189 | 
190 | - A keyword in function position is interpreted as a tag name. If the
191 |   name is not valid as a tag, it is ignored.
192 | 
193 |   Certain keywords are recognized as pseudo-tags and given special
194 |   treatment:
195 | 
196 |   :RAW :DOCTYPE :!DOCTYPE :CDATA :!-- :COMMENT :HTML :HEAD :H* :TAG :DISABLE-HTML
197 | 
198 |   - The pseudotag :RAW can be used to bypass Spinneret’s implicit
199 |     escaping for raw output. This allows inserting HTML literals, and
200 |     bypasses pretty printing.
201 | 
202 |     Note that you need :RAW for inline stylesheets and scripts,
203 |     otherwise angle brackets will be escaped as if they were HTML:
204 | 
205 |     ```common-lisp
206 |     (with-html-string (:style "a > p{color: white;}"))
207 |     => "<style>a &gt; p{color: white;}</style>"
208 | 
209 |     (with-html-string (:style (:raw "a > p{color: white;}")))
210 |     => "<style>a > p{color: white;}</style>"
211 | 
212 |     ```
213 | 
214 |   - The pseudotags :!– and :COMMENT insert comments into the output.
215 | 
216 |   - The pseudotag :H* renders as one of :H1 through :H6 depending on
217 |     how many :SECTION elements it is dynamically nested inside. At the
218 |     top level, :H* is equivalent to :H1. Inside the dynamic extent of
219 |     one :SECTION tag, it is equivalent to :H2; inside two section
220 |     tags, it is equivalent to :H3; and so forth up to :H6.
221 | 
222 |   - The pseudotag :TAG allows dynamic selection of a tag.
223 | 
224 |   - The pseudotag :DISABLE-HTML stops HTML parsing. Code within a
225 |     `:disable-html` form is not descended into by the `with-html`
226 |     macro.
227 | 
228 |     If there is only a single form inside `:disable-html`, it replaces
229 |     `:disable-html` (rather than expanding into a `progn`.) You can
230 |     use this to `escape` syntax that might otherwise be interpeted as
231 |     HTML:
232 | 
233 |         ```common-lisp
234 |         (with-complicated-macro (:disable-html (:keyword-option-1 ...))
235 |           ...)
236 |         ```
237 | 
238 |   The value of the LANG attribute of HTML is controlled by
239 |   `*html-lang*`; the value of the meta charset attribute is controlled
240 |   by `*html-charset*`. These are defaults; passing an explicit
241 |   attribute takes precedence.
242 | 
243 |   Constant classes and ids can be specified with a selector-like
244 |   syntax. E.g.:
245 | 
246 | ```common-lisp
247 |         (:div#wrapper (:div.section ...))
248 |         ≡ (:div :id "wrapper" (:div :class "section" ...))
249 | ```
250 | 
251 | - Keyword-value pairs following a tag are interpreted as attributes.
252 |   HTML syntax may not be used in attribute values. Attributes with nil
253 |   values are omitted from the output. Boolean attributes with non-nil
254 |   values are minimized.
255 | 
256 |   Duplicate attributes are handled like duplicate keyword arguments:
257 |   all values are evaluated, but only the leftmost value is used. The
258 |   exception is the handling of tokenized attributes, such as :CLASS or
259 |   :REL. The class of a tag is the union of all its :CLASS arguments.
260 | 
261 |   The argument :DATASET introduces a list of :DATA-FOO arguments:
262 | 
263 | ```common-lisp
264 |         (:p :dataset (:duck (dolomphious) :fish 'fizzgigious
265 |                             :spoon "runcible"))
266 |         ≡ (:p :data-duck (dolomphious) :data-fish 'fizzgigious
267 |               :data-spoon "runcible")
268 | 
269 | ```
270 | 
271 |   For flexibility, even at the cost of efficiency, the argument :ATTRS
272 |   introduces a form to evaluate at run time for a plist of extra
273 |   attributes and values.
274 | 
275 | - Forms after the attributes are treated as arguments. Each non-nil
276 |   (primary) value returned by an argument to a tag is written to the
277 |   stream by HTML, a generic function on which you can define your own
278 |   methods. By default only literal arguments are printed. Literal
279 |   arguments are strings, characters, numbers and symbols beside NIL.
280 | 
281 | WITH-HTML-STRING is like WITH-HTML, but intercepts the generated HTML
282 | at run time and returns a string.
283 | 
284 | ### Dynamic output
285 | 
286 | For flexibility, even at the cost of efficiency, the pseudo-attribute
287 | :ATTRS introduces a form to evaluate at run time for a plist of extra
288 | attributes and values.
289 | 
290 | ```common-lisp
291 |     (:p :attrs (list :id "dynamic!"))
292 |     => <p id="dynamic!">
293 | ```
294 | 
295 | Similarly, the pseudo-tag :TAG allows you to select a tag at run time.
296 | 
297 | ```common-lisp
298 |     (:tag :name "div"
299 |      (:tag :name "p"
300 |       (:tag :name "span"
301 |         "Hello.")))
302 |     ≡ (:div (:p (:span "Hello")))
303 | ```
304 | 
305 | Note that :TAG only allows you to *select* a tag, not *create* one.
306 | The tag must still be one that is known to Spinneret to be valid. (That is, either defined as part of HTML or matching the requirements for a custom element.)
307 | 
308 | For maximum dynamicity, you can combine :TAG and :ATTRS:
309 | 
310 | ```common-lisp
311 |     (:tag :name "div" :attrs (list :id "dynamic!"))
312 |     => <div id=dynamic!></div>
313 | ```
314 | 
315 | ### Interpreting trees
316 | 
317 | For the *ne plus ultra* of flexibility, you can interpret trees at runtime using a subset of Spinneret syntax:
318 | 
319 | ```common-lisp
320 |     (interpret-html-tree `(:div :id "dynamic!"))
321 |     => <div id=dynamic!></div>
322 | ```
323 | 
324 | The interpreter is still under development; it supports most but not yet all Spinneret syntax.
325 | 
326 | ### Markdown
327 | 
328 | If the additional system `spinneret/cl-markdown` is loaded, then a
329 | string in function position is first compiled as Markdown (using
330 | [CL-MARKDOWN][]), then passed to `format` as a control string and
331 | applied to its arguments.
332 | 
333 | This is useful for inline formatting, like links, where sexps would be
334 | clumsy:
335 | 
336 | ```common-lisp
337 |     (with-html
338 |      ("Here is some copy, with [a link](~a)" link))
339 | 
340 |     (with-html
341 |       (:span "Here is some copy, with "
342 |         (:a :href link "a link.")))
343 | ```
344 | 
345 | ## `get-html-path`
346 | 
347 | Sometimes it is useful for a piece of HTML-generating code to know
348 | where in the document it appears. You might, for example, want to
349 | define a `tabulate` function that prints list-of-lists as rows of
350 | cells, but only prints the surrounding `<table></table>` if it is not
351 | already within a table. The function `get-html-path` returns a list of
352 | open tags, from latest to earliest. Usually it will look something
353 | like
354 | 
355 | ```common-lisp
356 |       (get-html-path) ;-> '(:table :section :body :html)
357 | ```
358 | 
359 | Thus `tabulate' could be written
360 | 
361 | ```common-lisp
362 |      (defun tabulate (&rest rows)
363 |        (with-html
364 |          (flet ((tabulate ()
365 |                   (loop for row in rows do
366 |                     (:tr (loop for cell in row do
367 |                       (:td cell))))))
368 |            (if (find :table (get-html-path))
369 |                (tabulate)
370 |                (:table (:tbody (tabulate)))))))
371 | ```
372 | 
373 | Note that `get-html-path` returns a freshly-consed list each time it
374 | is called.
375 | 
376 | ### `*html-path*`
377 | 
378 | The variable underneath `get-html-path` is `*html-path*`, and it can
379 | be let-bound to manipulate the nested tags (like `:h*` and `tabulate`
380 | from the example above).
381 | 
382 | WARNING: Spinneret binds `*html-path*` with [dynamic
383 | extent](http://clhs.lisp.se/Body/d_dynami.htm). If you need to inspect
384 | the binding, use `get-html-path` instead to get a value you can safely
385 | store.
386 | 
387 | `*html-path*` is most useful if the document generated by Spinneret is
388 | split into several functions. Binding `*html-path*` allows to preserve
389 | the structure of the document there.
390 | 
391 | Example:
392 | ```common-lisp
393 | (defun inner-section ()
394 |   "Binds *HTML-PATH* to replicate the depth the output is used in."
395 |   (with-html-string
396 |     (let ((*html-path* (append *html-path* '(:section :section))))
397 |       (:h* "Heading three levels deep"))))
398 | 
399 | (defun outer-section (html)
400 |   "Uses HTML from elsewhere and embed it into a section"
401 |   (with-html-string
402 |     (:section
403 |      (:h* "Heading two levels deep")
404 |      (:section
405 |       (:raw html)))))
406 | 
407 | (outer-section (inner-section))
408 | ;; <section>
409 | ;; <h2>Heading two levels deep</h2>
410 | ;; <section><h3>Heading three levels deep</h3>
411 | ;; </section>
412 | ;;</section>
413 | ```
414 | 
415 | ## `deftag`
416 | 
417 | The stumbling block for all sexp-based HTML generators is order of
418 | evaluation. It's tempting to write something like this:
419 | 
420 | ```common-lisp
421 |      ;; Doesn't work
422 |      (defun field (control)
423 |        (with-html (:p control)))
424 | 
425 |      (defun input (default &key name label (type "text"))
426 |        (with-html
427 |          (:label :for name label)
428 |          (:input :name name :id name :type type :value default)))
429 | ```
430 | 
431 | But it won't work: in `(field (input "Default" :name "why" :label
432 | "Reason"))`, `(input)` gets evaluated before `(field)`, and the HTML
433 | is printed inside-out.
434 | 
435 | Macros do work:
436 | 
437 | ```common-lisp
438 |      (defmacro field (control)
439 |        `(with-html (:p ,control)))
440 | 
441 |      (defmacro input (name label &key (type "text"))
442 |        `(with-html
443 |           (:label :for ,name ,label)
444 |           (:input :name ,name :id ,name :type ,type)))
445 | ```
446 | 
447 | But we can do better than this. Spinneret provides a macro-writing
448 | macro, `deftag`, which lets you *refactor* HTML without *hiding* it.
449 | 
450 | ```common-lisp
451 |      (deftag field (control attrs)
452 |       `(:p ,@attrs ,@control))
453 | 
454 |      (deftag input (default attrs &key name label (type "text"))
455 |        (once-only (name)
456 |          `(progn
457 |             (:label :for ,name ,label)
458 |             (:input :name ,name :id ,name :type ,type
459 |               ,@attrs
460 |               :value (progn ,@default)))))
461 | ```
462 | 
463 | A macro defined using `deftag` takes its arguments just like an HTML
464 | element. Instead of
465 | 
466 | ```common-lisp
467 |     (input "Default" :name "why" :label "Reason") ; defmacro
468 | ```
469 | 
470 | You write
471 | 
472 | ```common-lisp
473 |     (input :name "why" :label "Reason" "Default") ; deftag
474 | ```
475 | 
476 | The macro re-arranges the arguments so they can be bound to an
477 | ordinary lambda list, like the one above: the body of the tag is bound
478 | to the first argument, and matching attributes are bound to keywords.
479 | Multiple `:class` arguments, `:dataset`, and other shorthands are
480 | handled exactly as in the usual HTML syntax.
481 | 
482 | But the great advantage of `deftag` is how it handles attributes which
483 | are *not* bound to keywords. In the definition of `input` using
484 | `deftag`, you see that the `attrs` catch-all argument is spliced into
485 | the call to `:input`. This means that any unhandled attributes pass
486 | through to the actual input element.
487 | 
488 | ```common-lisp
489 |     (input :name "why" :label "Reason" :required t :class "special" "Default")
490 |     => <label for=why>Reason</label>
491 |        <input class=special name=why id=why type=text required value=Default>
492 | ```
493 | 
494 | In effect, `input` *extends* the `:input` tag, almost like a subclass.
495 | This is a very idiomatic and expressive way of building abstractions
496 | over HTML.
497 | 
498 | (Note that when the name `deftag` is a keyword, then no macro is
499 | defined, and it can only be used within a `with-html` form.)
500 | 
501 | ## Spinneret in Parenscript
502 | 
503 | To use Spinneret with Parenscript, load the system `spinneret/ps`.
504 | 
505 | The semantics of Spinneret in Parenscript are almost the same. There
506 | is no `with-html-string`, and `with-html` returns a
507 | `DocumentFragment`.
508 | 
509 | If Markdown support is enabled, strings in function position are still
510 | parsed as Markdown, but supplying arguments triggers an error (since
511 | Parenscript does not have `format`).
512 | 
513 | `get-html-path` is not implemented for Parenscript.
514 | 
515 | Neither :ATTRS nor :TAG is available in Parenscript.
516 | 
517 | ## Parenscript in Spinneret
518 | 
519 | To use Parenscript in Spinneret, remember to wrap the `ps` macro with `:raw`, otherwise the generated JavaScript will be escaped.
520 | 
521 | ```common-lisp
522 | (with-html-string
523 |   (:script
524 |     (:raw (ps
525 |             (defun greeting ()
526 |               (alert "Hello"))))))
527 | =>
528 | "<script>function greeting() {
529 |     __PS_MV_REG = [];
530 |     return alert('Hello');
531 | };</script>"
532 | 
533 | (with-html-string
534 |   (:div :onclick (:raw (ps (alert "Hello")))))
535 | "<div onclick=\"alert('Hello');\"></div>"
536 | ```
537 | 
538 | ## Validation
539 | 
540 | Spinneret does not do document validation, but it does warn, at compile time, about invalid tags and attributes.
541 | 
542 | Although HTML5 does include a mechanism for application-specific
543 | attributes (the `data-` prefix), some client-side frameworks choose to
544 | employ their own prefixes instead. You can disable validation for a
545 | given prefix by adding it to `*unvalidated-attribute-prefixes*`.
546 | 
547 | ```common-lisp
548 |     (pushnew "ng-" *unvalidated-attribute-prefixes* :test #’equal)
549 | ```
550 | 
551 | You can disable attribute validation altogether by adding the empty
552 | string to the list:
553 | 
554 | ```common-lisp
555 |     ;; Disable attribute validation.
556 |     (setf *unvalidated-attribute-prefixes* '(""))
557 | ```
558 | 
559 | Tags are considered valid if they are defined as part of the HTML standard, or if they match the rules for the name of a [custom element][] – basically, start with an ASCII alphabetic character and include a hyphen. For custom elements, attributes are not validated.
560 | 
561 | [CL-MARKDOWN]: https://github.com/gwkkwg/cl-markdown
562 | [custom element]: https://html.spec.whatwg.org/multipage/custom-elements.html#valid-custom-element-name
563 | [Parenscript]: https://parenscript.common-lisp.dev/
564 | 


--------------------------------------------------------------------------------
/tests.lisp:
--------------------------------------------------------------------------------
  1 | (defpackage #:spinneret.tests
  2 |   (:use #:cl #:spinneret #:fiveam)
  3 |   (:import-from #:alexandria #:ensure-list #:make-keyword)
  4 |   (:import-from #:serapeum
  5 |                 #:~> #:op #:lines #:string-join #:concat #:fmt)
  6 |   (:import-from :spinneret :valid-custom-element-name?)
  7 |   (:shadow :test)
  8 |   (:export #:run-tests))
  9 | 
 10 | (in-package #:spinneret.tests)
 11 | 
 12 | (def-suite spinneret)
 13 | (in-suite spinneret)
 14 | 
 15 | (defmacro test (name &body body)
 16 |   `(5am:test (,@(ensure-list name) :compile-at :run-time)
 17 |      ;; Ensure the expected defaults.
 18 |      (let ((*html-style* :human)
 19 |            (*print-pretty* t))
 20 |        ,@body)))
 21 | 
 22 | (defun run-tests ()
 23 |   (run! 'spinneret))
 24 | 
 25 | (defun visually-equal (string1 string2)
 26 |   (let ((lines1 (serapeum:lines string1))
 27 |         (lines2 (serapeum:lines string2)))
 28 |     (and (= (length lines1)
 29 |             (length lines2))
 30 |          (every (lambda (line1 line2)
 31 |                   (equal (string-right-trim " " line1)
 32 |                          (string-right-trim " " line2)))
 33 |                 lines1 lines2))))
 34 | 
 35 | (defun linewise-equal (string1 string2)
 36 |   (let ((lines1 (mapcar #'serapeum:trim-whitespace (serapeum:lines string1)))
 37 |         (lines2 (mapcar #'serapeum:trim-whitespace (serapeum:lines string2))))
 38 |     (and (= (length lines1)
 39 |             (length lines2))
 40 |          (every #'equal lines1 lines2))))
 41 | 
 42 | (defmacro with-pretty-printing (&body body)
 43 |   `(let ((*print-pretty* t)
 44 |          (*html-style* :human))
 45 |      ,@body))
 46 | 
 47 | (defmacro without-pretty-printing (&body body)
 48 |   `(let ((*print-pretty* nil))
 49 |      ,@body))
 50 | 
 51 | (test dataset
 52 |   (without-pretty-printing
 53 |     (flet ((dolomphious () 'dolomphious))
 54 |       (is (equal
 55 |            "<p data-duck=DOLOMPHIOUS data-fish=FIZZGIGIOUS data-spoon=runcible>"
 56 |            (with-html-string
 57 |              (:p :dataset (:duck (dolomphious) :fish 'fizzgigious
 58 |                            :spoon "runcible"))))))))
 59 | 
 60 | (test attrs
 61 |   (without-pretty-printing
 62 |     (is (equal
 63 |          "<p foo=bar baz=quux>bar"
 64 |          (let ((attrs '(:foo "bar" :baz "quux")))
 65 |            (with-html-string (:p :attrs attrs "bar")))))))
 66 | 
 67 | (defun bigtable (&optional (*html* *html*))
 68 |   (with-html
 69 |     (:table
 70 |       (dotimes (i 1000)
 71 |         (:tr (dotimes (i 10)
 72 |                (:td (1+ i))))))))
 73 | 
 74 | (test bigtable
 75 |   (flet ((bt (msg)
 76 |            (let ((start (get-internal-run-time)))
 77 |              (with-output-to-string (*html*)
 78 |                (finishes (bigtable)))
 79 |              (let* ((end (get-internal-run-time))
 80 |                     (duration (- end start))
 81 |                     (seconds (/ duration (float internal-time-units-per-second))))
 82 |                (format t "~&Bigtable benchmark ~a: ~d second~:p~%" msg seconds)))))
 83 |     (let ((*print-pretty* t)
 84 |           (*html-style* :human))
 85 |       (bt "with pretty printing"))
 86 |     (let ((*print-pretty* t)
 87 |           (*html-style* :tree))
 88 |       (bt "with pretty printing (tree style)"))
 89 |     (let ((*print-pretty* nil)
 90 |           (*html-style* :human))
 91 |       (bt "without pretty printing"))
 92 |     (let ((*print-pretty* nil)
 93 |           (*html-style* :tree))
 94 |       (bt "without pretty printing (tree style)"))))
 95 | 
 96 | (defun readme-example ()
 97 |   (with-pretty-printing
 98 |     (let* ((user-name "John Q. Lisper")
 99 |            (last-login "12th Never")
100 |            (shopping-list
101 |              '("Atmospheric ponds"
102 |                "Electric gumption socks"
103 |                "Mrs. Leland's embyronic television combustion"
104 |                "Savage gymnatic aggressors"
105 |                "Pharmaceutical pianos"
106 |                "Intravenous retribution champions"))
107 |            (amounts '(10 6 4 9 6 9)))
108 |       (with-html
109 |         (:doctype)
110 |         (:html
111 |           (:head
112 |             (:title "Home page"))
113 |           (:body
114 |             (:header
115 |               (:h1 "Home page"))
116 |             (:section
117 |               ("~A, here is *your* shopping list: " user-name)
118 |               (:ol (loop for item in shopping-list
119 |                          for amount in amounts
120 |                          do (:li amount item))))
121 |             (:footer ("Last login: ~A" last-login))))))))
122 | 
123 | (defun readme-example-string ()
124 |   (with-output-to-string (*html*)
125 |     (readme-example)))
126 | 
127 | (test readme-example
128 |   (with-pretty-printing
129 |     (let* ((expected-string
130 |              (format nil "~
131 | <!DOCTYPE html>
132 | <html lang=en>
133 |  <head>
134 |   <meta charset=UTF-8>
135 |   <title>Home page</title>
136 |  </head>
137 |  <body>
138 |   <header>
139 |    <h1>Home page</h1>
140 |   </header>
141 |   <section>
142 |    John Q. Lisper, here is <em>your</em> shopping list:
143 |    <ol>
144 |     <li>10 Atmospheric ponds
145 |     <li>6 Electric gumption socks
146 |     <li>4 Mrs. Leland&#39;s embyronic television combustion
147 |     <li>9 Savage gymnatic aggressors
148 |     <li>6 Pharmaceutical pianos
149 |     <li>9 Intravenous retribution champions
150 |    </ol>
151 |   </section>
152 |   <footer>
153 |    Last login: 12th Never
154 |   </footer>
155 |  </body>
156 | </html>"))
157 |            (*print-pretty* t)
158 |            (generated-string
159 |              (readme-example-string)))
160 |       (is (visually-equal generated-string expected-string)))))
161 | 
162 | (test indent-problem
163 |   (with-pretty-printing
164 |     (is (visually-equal
165 |          (with-html-string
166 |            (:ul (:li (:a "hai"))))
167 |          (format nil "~
168 | <ul>
169 |  <li><a>hai</a>
170 | </ul>")))
171 | 
172 |     (is (visually-equal
173 |          (with-html-string
174 |            (:html (:head)
175 |              (:body (:a "hai"))))
176 |          (format nil "~
177 | <html lang=en>
178 |  <head>
179 |   <meta charset=UTF-8>
180 |  </head>
181 |  <body>
182 |   <a>hai</a>
183 |  </body>
184 | </html>")))))
185 | 
186 | (test space-problem
187 |   (without-pretty-printing
188 |     (is
189 |      (equal
190 |       "<div>hello<a href=#></a> there world</div>"
191 |       (spinneret:with-html-string
192 |         (:div "hello"
193 |           (:a :href "#")
194 |           "there world"))))))
195 | 
196 | (test explicit-spaces
197 |   (without-pretty-printing
198 |     (is (equal "<div>hi<span> there</span></div>"
199 |                (spinneret:with-html-string (:div "hi" (:span " there"))))))
200 |   (with-pretty-printing
201 |     (is (visually-equal
202 |          #.(format nil "~
203 | <p>hi <span>there</span>")
204 |          (let ((*print-pretty* t))
205 |            (spinneret:with-html-string
206 |              (:p "hi " (:span "there"))))))))
207 | 
208 | (test null-attr
209 |   (without-pretty-printing
210 |     (is (equal (with-html-string (:li :class nil "Hello"))
211 |                "<li>Hello")))
212 |   (without-pretty-printing
213 |     (is (equal (with-html-string (:li :class nil "Hello"))
214 |                "<li>Hello")))
215 | 
216 |   (is (equal (with-html-string (:li :class (progn nil)))
217 |              "<li>")))
218 | 
219 | (test no-final-space-after-skipped-attribute
220 |   (without-pretty-printing
221 |     (is (equal (with-html-string (:a :href "#" :data-instant t))
222 |                "<a href=# data-instant=true></a>"))
223 |     (is (equal (with-html-string (:a :href "#" :data-instant nil))
224 |                "<a href=#></a>"))))
225 | 
226 | (serapeum:def lorem-ipsum
227 |   "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.")
228 | 
229 | (defun lorem-ipsum ()
230 |   (with-pretty-printing
231 |     (let ((*fill-column* 80))
232 |       (with-html
233 |         (:doctype)
234 |         (:html
235 |           (:body
236 |             (:div
237 |               (:p lorem-ipsum (:span)
238 |                 (:a :href "" :data-instant t "Hello")
239 |                 lorem-ipsum))))))))
240 | 
241 | (defun lorem-ipsum-string ()
242 |   (with-output-to-string (*html*)
243 |     (lorem-ipsum)))
244 | 
245 | (test lorem-ipsum
246 |   (is (visually-equal
247 |        #.(format nil
248 |                  "~
249 | <!DOCTYPE html>
250 | <html lang=en>
251 |  <body>
252 |   <div>
253 |    <p>Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor
254 |     incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis
255 |     nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.
256 |     Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu
257 |     fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in
258 |     culpa qui officia deserunt mollit anim id est laborum.<span></span><a href=\"\"
259 |     data-instant=true>Hello</a> Lorem ipsum dolor sit amet, consectetur adipiscing
260 |     elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim
261 |     ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea
262 |     commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit
263 |     esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat
264 |     non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.
265 |   </div>
266 |  </body>
267 | </html>")
268 |        (lorem-ipsum-string))))
269 | 
270 | (test hello-hello-hello
271 |   (with-pretty-printing
272 |     (is (visually-equal
273 |          "<div>
274 |  <div>
275 |   <div>
276 |    <ul>
277 |     <li><a class=\"class1 class2 class3 class4 class5\" href=\"hello hello hello\"></a>
278 |    </ul>
279 |   </div>
280 |  </div>
281 | </div>"
282 |          (spinneret:with-html-string
283 |            (:div
284 |              (:div
285 |                (:div
286 |                  (:ul
287 |                    (:li
288 |                      (:a.class1.class2.class3.class4.class5
289 |                       :href "hello hello hello")))))))))))
290 | 
291 | (test inline-element-after-paragraph
292 |   (with-pretty-printing
293 |     (is (visually-equal
294 |          (format nil "~
295 | <div>
296 |  <p>Hello
297 |  <a>world</a>
298 | </div>")
299 |          (with-html-string
300 |            (:div
301 |              (:p "Hello")
302 |              (:a "world")))))))
303 | 
304 | (test indent-attributes-in-blocks
305 |   (with-pretty-printing
306 |     (is (visually-equal
307 |          (format nil "~
308 | <input class=form-control type=password
309 |        name=password id=password required>")
310 |          (with-html-string
311 |            (:input :type "password" :name "password"
312 |              :class "form-control" :id "password"
313 |              :required t))))))
314 | 
315 | (test indent-text-sanely
316 |   (with-pretty-printing
317 |     (is (linewise-equal
318 |          (format nil "~
319 |    <div class=\"last-update col-xs-2 col-md-1\"
320 |         title=\"Last updated 232 days ago\">
321 |     232d
322 |    </div>")
323 |          (with-html-string
324 |            (:div :class "last-update col-xs-2 col-md-1" :title "Last updated 232 days ago"
325 |              "232d"))))))
326 | 
327 | (defun indent-string (string n)
328 |   "Add N spaces at the beginning of each line of STRING."
329 |   (let ((padding (make-string n :initial-element #\Space)))
330 |     (~> string
331 |         lines
332 |         (mapcar (op (concat padding _)) _)
333 |         (string-join #\Newline))))
334 | 
335 | (test indent-sanely-in-blocks-in-paragraphs
336 |   (with-pretty-printing
337 |     (is (serapeum:string*=
338 |          (indent-string
339 |           (with-html-string
340 |             (:div :class "status col-xs-2 col-md-1"
341 |               (:span :class "text-success"
342 |                 (:a :href "https://en.wikipedia.org/wiki/List_of_HTTP_status_codes#200"
343 |                   200))))
344 |           ;; Stick an extra space on each line.
345 |           1)
346 |          (with-html-string
347 |            (:li
348 |              (:div :class "status col-xs-2 col-md-1"
349 |                (:span :class "text-success"
350 |                  (:a :href "https://en.wikipedia.org/wiki/List_of_HTTP_status_codes#200"
351 |                    200)))))))))
352 | 
353 | ;; (test (indent-closing-inline-tags-in-blocks :compile-at :run-time)
354 | ;;   (let ((*print-pretty* t))
355 | ;;     (is (visually-equal
356 | ;;          (format nil "~
357 | ;; <div>
358 | ;;  <span>
359 | ;;   <a href=#>Hello</a>
360 | ;;  </span>
361 | ;; </div>")
362 | ;;          (with-html-string
363 | ;;            (:div
364 | ;;              (:span
365 | ;;                (:a :href "#" "Hello"))))))))
366 | 
367 | (test indent-inline-after-paragraph
368 |   (with-pretty-printing
369 |     (is (visually-equal
370 |          (format nil "~
371 | <p>
372 |  <button>Log in</button>
373 |  <a href=#>Forgot?</a>")
374 |          (with-html-string
375 |            (:p
376 |              (:button "Log in")
377 |              (:a :href "#" "Forgot?")))))))
378 | 
379 | (test empty-tags-on-same-line
380 |   (with-pretty-printing
381 |     (is (visually-equal
382 |          (format nil "~
383 | <div>
384 |  <div></div>
385 | </div>")
386 |          (with-html-string
387 |            (:div
388 |              (:div)))))))
389 | 
390 | (test misaligned-attrs-in-nested-blocks
391 |   (with-pretty-printing
392 |     (is (visually-equal
393 |          (format nil "~
394 | <div>
395 |  <div>
396 |   <div>
397 |    <div class=\"list-group toc-entries\"
398 |         data-instant=true></div>
399 |   </div>
400 |  </div>
401 | </div>")
402 |          (with-html-string
403 |            (:div
404 |              (:div
405 |                (:div
406 |                  (:div.list-group.toc-entries
407 |                   :data-instant t)))))))))
408 | 
409 | (test keywords-in-tokenized-attributes
410 |   (with-pretty-printing
411 |     (is (equal "<p class=foo>"
412 |                (with-html-string
413 |                  (:p :class :foo))))
414 |     (is (equal "<link rel=stylesheet>"
415 |                (with-html-string
416 |                  (:link :rel :stylesheet))))))
417 | 
418 | (test dynamic-tags
419 |   (with-pretty-printing
420 |     (is (visually-equal
421 |          (with-html-string
422 |            (:div
423 |              (:section
424 |                (:h2
425 |                  (:p "hello")))))
426 |          (with-html-string
427 |            (:div
428 |              (:section
429 |                (:tag :name :h2
430 |                      (:p "hello")))))))))
431 | 
432 | (test h*
433 |   (with-pretty-printing
434 |     (is (visually-equal
435 |          (format nil "~
436 | <body>
437 |  <h1>This is a top level heading</h1>
438 |  <p>...
439 |  <section>
440 |   <p>...
441 |   <h2>This is a second-level heading</h2>
442 |   <p>...
443 |   <h2>This is another second-level heading</h2>
444 |   <p>...
445 |   <section>
446 |    <h3>This is a third-level heading</h3>
447 |    <p>...
448 |   </section>
449 |  </section>
450 | </body>")
451 |          (with-html-string
452 |            (:body
453 |              (:h* "This is a top level heading")
454 |              (:p "...")
455 |              (:section
456 |                (:p "...")
457 |                (:h* "This is a second-level heading")
458 |                (:p "...")
459 |                (:h* "This is another second-level heading")
460 |                (:p "...")
461 |                (:section
462 |                  (:h* "This is a third-level heading")
463 |                  (:p "...")))))))))
464 | 
465 | (test html-path
466 |   (is (visually-equal
467 |        (format nil "~
468 | <body>
469 |  <h1>This is a top level heading</h1>
470 |  <p>...
471 |  <h2>This is a second-level tricked by *HTML-PATH*</h2>
472 |  <p>...
473 | </body>")
474 |        (with-html-string
475 |          (:body
476 |            (:h* "This is a top level heading")
477 |            (:p "...")
478 |            (let ((*html-path* (append *html-path* '(:section))))
479 |              (:h* "This is a second-level tricked by *HTML-PATH*")
480 |              (:p "...")))))))
481 | 
482 | 
483 | (test print-tree
484 |   (with-pretty-printing
485 |     (is (visually-equal
486 |          (format nil "~
487 | <div>
488 |  <p>Text <a>link text</a> more text
489 | </div>")
490 |          (let ((*html-style* :human))
491 |            (with-html-string
492 |              (:div
493 |                (:p "Text " (:a "link text") " more text"))))))
494 | 
495 |     (is (visually-equal
496 |          (format nil "~
497 | <div>
498 |  <p>
499 |   Text
500 |   <a>
501 |    link text
502 |   </a>
503 |    more text
504 |  </p>
505 | </div>")
506 |          (let ((*html-style* :tree))
507 |            (with-html-string
508 |              (:div
509 |                (:p "Text " (:a "link text") " more text"))))))))
510 | 
511 | (test textarea-preformatting
512 |   (flet ((test1 ()
513 |            (with-html-string
514 |              (:div (:textarea "123"))))
515 |          (test2 ()
516 |            (with-html-string
517 |              (let ((*print-pretty*))
518 |                (:div (:textarea "123"))))))
519 |     (with-pretty-printing
520 |       (is (visually-equal (test1)
521 |                           (format nil "~
522 | <div>
523 |  <textarea>123</textarea>
524 | </div>")))
525 |       (is (visually-equal (test2)
526 |                           "<div><textarea>123</textarea></div>")))
527 |     ;; Test that dereferencing the underlying stream works when the
528 |     ;; stream is not, in fact, an HTML stream.
529 |     (without-pretty-printing
530 |       (is (visually-equal (test2)
531 |                           "<div><textarea>123</textarea></div>")))))
532 | 
533 | (test print-as-tree-without-pretty-printing
534 |   (is (visually-equal "<p>hello</p><span>world</span>"
535 |                       (let ((spinneret:*html-style* :tree)
536 |                             (*print-pretty* nil))
537 |                         (spinneret:with-html-string
538 |                           (:p "hello")
539 |                           (:span "world"))))))
540 | 
541 | 
542 | (test raw-shouldnt-pretty-print-its-content
543 |   (is (visually-equal
544 |        "Very very very very very very very very very very very very very very very very very very very very very very very very long line"
545 |        (with-html-string
546 |          (:raw "Very very very very very very very very very very very very very very very very very very very very very very very very long line")))))
547 | 
548 | (test valid-custom-element-names
549 |   (is (not (valid-custom-element-name? :x)))
550 |   (is (not (valid-custom-element-name? :-)))
551 |   (is (not (valid-custom-element-name? :-a)))
552 |   (is (valid-custom-element-name? :a-))
553 |   (is (not (valid-custom-element-name? (make-keyword "a")))))
554 | 
555 | (test literal-custom-element-names
556 |   (signals error
557 |     (eval
558 |      '(with-html-string
559 |        (:xy "Hello"))))
560 | 
561 |   (finishes
562 |     (eval
563 |      '(with-html-string
564 |        (:x-y "Hello")))))
565 | 
566 | (test dynamic-custom-element-names
567 |   (signals error
568 |     (eval
569 |      '(with-html-string
570 |        (:tag :name "xy" "Hello"))))
571 |   (finishes
572 |     (eval
573 |      '(with-html-string
574 |        (:tag :name "x-y" "Hello")))))
575 | 
576 | (test function-space-discrepancy
577 |   (let ((*html-style* :human)
578 |         (*print-pretty* t))
579 |     (is (equal
580 |          (with-html-string
581 |            (:p "foo"
582 |              "bar"
583 |              (values "baz")))
584 |          (with-html-string
585 |            (:p (values "foo")
586 |              "bar"
587 |              "baz"))))
588 |     (is (visually-equal
589 |          (with-html-string
590 |            (:p "foo"
591 |              "bar"
592 |              "baz"))
593 |          (with-html-string
594 |            (:p (values "foo")
595 |              (values "bar")
596 |              (values "baz")))))))
597 | 
598 | (test literal-pathnames
599 |   (finishes
600 |     (with-html-string
601 |       (:html
602 |         (:head
603 |           (:link #p"styles.css" :type "text/css"))))))
604 | 
605 | (test pre-closing-tag
606 |   (is
607 |    (visually-equal
608 |     "<div class=some-class>
609 |  <pre>verbatim line one
610 | verbatim line two</pre>
611 |  <p>Some following stuff
612 | </div>"
613 |     (with-html-string
614 |       (:div.some-class
615 |        (:pre "verbatim line one
616 | verbatim line two")
617 |        (:p "Some following stuff")))))
618 |   )
619 | 
620 | (test pre-no-spaces
621 |   (is
622 |    (visually-equal
623 |     "<pre>foo
624 | bar</pre>"
625 |     (with-html-string (:pre "foo" #\Newline "b" "a" "r")))))
626 | 
627 | (test pre-no-spaces-format
628 |   (is
629 |    (visually-equal
630 |     "<pre>foo
631 | bar</pre>"
632 |     (with-html-string (:pre ("foo ~A~A~A~A" #\Newline "b" "a" "r"))))))
633 | 
634 | (test pre-code
635 |   (let ((*print-pretty* t))
636 |     (is
637 |      (visually-equal
638 |       #.(format nil "~
639 | <pre><code>(defun blah ()
640 |     (+ 1 2))</code></pre>")
641 |       (spinneret:with-html-string
642 |         (:pre
643 |           (:code "(defun blah ()
644 |     (+ 1 2))")))))))
645 | 
646 | (test heading-depth
647 |   (let ((*print-pretty* nil))
648 |     (is (search "h1" (spinneret:with-html-string (:h*))))
649 |     (is (search "h2" (spinneret:with-html-string (:section (:h*)))))))
650 | 
651 | (test ps-attributes
652 |   (is (not (search "classvar()"
653 |                    (ps:ps
654 |                      (let ((classvar "myclass"))
655 |                        (spinneret:with-html
656 |                          (:div#myid :class classvar
657 |                                     (:p "lorem ipsum")))))))))
658 | 
659 | (test double-cdata-close
660 |   (is (equal (with-html-string
661 |                (:html
662 |                  (:head
663 |                    (:script
664 |                      (:CDATA "foo")))))
665 |              "<html lang=en>
666 |  <head>
667 |   <meta charset=UTF-8>
668 |   <script><![CDATA[foo]]></script>
669 |  </head>
670 | </html>")))
671 | 
672 | (test double-comment-close
673 |   (is (equal
674 |        (let (*print-pretty*)
675 |          (with-html-string
676 |            (:html
677 |              (:!-- "something"))))
678 |        "<html lang=en><!-- something --></html>")))
679 | 
680 | (test interpret-tree
681 |   (is (visually-equal
682 |        (with-output-to-string (*html*)
683 |          (interpret-html-tree
684 |           `(:ul :class "shuffle" (:li "Item1") (:li "Item2"))
685 |           :stream *html*))
686 |        (fmt
687 |         "~
688 | <ul class=shuffle>
689 |  <li>
690 |   Item1
691 |  </li>
692 |  <li>
693 |   Item2
694 |  </li>
695 | </ul>"))))
696 | 
697 | (test escape-quotes
698 |   (is (equal (with-html-string
699 |                (:p "She said, \"'Hello', she said.\""))
700 |              "<p>She said, &quot;&#39;Hello&#39;, she said.&quot;")))
701 | 
702 | (test escape-single-quotes-in-attributes
703 |   (is (equal
704 |        (let (*print-pretty*)
705 |          (with-html-string
706 |            (:button :onclick "window.alert('Hello, world.')"  "My button")))
707 |        ;; Interestingly this still works.
708 |        "<button onclick=\"window.alert(&#39;Hello, world.&#39;)\">My button</button>")))
709 | 
710 | (test raw-metatag
711 |   (is (equal "ahahaha"
712 |              (with-output-to-string (*html*)
713 |                (interpret-html-tree '(:raw "ahahaha")))))
714 |   (is (search "lang=en"
715 |               (with-output-to-string (*html*)
716 |                 (interpret-html-tree '(:html (:p "Hello"))))))
717 |   (is (search "!DOCTYPE"
718 |               (with-output-to-string (*html*)
719 |                 (interpret-html-tree '(:html (:doctype))))))
720 |   (is (search "ahahaha -->"
721 |               (with-output-to-string (*html*)
722 |                 (interpret-html-tree '(:comment "ahahaha")))))
723 |   (is (search "charset=UTF-8"
724 |               (with-output-to-string (*html*)
725 |                 (interpret-html-tree '(:html (:head))))))
726 |   (is (equal "<dangerous & forbidden>"
727 |              (with-output-to-string (*html*)
728 |                (interpret-html-tree '(:raw "<dangerous & forbidden>")))))
729 |   (is (search "h3"
730 |               (with-output-to-string (*html*)
731 |                 (interpret-html-tree '(:h* (:section (:h* (:section (:h*)))))))
732 |               ))
733 |   (is (search "<p>"
734 |               (with-output-to-string (*html*)
735 |                 (interpret-html-tree '(:tag :name :p))))))
736 | 
737 | (test dissect-interpreted-tag
738 |   (let ((spinneret:*html-style* :tree))
739 |     (is (equal
740 |          (with-html-string
741 |            (:div.my-class))
742 |          (remove #\Newline
743 |                  (with-output-to-string (*html*)
744 |                    (interpret-html-tree '(:div.my-class))))))))
745 | 
746 | (test dissect-dynamic-tag
747 |   (let ((spinneret:*html-style* :tree))
748 |     (is (equal
749 |          (with-html-string
750 |            (:tag :name :div.my-class))
751 |          (remove #\Newline
752 |                  (with-output-to-string (*html*)
753 |                    (interpret-html-tree '(:div.my-class))))))))
754 | 
755 | (test override-lang-defaults
756 |   (let ((string
757 |           (with-html-string
758 |             (:html
759 |               (:head)
760 |               (:p)))))
761 |     (is (search "lang=en" string))
762 |     (is (search "charset=UTF-8" string)))
763 |   (let ((string
764 |           (with-html-string
765 |             (:html :lang "foo"
766 |               (:head
767 |                 (:meta :charset "some-other"))
768 |               (:p)))))
769 |     (is (search "lang=foo" string))
770 |     (is (search "charset=some-other" string))))
771 | 
772 | (test allow-allowfullscreen
773 |   (finishes
774 |     (let ((*html* (make-broadcast-stream)))
775 |       (with-html (:iframe :width 560 :height 315 :src "example.com" :title "YouTube video player" :frameborder 0 :allow "accelerometer; autoplay; clipboard-write; encrypted-media; gyroscope; picture-in-picture" :allowfullscreen t)))))
776 | 
777 | (test always-quote-attributes
778 |   (let ((spinneret:*html-style* :tree)
779 | 	(spinneret:*always-quote* t))
780 |     (is (equal
781 |          (with-html-string
782 |            (:img :attrs (list :alt "some alt text" :src "https://test.com/image.png")))
783 |          "<img alt=\"some alt text\"
784 |      src=\"https://test.com/image.png\">"))))
785 | 
786 | (test raw-attributes
787 |   (is (equal
788 |        "<div onclick=\"alert('Hello');\"></div>"
789 |        (with-html-string
790 |          (:div :onclick (:raw (ps:ps (alert "Hello")))))))
791 |   (is (equal
792 |        (with-html-string
793 |          (:div :onclick (ps:ps (alert "Hello"))))
794 |        "<div onclick=alert(&#39;Hello&#39;);></div>")))
795 | 
796 | (deftag ul* (body attrs &key &allow-other-keys)
797 |   "<ul> with every form (except <li>) in BODY auto-wrapped into a <li>."
798 |   `(:ul ,@attrs ,@(loop for form in body
799 |                         when (and (listp form)
800 |                                   (eq :li (first form)))
801 |                           collect form
802 |                         else
803 |                           collect `(:li ,form))))
804 | 
805 | (test with-html-over-deftag
806 |   ;; The tag is bound as a macro.
807 |   (is (fboundp 'ul*))
808 |   (is (equal
809 |        (with-html-string
810 |          (ul*
811 |            "Item 1"
812 |            "Item 2"
813 |            (:b "Bold item 3")
814 |            (:li "Proper <li> item 4")
815 |            "Item 5"))
816 |        "<ul>
817 |  <li>Item 1
818 |  <li>Item 2
819 |  <li><b>Bold item 3</b>
820 |  <li>Proper &lt;li&gt; item 4
821 |  <li>Item 5
822 | </ul>")))
823 | 
824 | (deftag :selfref (body attrs &key href &allow-other-keys)
825 |   `(:a.selfref :href ,href ,@attrs ,@body))
826 | 
827 | (test deftag-selector-syntax
828 |   ;; The tag is not bound as a macro.
829 |   (is (not (fboundp :selfref)))
830 |   ;; The tag works.
831 |   (is (equal
832 |        "<a class=selfref href=\"https://example.com\" id=id>Example website</a>"
833 |        (with-html-string
834 |          (:selfref#id :href "https://example.com" "Example website")))))
835 | 
836 | (test inline-tag-leading-spaces
837 |   (flet ((f (url)
838 |            (with-html
839 |              (:h4 (:raw "&nbsp;") (:a :href url "Some Text")))))
840 |     (is (equal
841 |          "<h4>&nbsp;<a href=\"http://short.com/\">Some Text</a></h4>"
842 |          (with-html-string
843 |            (f "http://short.com/"))))
844 |     (is (search ">Some"
845 |                 (with-html-string
846 |                   (f "http://thisisreallyreallylonglonglonglongonwegoxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx.com"))))))
847 | 
848 | (test inline-tag-trailing-spaces
849 |   (is (equal
850 |        (spinneret:with-html-string
851 |          (:span "Click the " (:a :href "https://google.com" ) "."))
852 |        "<span>Click the <a href=\"https://google.com\"></a>.</span>")))
853 | 
854 | (test html-tag-empty-string
855 |   (finishes
856 |     (spinneret:with-html-string (:style ""))))
857 | 
858 | (test test-dataset-property-within-hyphens
859 |   "Hyphenated data properties should be translated to bracketed strings
860 | with underscores."
861 |   (is (search
862 |        "dataset['x_y']"
863 |        (ps:ps (with-html (:div :data-x-y "z"))))))
864 | 
865 | (defmacro with-thing-printing ((&key p) &body body)
866 |   (declare (ignore body))
867 |   `(progn (princ ,p *html*)
868 |           nil))
869 | 
870 | (test test-disable-html
871 |   (is (equal "<p>Hello"
872 |              (with-html-string
873 |                (:p
874 |                  (:disable-html
875 |                   (with-thing-printing (:p "Hello")))))))
876 |   (is (equal "<p>Hello"
877 |              (with-html-string
878 |                (:p
879 |                  (with-thing-printing
880 |                      (:disable-html (:p "Hello"))))))))
881 | 


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