@@ -16,6 +16,7 @@

                  (:file "scalar")

                  (:file "parser")

                  (:file "emitter")

+		 (:file "round-trip")

                  (:file "spec")

                  (:file "bench")

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

@@ -1,70 +1,228 @@

 (in-package :cl-user)

 (defpackage yaml.emitter

   (:use :cl)

-  (:export :encode

-           :emit

-           :emit-to-string)

+  (:import-from :cffi

+		:foreign-free

+		:null-pointer)

+  (:import-from :libyaml.emitter

+		:allocate-emitter

+		:emitter-initialize

+		:emitter-delete

+		:emit

+		: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 :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)

-;;; Encoder functions

-

-(defgeneric encode (value stream)

-  (:documentation "Write the YAML corresponding to value to a stream."))

-

-(defmethod encode ((true (eql 't)) stream)

-  "Encode true."

-  (write-string "true" stream))

-

-(defmethod encode ((true (eql 'nil)) stream)

-  "Encode false."

-  (write-string "false" stream))

-

-(defmethod encode ((integer integer) stream)

-  "Encode an integer."

-  (princ integer stream))

-

-(defmethod encode ((float float) stream)

-  "Encode a float."

-  (princ float stream))

-

-(defmethod encode ((string string) stream)

-  "Encode a string."

-  ;; (write-string string stream)

-  (format stream "~s" string))

-

-(defmethod encode ((list list) stream)

-  "Encode a list."

-  (write-string "[" stream)

-  (loop for sublist on list do

-    (encode (first sublist) stream)

-    (when (rest sublist)

-      (write-string ", " stream)))

-  (write-string "]" stream))

-

-(defmethod encode ((vector vector) stream)

-  "Encode a vector."

-  (encode (loop for elem across vector collecting elem) stream))

-

-(defmethod encode ((table hash-table) stream)

-  "Encode a hash table."

-  (write-string "{ " stream)

-  (loop for sublist on (alexandria:hash-table-keys table) do

-    (let ((key (first sublist)))

-      (encode key stream)

-      (write-string ": " stream)

-      (encode (gethash key table) stream)

-      (when (rest sublist)

-        (write-string ", " stream))))

-  (write-string " }" stream))

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

-;;; Interface

+(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))))

-(defun emit (value stream)

-  "Emit a value to a stream."

-  (encode value stream))

+(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 0)) &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)

+    (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)))

+

+;;; Interface

-(defun emit-to-string (value)

-  "Emit a value to string."

-  (with-output-to-string (stream)

-    (emit value stream)))

+(defgeneric emit-object (emitter obj)

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

@@ -3,8 +3,9 @@

   (:use :cl)

   (:nicknames :yaml)

   (:export :parse

-           :emit

-           :emit-to-string)

+           ;:emit

+           ;:emit-to-string

+	   )

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

 (in-package :yaml)

@@ -22,8 +23,8 @@

   (parse (uiop:read-file-string input)

          :multi-document-p multi-document-p))

-(defun emit (value stream)

-  (yaml.emitter:emit value stream))

+;; (defun emit (value stream)

+;;   (yaml.emitter:emit value stream))

-(defun emit-to-string (value)

-  (yaml.emitter:emit-to-string value))

+;; (defun emit-to-string (value)

+;;   (yaml.emitter:emit-to-string value))

@@ -10,5 +10,6 @@

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

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

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

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

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

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

@@ -1,67 +1,80 @@

 (in-package :cl-user)

 (defpackage cl-yaml-test.emitter

   (:use :cl :fiveam)

-  (:import-from :alexandria

-                :alist-hash-table)

   (:export :emitter)

   (:documentation "Emitter tests."))

 (in-package :cl-yaml-test.emitter)

-;;; Macros

-

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

   `(test ,name

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

-         `(is (equal (yaml.emitter:emit-to-string ,form)

-                     ,string)))))

+	    `(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))))))

-;;; Tests

+(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 emitter

-  :description "YAML emitter tests.")

+    :description "YAML emitter tests.")

 (in-suite emitter)

 (define-test-cases (boolean)

-  (t

-   "true")

-  (nil

-   "false"))

+  (t "true")

+  (nil "false"))

 (define-test-cases (integers)

-  (1

-   "1")

-  (123

-   "123")

-  (+123

-   "123")

-  (-123

-   "-123"))

+  (1 "1")

+  (123 "123")

+  (+123 "123")

+  (-123 "-123"))

 (define-test-cases (floats)

-  (1.23

-   "1.23")

-  (6.62607e-34

-   "6.62607e-34"))

+  (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

+")))

-(define-test-cases (lists)

-  ((list 1 2 3)

-   "[1, 2, 3]")

-  ((vector 1 2 3)

-   "[1, 2, 3]"))

+(test flow-mapping

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

+				:flow-mapping-style)

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

+")))

-(test hash-tables

-  (let ((table (alexandria:alist-hash-table

-                (list (cons "a" 1)

-                      (cons "b" 2)))))

-    (is

-     (equal (yaml:emit-to-string table)

-            "{ \"b\": 2, \"a\": 1 }"))))

+(test block-mapping

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

+				:block-mapping-style)

+	     "integer: 1

+string: test

+bool: false

+")))

-(test toplevel-function

-  (is

-    (equal (yaml:emit-to-string 1)

-           "1"))

-  (is

-    (equal (with-output-to-string (stream)

-             (yaml:emit 1 stream))

-           "1")))

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))))

+