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