src/mop.lisp @ a7ad406182d8

(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-object ()
  ((preserved :accessor preserved :initarg preserved)))

(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)
   (slot-map :accessor slot-map)
   (slot-alist :accessor slot-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)
   (before-print :initarg :json/before-print :accessor before-print)
   (after-read :initarg :json/after-read :accessor after-read)))

(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)
   (before-print :initarg :json/before-print :accessor before-print :initform nil)
   (after-read :initarg :json/after-read :accessor after-read :initform nil)))

(defmethod make-instance ((class (eql (find-class 'json-effective-slot-definition))) &rest initargs)
  ;; We need to wrap this to make sure that every JSON slot has at least one
  ;; initarg, so we can use it when calling `make-instance` during reading.
  ;;
  ;; If none of the direct slots have an initarg, we'll gensym one.  Otherwise
  ;; we can use an existing one and not clutter things up.
  (apply #'call-next-method class
         (append
           (when (null (getf initargs :initargs))
             (list :initargs
                   (list (gensym (string (getf initargs :name))))))
           initargs)))


(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 this stuff
      (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) (first (c2mop:slot-definition-initargs eslot))
            (after-read eslot) (if (slot-boundp dslot 'after-read)
                                 (after-read dslot)
                                 nil)
            (before-print eslot) (if (slot-boundp dslot 'before-print)
                                   (before-print dslot)
                                   nil))
      eslot)))


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

(defun make-slot-map (class)
  "Return a slot map for the JSON slots of `class`, used when reading.

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

  "
  (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 (after-read slot)))))
    result))

(defun make-slot-alist (class)
  "Return a slot alist for the JSON slots of `class`, used when printing.

  The result will be an alist of `((slot . (\"name\" before-print)))`.

  "
  (mapcar (lambda (slot)
            (cons (c2mop:slot-definition-name slot)
                  (list (json-name slot)
                        (before-print slot))))
          (json-slots class)))

(defun patch-direct-superclasses (direct-superclasses)
  "Patch `direct-superclasses` to ensure `json-object` will be a superclass.

  If one of the superclasses is already a `json-class` then `json-object` will
  already be an indirect superclass, so nothing needs to be done.  Otherwise add
  `json-object` to the list of direct superclasses.

  "
  (let ((meta (find-class 'json-class))
        (super (find-class 'json-object)))
    (if (find meta direct-superclasses :key #'class-of)
      direct-superclasses
      (append direct-superclasses (list super)))))

(defmethod shared-initialize :around
  ((class json-class) slot-names
   &rest initargs
   &key slot-name-to-json-name unknown-slots allow-print allow-read direct-superclasses
   &allow-other-keys)
  (flet ((arg (initarg args)
           (when args ; todo assert length = 1
             (list initarg (first args)))))
    (apply #'call-next-method class slot-names
           :direct-superclasses (patch-direct-superclasses direct-superclasses)
           (append (arg :slot-name-to-json-name slot-name-to-json-name)
                   (arg :unknown-slots unknown-slots)
                   (arg :allow-read (or allow-read '(t)))
                   (arg :allow-print (or allow-print '(t)))
                   initargs))))

(defmethod c2mop:finalize-inheritance :after ((class json-class))
  (setf (slot-map class) (make-slot-map class)
        (slot-alist class) (make-slot-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 preserved = nil
      :with unknown = (unknown-slots class)
      :with map = (slot-map class)
      :with init = (list)
      :for name = (read% 'string nil input)
      :for sep = (parse-kv-separator class-name input)
      :for (initarg c cc after-read) = (gethash name map)
      :do (progn
            (if (null initarg)
              (ecase unknown
                (:preserve (setf (gethash name (or preserved (setf preserved (make-hash-table :test #'equal))))
                                 (read% t nil input)))
                (:discard (read% nil nil input))
                (:error (e class-name input "got unknown object attribute ~S" name)))
              (let ((value (read% c cc input)))
                (push (if after-read (funcall after-read value) value) 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 (progn (when preserved
                        (push preserved init)
                        (push 'preserved init))
                      (return (apply #'make-instance class init))))))

(defmethod read% ((class-name symbol) (contained-class null) (input input))
  (let ((wrapper (find-wrapper class-name)))
    (if wrapper
      (read-with-wrapper wrapper 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 -----------------------------------------------------------------
(defun print-json-class (class thing stream &aux (first t))
  (write-char #\{ stream)
  (flet ((print-pair (k v)
           (if first
             (setf first nil)
             (write-char #\, stream))
           (print% k stream)
           (write-char #\: stream)
           (print% v stream)))
    (loop :for (slot name before-print) :in (slot-alist class)
          :when (slot-boundp thing slot)
          :do (let ((value (slot-value thing slot)))
                (print-pair name (if before-print
                                   (funcall before-print value)
                                   value)))
          :finally (when (slot-boundp thing 'preserved)
                     (maphash #'print-pair (slot-value thing 'preserved)))))
  (write-char #\} stream))

(defmethod print% ((thing json-object) stream)
  (let ((class (class-of thing)))
    (if (allow-print class)
      (print-json-class class thing stream)
      (error "Class ~S does not allow printing." class))))