src/activity-vocabulary.lisp

@@ -22,10 +22,6 @@
   ;; One should never USE this package, since some class-names shadow
   ;; core Common Lisp symbols! Beware! :P
   (:export
-   ;; Functions
-   :parse
-   ;; Globals
-   :*ap-packages*
    ;; Classes
    :accept :activity :add :announce :application :arrive :article :audio
    :collection :collection-page :create :delete :dislike :document :event :flag
@@ -63,18 +59,11 @@
 
 ;;; Globals
 ;;; ————————————————————————————————————————
-(defparameter *ap-packages* (list *package*)
+;; Used in YASON:ENCODE to ensure that a single top-level @context can be
-  "A list of packages in which we should search for AP classes and slot-symbols
+;; created where AP objects contain other AP objects in their slots.
-during JSON parsing. The class-name searched for is simply the value of the JSON
+;; This variable is overridden locally (LET), and should never be
-object’s “type” key. The package first in the list to export such a symbol
+;; modified globally (as we expect it to be nil in top-level objects).
-is the winner.")
+(defparameter *@context* nil)
-
-;; Private, internal variable.
-(defparameter *@context* nil
-  "Used in YASON:ENCODE to ensure that a single top-level @context can be
-created where AP objects contain other AP objects in their slots.
-This variable is overridden locally during encoding (LET), and should never be
-modified globally (as we expect it to be nil in top-level objects.")
 
 
 
@@ -84,13 +73,18 @@ modified globally (as we expect it to be nil in top-level objects.")
   "Identical to DEFCLASS, but with one convenience: A slot definition, if being
 simply a symbol, will default to a slot with an accessor and init-arg named after the
 symbol. The init-arg will be “:symbol”, and the accessor will be “classname-symbol”.
-For example, the following two forms are equivalent:
+For instance,
+
     (defclass-w-accessors PERSON () (AGE
                                      HEIGHT
                                      (NAME :INIT-FORM “Unknown”)))
+```
+is equivalent to
+```
     (defclass PERSON () ((AGE    :INIT-ARG :AGE    :ACCESSOR PERSON-AGE)
                          (HEIGHT :INIT-ARG :HEIGHT :ACCESSOR PERSON-HEIGHT)
-                         (NAME   :INIT-FORM “Unknown”)))"
+                         (NAME   :INIT-FORM “Unknown”)))
+```"
   `(defclass ,name ,direct-superclasses
      ,(mapcar
        (lambda (slot)
@@ -228,61 +222,46 @@ again and again, by YASON:ENCODE-SLOTS."
 
 
 
-;;; JSON parsing
+;;; Util
 ;;; ————————————————————————————————————————
-(defun parse (string)
+(defun camel-case (string)
-  "Parse a string containing JSON into an ActivityPub object."
+  "Convert a STRING to camel-casing.
-  (parse-table (yason:parse string)))
+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)))
 
-(defun parse-table (table)
+(defun class-pretty-name (class)
-  "Parse a hash-table corresponding to YASON-parsed JSON into an ActivityPub object."
+  "Return a CLASS’es name in a “pretty” (sentence-capitalized) string."
-  (let* ((class (car (find-registered-classes (gethash "type" table))))
+  (string-capitalize (symbol-name (class-name class))))
-         (obj   (make-instance class)))
-    (loop for key being each hash-key of table
-          for val being each hash-value of table
-          do (let ((slot-sym (car (find-registered-symbols key)))
-                   (val      (parse-value val)))
-               (when slot-sym
-                 (setf (slot-value obj slot-sym) val))))
-    obj))
 
-(defun parse-value (val)
+(defun merge-lists (a b)
-  "Parse the value of a key found in YASON-parsed JSON.
+  "Given lists A and B, merge them into one list non-redundantly — all unique
-All ActivityPub objects (hash-tables containing “type”) will be parsed into
+items in each will be contained in the resultant list."
-ActivityPub objects; all others will parsed into associative lists."
+  (append a (remove-if (lambda (item) (find item a :test #'equal)) b)))
-  (typecase val
-    (hash-table (maybe-parse-table val))
-    (list       (mapcar (lambda (a)
-                          (if (hash-table-p a)
-                              (maybe-parse-table a)
-                              a))
-                        val))
-    (t val)))
-
-(defun maybe-parse-table (table)
-  "If a hash-table seems to be a valid ActivityPub object, attempt parsing it
-into one. Otherwise, parse it into an associative list."
-  (if (gethash "type" table)
-      (parse-table table)
-      (alexandria:hash-table-alist table)))
 
 
 
 ;;; JSON serialization
 ;;; ————————————————————————————————————————
 (defmethod yason:encode ((obj object) &optional (stream *standard-output*))
-  (yason:with-object ()
+  (yason:with-output (stream)
-    (if *@context* ; If this object is nested in another, use old context.
+    (yason:with-object ()
-        (yason:encode-object obj)
+      (if *@context*
-        (let ((*@context* (slot-value obj '@context))) ; Unnested, so create context.
           (yason:encode-object obj)
-          (yason:encode-object-element
+          (let ((*@context* (slot-value obj '@context)))
-           "@context"
+            (yason:encode-object obj)
-           *@context*)))
+            (yason:encode-object-element
-    (yason:encode-object-element
+             "@context"
-     "type"
+             *@context*)))
-     (or (object-type obj)
+      (yason:encode-object-element
-         (class-pretty-name (class-of obj))))))
+       "type"
+       (or (object-type obj)
+           (class-pretty-name (class-of obj)))))))
 
 (defun class-slots-to-camel-cased-strings-alist (class)
   "Return an associative list of a CLASS’es direct slots (by symbol) matched with
@@ -307,47 +286,7 @@ containing both of their elements."
           (if (listp a) a (list a))
           (if (listp b) b (list b))))))
 
-
+;; Ensure all classes have their slots’ encodings defined with YASON.
-
-;;; Util
-;;; ————————————————————————————————————————
-(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)))
-
-(defun class-pretty-name (class)
-  "Return a CLASS’es name in a “pretty” (sentence-capitalized) string."
-  (string-capitalize (symbol-name (class-name class))))
-
-(defun merge-lists (a b)
-  "Given lists A and B, merge them into one list non-redundantly — all unique
-items in each will be contained in the resultant list."
-  (append a (remove-if (lambda (item) (find item a :test #'equal)) b)))
-
-(defun find-registered-symbols (str)
-  "Find all symbols identified by string STR within packages in the
-*ap-packages* list."
-  (mapcar (lambda (package) (find-symbol (string-upcase str) package))
-          *ap-packages*))
-
-(defun find-registered-classes (str)
-  "Find all classes identified by string STR within pacakges in the
-*ap-packages* list."
-  (mapcar (lambda (sym) (find-class sym))
-          (find-registered-symbols str)))
-
-
-
-;;; Defining YASON:ENCODE-SLOTS
-;;; ————————————————————————————————————————
-;; On-the-fly define YASON:ENCODE for each of our distinct AP classes.
 (mapcar (lambda (class)
           (closer-mop:finalize-inheritance class)
           (eval `(define-yason-encode-slots ,class)))