(in-package #:oh-ducks)

(defvar *implicit-element* nil
  "The element to be considered as an implicit element to be matched by combinators without a leading qualifier.  E.g., \"> a\" will match <a> tags directly under *implicit-element*, and \"+ a\" will match <a> tags directly following *implicit-element*.")

#.(set-dispatch-macro-character #\# #\T 'unify::|sharp-T-reader|)

(defclass selector (unify::string-template)
  ((matcher :reader matcher :initarg :matcher)))

(defgeneric selector-p (object)
  (:method ((ob selector)) t)
  (:method ((ob t)) nil))

(defclass simple-selector (selector)
  ((arg :reader selector-arg :initarg :arg)))

(defmethod print-object ((selector simple-selector) stream)
  (format stream "#<selector ~s>" (selector-arg selector)))

(defclass combinator (selector) ())

(defgeneric combinator-p (object)
  (:method ((ob combinator)) t)
  (:method ((ob t)) nil))

(defmethod print-object ((selector combinator) stream)
  (format stream "#<~s ~s>" (class-name (class-of selector)) (matcher selector)))

(defclass child-combinator (combinator) ())
(defclass descendant-combinator (combinator) ())
(defclass adjacent-combinator (combinator) ())
(defclass sibling-combinator (combinator) ())

(defclass universal-selector (simple-selector) ())
(defclass type-selector  (simple-selector) ())
(defclass id-selector    (simple-selector) ())
(defclass class-selector (simple-selector) ())
(defclass nth-child-selector (simple-selector) ())
(defclass nth-last-child-selector (nth-child-selector) ())
(defclass nth-of-type-selector (nth-child-selector) ())
(defclass nth-last-of-type-selector (nth-of-type-selector) ())
(defclass empty-selector (simple-selector) ())

(defclass attribute-selector (simple-selector)
  ((val :reader attribute-value :initarg :value)))
(defclass attribute-present-selector (attribute-selector) ())
(defclass attribute-equal-selector (attribute-selector) ())
(defclass attribute-starts-with-selector (attribute-selector) ())

(defmethod initialize-instance :after ((selector nth-child-selector)
                                       &key (asign "+") a
                                            (bsign "+") b
                                            namedp)
  (setf (slot-value selector 'arg)
        (if namedp
            (cons 2 (if (string-equal "odd" b) 1 0))
            (cons (parse-integer (format nil "~a~a" asign (or a 1)))
                  (parse-integer (format nil "~a~a" bsign (or b 0)))))))

(defmethod print-object ((selector universal-selector) stream)
  (format stream "#<universal-selector>"))

(defmethod initialize-instance :after ((template combinator) &key)
  (unless (slot-boundp template 'matcher)
    (let ((selector (template-spec template)))
      (setf (slot-value template 'matcher) (parse-selector (string-trim " " selector))))))

(defclass %implicit-element-selector (selector) ())
(defparameter %implicit-element-selector (make-instance '%implicit-element-selector))

(defmethod print-object ((selector %implicit-element-selector) stream)
  (print-unreadable-object (selector stream :type t)))

(cl-ppcre:define-parse-tree-synonym \s*
  (:non-greedy-repetition 0 nil :whitespace-char-class))
(cl-ppcre:define-parse-tree-synonym \s+
  (:greedy-repetition 1 nil :whitespace-char-class))
(cl-ppcre:define-parse-tree-synonym sign
  (:char-class #\+ #\-))
(cl-ppcre:define-parse-tree-synonym sign?
  (:greedy-repetition 0 1 sign))
(cl-ppcre:define-parse-tree-synonym integer
  (:greedy-repetition 1 nil :digit-class))
(cl-ppcre:define-parse-tree-synonym name
  (:greedy-repetition 1 nil (:char-class :word-char-class #\-)))
(cl-ppcre:define-parse-tree-synonym $name
  (:register name))
(cl-ppcre:define-parse-tree-synonym an+b
  (:sequence
   (:register sign?) (:greedy-repetition 0 1 (:register integer))
   #\n \s*
   (:register sign?) \s* (:greedy-repetition 0 1 (:register integer))))
(cl-ppcre:define-parse-tree-synonym b
  (:register (:sequence sign? integer)))
(cl-ppcre:define-parse-tree-synonym odd/even
  (:register (:alternation "odd" "even")))

;; FIXME: proper parsing (e.g., by using the W3C's provided FLEX and YACC bits).
(defun parse-selector (selector)
  (match-case (selector)
    ;; combinators
    (#T(regexp$ (\s* #\~ \s*) ())
     (list (make-instance 'sibling-combinator    :matcher (or (parse-selector &rest) %implicit-element-selector))))
    (#T(regexp$ (\s* #\+ \s*) ())
     (list (make-instance 'adjacent-combinator   :matcher (or (parse-selector &rest) %implicit-element-selector))))
    (#T(regexp$ (\s* #\> \s*) ())
     (list (make-instance 'child-combinator      :matcher (or (parse-selector &rest) %implicit-element-selector))))
    (#T(regexp$ (\s+)         ())
     (list (make-instance 'descendant-combinator :matcher (or (parse-selector &rest) %implicit-element-selector))))
    ;; simple selectors
    ;; attribute selectors
    (#T(regexp$ ("[" $name "]") (?attribute))
     (cons (make-instance 'attribute-present-selector :arg attribute)
           (parse-selector &rest)))
    (#T(regexp$ ("[" $name "=" $name "]") (?attribute ?value))
     (cons (make-instance 'attribute-equal-selector :arg attribute :value value)
           (parse-selector &rest)))
    (#T(regexp$ ("[" $name "^=" $name "]") (?attribute ?value))
     (cons (make-instance 'attribute-starts-with-selector :arg attribute :value value)
           (parse-selector &rest)))
    ;; cyclic (An+B, n+B)
    (#T(regexp$ (":nth-child(" \s* an+b \s* ")")
                (?asign ?a ?bsign ?b))
     (cons (make-instance 'nth-child-selector
                          :asign asign :a a
                          :bsign bsign :b b)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-last-child(" \s* an+b \s* ")")
                (?asign ?a ?bsign ?b))
     (cons (make-instance 'nth-last-child-selector
                          :asign asign :a a
                          :bsign bsign :b b)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-of-type(" \s* an+b \s* ")")
                (?asign ?a ?bsign ?b))
     (cons (make-instance 'nth-of-type-selector
                          :asign asign :a a
                          :bsign bsign :b b)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-last-of-type(" \s* an+b \s* ")")
                (?asign ?a ?bsign ?b))
     (cons (make-instance 'nth-last-of-type-selector
                          :asign asign :a a
                          :bsign bsign :b b)
           (parse-selector &rest)))
    ;; absolute (B)
    (#T(regexp$ (":nth-child(" \s* b \s* ")")
                (?b))
     (cons (make-instance 'nth-child-selector :a 0 :b b)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-last-child(" \s* b \s* ")")
                (?b))
     (cons (make-instance 'nth-last-child-selector :a 0 :b b)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-of-type(" \s* b \s* ")")
                (?b))
     (cons (make-instance 'nth-of-type-selector :a 0 :b b)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-last-of-type(" \s* b \s* ")")
                (?b))
     (cons (make-instance 'nth-last-of-type-selector :a 0 :b b)
           (parse-selector &rest)))
    ;; named (odd, even)
    (#T(regexp$ (":nth-child(" \s* odd/even \s* ")")
                (?which))
     (cons (make-instance 'nth-child-selector :namedp t :b which)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-last-child(" \s* odd/even \s* ")")
                (?which))
     (cons (make-instance 'nth-last-child-selector :namedp t :b which)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-of-type(" \s* odd/even \s* ")")
                (?which))
     (cons (make-instance 'nth-of-type-selector :namedp t :b which)
           (parse-selector &rest)))
    (#T(regexp$ (":nth-last-of-type(" \s* odd/even \s* ")")
                (?which))
     (cons (make-instance 'nth-last-of-type-selector :namedp t :b which)
           (parse-selector &rest)))
    ;; Everybody else
    (#T(regexp$ (":first-child") ())
     (cons (make-instance 'nth-child-selector :a 0 :b 1)
           (parse-selector &rest)))
    (#T(regexp$ (":last-child")  ())
     (cons (make-instance 'nth-last-child-selector :a 0 :b 1)
           (parse-selector &rest)))
    (#T(regexp$ (":only-child")  ())
      (list* (make-instance 'nth-child-selector      :a 0 :b 1)
             (make-instance 'nth-last-child-selector :a 0 :b 1)
             (parse-selector &rest)))
    (#T(regexp$ (":first-of-type") ())
     (cons (make-instance 'nth-of-type-selector :a 0 :b 1)
           (parse-selector &rest)))
    (#T(regexp$ (":last-of-type")  ())
     (cons (make-instance 'nth-last-of-type-selector :a 0 :b 1)
           (parse-selector &rest)))
    (#T(regexp$ (":only-of-type")  ())
      (list* (make-instance 'nth-of-type-selector      :a 0 :b 1)
             (make-instance 'nth-last-of-type-selector :a 0 :b 1)
             (parse-selector &rest)))
    (#T(regexp$ (":empty")       ())
      (cons (make-instance 'empty-selector)           (parse-selector &rest)))
    (#T(regexp$ (#\# $name)      (?id))
     (cons (make-instance 'id-selector :arg id)       (parse-selector &rest)))
    (#T(regexp$ (#\. $name)      (?class))
     (cons (make-instance 'class-selector :arg class) (parse-selector &rest)))
    (#T(regexp$ ($name)          (?type))
     (cons (make-instance 'type-selector :arg type)   (parse-selector &rest)))
    (#T(regexp$ (#\*)            ())
     (cons (make-instance 'universal-selector)        (parse-selector &rest)))
    (t (unless (string= selector "")
         (error "Unable to to parse selector: ~s" selector)))))

(defun subjects-in-list (selector element-list)
  (reduce #'nconc
          (mapcar (curry #'subjects-of selector)
                  element-list)))

(defun subjects-of (selector element)
  (nconc
   (when (subject-p selector element) (list element))
   (subjects-in-list selector (element-children element))))

(defgeneric subject-p (selector element))

(defmethod subject-p ((selector type-selector) element)
  (element-type-equal element (selector-arg selector)))

(defmethod subject-p ((selector id-selector) element)
  (string= (element-id element) (selector-arg selector)))

(defun an+b? (a b element siblings)
  (when-let* ((pos (1+ (position element siblings :test #'eq))))
    ;; pos = An + B
    (cond
      ;; pos = 0n + B
      ((= 0 a) (= b pos))
      ;; (pos - B)/A = n
      (t (and (zerop (mod (- pos b) a))
              (not (minusp (/ (- pos b) a))))))))

(defmethod subject-p ((selector nth-child-selector) element)
  (when-let* ((arg (selector-arg selector))
              (parent (element-parent element)))
    (an+b? (car arg) (cdr arg) element (element-children parent))))

(defmethod subject-p ((selector nth-last-child-selector) element)
  (when-let* ((arg (selector-arg selector))
              (parent (element-parent element)))
    (an+b? (car arg) (cdr arg) element (reverse (element-children parent)))))

(defmethod subject-p ((selector nth-of-type-selector) element)
  (when-let* ((arg (selector-arg selector))
              (parent (element-parent element)))
    (an+b? (car arg) (cdr arg) element
           (remove-if-not (rcurry #'element-type-equal (element-type element))
                          (element-children parent)))))

(defmethod subject-p ((selector nth-last-of-type-selector) element)
  (when-let* ((arg (selector-arg selector))
              (parent (element-parent element)))
    (an+b? (car arg) (cdr arg) element
           (reverse
            (remove-if-not (rcurry #'element-type-equal (element-type element))
                           (element-children parent))))))

(defmethod subject-p ((selector empty-selector) element)
  (= 0 (length (element-children element))))

(defmethod subject-p ((selector class-selector) element)
  (member (selector-arg selector)
          (element-classes element)
          :test #'string=))

(defmethod subject-p ((selector universal-selector) element)
  (declare (ignore element selector))
  t)

(defmethod subject-p ((selector attribute-present-selector) element)
  (element-attribute (selector-arg selector) element))

(defmethod subject-p ((selector attribute-equal-selector) element)
  (when-let* ((val (element-attribute (selector-arg selector) element)))
    (string= val (attribute-value selector))))

(defmethod subject-p ((selector attribute-starts-with-selector) element)
  (when-let* ((val (element-attribute (selector-arg selector) element)))
    (alexandria:starts-with-subseq (string-downcase (attribute-value selector)) (string-downcase val))))

(defmethod subject-p ((selector %implicit-element-selector) element)
  (eq element *implicit-element*))

(defmethod subject-p ((selector list) element)
  (every (rcurry #'subject-p element) selector))

(defmethod subject-p ((selector child-combinator) element)
  (subject-p (matcher selector) (element-parent element)))

(defmethod subject-p ((selector descendant-combinator) element)
  (some (curry #'subject-p (matcher selector)) (element-ancestors element)))

(defmethod subject-p ((selector adjacent-combinator) element)
  (let* ((parent (element-parent element))
         (siblings (element-children parent))
         (ourpos (position element siblings :test #'eq)))
    (and ourpos
         (> ourpos 0)
         (subject-p (matcher selector) (elt siblings (1- ourpos))))))

(defmethod subject-p ((selector sibling-combinator) element)
  (let* ((parent (element-parent element))
         (siblings (element-children parent))
         (ourpos (position element siblings :test #'eq)))
    (and ourpos
         (> ourpos 0)
         (find-if (curry #'subject-p (matcher selector)) siblings :end ourpos))))

;; Hello excessively long name
(defun terminating-implicit-sibling-combinator-p (selector)
  (typecase selector
    ((or sibling-combinator adjacent-combinator)
     (typecase (matcher selector)
       (%implicit-element-selector t)
       (list (terminating-implicit-sibling-combinator-p (car (last (matcher selector)))))))
    (combinator (terminating-implicit-sibling-combinator-p (matcher selector)))
    (selector   nil)
    (null       nil)
    (list       (terminating-implicit-sibling-combinator-p (car (last selector))))
    (t          nil)))