src/html-reader.lisp

   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))
   5
   6 (in-package #:lw2.html-reader)
   7
   8 (defvar *html-output* nil)
   9
  10 (defun encode-entities (text &optional stream)
  11   #||(if-client
  12    (let ((output
  13           (ps:chain text (replace (ps:regex "/[<>\"'&]/g")
  14                                   (lambda (match)
  15                                     (concatenate 'string
  16                                                  "&"
  17                                                  (ps:getprop (ps:create "<" "lt"
  18                                                                         ">" "gt"
  19                                                                         "\"" "quot"
  20                                                                         "'" "apos"
  21                                                                         "&" "amp")
  22                                                              match)
  23                                                  ";"))))))
  24      (if stream
  25          (progn (ps:chain stream (push output)) nil)
  26          output))|#
  27    (handler-bind
  28     (((or plump:invalid-xml-character plump:discouraged-xml-character) #'abort))
  29     (plump:encode-entities (princ-to-string text) stream)));)
  30
  31 (trivial-cltl2:define-declaration html-output (decl env) (declare (ignore env)) (values :declare (cons 'html-output (second decl))))
  32
  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))))
  37                             (_ body))))
  38     (if (trivial-cltl2:declaration-information 'html-output env)
  39         `(progn ,@body nil)
  40         `(let ((html-output *html-output*))
  41            (declare (ignorable html-output)
  42                     (html-output html-output))
  43            ,@body
  44            nil))))
  45
  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)))))))
  54
  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 ""))))
  67
  68 (defun html-reader (stream char)
  69   (declare (ignore char))
  70   (let (element
  71         out-body
  72         (string-output "")
  73         (buffer (make-array 128
  74                             :element-type 'character
  75                             :adjustable t
  76                             :fill-pointer 0)))
  77     (labels ((output-strings (&rest strings)
  78                (setf string-output (apply #'concatenate 'simple-string string-output strings)))
  79              (flush-output ()
  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))
  88                          (values nil object))
  89                    (cond
  90                      ((and (consp object) (stringp (first object)))
  91                       (flush-output)
  92                       (appendf out-body
  93                                (if safe
  94                                    `((format html-output ,@object))
  95                                    `((encode-entities (format nil ,@object) html-output)))))
  96                      ((and (consp object) (eq (first object) 'with-html-stream-output))
  97                       (flush-output)
  98                       (appendf out-body (list object)))
  99                      ((and (constantp object) (or (stringp object) (numberp object)))
 100                       (output-strings (princ-to-string (eval object))))
 101                      (t
 102                       (flush-output)
 103                       (appendf out-body
 104                                (if safe
 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)
 115             (loop
 116                with need-whitespace = t
 117                with in-leading-whitespace = nil
 118                with in-tag = t
 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)
 122                when (eq c #\>)
 123                do (progn
 124                     (output-strings ">")
 125                     (if (member element '("area" "base" "br" "col" "embed" "hr" "img" "input" "link" "meta" "param" "source" "track" "wbr")
 126                                 :test #'string-equal)
 127                         (return nil)
 128                         (setf need-whitespace nil
 129                               in-tag nil)))
 130                else when (and in-tag (eq c #\=))
 131                do (progn
 132                     (output-strings "=\"")
 133                     (let ((*readtable* (find-readtable 'html-reader-inner)))
 134                       (output-read-object))
 135                     (output-strings "\""))
 136                else when (eq c #\<)
 137                do (cond
 138                     ((eq (peek-char nil stream) #\/)
 139                      (read-char stream)
 140                      (unless (and
 141                               (loop for x across element
 142                                  when (not (eq (read-char stream) x))
 143                                  return nil
 144                                  finally (return t))
 145                               (eq (read-char stream) #\>))
 146                        (error "Mismatched HTML tag: ~A at position ~A." element (file-position stream)))
 147                      (output-strings "</" element ">")
 148                      (return nil))
 149                     (t
 150                      (unread-char c stream)
 151                      (output-read-object)))
 152                else when (eq c #\\)
 153                do (output-strings (string (read-char stream)))
 154                else when (eq c #\()
 155                do (progn
 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))
 160                     (output-strings " ")
 161                     (setf need-whitespace nil))
 162                else do (progn
 163                          (output-strings (string c))
 164                          (setf need-whitespace t)))
 165             (flush-output)
 166             `(with-html-stream-output ,.out-body))))
 167
 168 (defreadtable html-reader
 169   (:merge :standard)
 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))))|#)
 174
 175 (defreadtable html-reader-inner
 176   (:merge html-reader)
 177   (:macro-char #\> #'(lambda (stream char) (declare (ignore stream char)) (values))))
 178