Reformatting/factoring; no functional changes

This commit is contained in:
Jaidyn Ann 2024-08-16 23:46:46 -05:00
parent 7be6b396ee
commit 14f2f8f4da

View File

@ -19,7 +19,7 @@
(:use #:cl) (:use #:cl)
(:nicknames "AS/JSON-LD" "JSON-LD") (:nicknames "AS/JSON-LD" "JSON-LD")
(:export (:export
#:define-json-class)) #:define-json-type #:json-ld-context))
(in-package #:activity-servist/json-ld) (in-package #:activity-servist/json-ld)
@ -29,16 +29,32 @@
(defvar *http-cache* (make-hash-table :test #'equal)) (defvar *http-cache* (make-hash-table :test #'equal))
(defvar *json-types* ()) (defvar *json-types* ())
;;; Base class
;;; ————————————————————————————————————————
(defclass json-ld-type () (defclass json-ld-type ()
((@context :initform "https://www.w3.org/ns/activitystreams"))) ((@context :initform "https://www.w3.org/ns/activitystreams")))
(defgeneric json-ld-context (obj)
(:documentation
"Returns a JSON-LD CLOS objects @context, for use in JSON-encoding of the
object.
The implementation for the JSON-LD-TYPE class simply returns the @context slots
value. If you would like to have more a more elaborate logic to @context, you
should override this method."))
(defmethod json-ld-context ((obj json-ld-type)) (defmethod json-ld-context ((obj json-ld-type))
(slot-value obj '@context)) (slot-value obj '@context))
(defmethod yason:encode-slots progn ((obj json-ld-type)) (defmethod yason:encode-slots progn ((obj json-ld-type))
(yason:encode-object-element "@context" (json-ld-context obj))) (yason:encode-object-element "@context" (json-ld-context obj)))
(defmacro define-json-class (names direct-superclasses context direct-slots &rest options)
;;; CLOS definition
;;; ————————————————————————————————————————
(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 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 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. with JSON-LD:PARSE. Instances of this class can be encoded into JSON with YASON:ENCODE.
@ -91,13 +107,14 @@ Here is a brief example partially defining the “Place” type from ActivityStr
:required T :required T
:documentation The longitude of a place.)))" :documentation The longitude of a place.)))"
`(progn `(progn
(define-json-clos-class ,names ,(or direct-superclasses '(json-ld-type)) ,context ,direct-slots ,options) (define-json-clos-class ,names ,(or direct-superclasses '(json-ld-type))
(define-json-class-encoder ,(car names) ,direct-slots))) ,direct-slots ,options)
(define-json-type-encoder ,(car names) ,direct-slots)))
(defmacro define-json-clos-class (names direct-superclasses context direct-slots options) (defmacro define-json-clos-class (names direct-superclasses direct-slots options)
"Helper-macro for DEFINE-JSON-CLASS. "Helper-macro for DEFINE-JSON-TYPE.
This actually defines the CLOS class for a JSON-LD node-type. This actually defines the CLOS class for a JSON-LD node-type.
See DEFINE-JSON-CLASSs docstring for a description of parameters." See DEFINE-JSON-TYPEs docstring for a description of parameters."
(append `(defclass ,(car names) ,direct-superclasses (append `(defclass ,(car names) ,direct-superclasses
,(mapcar (lambda (slot) ,(mapcar (lambda (slot)
(let* ((our-slot-opts (let* ((our-slot-opts
@ -110,30 +127,20 @@ See DEFINE-JSON-CLASSs docstring for a description of parameters."
direct-slots)) direct-slots))
options)) 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) (defun json-type-slot-options (class-name slot-name slot-opts)
"Return DEFCLASS-format slot options from DEFINE-JSON-CLASS-format SLOT-OPTS, "Return DEFCLASS-format slot options from DEFINE-JSON-TYPE-format SLOT-OPTS,
applying default slot-options, etc." applying default slot-options, etc."
(json-type-normalize-slot-options (json-type-normalize-slot-options
(merge-plists (json-type-implicit-slot-options class-name slot-name) (merge-plists (json-type-implicit-slot-options class-name slot-name)
slot-opts))) slot-opts)))
(defun json-type-implicit-slot-options (class-name slot-name) (defun json-type-implicit-slot-options (class-name slot-name)
"Return default property-list slot options for a JSON-type CLOS class." "Return default property-list slot options for a json-type CLOS class."
(list :initform nil (list :initform nil
:accessor (intern (format nil "~A-~A" class-name slot-name)))) :accessor (intern (format nil "~A-~A" class-name slot-name))))
(defun json-type-normalize-slot-options (slot-opts) (defun json-type-normalize-slot-options (slot-opts)
"Take property-list slot options from a DEFINE-JSON-CLASS format and massage it "Take property-list slot options from a DEFINE-JSON-TYPE format and massage it
into a DEFCLASS format." into a DEFCLASS format."
(let* ((required (getf slot-opts :required)) (let* ((required (getf slot-opts :required))
(sans-required (alexandria:remove-from-plist slot-opts :required)) (sans-required (alexandria:remove-from-plist slot-opts :required))
@ -147,6 +154,20 @@ into a DEFCLASS format."
sans-accessor-maybe)) sans-accessor-maybe))
;;; Encoding
;;; ————————————————————————————————————————
(defmacro define-json-type-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-TYPEs 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)))
;;; Parsing ;;; Parsing
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————