synthesize.lisp

(in-package :edn)

(defgeneric synthesize (implementation args))
(defgeneric synthesize-compound (implementation discriminator args))
(defgeneric synthesize-tag (implementation tag args))

(defun parse (input &optional (realizer 'fset))
  (synthesize realizer
              (read-edn input)))


(defmethod synthesize ((implementation symbol) discriminator)
  (synthesize (make-instance implementation) discriminator))

(defmethod synthesize (implementation thing)
  (typecase thing
    (list (synthesize-compound implementation (car thing) (cdr thing)))
    (t thing)))

(defmethod synthesize-compound (implementation (discriminator (eql :keyword)) args)
  (destructuring-bind (ns name) args
    (alexandria:make-keyword (if ns
                                 (format nil "~a/~a" ns name)
                                 (format nil "~a" name)))))

(defmethod synthesize-compound (implementation (discriminator (eql :string)) args)
  (car args))

(defmethod synthesize-compound (implementation (discriminator (eql :symbol)) args)
  (destructuring-bind (ns name) args
    (make-symbol (if ns
                     (format nil "~a/~a" ns name)
                     (format nil "~a" name)))))

(defmethod synthesize-compound (implementation (discriminator (eql :tagged)) args)
  (destructuring-bind (sym obj) args
    (list :tagged
          (synthesize-compound implementation (car sym) (cdr sym))
          (synthesize implementation obj))))

(defmethod synthesize-compound (implementation (discriminator (eql :character)) args)
  (car args))

(defmethod synthesize-compound (implementation (discriminator (eql :tagged)) args)
  (destructuring-bind (sym obj) args
    (let ((tag (synthesize-compound implementation (car sym) (cdr sym))))
      (alexandria:switch ((symbol-name tag) :test 'string-equal)
        ("inst" (local-time:parse-rfc3339-timestring (synthesize implementation obj)
                                                     :allow-missing-time-part t))
        ("uuid" (uuid:make-uuid-from-string (synthesize implementation obj)))
        (t (let ((synthesized-object (synthesize implementation obj)))
             (fw.lu:if-let* ((tag-keyword (alexandria:make-keyword
                                           (string-upcase
                                            (symbol-name tag))))
                             (methods (compute-applicable-methods
                                       #'synthesize-tag
                                       (list implementation tag-keyword synthesized-object))))

               (synthesize-tag implementation tag-keyword synthesized-object)
               (list :tagged tag
                     synthesized-object))))))))