5a32a34392a2

--- a/src/main.lisp	Wed Jul 22 20:17:30 2020 -0400
+++ b/src/main.lisp	Tue Jul 28 21:28:29 2020 -0400
@@ -272,35 +272,47 @@
 
 
 (defclass json-direct-slot-definition (c2mop:standard-direct-slot-definition)
-  ((json-name :initarg :json/name :accessor json-name)
-   (json-class :initarg :json/class :accessor json-class)))
+  ((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-name :initarg :json/name :accessor json-name)
-   (json-class :initarg :json/class :accessor json-class)
+  ((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)
-  (declare (ignore initargs))
-  (find-class 'json-direct-slot-definition))
+  (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))
-  (find-class 'json-effective-slot-definition))
+  ;; 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)
-  (let ((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))
+  (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)
@@ -308,6 +320,11 @@
                  (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)
@@ -508,46 +525,3 @@
       (null (with-output-to-string (s)
               (print% object s))))))
 
-
-#; Scratch --------------------------------------------------------------------
-
-(defclass a () ())
-(defclass b () ())
-(defclass c () ())
-(defclass d () ())
-
-(defclass post (a b c)
-  ((id :json/class number)
-   (title :json/class string)
-   (body :json/class string)
-   (author :json/class user)
-   (extra))
-  (:metaclass json-class)
-  (:unknown-slots :discard))
-
-(defclass user ()
-  ((id :json/class number :initarg :id)
-   (name :json/class string)
-   (friends :json/class (vector number)))
-  (:metaclass json-class))
-
-
-(find-class 'user)
-(find-class 'post)
-(find-class 'wat)
-
-(make-instance 'user :id 1)
-(make-instance 'post)
-
-(setf (find-class 'post) nil (find-class 'user) nil)
-
-(print (read '(vector post) (substitute #\" #\' "[{
-    'id': 69,
-    'body': 'oh my christ, it works!',
-    'author': {
-        'id': 101,
-        'name': 'sjl',
-        'friends': [1,2,3]
-    },
-    'wat': 1
-  }]")))