(in-package :xmlisp2.codec)

(defvar *xmlisp-type-to-cxml-type* (make-hash-table))

(defun add-xmlisp-type-mapping (xmlisp-name cxml-type-name)
  (setf (gethash xmlisp-name *xmlisp-type-to-cxml-type*)
	(make-instance cxml-type-name)))

(defun find-cxml-type (xmlisp-type-name)
  (gethash xmlisp-type-name *xmlisp-type-to-cxml-type*))

(defgeneric xml->lisp-value (xml-value xml-type))
(defgeneric lisp->xml-value (lisp-value xml-type))

(defmethod xml->lisp-value (xml-value (xml-type cxml-types:data-type))
  (cxml-types:parse xml-type xml-value))

(defmacro define-xml-type (XML-TYPE XML-SUPERS LISP-TYPE-SPEC CXML-TYPE UNPARSE)
  `(progn
     (deftype ,xml-type ()
       (quote ,(if xml-supers
		   `(and ,@xml-supers ,lisp-type-spec)
		   lisp-type-spec)))
     (eval-when (:load-toplevel)
       (add-xmlisp-type-mapping ',xml-type ',cxml-type))
     (defcodec ,xml-type ,cxml-type ,unparse)))

(defmacro defcodec (type
		    cxml-type
		    ((lisp-value-name xml-type-name &optional (lisp-type type))
		     &body unparse))
  `(progn
     (defmethod lisp->xml-value ((,lisp-value-name ,lisp-type) (,xml-type-name ,cxml-type))
       ,@unparse)))

(defmacro define-simple-xml-type ((type-name &rest supers) type-spec
				  cxml-type
				  (unparse &optional (lisp-type-name type-name)))
  (with-unique-names (lisp-value xml-type)
    `(define-xml-type ,type-name ,supers ,type-spec ,cxml-type
		      ((,lisp-value ,xml-type ,lisp-type-name)
		       (declare (ignore ,xml-type))
		       (,unparse ,lisp-value)))))

;;; Numbers

(macrolet ((define-simple-numbers (&rest definitions)
	     `(progn
		,@(mapcar (lambda (def)
			    `(define-simple-xml-type ,(first def)
				 ,(second def) ,(third def)
				 (princ-to-string ,(second def))))
			  definitions))))
  (define-simple-numbers
    ((xmlisp2.types:decimal) number cxml-types:decimal-type)
    ((xmlisp2.types:float) single-float cxml-types:float-type)
    ((xmlisp2.types:double) double-float cxml-types:double-type)))

(define-simple-xml-type (xmlisp2.types:integer xmlisp2.types:decimal)
    integer cxml-types:integer-type
  (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:non-positive-integer xmlisp2.types:integer)
    (integer * 0) cxml-types:non-positive-integer-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:negative-integer xmlisp2.types:non-positive-integer)
    (integer * -1) cxml-types:non-positive-integer-type
  (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:long xmlisp2.types:integer)
    (integer -9223372036854775808 9223372036854775807) cxml-types:long-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:int xmlisp2.types:long)
    (integer -2147483648 2147483647) cxml-types:int-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:short xmlisp2.types:int)
    (integer -32768 32767) cxml-types:short-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:byte xmlisp2.types:short)
    (integer -128 127) cxml-types:byte-type
  (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:non-negative-integer
			 xmlisp2.types:integer)
    (integer 0 *) cxml-types:non-negative-integer-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:unsigned-long xmlisp2.types:non-negative-integer)
    (integer 0 18446744073709551615) cxml-types:unsigned-long-type
  (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:unsigned-int xmlisp2.types:unsigned-long)
    (integer 0 2147483647) cxml-types:unsigned-int-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:unsigned-short xmlisp2.types:unsigned-int)
    (integer 0 32767) cxml-types:unsigned-short-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:unsigned-byte xmlisp2.types:unsigned-short)
    (integer 0 127) cxml-types:unsigned-byte-type
    (princ-to-string integer))

(define-simple-xml-type (xmlisp2.types:positive-integer
			 xmlisp2.types:non-negative-integer)
    
    (integer 1 *) cxml-types:positive-integer-type
    (princ-to-string integer))

(define-xml-type xmlisp2.types:boolean () (member t nil) cxml-types:boolean-type
  ((lisp-value xml-type t)
   (cond ((eq lisp-value nil) "false")
	 ((eq lisp-value t) "true")
	 (t (error "invalid boolean value")))))

(define-simple-xml-type (xmlisp2.types:string) cl:string cxml-types:string-type
			(identity string))