This repository has been archived by the owner on Nov 14, 2023. It is now read-only.
/
print-html.lisp
153 lines (106 loc) · 3.99 KB
/
print-html.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
;; * Overview
;; This program is an Html generator for Common Lisp.
;; Why another one?
;; I want programmatically generate and process Html.
;; In particular I want to
;; - Store Html in variables
;; - Use Html as a function argument
;; - Use Html as a function return value
;; To achieve this, we transform symbolic expressions into lists of tag
;; structures. The method print-html then prints its input as properly
;; escaped Html.
;; * Package
;; We only use common-lisp.
(defpackage print-html
(:use :common-lisp)
(:export :render :print-html :print-html-to-string :html :unsafe))
(in-package :print-html)
;; * Self closing tags
(defvar *self-closing-tags*
(list :area :base :br :col :command :embed :frame :hr :img :input :keygen
:link :menuitem :meta :param :source :track :wbr)
"List of self closing tags.")
;; * Render
;; The /RENDER/ method is called by /PRINT-HTML/ to map an
;; object into something that /PRINT-HTML/ is specialized for.
;; By default, /RENDER/ calls /princ-to-string/.
(defgeneric render (object)
(:method (object)
(princ-to-string object)))
;; * Print Html
;; The interpreter. Calls /render/ for objects it is not specialized
;; for.
(defgeneric print-html (object stream)
(:method (object stream)
(print-html (render object) stream))
(:method ((char character) stream)
(case char
(#\< (write-string "<" stream))
(#\> (write-string ">" stream))
(#\& (write-string "&" stream))
(#\" (write-string """ stream))
(t (write-char char stream))))
(:method ((string string) stream)
(map nil (lambda (char) (print-html char stream)) string))
(:method ((list list) stream)
(dolist (object list)
(print-html object stream))))
;; Print /OBJECT/ to string. Note: This function is also used to
;; escape attributes.
(defun print-html-to-string (object)
(with-output-to-string (stream)
(print-html object stream)))
;; * Tag
(defstruct tag name attrs children)
(defmethod print-html ((self tag) stream)
(print-html (tag-children self) stream))
(defmethod print-html :before ((self tag) stream)
(format stream "~&<~(~a~)~{ ~(~a~)=~s~}>" (tag-name self)
(loop for (k v) on (tag-attrs self) by #'cddr when v
collect (print-html-to-string k) and
collect (print-html-to-string (if (eq v t) k v)))))
(defmethod print-html :after ((self tag) stream)
(unless (member (tag-name self) *self-closing-tags*)
(format stream "</~(~a~)>~&" (tag-name self))))
;; * Html DSL
;; Macroexpand example:
;; The code
;; #+begin_example
;; (print-html-to-string
;; (html
;; ((:span :style "color:blue") "text")))
;; #+end_example
;; expands to
;; #+begin_example
;; (PRINT-HTML-TO-STRING (LIST (MAKE-TAG :NAME
;; :SPAN
;; :ATTRS
;; (LIST :STYLE "color:blue")
;; :CHILDREN
;; (HTML "text"))))
;; #+end_example
;; and evaluates to
;; #+begin_example
;; "<span style=\"color:blue\">text</span>"
;; #+end_example
;; The html generation macro:
(defmacro html (&body body)
(labels ((listify (x) (if (listp x) x (list x)))
(codegen (x)
(cond ((atom x) x)
((not (keywordp (car (listify (car x))))) x)
(t (destructuring-bind (head &rest body) x
(destructuring-bind (name &rest attrs) (listify head)
`(make-tag :name ,name :attrs (list ,@attrs)
:children (html ,@body))))))))
`(list ,@(mapcar #'codegen body))))
;; * Extending the Print-Html package
;; ** Doctype
;; Print doctype.
(defmethod print-html ((self (eql :doctype-html)) stream)
(format stream "<!doctype html>~&"))
;; ** Unsafe
;; Print string without escaping
(defstruct (unsafe (:constructor unsafe (string))) string)
(defmethod print-html ((unsafe unsafe) stream)
(write-string (unsafe-string unsafe) stream))