Fix slot map/alist initialization
Instead of doing this on `finalize-inheritance`, do it after `compute-slots`.
I swear, sometimes using the MOP feels like playing whack-a-mole.
Also adds another real-world test case.
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Mon, 31 Aug 2020 22:18:48 -0400 |
| parents |
8baa554470fd |
| children |
f91e6bc7fd56 |
(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 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)))
(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 (effective-slots)
(remove-if-not (lambda (slot) (typep slot 'json-effective-slot-definition))
effective-slots))
(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-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-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))
(defmethod shared-initialize :around
((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 (or allow-read '(t)))
(arg :allow-print (or allow-print '(t)))
initargs))))
(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 initialize-instance :around
((class json-class) &rest initargs
&key direct-superclasses &allow-other-keys)
;;; I have no idea why doing this once in shared-initialize works in SBCL but
;;; not in CCL/ECL. Oh well. This solution from https://www.cliki.net/MOP%20design%20patterns
;;; seems to work everywhere.
(apply #'call-next-method class
:direct-superclasses (patch-direct-superclasses direct-superclasses)
initargs))
(defmethod reinitialize-instance :around
((class json-class) &rest initargs
&key (direct-superclasses nil direct-superclasses?) &allow-other-keys)
(if direct-superclasses?
(apply #'call-next-method class
:direct-superclasses (patch-direct-superclasses direct-superclasses)
initargs)
(call-next-method)))
;;;; 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 (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))))