;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause

(nyxt:define-package :nyxt/dom
    (:documentation "Nyxt-specific DOM classes and functions operating on them.

The classes are generated for every HTML element, including `h1-element',
`div-element', `img-element' and others.

Classes corresponding to non-HTML elements, such as `text-element',
`semantic-element', or `h-element', act as higher hierarchical entities of
element classes.  For instance, every `h<n>-element' inherits from `h-element'.

The most useful functions are:
- `named-html-parse' and `named-json-parse' to turn HTML and JSON documents into
  a representation of type `plump:root', converting elements into its matching
  classes.
- `copy' to produce a full recursive copy of a DOM.
- `parents', `url' and `body' to access element-specific features in a unified
  fashion.
- `click-element', `focus-select-element', `select-option-element' and others to
  interact with the page using `nyxt/dom' elements as representations of the
  actual DOM elements."))
(in-package :nyxt/dom)

;; TODO: Factor out into a library?

(defvar *nyxt-dom-classes* (make-hash-table :test #'equalp)
  "A table associating the HTML tag name (e.g., \"a\") with the corresponding
  nyxt/dom class.")

(defmacro define-element-classes (&body names)
  (loop for name in names
        collect (let* ((class-name (alex:ensure-car name))
                       (tag (str:replace-all "-element"  "" (str:downcase (symbol-name class-name))))
                       (additional-superclasses (when (listp name) (rest name))))
                  `(progn
                     (define-class ,class-name (,@(if additional-superclasses
                                                      additional-superclasses
                                                      '(plump:element)))
                       ()
                       (:export-class-name-p t)
                       (:export-accessor-names-p t)
                       (:export-predicate-name-p t)
                       (:documentation ,(format nil "An autogenerated class for <~a> HTML tag." tag)))
                     (setf (gethash ,tag *nyxt-dom-classes*)
                           (quote ,class-name))))
          into classes
        finally (return `(progn ,@classes))))


(define-element-classes
  ;; All HTML5 tags, including experimental ones. Scraped with:
  ;;
  ;; (format t "~{~a-element~^ ~}"
  ;;         (map 'list (lambda (item)
  ;;                        (slot-value (elt (slot-value item 'plump-dom::%children) 0)
  ;;                                    'plump-dom::%text))
  ;;              (clss:select ".item-name" (plump:parse (dex:get "https://htmlreference.io/")))))
  ;; Pseudo-tags:
  text-element (h-element text-element) list-element structure-element semantic-element
  (checkbox-element input-element) (radio-element input-element) (file-chooser-element input-element)
  ;; HTML5 elements:
  (a-element text-element) abbr-element address-element area-element
  (article-element semantic-element) (aside-element semantic-element)
  audio-element (b-element text-element) base-element bdi-element bdo-element
  blockquote-element body-element br-element button-element canvas-element
  caption-element (cite-element text-element) (code-element text-element) col-element
  colgroup-element data-element datalist-element (dd-element list-element)
  (del-element text-element) details-element dfn-element div-element (dl-element list-element)
  (dt-element list-element) em-element embed-element fieldset-element
  (figcaption-element semantic-element) figure-element (footer-element semantic-element)
  form-element (h1-element h-element) (h2-element h-element) (h3-element h-element)
  (h4-element h-element) (h5-element h-element) (h6-element h-element) head-element
  (header-element semantic-element) hr-element html-element (i-element text-element) iframe-element
  img-element input-element ins-element kbd-element label-element legend-element
  (li-element list-element) link-element (main-element semantic-element) map-element
  (mark-element semantic-element) meta-element meter-element (nav-element semantic-element)
  (noscript-element plump:fulltext-element) object-element (ol-element list-element) optgroup-element
  (option-element text-element) output-element (p-element text-element) param-element
  (pre-element text-element) progress-element q-element rp-element rt-element rtc-element
  ruby-element samp-element (script-element plump:fulltext-element)
  (section-element semantic-element) select-element small-element source-element
  (span-element text-element) (strong-element text-element) (style-element plump:fulltext-element)
  (sub-element text-element) summary-element (sup-element text-element) table-element
  tbody-element td-element textarea-element tfoot-element th-element thead-element
  (time-element semantic-element) title-element tr-element track-element (ul-element list-element)
  var-element video-element
  ;; obsolete elements (from https://www.w3.org/TR/2010/WD-html5-20100304/obsolete.html):
  applet-element acronym-element bgsound-element dir-element frame-element frameset-element
  noframes-element isindex-element (listing-element text-element) (xmp-element text-element)
  nextid-element noembed-element (plaintext-element text-element) (rb-element ruby-element)
  (basefont-element text-element) (big-element text-element) (blink-element text-element)
  (center-element text-element) (font-element text-element) (marquee-element text-element)
  (multicol-element text-element) (nobr-element text-element) (s-element text-element)
  (spacer-element text-element) (strike-element text-element) (tt-element text-element)
  (u-element text-element)
  ;; Experimental elements:
  dialog-element hgroup-element picture-element slot-element template-element
  (wbr-element text-element))

(defmethod name-dom-elements ((node plump:node))
  (when-let* ((tag-p (plump:element-p node))
              (class (gethash (plump:tag-name node) *nyxt-dom-classes*)))
    (change-class node class))
  (when (plump:nesting-node-p node)
    (loop for child across (plump:children node)
          do (name-dom-elements child)))
  node)

(export-always 'named-html-parse)
(-> named-parse (string) (values (or plump-dom:root null) &optional))
(defun named-html-parse (input)
  "Assign tag classes (e.g., `input-element') to the nodes in the `plump:parse'-d input."
  (name-dom-elements (plump:parse input)))

(define-parenscript get-document-body-json ()
  (defun process-element (element)
    (let ((object (ps:create :name (ps:@ element node-name)))
          (attributes (ps:chain element attributes)))
      (unless (or (ps:undefined attributes)
                  (= 0 (ps:@ attributes length)))
        (setf (ps:@ object :attributes) (ps:create))
        (loop for i from 0 below (ps:@ attributes length)
              do (setf (ps:@ object :attributes (ps:chain attributes (item i) name))
                       (ps:chain attributes (item i) value))))
      (unless (or (ps:undefined (ps:chain element child-nodes))
                  (= 0 (ps:chain element child-nodes length)))
        (setf (ps:chain object :children)
              (loop for child in (ps:chain element child-nodes)
                    collect (process-element child))))
      (when (and (ps:@ element shadow-root)
                 (ps:@ element shadow-root first-child))
        (setf (ps:chain object :children)
              (loop for child in (ps:chain *array
                                           (from (ps:@ element shadow-root children))
                                           (concat (ps:chain *array (from (ps:@ element children)))))
                    collect (process-element child))))
      (when (or (equal (ps:@ element node-name) "#text")
                (equal (ps:@ element node-name) "#comment")
                (equal (ps:@ element node-name) "#cdata-section"))
        (setf (ps:@ object :text) (ps:@ element text-content)))
      object))
  (ps:chain -j-s-o-n (stringify (process-element (nyxt/ps:qs document "html")))))

(export-always 'named-json-parse)
(-> named-json-parse (string) (values (or plump-dom:root null) &optional))
(defun named-json-parse (json)
  "Return a `plump:root' of a DOM-tree produced from the JSON.

JSON should have the format like what `get-document-body-json' produces:
- A nested hierarchy of objects (with only one root object), where
  - Every object has a 'name' (usually a tag name or '#text'/'#comment').
  - Some objects can have 'attributes' (a string->string dictionary).
  - Some objects have a subarray ('children') of objects working by these three
    rules."
  (labels ((json-to-plump (json parent)
             (let ((element
                     (cond
                       ((string-equal (j:get "name" json) "#text")
                        (plump:make-text-node parent (j:get "text" json)))
                       ((string-equal (j:get "name" json) "#cdata-section")
                        (plump:make-cdata parent :text (j:get "text" json)))
                       ((string-equal (j:get "name" json) "#comment")
                        (plump:make-comment parent (j:get "text" json)))
                       (t (plump:make-element parent (str:downcase
                                                      (j:get "name" json)))))))
               (when (typep element 'plump:nesting-node)
                 (setf (plump:children element)
                       (plump:ensure-child-array
                        (map 'vector (rcurry #'json-to-plump element)
                             (let ((children (j:get "children" json)))
                               (if (stringp children)
                                   (j:decode children)
                                   children))))))
               (when (typep element 'plump:element)
                 (setf (plump:attributes element)
                       (sera:lret ((map (plump:make-attribute-map)))
                         (when (j:get "attributes" json)
                           (maphash (lambda (key val)
                                      (setf (gethash key map) val))
                                    (j:get "attributes" json))))))
               element)))
    (let ((json (j:decode json))
          (root (plump:make-root)))
      (json-to-plump json root)
      (name-dom-elements root))))

(export-always 'copy)
(defgeneric copy (node &optional parent)
  (:method ((element plump:root) &optional parent)
    (declare (ignore parent))
    (serapeum:lret ((copy (plump:make-root)))
      (map nil (lambda (c) (plump:append-child copy (copy c copy))) (plump:children element))))
  (:method ((element plump:element) &optional parent)
    (serapeum:lret ((copy (make-instance
                           'plump:element
                           :parent parent
                           :attributes (alex:copy-hash-table (plump:attributes element))
                           :tag-name (plump:tag-name element))))
      (map nil (lambda (c) (plump:append-child copy (copy c copy))) (plump:children element))))
  (:method ((element plump:text-node) &optional parent)
    (make-instance 'plump:text-node
                   :parent parent
                   :text (plump:text element)))
  (:method ((element plump:comment) &optional parent)
    (make-instance 'plump:comment
                   :parent parent
                   :text (plump:text element)))
  (:method ((element plump:doctype) &optional parent)
    (make-instance 'plump:doctype
                   :parent parent
                   :doctype (plump:doctype element)))
  (:method ((element plump:xml-header) &optional parent)
    (make-instance 'plump:xml-header
                   :parent parent
                   :attributes (alex:copy-hash-table (plump:attributes element))))
  (:method ((element plump:cdata) &optional parent)
    (make-instance 'plump:cdata
                   :parent parent
                   :text (plump:text element)))
  (:method ((element plump:processing-instruction) &optional parent)
    (make-instance 'plump:processing-instruction
                   :parent parent
                   :text (plump:text element)
                   :tag-name (plump:tag-name element)))
  (:documentation "Produce a full copy of NODE as belonging to the PARENT node.
Full copy means recursively descending to the children of the NODE too."))

(export-always 'parents)
(defgeneric parents (node)
  (:method ((node plump:node)) nil)
  (:method ((node plump:child-node))
    (let ((parent (plump:parent node)))
      (cons parent (parents parent))))
  (:documentation "Get the recursive parents of the NODE.
The closest parent goes first, the furthest one goes last."))

(defmethod url :around ((element plump:element))
  (when-let* ((result (call-next-method))
              (url (url result)))
    (if (valid-url-p url)
        url
        (quri:merge-uris url (url (current-buffer))))))

(defmethod url ((element plump:element))
  (when (plump:has-attribute element "href")
    (quri:uri (plump:get-attribute element "href"))))

(defmethod url ((img img-element))
  (when (plump:has-attribute img "src")
    (quri:uri (plump:get-attribute img "src"))))

;; REVIEW: Export to :nyxt? We are forced to use it with nyxt/dom: prefix.
(export-always 'body)
(defgeneric body (element)
  (:method ((element plump:element))
    (when (plump:children element)
      (plump:text element)))
  (:method :around (element)
    (declare (ignorable element))
    (let ((result (call-next-method)))
      (when result
        (sera:collapse-whitespace (sera:trim-whitespace result)))))
  (:documentation "Return the textual contents of the ELEMENT and its recursive children."))

(defun label-of (element)
  (let ((label-for (and (plump:has-attribute element "name")
                        (ignore-errors
                         (elt (clss:select (format nil "label[for=\"~a\"]"
                                                   (plump:attribute element "name"))
                                (alex:lastcar (parents element)))
                              0)))))
    (cond
      ((label-element-p (plump:parent element)) (body (plump:parent element)))
      (label-for (body label-for))
      (t nil))))

(defun fallback-body (element)
  (when-let ((body (or (plump:get-attribute element "value")
                       (plump:get-attribute element "placeholder"))))
    body))

(defmethod body ((input input-element))
  (or (label-of input) (fallback-body input)))

(defmethod body ((textarea textarea-element))
  (or (label-of textarea) (fallback-body textarea)))

(defmethod body ((details details-element))
  (let ((summary (clss:select "summary" details)))
    (unless (uiop:emptyp summary)
      (plump:text (elt summary 0)))))

(defmethod body ((select select-element))
  (or (label-of select)
      (str:join ", " (map 'list #'plump:text
                          (clss:select "option" select)))))

(defmethod body ((img img-element))
  (when (plump:has-attribute img "alt")
    (plump:attribute img "alt")))

(export-always 'get-nyxt-id)
(defmethod get-nyxt-id ((element plump:element))
  "Get the nyxt-identifier of the page element matching ELEMENT."
  (plump:attribute element "nyxt-identifier"))

(export-always 'click-element)
(define-parenscript click-element (element)
  "Click the ELEMENT (Lisp object) on the page with JS."
  (ps:chain (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element))) (click)))

(export-always 'focus-select-element)
(define-parenscript focus-select-element (element)
  "Focus the element matching ELEMENT on the page."
  (let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element)))))
    (unless (nyxt/ps:element-in-view-port-p element)
      (ps:chain element (scroll-into-view)))
    (ps:chain element (focus))
    (when (functionp (ps:chain element select))
      (ps:chain element (select)))))

(export-always 'check-element)
(define-parenscript check-element (element &key (value t))
  "Toggle (to VALUE) the checkbox/radio button matching ELEMENT on the page."
  (let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element)))))
    (unless (nyxt/ps:element-in-view-port-p element)
      (ps:chain element (scroll-into-view)))
    (ps:chain element (set-attribute "checked" (ps:lisp value)))))

(export-always 'toggle-details-element)
(define-parenscript toggle-details-element (element)
  "Open/close the <details> element matching ELEMENT on the page."
  (ps:let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element)))))
    (unless (nyxt/ps:element-in-view-port-p element)
      (ps:chain element (scroll-into-view)))
    (if (ps:chain element (get-attribute "open"))
        (ps:chain element (remove-attribute "open"))
        (ps:chain element (set-attribute "open" t)))))

(export-always 'select-option-element)
(define-parenscript select-option-element (element parent)
  "Select one of the <option> elements (ELEMENT) in PARENT <select>."
  (ps:let* ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element))))
            (parent-select (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id parent)))))
    (unless (nyxt/ps:element-in-view-port-p element)
      (ps:chain element (scroll-into-view)))
    (if (ps:chain element (get-attribute "multiple"))
        (ps:chain element (set-attribute "selected" t))
        (setf (ps:@ parent-select value) (ps:@ element value)))))

(export-always 'scroll-to-element)
(define-parenscript scroll-to-element (element)
  "Scroll the element matching ELEMENT on the page into view."
  (ps:chain (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element)))
            (scroll-into-view)))

(export-always 'set-caret-on-start)
(define-parenscript set-caret-on-start (element)
  "Set the cursor at the start of input element matching ELEMENT."
  (let ((el (nyxt/ps:qs-nyxt-id document (ps:lisp (get-nyxt-id element))))
        (range (ps:chain document (create-range)))
        (sel (ps:chain #:window (get-selection))))
    (ps:chain #:window (focus))
    (ps:chain range (set-start (ps:@ el child-nodes 0) 0))
    (ps:chain range (collapse true))
    (ps:chain sel (remove-all-ranges))
    (ps:chain sel (add-range range))))
