src/mop.lisp @ 96b886c42e68 default tip

(in-package :jarl)

;;;; Dependents Maintenance ---------------------------------------------------
;;; We need to use the MOP dependent maintenance protocol to recompute any
;;; defaulted class options when a superclass changes.

(defclass json-dependent ()
  ((dep :accessor dep :initarg :dep)))

(defun dep= (d class)
  ;; We need to filter out any other dependents other code might have added.
  (and (typep d 'json-dependent)
       (eql (dep d) class)))

(defun ensure-dep (superclass class)
  (c2mop:map-dependents superclass
                        (lambda (d)
                          (when (dep= d class)
                            (return-from ensure-dep))))
  (c2mop:add-dependent superclass (make-instance 'json-dependent :dep class)))

(defun ensure-no-dep (superclass class)
  (c2mop:map-dependents superclass
                        (lambda (d)
                          (when (dep= d class)
                            (c2mop:remove-dependent superclass d)
                            (return-from ensure-no-dep)))))


;;;; JSON Metaclass -----------------------------------------------------------
(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)
  ((given-unknown-slots)
   (given-slot-name-to-json-name)
   (given-allow-print)
   (given-allow-read)
   (unknown-slots :accessor unknown-slots
                  :initarg :unknown-slots
                  :initform :discard)
   (slot-name-to-json-name :accessor slot-name-to-json-name
                           :initarg :slot-name-to-json-name
                           :initform 'lisp-case-to-snake-case)
   (allow-print :accessor allow-print :initarg :allow-print :initform t)
   (allow-read :accessor allow-read :initarg :allow-read :initform t)
   (slot-map :accessor slot-map)
   (slot-alist :accessor slot-alist)))

(defun json-class-p (object)
  (typep object 'json-class))

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

(defun json-direct-slot-p (slot)
  (typep slot 'json-direct-slot-definition))

(defun json-effective-slot-p (slot)
  (typep slot 'json-effective-slot-definition))

(defun json-direct-slots (direct-slots)
  (remove-if-not #'json-direct-slot-p direct-slots))

(defun json-effective-slots (effective-slots)
  (remove-if-not #'json-effective-slot-p effective-slots))


(defmethod make-instance ((class (eql (find-class 'json-effective-slot-definition)))
                          &rest args
                          &key initargs name &allow-other-keys)
  ;; 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 initargs)
                   (list :initargs (list (gensym (string name)))))
                 args)))


(defun plist-keys (plist)
  (loop :for (k) :on plist :by #'cddr :collect k))

(defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs)
  (if (intersection (plist-keys initargs)
                    '(:json :json/name :json/before-print :json/after-read))
    (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)))


(defmacro found-or (form default)
  (let ((result (gensym "RESULT"))
        (found (gensym "FOUND")))
    `(multiple-value-bind (,result ,found) ,form
       (if ,found ,result ,default))))

(defun coalesce-most-specific-value (dslots slot-name)
  "Coalesce the most-specific value of `slot-name` from the JSON direct slots.

  Given a list of JSON direct slot definitions for a particular slot `foo`:

    ((foo :json/name \"x\") ; sub sub
     (foo :json/name \"x\") ; sub
     (foo :json string))    ; super

  Return the most-specific slot value for the given slot name (e.g. \"x\" in
  this example), or `nil` if none is found.

  Also returns `t` as a second value if a value was found.

  "
  (dolist (dslot dslots (values nil nil))
    (when (slot-boundp dslot slot-name)
      (return (values (slot-value dslot slot-name) t)))))

(defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
  (if (not (some #'json-direct-slot-p direct-slots))
    (call-next-method)
    (let* ((*effective-slot-definition-class* (find-class 'json-effective-slot-definition))
           (eslot (call-next-method))
           (dslots (remove-if-not #'json-direct-slot-p direct-slots)))
      (setf (json-name eslot) (found-or (coalesce-most-specific-value dslots 'json-name)
                                        (funcall (slot-name-to-json-name class) name))
            (json-class eslot) (canonicalize-class-designator
                                 (found-or (coalesce-most-specific-value dslots 'json-class) t))
            (json-initarg eslot) (first (c2mop:slot-definition-initargs eslot))
            (after-read eslot) (coalesce-most-specific-value dslots 'after-read)
            (before-print eslot) (coalesce-most-specific-value dslots 'before-print))
      eslot)))


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

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

  "
  (let* ((slots (json-effective-slots effective-slots))
         (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 (effective-slots)
  "Return a slot alist for the JSON slots of `effective-slots`, 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-effective-slots effective-slots)))


(defmethod c2mop:compute-slots :around ((class json-class))
  (let ((effective-slots (call-next-method)))
    (setf (slot-map class) (make-slot-map effective-slots)
          (slot-alist class) (make-slot-alist effective-slots))
    effective-slots))


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

(defun recompute-slot (&key class superclasses slot given-slot value value? default)
  "Set the metaclass' slot to the appropriate value.

  For metaclass slots like `:allow-print`, if the user provides an explicit
  value it will be used, otherwise the value will be inherited from any
  superclass' value, otherwise the default will be used.

  In any case, the computed value is stored in the slot, and the original
  user-given value (if any) is stored in the `given-…` slot so we can use it
  later if any superclasses change and we need to recompute this.

  "
  (setf superclasses (remove-if-not #'json-class-p superclasses))
  ;; We need to store whether the user gave an explicit value for later.
  (if value?
    (setf (slot-value class given-slot) value)
    (slot-makunbound class given-slot))
  ;; Set the actual value to the given value, or the superclass value, or the default.
  (setf (slot-value class slot)
        (cond
          (value? (progn (when (/= 1 (length value))
                           (error "Bad json-class ~A value ~A, expected exactly one value." slot value))
                         (first value)))
          (superclasses (slot-value (first superclasses) slot))
          (t default))))

(defun recompute-slots (class &key
                        direct-superclasses
                        (slot-name-to-json-name nil slot-name-to-json-name?)
                        (unknown-slots nil unknown-slots?)
                        (allow-read nil allow-read?)
                        (allow-print nil allow-print?)
                        &allow-other-keys)
  (recompute-slot :class class :superclasses direct-superclasses
                  :slot 'slot-name-to-json-name :given-slot 'given-slot-name-to-json-name
                  :value slot-name-to-json-name :value? slot-name-to-json-name?
                  :default #'lisp-case-to-snake-case)
  (recompute-slot :class class :superclasses direct-superclasses
                  :slot 'unknown-slots :given-slot 'given-unknown-slots
                  :value unknown-slots :value? unknown-slots?
                  :default :discard)
  (recompute-slot :class class :superclasses direct-superclasses
                  :slot 'allow-print :given-slot 'given-allow-print
                  :value allow-print :value? allow-print?
                  :default t)
  (recompute-slot :class class :superclasses direct-superclasses
                  :slot 'allow-read :given-slot 'given-allow-read
                  :value allow-read :value? allow-read?
                  :default t))

(defun strip-initargs (initargs)
  "Remove any JSON class initargs from `initargs`.

  We need to do this because we handle these ourselves before `call-next-method`,
  in `recompute-slots`, and if we leave them in the initarg list then
  `call-next-method` will happily overwrite all that hard work we just did.

  "
  (loop
    :for (initarg value) :on initargs :by #'cddr
    :unless (member initarg
                    '(:allow-print :allow-read :unknown-slots :slot-name-to-json-name))
    :append (list initarg value)))

(defmethod initialize-instance :around
    ((class json-class) &rest initargs &key
     direct-superclasses
     &allow-other-keys)
  (apply #'recompute-slots class initargs)
  (apply #'call-next-method class
         :direct-superclasses (patch-direct-superclasses direct-superclasses)
         (strip-initargs initargs))
  ;; You might think we could get away with only having dependencies on
  ;; superclasses that happen to be our specific metaclass, instead of on ALL
  ;; direct superclasses.  Sadly this fails for forward-referenced classes, so
  ;; we need to add dependencies on all of them and filter out the non-MC
  ;; classes later.
  (dolist (superclass (c2mop:class-direct-superclasses class))
    (ensure-dep superclass class)))

(defmethod reinitialize-instance :around
  ((class json-class) &rest initargs
   &key (direct-superclasses nil direct-superclasses?) &allow-other-keys)
  ;; We have to recompute slots /before/ we call-next-method because the
  ;; update-dependent calls happen as part of that next method.  If we wait
  ;; until after call-next-method to patch up X, then the dependent will still
  ;; see the old version when it's updated and won't get the new value until
  ;; a second round of initialization.
  (apply #'recompute-slots class
         :direct-superclasses (if direct-superclasses?
                                direct-superclasses
                                (c2mop:class-direct-superclasses class))
         initargs)
  (let ((before (c2mop:class-direct-superclasses class)))
    (apply #'call-next-method class
           (append (when direct-superclasses?
                     (list :direct-superclasses
                           (patch-direct-superclasses direct-superclasses)))
                   (strip-initargs initargs)))
    (let* ((after (c2mop:class-direct-superclasses class))
           (removed (set-difference before after))
           (added (set-difference after before)))
      (dolist (superclass removed)
        (ensure-no-dep superclass class))
      (dolist (superclass added)
        (ensure-dep superclass class)))))

(defun given-to-initarg (class initarg given-slot)
  (when (slot-boundp class given-slot)
    (list initarg (slot-value class given-slot))))

(defmethod c2mop:update-dependent (obj (dep json-dependent) &rest initargs)
  (declare (ignore initargs))
  (when (json-class-p obj) ; We can ignore changes in non-JSON superclasses here.
    ;; We need to call reinitialize-instance here (instead of just recomputing
    ;; the slots) because otherwise transitive dependencies won't get updated
    ;; properly.
    (let ((class (dep dep)))
      (apply #'reinitialize-instance class
             (append
               (given-to-initarg class :slot-name-to-json-name 'given-slot-name-to-json-name)
               (given-to-initarg class :unknown-slots 'given-unknown-slots)
               (given-to-initarg class :allow-print 'given-allow-print)
               (given-to-initarg class :allow-read 'given-allow-read))))))


;;;; 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 (initarg c cc after-read) = (gethash name map)
      :do (progn
            (parse-kv-separator class-name input)
            (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 (error 'unknown-json-slot-error
                               :class-designator class-name
                               :line (input-line input)
                               :column (input-column input)
                               :name name
                               :message (format nil "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 indent &aux (first t))
  (write-char #\{ stream)
  (when indent (incf indent 2))
  (flet ((print-pair (k v)
           (if first
             (setf first nil)
             (write-char #\, stream))
           (indent indent stream)
           (print% k stream indent)
           (write-char #\: stream)
           (when indent (write-char #\space stream))
           (print% v stream indent)))
    (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)))))
  (when (and indent (not first))
    (terpri stream))
  (write-char #\} stream))

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