@@ -16,6 +16,8 @@

                  (:file "scalar")

                  (:file "parser")

                  (:file "emitter")

+                 (:file "emitter2")

+                 (:file "round-trip")

                  (:file "spec")

                  (:file "bench")

                  (:file "cl-yaml")))))

@@ -1,9 +1,52 @@

 (in-package :cl-user)

 (defpackage yaml.emitter

   (:use :cl)

-  (:export :encode

+  (:import-from :cffi

+                :foreign-free

+                :null-pointer)

+  (:import-from :libyaml.emitter

+                :allocate-emitter

+                :emitter-initialize

+                :emitter-delete

+                :set-output

+                :stream-start-event-initialize

+                :stream-end-event-initialize

+                :document-start-event-initialize

+                :document-end-event-initialize

+                :scalar-event-initialize

+                :sequence-start-event-initialize

+                :sequence-end-event-initialize

+                :mapping-start-event-initialize

+                :mapping-end-event-initialize)

+  (:import-from :libyaml.event

+                :allocate-event

+                :event-delete)

+  (:import-from :libyaml.write-handler

+                :*write-handler-callback*

+                :*write-handler-stream*)

+  (:export ;; Original interface

            :emit

-           :emit-to-string)

+           :emit-to-string

+           :encode

+           ;; libyaml based interface

+           :stream-start-event

+           :stream-end-event

+           :document-start-event

+           :document-end-event

+           :scalar-event

+           :sequence-start-event

+           :sequence-end-event

+           :mapping-start-event

+           :mapping-end-event

+           :emit-stream

+           :emit-document

+           :emit-sequence

+           :emit-mapping

+           :emit-scalar

+           :emit-object

+           :print-scalar

+           :with-emitter-to-stream

+           :with-emitter-to-string)

   (:documentation "The YAML emitter."))

 (in-package :yaml.emitter)

@@ -67,4 +110,196 @@

 (defun emit-to-string (value)

   "Emit a value to string."

   (with-output-to-string (stream)

-    (emit value stream)))

+(emit value stream)))

+

+;;; Wrappers around cl-libyaml event interface with defaults and keyword args

+

+(defun stream-start-event (event &key (encoding :utf8-encoding))

+  (stream-start-event-initialize event encoding))

+

+(defun stream-end-event (event)

+  (stream-end-event-initialize event))

+

+(defun document-start-event (event &key (version-directive (null-pointer))

+                                     (tag-directive-start (null-pointer))

+                                     (tag-directive-end (null-pointer))

+                                     (implicit nil))

+  (document-start-event-initialize event version-directive

+                                   tag-directive-start

+                                   tag-directive-end

+                                   implicit))

+

+(defun document-end-event (event &key (implicit nil))

+  (document-end-event-initialize event implicit))

+

+(defun sequence-start-event (event &key (anchor (null-pointer))

+                                     (tag (null-pointer))

+                                     (implicit nil)

+                                     (style :any-sequence-style))

+  (sequence-start-event-initialize event anchor tag implicit style))

+

+(defun sequence-end-event (event)

+  (sequence-end-event-initialize event))

+

+(defun mapping-start-event (event &key (anchor (null-pointer))

+                                    (tag (null-pointer))

+                                    (implicit nil)

+                                    (style :any-mapping-style))

+  (mapping-start-event-initialize event anchor tag implicit style))

+

+(defun mapping-end-event (event)

+  (mapping-end-event-initialize event))

+

+(defun scalar-event (event value length &key (anchor (null-pointer))

+                                          (tag (null-pointer))

+                                          (plain-implicit t)

+                                          (quoted-implicit t)

+                                          (style :plain-scalar-style))

+  (scalar-event-initialize event anchor tag value length

+                           plain-implicit quoted-implicit style))

+

+;;; Emitter macros and output functions

+

+;;; When passing a foreign emitter object, it is also paired with a

+;;; foreign event object.

+

+(defun foreign-emitter (emitter) (car emitter))

+

+(defun foreign-event (emitter) (cdr emitter))

+

