[Infrastructure and semi-implementation of xml schema type based codecs clinton@unknownlamer.org**20090501205808 Ignore-this: 2bbe2e9e3faa99afa1e46514910d4521 * `define-xml-type' defines a lisp<->xml mapping for an arbitrarily named xml type. * `xmlisp2.types' package contains xml schema type names * Any class that wishes to be {un}parseable must use slot types from `xmlisp2.types' todo: implement all of the primitive and derived xml schema types ] hunk ./src/codec.lisp 1 -(in-package :xmlisp2) +(in-package :xmlisp2.codec) + +(defgeneric xml->lisp-value (xml-value xml-type)) +(defgeneric lisp->xml-value (lisp-value xml-type)) + +(defmacro define-xml-type (XML-TYPE LISP-TYPE-SPEC PARSE UNPARSE) + `(progn + (deftype ,xml-type () + ,lisp-type-spec) + (defcodec ,xml-type ,parse ,unparse))) hunk ./src/codec.lisp 14 - ((lisp-value-name) &body unparse)) + ((lisp-value-name xml-type-name &optional (lisp-type type)) + &body unparse)) hunk ./src/codec.lisp 17 - (defmethod xml-value->lisp-value (,xml-value-name (,lisp-type-name (eql ',type))) + (defmethod xml->lisp-value (,xml-value-name (,lisp-type-name (eql ',type))) hunk ./src/codec.lisp 19 - (defmethod lisp-value->xml-value ((,lisp-value-name ,type)) + (defmethod lisp->xml-value ((,lisp-value-name ,lisp-type) (,xml-type-name (eql ',type))) hunk ./src/codec.lisp 22 -(defmacro define-simple-codec (type (parse &optional (assert nil assert-p)) unparse) - (with-unique-names (xml-value lisp-value lisp-type maybe-parsed) - `(defcodec ,type +(defmacro define-simple-xml-type (type-name type-spec + (parse &optional (assert nil assert-p)) + (unparse &optional (lisp-type-name type-name))) + (with-unique-names (xml-value lisp-value lisp-type xml-type maybe-parsed) + `(define-xml-type ,type-name ,type-spec hunk ./src/codec.lisp 33 - ((,lisp-value) + ((,lisp-value ,xml-type ,lisp-type-name) + (declare (ignore ,xml-type)) hunk ./src/codec.lisp 42 - `(define-simple-codec - ,def - (read-from-string) - princ-to-string)) + `(define-simple-xml-type ,(first def) + ',(second def) + (read-from-string) + (princ-to-string ,(second def)))) hunk ./src/codec.lisp 48 - number - float - single-float - double-float) - (define-simple-codec integer (parse-integer) princ-to-string)) - -;;; pretty printed t/nil -(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'boolean))) - (cond ((string= xml-value "true") t) - ((string= xml-value "false") nil) - (t (error "invalid boolean value")))) - -(defmethod lisp-value->xml-value ((lisp-value (eql t))) - "true") - -(defmethod lisp-value->xml-value ((lisp-value null)) - "false") - -;;; characters/strings -(defcodec character - ((xml-value lisp-type) - (assert (= 1 (length xml-value))) - (char xml-value 0)) - ((lisp-value) (string lisp-value))) + (xmlisp2.types:decimal number) + (xmlisp2.types:float single-float) + (xmlisp2.types:double double-float))) hunk ./src/codec.lisp 52 -(define-simple-codec string (identity) identity) +(define-xml-type xmlisp2.types:boolean `(member t nil) + ((xml-value lisp-type) + (cond ((or (string= xml-value "1") (string= xml-value "true")) t) + ((or (string= xml-value "0") (string= xml-value "false")) nil) + (t (error "invalid boolean value")))) + ((lisp-value xml-type t) + (cond ((eq lisp-value nil) "false") + ((eq lisp-value t) "true") + (t (error "invalid boolean value"))))) hunk ./src/codec.lisp 62 -;;; sequences -(define-simple-codec list (read-from-string) princ-to-string) -(define-simple-codec array (read-from-string) princ-to-string) +(define-simple-xml-type xmlisp2.types:string `cl:string (identity) + (identity string)) hunk ./src/packages.lisp 3 +(defpackage :xmlisp2.codec + (:use :cl) + (:import-from :arnesi :with-unique-names) + (:export + :xml->lisp-value + :lisp->xml-value)) + hunk ./src/packages.lisp 11 - (:use :cl :klacks :cxml) - (:import-from :arnesi :compose :cond-bind :curry :if-bind :rcurry :when-bind)) + (:use :cl :klacks :cxml :xmlisp2.codec) + (:import-from :arnesi :compose :cond-bind :curry :if-bind :rcurry + :when-bind :with-unique-names)) + +(defpackage :xmlisp2.types + (:export + #:string + #:boolean + #:decimal + #:float + #:double + #:duration + #:|dateTime| + #:time + #:date + #:|gYearMonth| + #:|gYear| + #:|gMonthDay| + #:|gDay| + #:|gMonth| + #:|hexBinary| + #:|base64Binary| + #:|anyURI| + #:|QName| + #:|NOTATION|)) hunk ./src/protocol.lisp 11 -;;; coding/decoding -(defgeneric xml-value->lisp-value (xml-value lisp-type)) -(defgeneric lisp-value->xml-value (lisp-value)) - hunk ./src/serializer-class.lisp 17 - (xml-value->lisp-value xml-value - (c2mop:slot-definition-type slot-definition))) + (xml->lisp-value xml-value + (c2mop:slot-definition-type slot-definition))) hunk ./src/unparse.lisp 34 - (xmlns-attributes (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))))))))) + (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)))))) hunk ./src/unparse.lisp 73 - :value (lisp-value->xml-value - (slot-value object name)) + :value (lisp->xml-value + (slot-value object name) + type) hunk ./src/vars.lisp 6 - (find-package :xmlisp2)))) + (find-package :xmlisp2)) + (cons "http://www.w3.org/2001/XMLSchema" + (find-package :xmlisp2.types)) + (cons "http://www.w3.org/2001/XMLSchema-datatypes" + (find-package :xmlisp2.types)))) hunk ./tests/test.lisp 4 - ((moo :initform nil :type character) - (hem :initform nil :type boolean))) + ((moo :initform nil :type xmlisp2.types:string) + (hem :initform nil :type xmlisp2.types:boolean))) hunk ./tests/test.lisp 8 - ((meh :initform nil :type number) - (hrm :initform nil :type string))) + ((meh :initform nil :type xmlisp2.types:float) + (hrm :initform nil :type xmlisp2.types:string))) hunk ./tests/test.lisp 12 - ((bar :initform 0 :type integer) - (baz :initform nil :type list) - (arr :initform #() :type array) + ((bar :initform 0 :type xmlisp2.types:decimal) hunk ./tests/test.xml 2 - +