;;; dat/html.lisp --- HTML parser

 ;; see https://github.com/rotatef/cl-html5-parser

 ;; spec: https://html.spec.whatwg.org/

 ;;; Commentary:

 ;; HTML is usually associated with XML, but not all HTML is valid

 ;; XML.

 ;; This package provides a pretty good HTML parser, with the default

 ;; DOM being the one used in our XML package DAT/XML.

 ;;; Code:

 ;;; inputstream

 (in-package :dat/html)

 (deftype array-length ()

   "Type of an array index."

   '(integer 0 #.array-dimension-limit))

 (deftype chunk ()

   "Type of the input stream buffer."

   '(vector character *))

 (defparameter *default-encoding* :utf-8)

 (defclass html-input-stream ()

   ((source :initarg :source)

    (encoding :reader html5-stream-encoding)

    (char-stream :initform nil)

    (chunk)

    (chunk-offset)

    (pending-cr)

    (errors :initform nil :accessor html5-stream-errors)))

 (defun make-html-input-stream (source &key override-encoding fallback-encoding)

   (when (stringp source)

     ;; Encoding is not relevant when input is a string,

     ;; but we set it utf-8 here to avoid auto detecting taking place.

     (setf override-encoding :utf-8))

   (let ((self (make-instance 'html-input-stream :source source)))

     (with-slots (encoding stream) self

       (setf encoding (detect-encoding self

                                       (find-encoding override-encoding)

                                       (find-encoding fallback-encoding)))

       (open-char-stream self))

     self))

 ;; 12.2.2.2 Character encodings

 (defun find-encoding (encoding-name)

   ;; Normalize the string designator

   (setf encoding-name (string-upcase (substitute #\- #\_ (string-trim +space-characters+ (string encoding-name)))))

   ;; All known encoding will already be interned in the keyword package so find-symbol is fine here

   (setf encoding-name (find-symbol encoding-name :keyword))

   (handler-case

       ;; Verfiy that flexi-streams knows the encoding and resolve aliases

       (case (flex:external-format-name (flex:make-external-format encoding-name))

         ;; Some encoding should be replaced by some other.

         ;; Only those supported by flexi-streams are listed here.

         ;; iso-8859-11 should be replaced by windows-874, but flexi-streams doesn't that encoding.

         (:iso-8859-1 :windows-1252)

         (:iso-8859-9 :windows-1254)

         (:us-ascii :windows-1252)

         (otherwise encoding-name))

     (flex:external-format-error ())))

 ;; 12.2.2.1 Determining the character encoding

 (defun detect-encoding (stream override-encoding fallback-encoding)

   (with-slots (encoding) stream

     (block nil

       ;; 1. and 2. encoding overridden by user or transport layer

       (when override-encoding

         (return (cons override-encoding :certain)))

       ;; 3. wait for 1024 bytes, not implemented

       ;; 4. Detect BOM

       (let ((bom-encoding (detect-bom stream)))

         (when bom-encoding

           (return (cons bom-encoding :certain))))

       ;; 5. Prescan not implemented

       ;; 6. Use fallback encoding

       (when fallback-encoding

         (return (cons encoding :tentative)))

       ;; 7. Autodect not implemented

       ;; 8. Implementation-defined default

       (return (cons *default-encoding* :tentative)))))

 (defmacro handle-encoding-errors (stream &body body)

   `(handler-bind ((flex:external-format-encoding-error

                    (lambda (x)

                      (declare (ignore x))

                      (push :invalid-codepoint (html5-stream-errors ,stream))

                      (use-value #\uFFFD))))

      ,@body))

 (defun open-char-stream (self)

   (with-slots (source encoding char-stream chunk chunk-offset pending-cr) self

     (setf chunk (make-array (* 10 1024) :element-type 'character :fill-pointer 0))

     (setf chunk-offset 0)

     (setf pending-cr nil)

     (when char-stream

       (close char-stream))

     (setf char-stream

           (if (stringp source)

               (make-string-input-stream source)

               (flex:make-flexi-stream

                (etypecase source

                  (pathname

                   (open source :element-type '(unsigned-byte 8)))

                  (stream

                   source)

                  (vector

                   (flex:make-in-memory-input-stream source)))

                :external-format (flex:make-external-format (car encoding) :eol-style :lf))))

     ;; 12.2.2.4 says we should always skip the first byte order mark

     (handle-encoding-errors self

       (let ((first-char (peek-char nil char-stream nil)))

         (when (eql first-char #\ufeff)

           (read-char char-stream))))))

 (defun detect-bom (self)

   (with-slots (source) self

     (let (byte-0 byte-1 byte-2)

       (etypecase source

         (vector

          (when (> (length source) 0) (setf byte-0 (aref source 0)))

          (when (> (length source) 1) (setf byte-1 (aref source 1)))

          (when (> (length source) 2) (setf byte-2 (aref source 2))))

         (pathname

          (with-open-file (in source :element-type '(unsigned-byte 8))

            (setf byte-0 (read-byte in nil))

            (setf byte-1 (read-byte in nil))

            (setf byte-2 (read-byte in nil))))

         (stream

          (error "Can't detect encoding when source is a stream.")))

       (cond ((and (eql byte-0 #xfe)

                   (eql byte-1 #xff))

              :utf-16be)

             ((and (eql byte-0 #xff)

                   (eql byte-1 #xfe))

              :utf-16le)

             ((and (eql byte-0 #xef)

                   (eql byte-1 #xbb)

                   (eql byte-2 #xbf))

              :utf-8)))))

 ;; 12.2.2.3 Changing the encoding while parsing

 (defun html5-stream-change-encoding (stream new-encoding)

   (setf new-encoding (find-encoding new-encoding))

   (with-slots (encoding char-stream) stream

     ;; 1.

     (when (member (car encoding) '(:utf-16le :utf-16be))

       (setf encoding (cons (car encoding) :certain))

       (return-from html5-stream-change-encoding))

     ;; 2.

     (when (member new-encoding '(:utf-16le :utf-16be))

       (setf new-encoding :utf-8))

     ;; 3.

     (when (eql (car encoding) new-encoding)

       (setf encoding (cons (car encoding) :certain))

       (return-from html5-stream-change-encoding))

     ;; 4. Not impleneted

     ;; 5. Restart paring from scratch

     (setf encoding (cons new-encoding :certain))

     (open-char-stream stream)

     (throw 'please-reparse t)))

 (defun html5-stream-char (stream)

   (with-slots (chunk chunk-offset) stream

     (when (>= chunk-offset (length chunk))

       (unless (read-chunk stream)

         (return-from html5-stream-char +eof+)))

     (prog1 (char chunk chunk-offset)

       (incf chunk-offset))))

 (defun our-scan (chars opposite-p chunk &key start)

   (loop for i from start below (length chunk)

         for char = (char chunk i)

         while (if opposite-p

                   (position char chars)

                   (not (position char chars)))

         finally (return i)))

 (defun html5-stream-chars-until (stream characters &optional opposite-p)

   "Returns a string of characters from the stream up to but not

    including any character in characters or end of file.

    "

   (with-slots (chunk chunk-offset) stream

     (declare (array-length chunk-offset) (chunk chunk))

     (with-output-to-string (data)

       (loop for end = (our-scan characters opposite-p chunk :start chunk-offset) do

             ;; If nothing matched, and it wasn't because we ran out of chunk,

             ;; then stop

             (when (and (not end)

                        (/= chunk-offset (length chunk)))

               (return))

             ;; If not the whole chunk matched, return everything

             ;; up to the part that didn't match

             (when (and end

                        (/= chunk-offset (length chunk)))

               (write-string chunk data :start chunk-offset :end end)

               (setf chunk-offset end)

               (return))

             ;; If the whole remainder of the chunk matched,

             ;; use it all and read the next chunk

             (write-string chunk data :start chunk-offset)

             (unless (read-chunk stream)

               (return))))))

 (defun html5-stream-unget (stream char)

   (with-slots (chunk chunk-offset) stream

     (unless (eql char +eof+)

       (cond ((zerop chunk-offset)

              (cond ((< (fill-pointer chunk) (array-dimension chunk 0))

                     (incf (fill-pointer chunk))

                     (replace chunk chunk :start1 1))

                    (t

                     (let ((new-chunk (make-array (1+ (array-dimension chunk 0))

                                                  :element-type 'character

                                                  :fill-pointer (1+ (fill-pointer chunk)))))

                       (replace new-chunk chunk :start1 1)

                       (setf chunk new-chunk))))

              (setf (char chunk 0) char))

             (t

              (decf chunk-offset)

              (assert (char= char (char chunk chunk-offset))))))))

 (defun read-chunk (stream)

   (declare (optimize speed))

   (with-slots (char-stream chunk chunk-offset pending-cr) stream

     (declare (array-length chunk-offset)

              (chunk chunk))

     (setf chunk-offset 0)

     (let ((start 0))

       (when pending-cr

         (setf (char chunk 0) #\Return)

         (setf start 1)

         (setf pending-cr nil))

       (setf (fill-pointer chunk) (array-dimension chunk 0))

       (handle-encoding-errors stream

         (setf (fill-pointer chunk) (read-sequence chunk char-stream :start start)))

       (unless (zerop (length chunk))

         ;; check if last char is CR and EOF was not reached

         (when (and (= (length chunk) (array-dimension chunk 0))

                    (eql (char chunk (1- (length chunk))) #\Return))

           (setf pending-cr t)

           (decf (fill-pointer chunk)))

         (report-character-errors stream chunk)

         ;; Python code replaces surrugate pairs with U+FFFD here. Why?

         ;; Normalize line endings (CR LF)

         (loop for previous = nil then current

            for current across chunk

            for index of-type array-length from 0

            with offset of-type array-length = 0

            do (unless (and (eql previous #\Return)

                            (eql current #\Newline))

                 (unless (= index offset)

                   (setf (char chunk offset) current))

                 (when (eql current #\Return)

                   (setf (char chunk offset) #\Newline))

                 (incf offset))

            finally (setf (fill-pointer chunk) offset))

         t))))

 (defun char-range (char1 char2)

   (loop for i from (char-code char1) to (char-code char2)

         collect (code-char i)))

 (defparameter *invalid-unicode*

   `(,@(char-range #\u0001 #\u0008)

     #\u000B

     ,@(char-range #\u000E #\u001F)

     ,@(char-range #\u007F #\u009F)

     ;; The following are noncharacter as defined by Unicode.

     ;; Clozure Common Lisp doesn't like them.

 (defparameter *invalid-unicode-hash* (make-hash-table))

 (dolist (char *invalid-unicode*)

   (setf (gethash char *invalid-unicode-hash*) char))

 (defun report-character-errors (stream data)

   (loop for char across data

         when (gethash char *invalid-unicode-hash*)

           do (push :invalid-codepoint (html5-stream-errors stream))))

 ;;; Tokenizer

 (defclass html-tokenizer ()

   ((stream :initarg :stream :reader tokenizer-stream)

    (cdata-switch-helper :initarg :cdata-switch-helper

                         :initform (constantly nil))

    (lowercase-element-name :initform t)

    (lowercase-attr-name :initform t)

    (escape-flag :initform nil)

    (last-four-chars :initform nil)

    (state :initform :data-state :accessor tokenizer-state)

    (escape :initform nil)

    (current-token :initform nil)

    (token-queue :initform nil)

    (temporary-buffer :initform nil)))

 (defun make-html-tokenizer (source &key encoding cdata-switch-helper)

   (make-instance 'html-tokenizer

                  :stream (make-html-input-stream source :override-encoding encoding)

                  :cdata-switch-helper cdata-switch-helper))

 (defun map-tokens (tokenizer function)

   "Return next token or NIL on eof"

   (with-slots (token-queue stream) tokenizer

     (loop while (run-state tokenizer) do

          (setf token-queue (nreverse token-queue))

          (loop while (html5-stream-errors stream)

             do (funcall function (list :type :parse-error :data (pop (html5-stream-errors stream)))))

          (loop while token-queue

             do (funcall function (pop token-queue))))))

 (defun run-state (tokenizer)

   (run-state* tokenizer (slot-value tokenizer 'state)))

 (defgeneric run-state* (tokenizer state))

 (defmacro defstate (state (&rest slots) &body body)

   `(defmethod run-state* (self (state (eql ,state)))

      (with-slots (,@slots) self

        (block nil

          ,@body

          t))))

 (defun push-token (self token)

   (with-slots (token-queue) self

     (push token token-queue)))

 (defun make-growable-string (&optional (init ""))

   "Make an adjustable string with a fill pointer.

 Given INIT, a string, return an adjustable version of it with the fill

 pointer at the end."

   (let ((string

           (make-array (max 5 (length init))

                       :element-type 'character

                       :adjustable t

                       :fill-pointer (length init))))

     (when init

       (replace string init))

     string))

 (defun nconcat (string &rest data)

   "Destructively concatenate DATA, string designators, to STRING."

   (declare (optimize speed))

   (unless (array-has-fill-pointer-p string)

     (setf string (make-growable-string string)))

   (labels ((conc (string x)

              (typecase x

                (character

                 (vector-push-extend x string))

                (string

                 (let ((len (length x)))

                   (loop for c across x do

                     (vector-push-extend c string len))))

                (symbol (conc string (string x))))))

     (dolist (x data string)

       (conc string x))))

 (define-modify-macro nconcatf (&rest data) nconcat)

 (defun push-token* (self type &rest data)

   "Push a token with :type type and :data the a string concatenation of data"

   (push-token self (list :type type

                          :data (apply #'nconcat (make-growable-string) data))))

 (defun add-attribute (token name)

   (setf (getf token :data) (append (getf token :data)

                                    (list (cons (make-growable-string (string name))

                                                (make-growable-string))))))

 (defun add-to-attr-name (token &rest data)

   (setf (caar (last (getf token :data)))

         (apply #'nconcat

                (caar (last (getf token :data)))

                data)))

 (defun add-to-attr-value (token &rest data)

   (setf (cdar (last (getf token :data)))

         (apply #'nconcat

                (cdar (last (getf token :data)))

                data)))

 (defun add-to (token indicator &rest data)

   (setf (getf token indicator)

         (apply #'nconcat

                (getf token indicator)

                data)))

 (defun consume-number-entity (self is-hex)

   "This function returns either U+FFFD or the character based on the

    decimal or hexadecimal representation. It also discards \";\" if present.

    If not present a token (:type :parse-error) is emitted.

   "

   (with-slots (stream) self

     (let ((allowed +digits+)

           (radix 10)

           (char-stack)

           (c)

           (char-as-int)

           (char))

       (when is-hex

         (setf allowed +hex-digits+)

         (setf radix 16))

       ;; Consume all the characters that are in range while making sure we

       ;; don't hit an EOF.

       (setf c (html5-stream-char stream))

       (loop while (and (find c allowed) (not (eql c +eof+))) do

            (push c char-stack)

            (setf c (html5-stream-char stream)))

       ;; Convert the set of characters consumed to an int.

       (setf char-as-int (parse-integer (coerce (nreverse char-stack) 'string) :radix radix))

       ;; Certain characters get replaced with others

       (cond ((find char-as-int +replacement-characters+)

              (setf char (getf +replacement-characters+ char-as-int))

              (push-token self `(:type :parse-error

                                       :data :illegal-codepoint-for-numeric-entity

                                       :datavars '(:char-as-int ,char-as-int))))

             ((or (<= #xD800 char-as-int #xDFFF)

                  (> char-as-int #x10FFFF))

              (setf char #\uFFFD)

              (push-token self `(:type :parse-error

                                       :data :illegal-codepoint-for-numeric-entity

                                       :datavars '(:char-as-int ,char-as-int))))

             (t

              ;; Python comment: Should speed up this check somehow (e.g. move the set to a constant)

              (when (or (<= #x0001 char-as-int #x0008)

                        (<= #x000E char-as-int #x001F)

                        (<= #x007F char-as-int #x009F)

                        (<= #xFDD0 char-as-int #xFDEF)

                        (find char-as-int

                              #(#x000B #xFFFE #xFFFF #x1FFFE

                                #x1FFFF #x2FFFE #x2FFFF #x3FFFE

                                #x3FFFF #x4FFFE #x4FFFF #x5FFFE

                                #x5FFFF #x6FFFE #x6FFFF #x7FFFE

                                #x7FFFF #x8FFFE #x8FFFF #x9FFFE

                                #x9FFFF #xAFFFE #xAFFFF #xBFFFE

                                #xBFFFF #xCFFFE #xCFFFF #xDFFFE

                                #xDFFFF #xEFFFE #xEFFFF #xFFFFE

                                #xFFFFF #x10FFFE #x10FFFF)))

                (push-token self `(:type :parse-error

                                         :data :illegal-codepoint-for-numeric-entity

                                         :datavars '(:char-as-int ,char-as-int))))

              ;; Assume char-code-limit >= 1114112

              (setf char (code-char char-as-int))))

       ;; Discard the ; if present. Otherwise, put it back on the queue and

       ;; invoke parseError on parser.

       (unless (eql c #\;)

         (push-token self `(:type :parse-error :data :numeric-entity-without-semicolon))

         (html5-stream-unget stream c))

       (string char))))

 (defun consume-entity (self &key allowed-char from-attribute)

   (with-slots (stream current-token) self

     (let ((output "&")

           (stack (list (html5-stream-char stream))))

       (cond ((or (find (car stack) +space-characters+)

                  (find (car stack) '(+eof+ #\< #\&))

                  (and allowed-char (eql allowed-char (car stack))))

              (html5-stream-unget stream (car stack)))

             ((eql (car stack) #\#)

              (push (html5-stream-char stream) stack)

              (let ((is-hex (find (car stack) "xX")))

                (when is-hex

                  (push (html5-stream-char stream) stack))

                (cond ((find (car stack) (if is-hex +hex-digits+ +digits+))

                       (html5-stream-unget stream (car stack))

                       (setf output (consume-number-entity self is-hex)))

                      (t

                       (push-token self '(:type :parse-error :data :expected-numeric-entity))

                       (html5-stream-unget stream (pop stack))

                       (when is-hex

                         (html5-stream-unget stream (pop stack)))

                       (html5-stream-unget stream (pop stack))))))

             (t

              ;; Consume the maximum number of characters possible, with the

              ;; consumed characters matching one of the identifiers in the first

              ;; column of the named character references table

              ;; (in a case-sensitive manner).

              (let ((entity)

                    (match-at 0))

                (loop with node = *entities-tree*

                      for char = (car stack) then (car (push (html5-stream-char stream)

                                                             stack))

                      for next-node = (assoc char node)

                      while next-node

                      do (when (second next-node)

                           (setf entity (second next-node))

                           (setf match-at (length stack)))

                      do (setf node (cddr next-node)))

                (let ((next-char))

                  ;; Unconsume those characters that are not part of the match

                  ;; This unconsumes everything if there where no match

                  (loop until (= (length stack) match-at) do

                       (setf next-char (car stack))

                       (html5-stream-unget stream (pop stack)))

                  (cond ((not entity)

                         ;; If no match can be made, then no characters are consumed, and nothing is returned.

                         ;; Is this always a parse error really?

                         (push-token self '(:type :parse-error :data :expected-named-entity)))

                        ((and from-attribute