JSON tweaks: Objects-in-objects, ignore nil slots

… I’m not even sure what I committed earlier.

src/activity-vocabulary.lisp

@@ -22,6 +22,7 @@
   ;; One should never USE this package, since some class-names shadow
   ;; core Common Lisp symbols! Beware! :P
   (:export
+   ;; Classes
    :accept :activity :add :announce :application :arrive :article :audio
    :collection :collection-page :create :delete :dislike :document :event :flag
    :follow :group :ignore :ignore :image :intransitive-activity :invite :join
@@ -29,8 +30,27 @@
    :ordered-collection :ordered-collection-page :organization :page :person
    :place :profile :question :read :reject :relationship :remove :service
    :tentative-accept :tentative-reject :tombstone :travel :undo :update :video
-   :view))
+   :view
-
+   ;; Slots
+   :activity-actor :activity-instrument :activity-object :activity-origin
+   :activity-result :activity-target
+   :collection-current :collection-first :collection-items :collection-last
+   :collection-total-items
+   :collection-page-next :collection-page-part-of :collection-page-prev
+   :link-height :link-href :link-hreflang :link-media-type :link-name
+   :link-preview :link-rel :link-width
+   :object-attachment :object-attributed-to :object-audience :object-bcc
+   :object-bto :object-cc :object-content :object-context :object-duration
+   :object-end-time :object-generator :object-icon :object-image
+   :object-in-reply-to :object-location :object-media-type :object-name
+   :object-preview :object-published :object-replies :object-start-time
+   :object-summary :object-tag :object-to :object-updated :object-url
+   :ordered-collection-page-start-index
+   :place-accuracy :place-altitude :place-latitude :place-longitude
+   :place-radius :place-units
+   :profile-describes
+   :relationship-object :relationship-relationship :relationship-subject
+   :tombstone-former-type :tombstone-deleted))
 
 (in-package #:activitypub-servist/activity-vocabulary)
 
@@ -59,7 +79,8 @@ is equivalent to
          (typecase slot
            (list slot)
            (t (list slot :accessor (intern (format nil "~A-~A" name slot))
-                         :initarg  (intern (symbol-name slot) "KEYWORD")))))
+                         :initarg  (intern (symbol-name slot) "KEYWORD")
+                         :initform nil))))
        slots)
      ,@options))
 
@@ -73,6 +94,17 @@ of NAME."
              `(defclass ,a (,name) ()))
            direct-children)))
 
+(defmacro define-yason-encode-slots-to-camel-cased-keys (class)
+  "Define a YASON:ENCODE-SLOTS method for a CLASS, which simply encodes all of
+CLASS’es slots with JSON keys based on the camel-cased slot name."
+  (append
+   `(defmethod yason:encode-slots progn ((obj ,class)))
+   (mapcar (lambda (slot-key-pair)
+             `(let ((value (slot-value obj ',(car slot-key-pair))))
+                (when value
+                  (yason:encode-object-element ,(cdr slot-key-pair) value))))
+      (class-slots-to-camel-cased-strings-alist class))))
+
 
 
 ;;; Core types
@@ -81,9 +113,14 @@ of NAME."
 (defclass-w-accessors object ()
   (
    attachment attributed-to audience bcc bto cc content context
-   duration end-time generator icon image in-reply-to location
+   duration end-time generator icon id image in-reply-to location
    media-type name preview published replies start-time summary
-   tag to updated url))
+   tag to updated url
+   (@context :initform "https://www.w3.org/ns/activitystreams")))
+
+(defmethod yason:encode ((obj object) &optional (stream *standard-output*))
+  (yason:with-output (stream)
+    (yason:encode-object obj)))
 
 ;; https://www.w3.org/ns/activitystreams#Link
 (defclass-w-accessors link ()
@@ -131,7 +168,7 @@ of NAME."
 
 ;;; Extended Actor types
 ;;; ————————————————————————————————————————
-(defclass-empty-children actor
+(defclass-empty-children object
   (application group organization person service))
 
 
@@ -166,3 +203,39 @@ of NAME."
 ;;; ————————————————————————————————————————
 (defclass-empty-children link
   (mention))
+
+
+
+;;; JSON serialization
+;;; ————————————————————————————————————————
+;; Ensure all classes have their slots’ encodings defined with YASON.
+(mapcar (lambda (class)
+          (closer-mop:finalize-inheritance class)
+          (eval `(define-yason-encode-slots-to-camel-cased-keys ,class)))
+        (mapcar #'find-class
+                '(object link activity collection collection-page
+                  ordered-collection-page place profile relationship tombstone)))
+
+
+
+;;; Util
+;;; ————————————————————————————————————————
+(defun class-slots-to-camel-cased-strings-alist (class)
+  "Return an associative list of a CLASS’es direct slots (by symbol) matched with
+their names in camel-case format."
+  (mapcar
+   (lambda (slot)
+     (let ((name (closer-mop:slot-definition-name slot)))
+      (cons name (camel-case (symbol-name name)))))
+   (closer-mop:class-direct-slots class)))
+
+(defun camel-case (string)
+  "Convert a STRING to camel-casing.
+Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
+character at the start of the string gets erroneously (or at least undesireably,
+to us) removed."
+  (if (not (alphanumericp (aref string 0)))
+      (concatenate 'string
+                   (string (aref string 0))
+                   (str:camel-case string))
+      (str:camel-case string)))