(in-package :webutils.xml-mixed-mode)

(defclass translator ()
  ((functions :initarg :functions :accessor translator-functions :initform nil)))

(defmacro bind/fail-k (binding-pattern object fail-k &body body)
  (labels ((proper-list-p (thing)
             (etypecase thing
               (null t)
               (list (proper-list-p (cdr thing)))
               (symbol nil)))
           (build-match-let (whole-var binding-pattern)
             (etypecase binding-pattern
               (null nil)
               (list
                (if (null (cdr binding-pattern))
                    `((,(first binding-pattern) (car ,whole-var)))
                    (let ((new-whole (gensym)))
                      `((,(first binding-pattern) (car ,whole-var))
                        (,new-whole (cdr ,whole-var))
                        ,@(build-match-let new-whole (cdr binding-pattern))))))
               (symbol
                `((,binding-pattern ,whole-var))))))
   (let ((expected-length (if (proper-list-p binding-pattern)
                              (length binding-pattern)
                              nil))
         (object-var (gensym))
         (fail-k-var (gensym))
         (block-name (gensym)))
     `(block ,block-name
        (let ((,object-var ,object)
              (,fail-k-var ,fail-k))
          (declare (ignorable ,fail-k-var))
          ,@(when expected-length
                  `((unless (eql (length ,object-var) ,expected-length)
                      (return-from ,block-name (funcall ,fail-k-var)))))
          (let* ,(build-match-let object-var binding-pattern)
            ,@body))))))

(defmacro fail-match-when (condition)
  `(when ,condition (fail-match)))

(defmacro fail-match-unless (condition)
  `(unless ,condition (fail-match)))

(defmacro translator-function (xml-pattern &body body)
  (let ((xml-object (gensym))
        (fail-k (gensym))
        (b (gensym))
        (tag (gensym))
        (tag-body (gensym)))
    `(lambda (,xml-object ,fail-k)
       (block ,b
         (flet ((fail-match ()
                  (return-from ,b (funcall ,fail-k))))
           ,(if (xml-constructor-form-p xml-pattern)
                ;; no body matching in pattern
                `(if (typep ,xml-object 'xml-tag)
                     (destructuring-bind ,(xml-pattern-bindings xml-pattern)
                         (parse-xml-tag-from-pattern ,xml-object ',(main-xml-pattern-form xml-pattern) #'fail-match)
                       ,@body)
                     (fail-match))
                `(let ((,tag (etypecase ,xml-object
                               (xml-tag ,xml-object)
                               (xml-tag-enclosed (slot-value ,xml-object 'tag))))
                       (,tag-body (etypecase ,xml-object
                                    (xml-tag nil)
                                    (xml-tag-enclosed (slot-value ,xml-object 'object)))))
                   (destructuring-bind ,(xml-pattern-bindings (car xml-pattern))
                       (parse-xml-tag-from-pattern ,tag ',(main-xml-pattern-form (car xml-pattern)) #'fail-match)
                     (bind/fail-k ,(cdr xml-pattern) ,tag-body #'fail-match
                       ,@body)))))))))

(defmacro define-translator (translator-object name xml-pattern &body body)
  `(setf (cdr (or (assoc ',name (translator-functions ,translator-object))
                  (car (push (cons ',name nil) (translator-functions ,translator-object)))))
         (translator-function ,xml-pattern
           ,@body)))

(defmacro extend-translator (translator (xml-pattern &body translator-body) &body body)
  `(let ((,translator
          (make-instance 'translator :functions
                         (cons (cons (gensym) (translator-function ,xml-pattern ,@translator-body))
                               (translator-functions ,translator)))))
     ,@body))

(defmacro extend-translator* (translator patterns &body body)
  (if (null patterns)
      `(progn ,@body)
      (labels ((extend (patterns)
                 (if patterns
                     `(extend-translator ,translator ,(first patterns)
                        ,(extend (cdr patterns)))
                     `(progn ,@body))))
        (extend (reverse patterns)))))

(defun make-translator () (make-instance 'translator))

(defun apply-translator (translator xml-object)
  (labels ((apply-translator-to-body ()
             (if (typep xml-object 'xml-tag-enclosed)
                 (make-xml-tag-enclosed
                  (slot-value xml-object 'tag)
                  (loop for thing in (slot-value xml-object 'object)
                     collect (apply-translator translator thing)))
                 xml-object))
           (apply-translator-functions (functions)
             (if (null functions)
                 (apply-translator-to-body)
                 (let ((translated
                        (funcall (cdr (car functions)) xml-object
                                 (lambda ()
                                   (return-from apply-translator-functions
                                     (apply-translator-functions (cdr functions)))))))
                   (return-from apply-translator (apply-translator translator translated))))))
    (typecase xml-object
      ((or xml-tag xml-tag-enclosed)
       (apply-translator-functions (translator-functions translator)))
      (list
       (loop for object in xml-object
            collect (apply-translator translator object)))
      (t xml-object))))