(in-package :increvi)

(defvar *document*)

(defmacro with-document (&body ops)
  `(let ((*document* (plump:make-root)))
     ,@ops
     *document*))

(defgeneric node (node-designator)
  (:method ((node-designator plump:node))
    node-designator)
  (:method ((node-designator function))
    (node (funcall node-designator *document*)))
  (:method ((node-designator symbol))
    (node (string-downcase node-designator)))
  (:method ((node-designator string))
    (let ((pos 0)
          tag id classes)
      (labels ((parse ()
                 (read-tag)
                 (when pos
                   (read-attrs)))
               (separator-p (c)
                 (member c '(#\. #\#)))
               (update-pos (new-pos)
                 (setf pos new-pos))
               (read-tag ()
                 (let ((tag-end (position-if #'separator-p
                                             node-designator
                                             :start pos)))
                   (setf tag
                         (subseq node-designator 0 tag-end))
                   (update-pos tag-end)))
               (read-attrs ()
                 (loop while (and pos (< pos (length node-designator)))
                       do (ecase (elt node-designator pos)
                            (#\.
                             (update-pos (1+ pos))
                             (read-class))
                            (#\#
                             (update-pos (1+ pos))
                             (read-id)))))
               (read-class ()
                 (let ((class-end (position-if #'separator-p
                                               node-designator
                                               :start pos)))
                   (pushnew (subseq node-designator pos class-end)
                            classes
                            :test #'equal)
                   (update-pos class-end)))
               (read-id ()
                 (let ((id-end (position-if #'separator-p
                                            node-designator
                                            :start pos)))
                   (if id
                       (cerror "suppress new id" 'error)
                       (setf id
                             (subseq node-designator pos id-end)))
                   (update-pos id-end))))
        (parse)
        (let ((attrs (plump:make-attribute-map)))
          (when id
            (setf (gethash "id" attrs) id))
          (when classes
            (setf (gethash "class" attrs)
                  (with-output-to-string (s)
                    (format s "~{~a~^ ~}"
                            (nreverse classes)))))
          (plump:make-element *document* tag
                              :attributes attrs))))))

(defun {} (text)
  (etypecase text
    (string (plump:make-text-node *document* text))
    (function (plump:make-text-node *document* (funcall text)))))

(defun + (&rest nodes)
  (mapcar 'node nodes))

(defun * (node count)
  (typecase node
    (function (loop repeat count
                    for x from 0
                    for hydrated = (node (funcall node x))
                    do (plump:remove-child hydrated)
                    collect (plump:append-child *document*
                                                hydrated)))
    (t (let ((hydrated (node node)))
         (plump:remove-child hydrated)
         (loop repeat count
               collect (plump:append-child *document*
                                           (plump:clone-node hydrated t)))))))

(defun > (parent child)
  (let ((parent (node parent)))
    (prog1 parent
      (typecase child
        ((and sequence (not string))
         (map nil
              (lambda (it)
                (> parent it))
              child))
        (t (let ((child (node child)))
             (plump:remove-child child)
             (plump:append-child parent child)))))))

(defun @ (node &rest attrs)
    (let ((hydrated (node node)))
      (prog1 hydrated
        (loop for (k v) on attrs by #'cddr
              do (plump:set-attribute hydrated
                                      (etypecase k
                                        (symbol (string-downcase k))
                                        (string k))
                                      v)))))

(defun link (rel href &rest attrs)
  (apply #'@ "link"
             :rel rel
             :href href
             attrs))