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.

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))