(require 'xml)

;;; patches.

(defun pprint (object &optional stream)
  (pp object stream))

(defadvice xml-parse-region (around xml-parse-region/dtd-patch last
                                    (beg end &optional buffer parse-dtd parse-ns)
                                    activate)
  "DTD are file-level, so we move elements out of the dtd sexp."
  (if (or xml-validating-parser parse-dtd)
      (let ((sexp ad-do-it))
        (if (and (listp sexp)
                 (consp (car sexp))
                 (listp (caar sexp))
                 (eq 'dtd (caaar sexp)))
            (list* :hi
                   (caar sexp)
                   (cdar sexp)
                   (cdr sexp))
            sexp))
      ad-do-it))


;;; documents additions.

(defun* make-doc (&key dtd root)
  "dtd may be nil."
  (if dtd
      (list dtd root)
      (list root)))

(defun doc-has-dtd (doc)
  (and (listp doc)
       (listp (car doc))
       (eq 'dtd (caar doc))))

(defun doc-dtd (doc)
  (when (doc-has-dtd doc)
    (first doc)))

(defun doc-root (doc)
  (cond
    ((doc-has-dtd doc) (second doc))
    ((null (first doc)) (second doc))
    (t (first doc))))


;;; xml nodes additions.

(defun* make-xml-node (&key name attributes children)
  (list* name attributes children))

(defun xml-node-p (object)
  (and (consp object)
       (or (symbolp (car object))
           (and (consp (car object))
                (consp (cadr object))
                (null (cddr object))))
       (consp (cdr object))))


;;; attributes additions.

(defun make-xml-attribute (name value) (cons name value))
(defun xml-attribute-name  (attribute) (car attribute))
(defun xml-attribute-value (attribute) (cdr attribute))


;;; Let's clean up xml inputs.

(defun* xml-remove-blank-elements (xml-node &optional (recursively t))
  (make-xml-node :name (xml-node-name xml-node)
                 :attributes (xml-node-attributes xml-node)
                 :children (mapcan (lambda (node)
                                     (typecase node
                                       (string
                                        (if (every (lambda (ch) (find ch " \n\t\r\l\f\v")) node)
                                            '()
                                            (cons node nil)))
                                       (cons   (cons (if recursively
                                                         (xml-remove-blank-elements node recursively)
                                                         node)
                                                     nil))
                                       (t      (cons node nil))))
                                   (xml-node-children xml-node))))


;;; Conversion routines.

(defun xml-to-sexp-buffer ()
  "Convert the XML text in the buffer into a lisp S-exp."
  (interactive)
  (let* ((rdoc (xml-parse-region (point-min) (point-max) (current-buffer) t))
         (di (message "%S" rdoc))
         (pdoc (make-doc :dtd (doc-dtd rdoc)
                         :root (xml-remove-blank-elements (doc-root rdoc)))))
    (delete-region (point-min) (point-max))
    (lisp-mode)
    (pprint pdoc (current-buffer))
    (goto-char (point-min))
    (down-list)
    (when (doc-has-dtd rdoc)
      (forward-sexp 2)
      (backward-sexp 1))))




(defun* xml-insert-header (&optional (encoding 'utf-8))
  (insert (format  "<?xml version=\"1.0\" encoding=\"%s\"?>\n" (string-upcase encoding))))

(defun xml-quote-attribute-value (value)
  (with-output-to-string
      (loop
         for code across value
         for ch = (string code)
         do (princ (cond
                     ((string= ch "\"")  "\\\"")
                     ((string= ch "\\")  "\\\\")
                     (t                  ch))))))

(defun test/xml-quote-attribute-value ()
  (assert (string= "1.0" (xml-quote-attribute-value "1.0")))
  (assert (string= "There is no \\\"spoon\\\"!"
                   (xml-quote-attribute-value "There is no \"spoon\"!")))
  (assert (string= "A new line is inserted writting \\\\n in the string."
                   (xml-quote-attribute-value "A new line is inserted writting \\n in the string."))))

;; (dtd "plist"
;;      ("-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd" public)
;; <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"

(defun xml-insert-dtd (dtd)
  ;; TODO: missing processing various kinds of doctype contents elements.
  (assert (eq 'dtd (first dtd)))
  (let ((name     (second dtd))
        (contents (cddr dtd)))
    (insert (format "<!DOCTYPE %s" name))
    (let ((item (car contents)))
      (if (member (car (last item)) '(public system))
          (case (car (last item))
            ((public)
             (insert (format " PUBLIC %S %S" (first item) (second item))))
            ((system)
             (insert (format " SYSTEM %S" (first item)))))
          (progn
            (insert " [\n")
            (dolist (element contents)
              (insert (format "<!ELEMENT %s (%s)>\n"
                              (first element)
                              (if (symbolp (second element))
                                  (format "#%s" (string-upcase (second element)))
                                  (second element)))))
            (insert "]"))))
    (insert ">\n")))


(defun xml-insert-xml-node (node)
  (if (xml-node-p node)
      (let ((name       (xml-node-name       node))
            (attributes (xml-node-attributes node))
            (children   (xml-node-children   node)))
        (insert (format "<%s" name))
        (dolist (attribute attributes)
          (insert (format " %s=\"%s\""
                          (xml-attribute-name attribute)
                          (xml-quote-attribute-value (xml-attribute-value attribute)))))
        (if children
            (progn
              (insert ">")
              (mapc (function xml-insert-xml-node) children)
              (insert (format "</%s>" name)))
            (insert " />")))
      (insert (format "%s" node))))


(defun sexp-to-xml-buffer ()
  "Convert the lisp S-exp in the buffer that represents a XML tree into XML text.
The buffer should contain a single lisp list, each element representing a XML node,
being a list (name attributes . children); attributes is an a-list of (name . value);
name is a string designator or a cons cell (namespace . tag).
children is a list of strings or sexp representing a XML tree.
"
  (interactive)
  (goto-char (point-min))
  (let ((doc (read (current-buffer))))
    (delete-region (point-min) (point-max))
    (nxml-mode)
    (let ((coding-system 'utf-8))
      (set-buffer-file-coding-system coding-system)
      (xml-insert-header coding-system))
    (when (doc-has-dtd doc)
      (xml-insert-dtd (doc-dtd doc)))
    (xml-insert-xml-node (doc-root doc))
    (insert "\n")))



(provide 'pjb-xml)