src/mop.lisp @ d23a34c34dc3

(in-package :jarl)

;;;; Object Parsers -----------------------------------------------------------
(defun lisp-case-to-snake-case (string)
  "Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake cased `\"foo_bar\"`."
  (substitute #\_ #\- (string-downcase string)))

(defclass json-class (standard-class)
  ((slot-name-to-json-name :accessor slot-name-to-json-name
                           :initarg :slot-name-to-json-name
                           :initform 'lisp-case-to-snake-case)
   (unknown-slots :accessor unknown-slots
                  :initarg :unknown-slots
                  :initform :discard)
   (name-initarg-map :accessor name-initarg-map)
   (slot-name-alist :accessor slot-name-alist)))

(defmethod c2mop:validate-superclass ((class json-class) (superclass standard-class))
  t)


(defclass json-direct-slot-definition (c2mop:standard-direct-slot-definition)
  ((json-class :initarg :json :accessor json-class)
   (json-name :initarg :json/name :accessor json-name)))

(defclass json-effective-slot-definition (c2mop:standard-effective-slot-definition)
  ((json-class :initarg :json :accessor json-class)
   (json-name :initarg :json/name :accessor json-name)
   (json-initarg :accessor json-initarg)))

(defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs)
  (if (getf initargs :json)
    (find-class 'json-direct-slot-definition)
    (call-next-method)))

(defvar *effective-slot-definition-class* nil)

(defmethod c2mop:effective-slot-definition-class ((class json-class) &rest initargs)
  (declare (ignore initargs))
  ;; I'm not sure why we need to use this hack here, but for some reason
  ;; initargs doesn't contain the slot options like :json and :json/name here
  ;; like it does in direct-slot-definition-class.  So we need another way to
  ;; know which class to use here.
  (or *effective-slot-definition-class* (call-next-method)))

(defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
  (if (not (some (lambda (dslot)
                   (typep dslot 'json-direct-slot-definition))
                 direct-slots))
    (call-next-method)
    (let* ((*effective-slot-definition-class* (find-class 'json-effective-slot-definition))
           (eslot (call-next-method))
           (dslot (first direct-slots)) ; todo be smarter about coalescing these
           (initarg (gensym (format nil "json-initarg-~A" name)))) ; todo nicer name
      (setf (json-name eslot) (if (slot-boundp dslot 'json-name)
                                (json-name dslot)
                                (funcall (slot-name-to-json-name class) name)) ; todo make this less shitty
            (json-class eslot) (if (slot-boundp dslot 'json-class)
                                 (canonicalize-class-designator (json-class dslot))
                                 '(t))
            (json-initarg eslot) initarg) ; todo nicer name
      (push initarg (c2mop:slot-definition-initargs eslot))
      eslot)))


(defun json-slots (class)
  (remove-if-not (lambda (slot) (typep slot 'json-effective-slot-definition))
                 (c2mop:class-slots class)))

(defun make-name-initarg-map (class)
  "Return a name/initarg map for the JSON slots of `class`.

  The result will be a hash table of `{name: (initarg class contained-class)}`.

  "
  (let* ((slots (json-slots class))
         (result (make-hash-table :test #'equal :size (length slots))))
    (dolist (slot slots)
      (destructuring-bind (c &optional cc) (json-class slot)
        (setf (gethash (json-name slot) result)
              (list (json-initarg slot) c cc))))
    result))

(defun make-slot-name-alist (class)
  (mapcar (lambda (slot)
            (cons (c2mop:slot-definition-name slot)
                  (json-name slot)))
          (json-slots class)))

(defmethod shared-initialize ((class json-class) slot-names
                              &rest initargs
                              &key slot-name-to-json-name unknown-slots
                              &allow-other-keys)
  (apply #'call-next-method class slot-names
         (append
           (when slot-name-to-json-name ; todo assert length = 1
             (list :slot-name-to-json-name (first slot-name-to-json-name)))
           (when unknown-slots ; todo assert length = 1
             (list :unknown-slots (first unknown-slots)))
           initargs)))

(defmethod c2mop:finalize-inheritance :after ((class json-class))
  (setf (name-initarg-map class) (make-name-initarg-map class)
        (slot-name-alist class) (make-slot-name-alist class)))


;;;; Read ---------------------------------------------------------------------
(defun parse-json-class (class-name class input)
  (let ((ch (r input)))
    (unless (eql ch #\{)
      (e class-name input "expected ~S but got ~S" #\{ ch)))
  (skip-whitespace input)
  (if (eql (p input) #\})
    (progn
      (r input)
      (make-instance class))
    (loop
      :with unknown = (unknown-slots class)
      :with map = (name-initarg-map class)
      :with init = (list)
      :for name = (read% 'string nil input)
      :for sep = (parse-kv-separator class-name input)
      :for (initarg c cc) = (gethash name map)
      :do (progn
            (if (null initarg)
              (ecase unknown
                (:discard (read% t nil input))
                (:error (e class-name input "got unknown object attribute ~S" name)))
              (progn
                (push (read% c cc input) init)
                (push initarg init)))
            (skip-whitespace input)
            (let ((ch (r input)))
              (case ch
                (#\} (loop-finish))
                (#\, (skip-whitespace input))
                (t (e class-name input "expected ~S or ~S but got ~S." #\} #\, ch)))))
      :finally (return (apply #'make-instance class init)))))

(defmethod read% ((class-name symbol) (contained-class null) (input input))
  (let ((class (find-class class-name nil)))
    (typecase class
      (json-class
        (c2mop:ensure-finalized class)
        (parse-json-class class-name class input))
      (null (error "Cannot find class ~S to parse JSON into." class-name))
      (t (error "Cannot parse JSON into class ~S because that class is not a ~S"
                class-name 'json-class)))))


;;;; Printing -----------------------------------------------------------------
(defmethod print% (thing stream)
  (let ((class (class-of thing)))
    (if (typep class 'json-class)
      (progn
        (write-char #\{ stream)
        (loop :with first = t
              :for (slot . name) :in (slot-name-alist class)
              :when (slot-boundp thing slot)
              :do (progn (if first
                           (setf first nil)
                           (write-char #\, stream))
                         (print% name stream)
                         (write-char #\: stream)
                         (print% (slot-value thing slot) stream)))
        (write-char #\} stream))
      (error "Don't know how to print object ~S of class ~S as JSON." thing class))))


;;;; API ----------------------------------------------------------------------
(defun canonicalize-class-designator (class-designator)
  (flet ((fail () (error "Malformed class designator ~S" class-designator)))
    (etypecase class-designator
      (cons (destructuring-bind (head a &optional (b nil b?)) class-designator
              (ecase head
                ; (vector foo)
                ((hash-table vector)
                 (progn (when b? (fail))
                        (list head (canonicalize-class-designator a))))
                ; (or null foo)
                (or (progn
                      (unless b? (fail)) ; must have a second option
                      (when (eql 'null b) (rotatef a b)) ; sort a/b
                      (unless (eql 'null a) (fail)) ; no arbitrary ors
                      (list 'nullable (canonicalize-class-designator b)))))))
      (symbol (case class-designator
                (vector '(vector (t)))
                (hash-table '(hash-table (t)))
                (t (list class-designator)))))))

(defun ensure-stream (stream-or-string)
  (etypecase stream-or-string
    (stream stream-or-string)
    (string (make-string-input-stream stream-or-string))))

(defun read (class-designator stream-or-string &optional (eof-error-p t) eof)
  (let ((input (make-input :stream (ensure-stream stream-or-string))))
    (skip-whitespace input)
    (if (eql :eof (p input))
      (if eof-error-p
        (error 'end-of-file)
        eof)
      (destructuring-bind (class &optional contained)
          (canonicalize-class-designator class-designator)
        (read% class contained input)))))

(defun print (object &optional (stream *standard-output*))
  (let ((*read-default-float-format* 'double-float)
        (*print-base* 10))
    (etypecase stream
      ((or stream (eql t)) (progn (print% object stream)
                                  (values)))
      (null (with-output-to-string (s)
              (print% object s))))))