1 (uiop:define-package
#:lw2.html-reader
2 (:use
#:cl
#:alexandria
#:iterate
#:named-readtables
)
3 (:export
#:*html-output
* #:with-html-stream-output
#:safe
#:encode-entities
#:html-reader
)
4 (:recycle
#:lw2-viewer
))
6 (in-package #:lw2.html-reader
)
8 (defvar *html-output
* nil
)
10 (defun encode-entities (text &optional stream
)
13 (ps:chain text
(replace (ps:regex
"/[<>\"'&]/g")
17 (ps:getprop
(ps:create
"<" "lt"
25 (progn (ps:chain stream
(push output
)) nil
)
28 (((or plump
:invalid-xml-character plump
:discouraged-xml-character
) #'abort
))
29 (plump:encode-entities
(princ-to-string text
) stream
)));)
31 (trivial-cltl2:define-declaration html-output
(decl env
) (declare (ignore env
)) (values :declare
(cons 'html-output
(second decl
))))
33 (defmacro with-html-stream-output
(&environment env
&body body
)
34 (let ((body (trivia:match
(first body
)
35 ((list :stream stream-var
)
36 `((let ((,stream-var html-output
)) ,@(rest body
))))
38 (if (trivial-cltl2:declaration-information
'html-output env
)
40 `(let ((html-output *html-output
*))
41 (declare (ignorable html-output
)
42 (html-output html-output
))
46 (defun process-html-stream-output-forms (forms)
47 (iter (for form in forms
)
48 (collect (trivia:match form
49 ((list* :stream _
) nil
)
50 ((list* (or 'write-string
'princ
) string _
) `(ps:chain html-output
(push ,string
)))
51 ((list* 'encode-entities _
) form
)
52 ((list* 'with-html-stream-output forms
) `(progn ,@(process-html-stream-output-forms forms
)))
53 (_ `(ps:chain html-output
(push ,form
)))))))
55 (ps:defpsmacro with-html-stream-output
(&body body
)
56 `(let ((html-output (make-array)))
57 (macrolet ((write-string (string stream
)
58 (declare (ignore stream
))
59 `(ps:chain html-output
(push ,string
)))
60 (princ (string stream
)
61 (declare (ignore stream
))
62 `(ps:chain html-output
(push ,string
)))
63 (with-html-stream-output (&body body
)
64 `(progn ,@(process-html-stream-output-forms body
) nil
)))
65 ,@(process-html-stream-output-forms body
))
66 (ps:chain html-output
(join ""))))
68 (defun html-reader (stream char
)
69 (declare (ignore char
))
73 (buffer (make-array 128
74 :element-type
'character
77 (labels ((output-strings (&rest strings
)
78 (setf string-output
(apply #'concatenate
'simple-string string-output strings
)))
80 (unless (string= string-output
"")
81 (appendf out-body
`((write-string ,string-output html-output
)))
82 (setf string-output
"")))
83 (output-read-object ()
84 (let ((object (read-preserving-whitespace stream
)))
85 (multiple-value-bind (safe object
)
86 (if (and (consp object
) (eq (first object
) 'safe
))
87 (values t
(second object
))
90 ((and (consp object
) (stringp (first object
)))
94 `((format html-output
,@object
))
95 `((encode-entities (format nil
,@object
) html-output
)))))
96 ((and (consp object
) (eq (first object
) 'with-html-stream-output
))
98 (appendf out-body
(list object
)))
99 ((and (constantp object
) (or (stringp object
) (numberp object
)))
100 (output-strings (princ-to-string (eval object
))))
105 `((princ ,object html-output
))
106 `((encode-entities (or ,object
"") html-output
))))))))))
107 (loop for c
= (peek-char nil stream
)
108 while
(not (member c
'(#\Space
#\Newline
#\
>)))
109 do
(vector-push-extend (read-char stream
) buffer
))
110 (when-let ((symbol (find-symbol (concatenate 'string
"<" buffer
) *package
*)))
111 (unless (eq (symbol-package symbol
) *package
*)
112 (return-from html-reader symbol
)))
113 (setf element
(coerce buffer
'simple-string
))
114 (output-strings "<" element
)
116 with need-whitespace
= t
117 with in-leading-whitespace
= nil
119 for c
= (read-char stream
)
120 when
(eq c
#\Newline
) do
(setf in-leading-whitespace t
)
121 else when
(not (member c
'(#\Space
#\Tab
))) do
(setf in-leading-whitespace nil
)
125 (if (member element
'("area" "base" "br" "col" "embed" "hr" "img" "input" "link" "meta" "param" "source" "track" "wbr")
126 :test
#'string-equal
)
128 (setf need-whitespace nil
130 else when
(and in-tag
(eq c
#\
=))
132 (output-strings "=\"")
133 (let ((*readtable
* (find-readtable 'html-reader-inner
)))
134 (output-read-object))
135 (output-strings "\""))
138 ((eq (peek-char nil stream
) #\
/)
141 (loop for x across element
142 when
(not (eq (read-char stream
) x
))
145 (eq (read-char stream
) #\
>))
146 (error "Mismatched HTML tag: ~A at position ~A." element
(file-position stream
)))
147 (output-strings "</" element
">")
150 (unread-char c stream
)
151 (output-read-object)))
153 do
(output-strings (string (read-char stream
)))
156 (unread-char c stream
)
157 (output-read-object))
158 else when
(member c
'(#\Space
#\Newline
#\Tab
))
159 do
(when (or need-whitespace
(not in-leading-whitespace
))
161 (setf need-whitespace nil
))
163 (output-strings (string c
))
164 (setf need-whitespace t
)))
166 `(with-html-stream-output ,.out-body
))))
168 (defreadtable html-reader
170 (:macro-char
#\
< #'html-reader t
)
171 #|
(:macro-char
#\" #'(lambda (stream char
)
172 (let ((*readtable
* (find-readtable :standard
)))
173 (funcall (get-macro-character #\" *readtable
*) stream char
))))|
#)
175 (defreadtable html-reader-inner
177 (:macro-char
#\
> #'(lambda (stream char
) (declare (ignore stream char
)) (values))))