(in-package :xmlisp2)

(defun lisp->xml-case (name)
  (ecase (readtable-case *readtable*)
    (:upcase (string-downcase name))
    (t name)))


(defun package->xmlns (package)
  (or (car (find package *xmlns-to-package* :key #'cdr :test #'eql))
      (package-name package)))

(defun symbol-uri (symbol)
  (package->xmlns (symbol-package symbol)))

(defun symbol-local-name (symbol)
  (lisp->xml-case (symbol-name symbol)))

(defun symbol-qualified-name (symbol)
  (format nil "~A:~A"
	  (lisp->xml-case (package-name (symbol-package symbol)))
	  (lisp->xml-case (symbol-name symbol))))

(defun package->xmlns-attribute (package)
  (sax:make-attribute
   :namespace-uri "http://www.w3.org/2000/xmlns/"
   :local-name (lisp->xml-case (package-name package))
   :qname (format nil "xmlns:~A" (lisp->xml-case (package-name package)))
   :value (package->xmlns package)
   :specified-p t))

(defvar *current-namespaces* nil)

(defmethod serialize-xml-object ((object xml-serializer) sink)
  #+nil(break "~A ~A" object sink)
  (let* ((class-name (class-name (class-of object)))
	 (class-name-package (symbol-package class-name))
	 (xmlns (package->xmlns class-name-package))
	 (xmlns-attributes
	  (remove-duplicates
	   (remove-if
	    (lambda (ns)
	      (some (lambda (namespaces)
		      (member ns
			      namespaces
			      :test (lambda (i1 i2)
				      (string=
				       (sax:attribute-value i1)
				       (sax:attribute-value i2)))))
		    *current-namespaces*))
	    (cons (package->xmlns-attribute class-name-package)
		  (mapcar #'package->xmlns-attribute
			  (remove-duplicates
			   (mapcar (compose
				    #'symbol-package
				    #'c2mop:slot-definition-name)
				   (c2mop:class-slots
				    (class-of object)))))))
	   :test (lambda (i1 i2) (string=
			     (sax:attribute-value i1)
			     (sax:attribute-value i2))))))
    (let ((*current-namespaces* (cons xmlns-attributes *current-namespaces*)))
      #+nil(break "~A ~A ~A" class-name class-name-package xmlns)
      (sax:start-element sink xmlns (symbol-local-name class-name)
			 (symbol-qualified-name class-name)
			 (nconc
			  (mapcan (lambda (slot)
				    (let ((name (c2mop:slot-definition-name slot))
					  (type (c2mop:slot-definition-type slot)))
				      (when (and (serialize-slot-p object name)
						 (serialize-as-attribute-p object
									   name
									   type))
					(list (sax:make-attribute
					       :namespace-uri (symbol-uri name)
					       :local-name (symbol-local-name name)
					       :qname (symbol-qualified-name name)
					       :value (lisp->xml-value
						       (slot-value object name)
						       (find-cxml-type type))
					       :specified-p t)))))
				  (c2mop:class-slots (class-of object)))
			  xmlns-attributes))
      (mapc (lambda (slot-def)
	      (serialize-xml-object
	       (slot-value object
			   (c2mop:slot-definition-name slot-def))
	       sink))
	    (remove-if-not (lambda (slot)
			     (let ((name (c2mop:slot-definition-name slot))
				   (type (c2mop:slot-definition-type slot)))
			       (and (serialize-slot-p object name)
				    (serialize-as-subelement-p object
							       name
							       type))))
			   (c2mop:class-slots (class-of object)))))
    (sax:end-element sink xmlns (symbol-local-name class-name)
		     (symbol-qualified-name class-name))))

(defmethod serialize-xml-object ((object sequence) sink)
  (map nil (lambda (subobject)
	     (serialize-xml-object subobject sink))
       object))