Add :UPDATE class-option to DEFINE-JSON-TYPE

This allows one to add slots to a JSON type
without having to re-specify the old ones; for
convenience.
This commit is contained in:
Jaidyn Ann 2024-08-25 10:53:02 -05:00
parent ba1d62ceb2
commit de0fd8845c

View File

@ -44,6 +44,7 @@ The default value “*” refers to the base JSON-LD-OBJECT type.")
(defvar *http-cache* (make-hash-table :test #'equal)) (defvar *http-cache* (make-hash-table :test #'equal))
(defvar *json-types* (make-hash-table :test #'equal)) (defvar *json-types* (make-hash-table :test #'equal))
(defvar *class-defs* (make-hash-table))
@ -121,9 +122,10 @@ If you would like to change it on an object-level, set the @CONTEXT slot."))
;;; CLOS definition ;;; CLOS definition
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defmacro define-json-type (names direct-superclasses context direct-slots &rest options) (defmacro define-json-type (names direct-superclasses context direct-slots &rest options)
"Used to define a CLOS class and a JSON encoder/decoder for a JSON-LD node-type. "Used to define or update a CLOS class and a JSON encoder/decoder for a
An instance of class will be output, instead of a hash-table, when parsing JSON-LD JSON-LD node-type. An instance of class will be output, instead of a hash-table,
with JSON-LD:PARSE. Instances of this class can be encoded into JSON with YASON:ENCODE. when parsing JSON-LD with JSON-LD:PARSE. Instances of this class can be encoded
into JSON with YASON:ENCODE.
NAMES is a pair with two values: The CLOS class-name, and the name used during NAMES is a pair with two values: The CLOS class-name, and the name used during
encoding as @types value. If only the CLOS class-name is provided, @type will encoding as @types value. If only the CLOS class-name is provided, @type will
@ -153,8 +155,15 @@ By default, a slot will have an accessor named after the class and slot, like
PLACE-RADIUS for the class PLACE and the slot RADIUS. PLACE-RADIUS for the class PLACE and the slot RADIUS.
Set :ACCESSOR to NIL to define no accessor at all. Set :ACCESSOR to NIL to define no accessor at all.
OPTIONS contains ordinary class options, in the format of DEFCLASS; for OPTIONS contains ordinary class options, in the format of DEFCLASS (for example,
instance, :DOCUMENTATION. :DOCUMENTATION), with one exception: The :UPDATE option.
If the :UPDATE class option is non-nil, then DIRECT-SLOTS will be considered an
update to the class, and will be appended to any direct-slots defined during
previous definitions of that class done with DEFINE-JSON-TYPE.
This is for convenience, so that one doesnt have to copy an entire class
defintion over in order to add one or two slots (which is a common occurance
in the ActivityPub landscape).
Here is a brief example partially defining the Place type from ActivityStreams: Here is a brief example partially defining the Place type from ActivityStreams:
@ -165,13 +174,26 @@ Here is a brief example partially defining the “Place” type from ActivityStr
:documentation The latitude of a place.) :documentation The latitude of a place.)
(longitude longitude (longitude longitude
:documentation The longitude of a place.)))" :documentation The longitude of a place.)))"
;; If the definition is an :UPDATE, remove that from OPTIONS and merge the old
;; slots with the new.
(let ((direct-slots (if (assoc :update options)
(progn (setf options (remove-from-alist :update options))
(merge-alists direct-slots
(gethash (car names) *class-defs*)
't))
direct-slots)))
;; Save the direct-slots, in case of future :UPDATEs.
(setf (gethash (car names) *class-defs*) direct-slots)
;; Now, actually define the class, encoder, etc…
`(let ((json-class `(let ((json-class
(define-json-clos-class ,names (define-json-clos-class ,names
,(or direct-superclasses `(json-ld-object)) ,(or direct-superclasses `(json-ld-object))
,direct-slots ,options))) ,direct-slots
,options)))
(define-json-type-encoder ,(car names) ,direct-slots) (define-json-type-encoder ,(car names) ,direct-slots)
(register-json-type ',names (or ',direct-superclasses '(json-ld-object)) ',direct-slots ,context) (register-json-type ',names (or ',direct-superclasses '(json-ld-object)) ',direct-slots ,context)
json-class)) json-class)))
(defmacro define-json-clos-class (names direct-superclasses direct-slots options) (defmacro define-json-clos-class (names direct-superclasses direct-slots options)
"Helper-macro for DEFINE-JSON-TYPE. "Helper-macro for DEFINE-JSON-TYPE.
@ -599,6 +621,23 @@ returned."
"Makes a GET request to URI, returning the resultant string." "Makes a GET request to URI, returning the resultant string."
(dexador:get uri :headers headers :force-string 't)) (dexador:get uri :headers headers :force-string 't))
(defun remove-from-alist (item alist)
"Removes the cell corresponding to ITEM from an association list."
(remove item alist
:test (lambda (key cell)
(eq (car cell) key))))
(defun merge-alists (a b &optional clobberp)
"Merge two association lists, adding all items of A to B not pre-existing in B.
If CLOBBERP is set, pre-existing items of B will be overwritten regardless."
(loop for cell in a
do (let ((b-has-item-p (assoc (car cell) b)))
(cond ((and b-has-item-p clobberp)
(setf (cdr (assoc (car cell) b)) (cdr cell)))
((not b-has-item-p)
(alexandria:appendf b (list cell))))))
b)
(defun plist-keys (plist) (defun plist-keys (plist)
"Return a list of keys in a property list." "Return a list of keys in a property list."
(remove-if #'not (remove-if #'not
@ -606,12 +645,12 @@ returned."
for i from 0 for i from 0
collect (when (evenp i) item)))) collect (when (evenp i) item))))
(defun merge-plists (a b) (defun merge-plists (a b &optional clobberp)
"Merge two property lists, favouring adding all properties of A to B not "Merge two property lists, adding all properties of A to B not pre-existing
pre-existing in B." in B. If CLOBBERP is set, pre-existing properties of B will be overwritten."
(let ((a-keys (plist-keys a)) (let ((a-keys (plist-keys a))
(b-keys (plist-keys b))) (b-keys (plist-keys b)))
(loop for key in a-keys (loop for key in a-keys
do (when (not (find key b-keys)) do (when (or clobberp (not (find key b-keys)))
(setf (getf b key) (getf a key)))) (setf (getf b key) (getf a key))))
b)) b))