(in-package :cl-user)
 (defpackage yaml.emitter
   (:use :cl)

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

 ;;; 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))
 
 ;;; Interface
 
 (defun emit (value stream)
   "Emit a value to a stream."
   (encode value stream))
 
 (defun emit-to-string (value)
   "Emit a value to string."
   (with-output-to-string (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))