src/mop.lisp @ 8e500ea0d9ff

(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)
   (allow-print :accessor allow-print :initarg :allow-print :initform t)
   (allow-read :accessor allow-read :initarg :allow-read :initform t)))

(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-print allow-read
                              &allow-other-keys)
  (flet ((arg (initarg args)
           (when args ; todo assert length = 1
             (list initarg (first args)))))
    (apply #'call-next-method class slot-names
           (append (arg :slot-name-to-json-name slot-name-to-json-name)
                   (arg :unknown-slots unknown-slots)
                   (arg :allow-read allow-read)
                   (arg :allow-print allow-print)
                   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)
  (unless (allow-read class)
    (error "Class ~S does not allow reading." class))
  (let ((ch (r input)))
    (unless (eql ch #\{)
      (e class-name input "expected ~S but got ~S" #\{ ch)))
  (incf-depth input)
  (skip-whitespace input)
  (if (eql (p input) #\})
    (progn (r input)
           (decf-depth 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
                (#\} (decf-depth input) (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)))
    (cond
      ((not (typep class 'json-class))
       (error "Don't know how to print object ~S of class ~S as JSON." thing class))
      ((not (allow-print class))
       (error "Class ~S does not allow printing." class))
      (t
       (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)))))