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 |
af3ef34fe3ba |
children |
f91e6bc7fd56 |
(in-package :jarl)
(defvar *global-wrappers* (make-hash-table :test 'eq))
(defvar *wrappers* (list))
(defun make-wrapper (underlying-class-designator read print)
(list (canonicalize-class-designator underlying-class-designator) read print))
(defun wrapper-c (wrapper) (first (first wrapper)))
(defun wrapper-cc (wrapper) (second (first wrapper)))
(defun wrapper-read (wrapper) (second wrapper))
(defun wrapper-print (wrapper) (third wrapper))
(defun set-global-wrapper (class underlying-class-designator &key read print)
(check-type class symbol)
;; TODO Sanity check that there's not alread a json-class here? Or mabye not.
(setf (gethash class *global-wrappers*)
(make-wrapper underlying-class-designator read print)))
(defun remove-global-wrapper (class)
(check-type class symbol)
(remhash class *global-wrappers*))
(defun find-wrapper (class)
(dolist (wrappers *wrappers* (gethash class *global-wrappers*))
(let ((wrapper (getf wrappers class)))
(when wrapper
(return wrapper)))))
(defmacro with-wrappers (bindings &body body)
(flet ((binding-to-plist-entry (binding)
(destructuring-bind (class underlying-class-designator &key read print)
binding
(check-type class symbol)
(list `',class `(make-wrapper ,underlying-class-designator ,read ,print)))))
(let ((wrappers (mapcan #'binding-to-plist-entry bindings)))
;; todo optimize when everything is constant
`(let (,@(when wrappers
(list `(*wrappers* (cons (list ,@wrappers) *wrappers*)))))
,@body))))
(defun read-with-wrapper (wrapper input)
(funcall (wrapper-read wrapper)
(read% (wrapper-c wrapper) (wrapper-cc wrapper) input)))
(defun print-with-wrapper (wrapper thing stream)
(print% (funcall (wrapper-print wrapper) thing) stream))
(defmethod print% (thing stream)
(let* ((class (class-of thing))
(wrapper (find-wrapper (class-name class))))
(if wrapper
(print-with-wrapper wrapper thing stream)
(error "Don't know how to print object ~S of class ~S as JSON, ~
because it's not a JSON class and doesn't have any wrapper(s)."
thing class))))