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

   (:import-from :alexandria
                 :destructuring-case)

   (:import-from :libyaml.macros
                 :with-parser
                 :with-event)

   (: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)
   (let ((message (libyaml.parser:error-message parser))
         (line (libyaml.parser:error-line parser))
         (column (libyaml.parser:error-column parser)))
     (error 'yaml.error:parsing-error
            :message message
            :line line
            :column column)))
 
 (defun parse-yaml (input)
   "Parse a YAML string, returning a list of tokens."
   (let ((output (make-array 0 :fill-pointer 0 :adjustable t)))
     (with-parser (parser input)
       (with-event (event)
         (loop do
           ;; Parse the next event, checking for errors

           (let ((parsing-result (libyaml.parser:parse parser event)))
             (if parsing-result
                 ;; Decide what to do with the event
                 (let ((type (libyaml.event:event-type event)))
                   (flet ((add-to-output (data)
                            (vector-push-extend data output)))
                     (cond
                       ;; Stream events
                       ((eql type :stream-start-event)
                        ;; Do nothing
                        t)
                       ((eql type :stream-end-event)
                        (return-from parse-yaml output))
                       ;; Document events, push them to the output list
                       ((or (eql type :document-start-event)
                            (eql type :document-end-event))
                        (add-to-output (list type)))
                       ;; Alias and scalar event, push the type and data pair to

                       ;; the output list. Disabled since they are not supported.
                       #|

                       ((eql type :alias-event)
                        (add-to-output
                         (cons type
                               (libyaml.event:event-alias-data event))))

                       |#

                       ((eql type :scalar-event)
                        (add-to-output
                         (cons type
                               (libyaml.event:event-scalar-data event))))
                       ;; Sequence start and end events
                       ((eql type :sequence-start-event)
                        (add-to-output
                         (cons type
                               (libyaml.event:event-sequence-start-data event))))
                       ((eql type :sequence-end-event)
                        (add-to-output (list type)))
                       ;; Mapping start and end events
                       ((eql type :mapping-start-event)
                        (add-to-output
                         (cons type
                               (libyaml.event:event-mapping-start-data event))))
                       ((eql type :mapping-end-event)

                        (add-to-output (list type))))))

                 ;; Signal an error
                 (signal-reader-error parser))))))))

 
 (defun parse-tokens (vector)

   (let ((contexts (list (list :documents))))

     (loop for token across vector do
       (destructuring-case token
         ;; Documents
         ((:document-start-event)
          (push (list) contexts))
         ((:document-end-event)
          (let ((con (pop contexts)))
            (setf (first contexts)
                  (append (first contexts)

                          con))))

         ;; Alias event

         ;; Disabled since it's not supported
         #|

         ((:alias-event &key anchor)

          (declare (ignore anchor))
          t)

         |#

         ;; Scalar

         ((: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 (convert-scalar value tag style)))))

         ;; Sequence start event

         ((: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 implicit style)
          (declare (ignore anchor implicit style))
          (push (list tag) contexts))

         ;; End events
         ((:sequence-end-event)

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

            (setf (first contexts)
                  (append (first contexts)

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

         ((:mapping-end-event)

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

            (setf (first contexts)
                  (append (first contexts)

                          (list (convert-mapping
 				(alexandria:plist-hash-table plist :test #'equalp)
 				tag))))))

         ;; Do nothing
         ((t &rest rest)

          (declare (ignore rest)))))

     (first contexts)))

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