(in-package #:hypnotisml)

(defun var-p (thing)
  (and (listp thing)
       (= 1 (length thing))
       (symbolp (car thing))))

(defun make-queue (&rest xs)
  (let ((q (cons nil nil)))
    (when xs (enqueue* q xs))
    q))

(defun enqueue (q e)
  (push e (cdr q)))

(defun enqueue* (q es)
  (dolist (e es) (enqueue q e)))

(defun prequeue (q e)
  (push e (car q)))

(defun prequeue* (q es)
  (dolist (e (reverse es))
    (prequeue q e)))

(defun dequeue (q)
  (when (endp (car q))
    (setf (car q) (nreverse (cdr q))
          (cdr q) nil))
  (pop (car q)))

(defun empty-queue (q)
  (not (or (car q) (cdr q))))

(defun ensure-parent (parent nodes)
  (loop :for node :in nodes :do (setf (parent node) parent)))

(defun expand-walk (top node clauses)
  (a:with-gensyms (new-children frontier top-var parent)
    (multiple-value-bind
          (unconditional-exprs conditional-exprs remove-check-exprs)
        (loop
          :with unconditional-exprs := nil
          :with conditional-exprs := nil
          :with remove-check-exprs := nil
          :for (clause-start . clause-body) :in clauses
          :do (case clause-start
                (:do (push (first clause-body) unconditional-exprs))
                (:if (destructuring-bind (guard phrase) clause-body
                       (if (eq :remove phrase)
                           (push guard remove-check-exprs)
                           (destructuring-bind (phrase-head phrase-body) phrase
                             (ecase phrase-head
                               (:replace
                                (push `(,guard
                                        (let ((,node ,phrase-body))
                                          (setf (parent ,node) ,parent)
                                          (push ,node ,new-children)))
                                      conditional-exprs))
                               (:splice
                                (push `(,guard
                                        (let ((,node ,phrase-body))
                                          (ensure-parent ,parent ,node)
                                          (setf ,new-children
                                                (nconc (reverse ,node) ,new-children))))
                                      conditional-exprs))))))))
          :finally (return (values (nreverse unconditional-exprs)
                                   (nreverse conditional-exprs)
                                   (nreverse remove-check-exprs))))
      `(let ((,top-var ,top))
         (loop
           :with ,frontier := (make-queue ,top-var)
           :until (empty-queue ,frontier)
           :for ,parent := (dequeue ,frontier)
           :for ,new-children := (loop
                                   :with ,new-children := nil
                                   :for ,node :in (children ,parent)
                                   ,@(when unconditional-exprs
                                       (cons :do unconditional-exprs))
                                   :unless (or ,@remove-check-exprs)
                                     :do (cond
                                           ,@conditional-exprs
                                           (t (push ,node ,new-children)))
                                   :finally (return  (nreverse ,new-children)))
           :do (setf (children ,parent) ,new-children)
               (enqueue* ,frontier (remove-if-not #'elemp ,new-children)))
         ,top-var))))

(argot:deflanguage dom-transform ()
  (<walk>
   :match (:seq (:@ top (:item))
                (:@ var <var-declare>)
                (:@ clauses (:+ <clause>)) (:eof))
   :then (expand-walk top var clauses))
  (<var-declare>
   :match (:item)
   :if var-p
   :then #'car
   :note "Variable declaration (node)")
  (<clause>
   :match (:or <if-clause> <unconditional-clause>))
  (<unconditional-clause>
   :match (:seq (:= :do) (:item)))
  (<if-clause>
   :match (:seq (:= :if) (:item) <action-phrase>))
  (<action-phrase>
   :match (:or <remove-phrase> <replace-phrase> <splice-phrase>))
  (<remove-phrase>
   :match (:= :remove)
   :note "Removes the node from the tree, including all its children.")
  (<replace-phrase>
   :match (:seq (:= :replace) (:item))
   :note "Expression should return a DOM-NODE")
  (<splice-phrase>
   :match (:seq (:= :splice) (:item))
   :note "Expression should return a list of DOM-NODEs. These will be inserted
in place of the current node, and WALK will visit the first of these
nodes next."))