+(defmacro with-emitter-to-stream ((emitter-var output-stream) &rest body)

+  (let ((foreign-emitter (gensym "EMITTER"))

+        (foreign-event (gensym "EVENT")))

+    `(let* ((,foreign-emitter (allocate-emitter))

+            (,foreign-event (allocate-event))

+            (,emitter-var (cons ,foreign-emitter ,foreign-event))

+            (*write-handler-stream* ,output-stream))

+      (unwind-protect

+           (progn

+             (emitter-initialize ,foreign-emitter)

+             (set-output ,foreign-emitter *write-handler-callback* (null-pointer))

+             ,@body)

+        (libyaml.event:event-delete ,foreign-event)

+        (libyaml.emitter:emitter-delete ,foreign-emitter)

+        (foreign-free ,foreign-event)

+        (foreign-free ,foreign-emitter)))))

+

+(defmacro with-emitter-to-string ((emitter-var) &rest body)

+  (let ((str (gensym "STR")))

+    `(with-output-to-string (,str)

+       (with-emitter-to-stream (,emitter-var ,str)

+         ,@body))))

+

+(defmacro emit-stream ((emitter &key (encoding :utf8-encoding)) &body body)

+  (let ((emitter-value (gensym "EMITTER"))

+        (foreign-emitter (gensym "FOREIGN-EMITTER"))

+        (foreign-event (gensym "FOREIGN-EVENT")))

+    `(let* ((,emitter-value ,emitter)

+            (,foreign-emitter (foreign-emitter ,emitter-value))

+            (,foreign-event (foreign-event ,emitter-value)))

+       (stream-start-event ,foreign-event :encoding ,encoding)

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event)

+       ,@body

+       (stream-end-event ,foreign-event)

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event))))

+

+(defmacro emit-document ((emitter &rest rest

+                                  &key version-directive

+                                  tag-directive-start 

+                                  tag-directive-end

+                                  (implicit nil)) &body body)

+  (declare (ignorable version-directive tag-directive-start

+                      tag-directive-end implicit))

+  (let ((emitter-value (gensym "EMITTER"))

+        (foreign-emitter (gensym "FOREIGN-EMITTER"))

+        (foreign-event (gensym "FOREIGN-EVENT")))

+    `(let* ((,emitter-value ,emitter)

+            (,foreign-emitter (foreign-emitter ,emitter-value))

+            (,foreign-event (foreign-event ,emitter-value)))

+       (apply #'document-start-event ,foreign-event (list ,@rest))

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event)

+       ,@body

+       (document-end-event ,foreign-event :implicit ,implicit)

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event))))

+

+(defmacro emit-mapping ((emitter &rest rest &key anchor tag implicit style)

+                        &body body)

+  (declare (ignorable anchor tag implicit style))

+  (let ((emitter-value (gensym "EMITTER"))

+        (foreign-emitter (gensym "FOREIGN-EMITTER"))

+        (foreign-event (gensym "FOREIGN-EVENT")))

+    `(let* ((,emitter-value ,emitter)

+            (,foreign-emitter (foreign-emitter ,emitter-value))

+            (,foreign-event (foreign-event ,emitter-value)))

+       (apply #'mapping-start-event ,foreign-event (list ,@rest))

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event)

+       ,@body

+       (mapping-end-event ,foreign-event)

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event))))

+

+(defmacro emit-sequence ((emitter &rest rest &key anchor tag implicit style)

+                         &body body)

+  (declare (ignorable anchor tag implicit style))

+  (let ((emitter-value (gensym "EMITTER"))

+        (foreign-emitter (gensym "FOREIGN-EMITTER"))

+        (foreign-event (gensym "FOREIGN-EVENT")))

+    `(let* ((,emitter-value ,emitter)

+            (,foreign-emitter (foreign-emitter ,emitter-value))

+            (,foreign-event (foreign-event ,emitter-value)))

+       (apply #'sequence-start-event ,foreign-event (list ,@rest))

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event)

+       ,@body

+       (sequence-end-event ,foreign-event)

+       (libyaml.emitter:emit ,foreign-emitter ,foreign-event))))

+

+(defun emit-scalar (emitter value &rest rest &key anchor tag

+                                               plain-implicit

+                                               quoted-implicit

+                                               style)

+  (declare (ignorable anchor tag plain-implicit quoted-implicit style))

+  (let ((printed-value (print-scalar value)))

+    (apply #'scalar-event (foreign-event emitter)

+           printed-value (length printed-value) rest)

+    (libyaml.emitter:emit (foreign-emitter emitter) (foreign-event emitter))))

+

+(defgeneric print-scalar (scalar)

+  (:documentation "Convert a scalar object into its printed representation"))

+

