Begin CLOS-based system for JSON-LD encoding/etc

So far, defining a JSON-LD node-type automagically
defines a CLOS class and a YASON-encoder; what
remains is the decoder.

… and also @context-propagation  in the encoder.
This commit is contained in:
Jaidyn Ann 2024-08-16 22:33:40 -05:00
parent 0f93516cab
commit 7be6b396ee

View File

@ -17,7 +17,9 @@
(defpackage #:activity-servist/json-ld
(:use #:cl)
(:nicknames "AS/JSON-LD" "JSON-LD"))
(:nicknames "AS/JSON-LD" "JSON-LD")
(:export
#:define-json-class))
(in-package #:activity-servist/json-ld)
@ -25,6 +27,124 @@
;;; Globals
;;; ————————————————————————————————————————
(defvar *http-cache* (make-hash-table :test #'equal))
(defvar *json-types* ())
(defclass json-ld-type ()
((@context :initform "https://www.w3.org/ns/activitystreams")))
(defmethod json-ld-context ((obj json-ld-type))
(slot-value obj '@context))
(defmethod yason:encode-slots progn ((obj json-ld-type))
(yason:encode-object-element "@context" (json-ld-context obj)))
(defmacro define-json-class (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.
An instance of class will be output, instead of a hash-table, 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
encoding as @types value. If only the CLOS class-name is provided, @type will
not be encoded for this object.
DIRECT-SUPERCLASSES is a list of JSON-LD CLOS classes, whose slots and context
this should inherit. JSON-LD-TYPE should be somewhere in the hierarchy, in order
to provide @context; if no superclasses are provided, JSON-LD-TYPE is default.
CONTEXT is a context hash-table, parsed from a JSON-LD context by JSON-LD:PARSE
or JSON-LD:PARSE-CONTEXT. Any terms defined in this context will be used to
resolve names in your class definition including the class-name and slot-names.
DIRECT-SLOTS is a list of slots of the format:
(SLOT-NAME PROPERTY-NAME SLOT-OPTION SLOT-OPTION)
Where SLOT-NAME is the symbol corresponding to the slot and PROPERTY-NAME is the
name used in JSON parsing/encoding. Slots without a PROPERY-NAME will not be
encoded nor decoded in JSON.
SLOT-OPTIONS are key/value pairs in the format of DEFCLASSes slot-options.
Keywords such as :INITFORM, :DOCUMENTATION, etc. can be used.
There are two keywords with behavior unlike DEFCLASS, however:
:REQUIRED and :ACCESSOR.
By default, a slot will have an init-form of NIL; this can of course be
overridden by putting :INITFORM yourself in the slot definition.
Set :REQUIRED to T to not set :INITFORM at all, effectively making the slot
required.
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.
Set :ACCESSOR to NIL to define no accessor at all.
OPTIONS contains ordinary class options, in the format of DEFCLASS; for
instance, :DOCUMENTATION.
Here is a brief example partially defining the Place type from ActivityStreams:
(define-json-type (place Place) (object) ctx
((altitude altitude
:documentation Indicates the altitude of a place.)
(latitude latitude
:required T
:documentation The latitude of a place.)
(longitude longitude
:required T
:documentation The longitude of a place.)))"
`(progn
(define-json-clos-class ,names ,(or direct-superclasses '(json-ld-type)) ,context ,direct-slots ,options)
(define-json-class-encoder ,(car names) ,direct-slots)))
(defmacro define-json-clos-class (names direct-superclasses context direct-slots options)
"Helper-macro for DEFINE-JSON-CLASS.
This actually defines the CLOS class for a JSON-LD node-type.
See DEFINE-JSON-CLASSs docstring for a description of parameters."
(append `(defclass ,(car names) ,direct-superclasses
,(mapcar (lambda (slot)
(let* ((our-slot-opts
(cddr slot))
(slot-opts
(json-type-slot-options (car names) (car slot)
our-slot-opts)))
(append (list (car slot))
slot-opts)))
direct-slots))
options))
(defmacro define-json-class-encoder (class direct-slots)
"Helper-macro for DEFINE-JSON-CLOS-CLASS.
This actually defines the YASON-encoder for a JSON-LD node-type.
CLASS is the class-name; see DEFINE-JSON-CLASSs docstring about DIRECT-SLOTS."
(append
`(defmethod yason:encode-slots progn ((obj ,class)))
(mapcar (lambda (slot)
`(yason:encode-object-element ,(cadr slot) (slot-value obj ',(car slot))))
direct-slots)))
(defun json-type-slot-options (class-name slot-name slot-opts)
"Return DEFCLASS-format slot options from DEFINE-JSON-CLASS-format SLOT-OPTS,
applying default slot-options, etc."
(json-type-normalize-slot-options
(merge-plists (json-type-implicit-slot-options class-name slot-name)
slot-opts)))
(defun json-type-implicit-slot-options (class-name slot-name)
"Return default property-list slot options for a JSON-type CLOS class."
(list :initform nil
:accessor (intern (format nil "~A-~A" class-name slot-name))))
(defun json-type-normalize-slot-options (slot-opts)
"Take property-list slot options from a DEFINE-JSON-CLASS format and massage it
into a DEFCLASS format."
(let* ((required (getf slot-opts :required))
(sans-required (alexandria:remove-from-plist slot-opts :required))
(sans-initform-maybe (if required
(alexandria:remove-from-plist sans-required :initform)
sans-required))
(sans-accessor-maybe (if (and (find :accessor slot-opts)
(not (getf slot-opts :accessor)))
(alexandria:remove-from-plist sans-initform-maybe :accessor)
sans-initform-maybe)))
sans-accessor-maybe))