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:
parent
0f93516cab
commit
7be6b396ee
122
src/json-ld.lisp
122
src/json-ld.lisp
|
@ -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 @type’s 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 DEFCLASS’es 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-CLASS’s 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-CLASS’s 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))
|
||||
|
||||
|
||||
|
||||
|
|
Ŝarĝante…
Reference in New Issue