+(defmethod print-scalar ((scalar (eql 't)))

+  "true")

+

+(defmethod print-scalar ((scalar (eql 'nil)))

+  "false")

+

+(defmethod print-scalar ((scalar symbol))

+  (symbol-name scalar))

+

+(defmethod print-scalar ((scalar string))

+  scalar)

+

+(defmethod print-scalar ((scalar integer))

+  (princ-to-string scalar))

+

+(defmethod print-scalar ((scalar single-float))

+  (let ((*read-default-float-format* 'single-float))

+    (princ-to-string scalar)))

+

+(defmethod print-scalar ((scalar double-float))

+  (let ((*read-default-float-format* 'double-float))

+    (princ-to-string scalar)))

+

+(defgeneric emit-object (emitter obj)

+  (:documentation "Emit YAML representation of obj"))

+

+(defmethod emit-object (emitter (obj symbol))

+  (emit-scalar emitter obj))

+

+(defmethod emit-object (emitter (obj string))

+  (emit-scalar emitter obj))

+

+(defmethod emit-object (emitter (obj integer))

+  (emit-scalar emitter obj))

+

+(defmethod emit-object (emitter (obj float))

+  (emit-scalar emitter obj))

+

@@ -6,10 +6,44 @@

   (:import-from :libyaml.macros

                 :with-parser

                 :with-event)

-  (:export :parse-string)

+  (:export :parse-string

+	   :register-scalar-converter

+	   :register-sequence-converter

+	   :register-mapping-converter)

   (:documentation "The YAML parser."))

 (in-package :yaml.parser)

+(defvar +scalar-converters+ (make-hash-table :test #'equalp))

+(defvar +sequence-converters+ (make-hash-table :test #'equalp))

+(defvar +mapping-converters+ (make-hash-table :test #'equalp))

+

+(defun scalar-converter (tag)

+  (gethash tag +scalar-converters+))

+

+(defun convert-scalar (string tag &optional (style :plain-scalar-stype))

+  (let ((converter (scalar-converter tag)))

+    (if converter

+	(funcall converter string)

+	(yaml.scalar:parse-scalar string style))))

+

+(defun sequence-converter (tag)

+  (gethash tag +sequence-converters+))

+

+(defun convert-sequence (list tag)

+  (let ((converter (sequence-converter tag)))

+    (if converter

+	(funcall converter list)

+	list)))

+

+(defun mapping-converter (tag)

+  (gethash tag +mapping-converters+))

+

+(defun convert-mapping (hashtable tag)

+  (let ((converter (mapping-converter tag)))

+    (if converter

+	(funcall converter hashtable)

+	hashtable)))

+

 ;;; The parser

 (defun signal-reader-error (parser)

@@ -94,31 +128,32 @@

          t)

         |#

         ;; Scalar

-        ((:scalar-event &key anchor tag value)

-         (declare (ignore anchor tag))

+        ((:scalar-event &key anchor tag value length plain-implicit quoted-implicit style)

+         (declare (ignore anchor length plain-implicit quoted-implicit))

          (setf (first contexts)

                (append (first contexts)

-                       (list (yaml.scalar:parse-scalar value)))))

+                       (list (convert-scalar value tag style)))))

         ;; Sequence start event

-        ((:sequence-start-event &key anchor tag)

-         (declare (ignore anchor tag))

-         (push (list) contexts))

+        ((:sequence-start-event &key anchor tag implicit style)

+         (declare (ignore anchor implicit style))

+         (push (list tag) contexts))

         ;; Mapping start event

-        ((:mapping-start-event &key anchor tag)

-         (declare (ignore anchor tag))

-         (push (list) contexts))

+        ((:mapping-start-event &key anchor tag implicit style)

+         (declare (ignore anchor implicit style))

+         (push (list tag) contexts))

         ;; End events

         ((:sequence-end-event)

-         (let ((con (pop contexts)))

+         (destructuring-bind (tag &rest seq) (pop contexts)

            (setf (first contexts)

                  (append (first contexts)

-                         (list con)))))

+                         (list (convert-sequence seq tag))))))

         ((:mapping-end-event)

-         (let ((con (pop contexts)))

+         (destructuring-bind (tag &rest plist) (pop contexts)

            (setf (first contexts)

                  (append (first contexts)

-                         (list

-                          (alexandria:plist-hash-table con :test #'equal))))))

+                         (list (convert-mapping

+				(alexandria:plist-hash-table plist :test #'equalp)

+				tag))))))

         ;; Do nothing

         ((t &rest rest)

          (declare (ignore rest)))))

@@ -126,5 +161,14 @@

 ;;; The public interface

+(defun register-scalar-converter (tag converter)

+  (setf (gethash tag +scalar-converters+) converter))

+

+(defun register-sequence-converter (tag converter)

+  (setf (gethash tag +sequence-converters+) converter))

+

+(defun register-mapping-converter (tag converter)

+  (setf (gethash tag +mapping-converters+) converter))

+

 (defun parse-string (yaml-string)

   (parse-tokens (parse-yaml yaml-string)))

@@ -15,6 +15,9 @@

 ;;; Regular expressions or lists of names

+(defparameter +quoted-scalar-styles+

+  (list :single-quoted-scalar-style :double-quoted-scalar-style))

+

 (defparameter +null-names+

   (list "null" "Null" "NULL" "~"))

@@ -48,9 +51,12 @@

 ;;; The actual parser

-(defun parse-scalar (string)

+(defun parse-scalar (string &optional (style :plain-scalar-style))

   "Parse a YAML scalar string into a Lisp scalar value."

   (cond

+    ;; Quoted string

+    ((member style +quoted-scalar-styles+)

+     string)

     ;; Null

     ((member string +null-names+ :test #'equal)

      +null+)

@@ -2,9 +2,21 @@

 (defpackage cl-yaml

   (:use :cl)

   (:nicknames :yaml)

+  (:import-from :yaml.parser

+                :register-scalar-converter

+                :register-sequence-converter

+                :register-mapping-converter)

+  (:import-from :yaml.emitter

+                :emit-object

+                :print-scalar)

   (:export :parse

            :emit

-           :emit-to-string)

+           :emit-to-string

+           :register-scalar-converter

+           :register-sequence-converter

+           :register-mapping-converter

+           :emit-object

+           :print-scalar)

   (:documentation "The main YAML interface."))

 (in-package :yaml)

@@ -10,5 +10,7 @@

   (run! 'cl-yaml-test.scalar:scalar)

   (run! 'cl-yaml-test.parser:parser)

   (run! 'cl-yaml-test.emitter:emitter)

+  (run! 'cl-yaml-test.emitter2:emitter2)

+  (run! 'cl-yaml-test.round-trip:round-trip)

   (run! 'cl-yaml-test.spec:spec)

   (run! 'cl-yaml-test.bench:bench))

new file mode 100644

@@ -0,0 +1,79 @@

+(in-package :cl-user)

+(defpackage cl-yaml-test.emitter2

+  (:use :cl :fiveam)

+  (:export :emitter2)

+  (:documentation "Emitter tests - libyaml-based emitter."))

+(in-package :cl-yaml-test.emitter2)

+

+(defmacro define-test-cases ((name) &rest pairs)

+  `(test ,name

+     ,@(loop for (form string) in pairs collecting

+            `(is (equal (yaml.emitter:with-emitter-to-string (emitter)

+                          (yaml.emitter:emit-stream (emitter)

+                            (yaml.emitter:emit-document (emitter :implicit t)

+                              (yaml.emitter:emit-scalar emitter ,form))))

+                        ,(format nil "~a~%...~%" string)))))) ;; Document end marker

+                                                              ;; is libyaml behavior

+

+(defun test-emit-sequence (sequence style)

+  (yaml.emitter:with-emitter-to-string (emitter)

+    (yaml.emitter:emit-stream (emitter)

+      (yaml.emitter:emit-document (emitter :implicit t)

+        (yaml.emitter:emit-sequence (emitter :style style)

+          (mapcar (lambda (element) (yaml.emitter:emit-scalar emitter element))

+                  sequence))))))

+

+(defun test-emit-mapping (mapping style)

+  (yaml.emitter:with-emitter-to-string (emitter)

+    (yaml.emitter:emit-stream (emitter)

+      (yaml.emitter:emit-document (emitter :implicit t)

+        (yaml.emitter:emit-mapping (emitter :style style)

+          (mapcar (lambda (pair)

+                    (yaml.emitter:emit-scalar emitter (car pair))

+                    (yaml.emitter:emit-scalar emitter (cdr pair)))

+                  mapping))))))

+

+(def-suite emitter2

+    :description "YAML libyaml-based emitter tests.")

+(in-suite emitter2)

+

+(define-test-cases (boolean)

+  (t "true")

+  (nil "false"))

+

+(define-test-cases (integers)

+  (1 "1")

+  (123 "123")

+  (+123 "123")

+  (-123 "-123"))

+

+(define-test-cases (floats)

+  (1.23 "1.23")

+  (6.62607e-34 "6.62607e-34"))

+

+(test flow-sequence

+  (is (equal (test-emit-sequence '(1 "a" 3.14f0 3.14d0) :flow-sequence-style)

+             "[1, a, 3.14, 3.14]

+")))

+

+(test block-sequence

+  (is (equal (test-emit-sequence '(1 "a" 3.14f0 3.14d0) :block-sequence-style)

+             "- 1

+- a

+- 3.14

+- 3.14

+")))

+

+(test flow-mapping

+  (is (equal (test-emit-mapping '(("integer" . 1) ("string" . "test") ("bool" . nil))

+                                :flow-mapping-style)

+             "{integer: 1, string: test, bool: false}

+")))

+

+(test block-mapping

+  (is (equal (test-emit-mapping '(("integer" . 1) ("string" . "test") ("bool" . nil))

+                                :block-mapping-style)

+             "integer: 1

+string: test

+bool: false

+")))

new file mode 100644

@@ -0,0 +1,165 @@

+(in-package :cl-user)

+(defpackage cl-yaml-test.round-trip

+  (:use :cl :fiveam)

+  (:export :round-trip)

+  (:documentation "Round-trip Emitter/Parser tests."))

+(in-package :cl-yaml-test.round-trip)

+

+(def-suite round-trip

+    :description "YAML emitter/parser tests.")

+(in-suite round-trip)

+

+(defclass invoice ()

+  ((number :initarg :number :accessor invoice-number)

+   (date :initarg :date :accessor invoice-date)

+   (bill-to :initarg :bill-to :accessor invoice-bill-to)

+   ;; skip ship-to until aliases and anchors are more developed)

+   (product :initarg :product :accessor invoice-product)

+   (tax :initarg :tax :accessor invoice-tax)

+   (total :initarg :total :accessor invoice-total)

+   (comments :initarg :comments :accessor invoice-comments)))

+

+(defclass address ()

+  ((lines :initarg :lines :accessor address-lines)

+   (city :initarg :city :accessor address-city)

+   (state :initarg :state :accessor address-state)

+   (postal :initarg :postal :accessor address-postal)))

+

+(defclass product-order ()

+  ((sku :initarg :sku :accessor product-order-sku)

+   (quantity :initarg :quantity :accessor product-order-quantity)

+   (description :initarg :description :accessor product-order-description)

+   (price :initarg :price :accessor product-order-price)))

+

+(defun make-test-invoice ()

+  (make-instance 'invoice

+		 :number 34843

+		 :date "2001-01-23"

+		 :bill-to (list "Chris" "Dumars"

+				(make-instance 'address

+					       :lines "458 Walkman Dr.

+Suite #292"

+					       :city "Royal Oak"

+					       :state "MI"

+					       :postal "48046"))

+		 :product (list (make-instance 'product-order

+					       :sku "BL394D"

+					       :quantity 4

+					       :description "Basketball"

+					       :price 450.00)

+				(make-instance 'product-order

+					       :sku "BL4438H"

+					       :quantity 1

+					       :description "Super Hoop"

+					       :price 2392.00))

+		 :tax 251.42

+		 :total 4443.52

+		 :comments "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338."))

+

+;;; Methods to emit CLOS objects

+

+(defmethod yaml.emitter:emit-object (emitter (obj address))

+  (yaml.emitter:emit-mapping (emitter :style :block-mapping-style)

+    (yaml.emitter:emit-scalar emitter "lines")

+    (yaml.emitter:emit-scalar emitter (address-lines obj)

+			      :style :literal-scalar-style)

+    (yaml.emitter:emit-scalar emitter "city")

+    (yaml.emitter:emit-scalar emitter (address-city obj))

+    (yaml.emitter:emit-scalar emitter "state")

+    (yaml.emitter:emit-scalar emitter (address-state obj))

+    (yaml.emitter:emit-scalar emitter "postal")

+    (yaml.emitter:emit-scalar emitter (address-postal obj))))

+

+(defmethod yaml.emitter:emit-object (emitter (obj product-order))

+  (yaml.emitter:emit-mapping (emitter :style :block-mapping-style)

+    (yaml.emitter:emit-scalar emitter "sku")

+    (yaml.emitter:emit-scalar emitter (product-order-sku obj))

+    (yaml.emitter:emit-scalar emitter "quantity")

+    (yaml.emitter:emit-scalar emitter (product-order-quantity obj))

+    (yaml.emitter:emit-scalar emitter "description")

+    (yaml.emitter:emit-scalar emitter (product-order-description obj))

+    (yaml.emitter:emit-scalar emitter "price")

+    (yaml.emitter:emit-scalar emitter (product-order-price obj))))

+

+(defmethod yaml.emitter:emit-object (emitter (obj invoice))

+  (yaml.emitter:emit-mapping (emitter :style :block-mapping-style

+				      :tag "clarkevans.com,2002:invoice")

+    (yaml.emitter:emit-scalar emitter "invoice")

+    (yaml.emitter:emit-scalar emitter (invoice-number obj))

+    (yaml.emitter:emit-scalar emitter "date")

+    (yaml.emitter:emit-scalar emitter (invoice-date obj))

+    (yaml.emitter:emit-scalar emitter "bill-to")

+    (yaml.emitter:emit-mapping (emitter :style :block-mapping-style)

+      (yaml.emitter:emit-scalar emitter "given")

+      (yaml.emitter:emit-scalar emitter (first (invoice-bill-to obj)))

+      (yaml.emitter:emit-scalar emitter "family")

+      (yaml.emitter:emit-scalar emitter (second (invoice-bill-to obj)))

+      (yaml.emitter:emit-scalar emitter "address")

+      (yaml.emitter:emit-object emitter (third (invoice-bill-to obj))))

+    (yaml.emitter:emit-scalar emitter "product")

+    (yaml.emitter:emit-sequence (emitter :style :block-sequence-style)

+      (dolist (product (invoice-product obj))

+	(yaml.emitter:emit-object emitter product)))

+    (yaml.emitter:emit-scalar emitter "tax")

+    (yaml.emitter:emit-scalar emitter (invoice-tax obj))

+    (yaml.emitter:emit-scalar emitter "total")

+    (yaml.emitter:emit-scalar emitter (invoice-total obj))

+    (yaml.emitter:emit-scalar emitter "comments")

+    (yaml.emitter:emit-scalar emitter (invoice-comments obj)

+			      :plain-implicit t

+			      :quoted-implicit t

+			      :style :plain-scalar-style)))

+

+;;; Functions to construct objects from YAML

+

+(defun construct-address (mapping)

+  (make-instance 'address

+		 :lines (gethash "lines" mapping)

+		 :city (gethash "city" mapping)

+		 :state (gethash "state" mapping)

+		 :postal (gethash "postal" mapping)))

+

+(defun construct-product-order (mapping)

+  (make-instance 'product-order

+		 :sku (gethash "sku" mapping)

+		 :quantity (gethash "quantity" mapping)

+		 :description (gethash "description" mapping)

+		 :price (gethash "price" mapping)))

+

+(defun construct-invoice (mapping)

+  (let ((bill-to-mapping (gethash "bill-to" mapping)))

+    (make-instance 'invoice

+		   :number (gethash "invoice" mapping)

+		   :date (gethash "date" mapping)

+		   :bill-to (list (gethash "given" bill-to-mapping)

+				  (gethash "family" bill-to-mapping)

+				  (construct-address (gethash "address" bill-to-mapping)))

+		   :product (mapcar #'construct-product-order

+				    (gethash "product" mapping))

+		   :tax (gethash "tax" mapping)

+		   :total (gethash "total" mapping)

+		   :comments (gethash "comments" mapping))))

+

+;;; Register a construction function with a YAML tag

+

+(eval-when (:load-toplevel)

+  (yaml.parser:register-mapping-converter "clarkevans.com,2002:invoice"

+					  #'construct-invoice))

+

+;;; Helper

+

+(defun test-emit (obj)

+  (yaml.emitter:with-emitter-to-string (emitter)

+    (yaml.emitter:emit-stream (emitter)

+      (yaml.emitter:emit-document (emitter :implicit t)

+	(yaml.emitter:emit-object emitter obj)))))

+

+;;; Round-trip test

+

+(test invoice

+  (let* ((invoice-a (make-test-invoice))

+	 (yaml-a (test-emit invoice-a))

+	 (invoice-b (yaml:parse yaml-a))

+	 (yaml-b (test-emit invoice-b)))

+    (is (string= yaml-a yaml-b))))

+