src/json-ld.lisp

@@ -19,7 +19,7 @@
   (:use #:cl)
   (:nicknames "AS/JSON-LD" "JSON-LD")
   (:export
-   #:define-json-type #:json-ld-context))
+   #:define-json-class))
 
 (in-package #:activity-servist/json-ld)
 
@@ -27,48 +27,18 @@
 ;;; Globals
 ;;; ————————————————————————————————————————
 (defvar *http-cache* (make-hash-table :test #'equal))
-(defvar *json-types* (make-hash-table :test #'equal))
+(defvar *json-types* ())
 
-
-
-;;; Base class
-;;; ————————————————————————————————————————
 (defclass json-ld-type ()
-  ((@context
-    :initform nil
-    :documentation
-    "Used as an override for a class’es @context during encoding.
-The method JSON-LD-CONTEXT is how the contents of encoded @context is
-determined; to change a class’es default/calculated @context, override that
-method. This slot is for changing a specific object’s @context.")
-   (etc
-    :initform nil
-    :documentation
-    "Components of the JSON object which, during parsing, did not match any specific
-slot. This is often filled up in the case of undefined node-types or non-adherent
-object definitions.")))
-
-(defgeneric json-ld-context (obj)
-  (:documentation
-   "Returns a JSON-LD CLOS object’s @context, for use in JSON-encoding of the
-object.
-The implementation for the JSON-LD-TYPE class simply returns the activitystreams
-URL.
-If you would like to change @context on a class-level, override this method.
-If you would like to change it on an object-level, set the @CONTEXT slot."))
+  ((@context :initform "https://www.w3.org/ns/activitystreams")))
 
 (defmethod json-ld-context ((obj json-ld-type))
-  (or (slot-value obj '@context)
-      "https://www.w3.org/ns/activitystreams"))
+  (slot-value obj '@context))
 
 (defmethod yason:encode-slots progn ((obj json-ld-type))
   (yason:encode-object-element "@context" (json-ld-context obj)))
 
-
-
-;;; CLOS definition
-;;; ————————————————————————————————————————
-(defmacro define-json-type (names direct-superclasses context direct-slots &rest options)
+(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.
@@ -120,18 +90,14 @@ Here is a brief example partially defining the “Place” type from ActivityStr
      (longitude “longitude”
                 :required T
                 :documentation “The longitude of a place.”)))"
-  `(let ((json-class
-           (define-json-clos-class ,names
-               ,(or direct-superclasses `(json-ld-type))
-             ,direct-slots ,options)))
-     (define-json-type-encoder ,(car names) ,direct-slots)
-     (register-json-type ',names ',direct-slots ,context)
-     json-class))
+  `(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 direct-slots options)
-  "Helper-macro for DEFINE-JSON-TYPE.
+(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-TYPE’s docstring for a description of parameters."
+See DEFINE-JSON-CLASS’s docstring for a description of parameters."
   (append `(defclass ,(car names) ,direct-superclasses
              ,(mapcar (lambda (slot)
                         (let* ((our-slot-opts
@@ -144,20 +110,30 @@ See DEFINE-JSON-TYPE’s docstring for a description of parameters."
                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-TYPE-format 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."
+  "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-TYPE format and massage it
+  "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))
@@ -171,131 +147,42 @@ into a DEFCLASS format."
     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-TYPE’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)))
-
-
 
 ;;; Parsing
 ;;; ————————————————————————————————————————
-(defun register-json-type (names direct-slots context)
-  "Register a JSON node-type. This allows PARSE to recognize the type (and
-corresponding CLOS class) of a node."
-  (let* ((ctx       (parse-context context))
-         (type-iri  (getf (gethash (cadr names) ctx) :id))
-         (type-name (or type-iri (cadr names))))
-    (setf (gethash type-name *json-types*)
-          (json-type-registry-list names ctx direct-slots))))
-
-(defun json-type-registry-list (names parsed-context direct-slots)
-  "Return a REGISTER-JSON-TYPE-formed registry entry, a simple list of the form:
-  (TYPE-IRI (PROPERTY-NAME SLOT-NAME) ⋯ (PROPERTY-NAME SLOT-NAME))
-… where TYPE-IRI is the (hopefully) fully-resolved IRI form of the node-type’s
-name, though it might be unresolved if context was unprovided or lacking."
-  (append (list (cons (car names) (cadr names)))
-          (mapcar
-           (lambda (slot)
-             (when (cadr slot)
-               (let* ((property-name (cadr slot))
-                      (slot-name     (car slot))
-                      (ctx-item      (gethash property-name parsed-context))
-                      (url           (or (getf ctx-item :id)
-                                         property-name)))
-                 (cons url (cons slot-name property-name)))))
-           direct-slots)))
-
 (defun parse (str)
   "Parse the JSON-LD document contained in STR."
-  (let ((ctx     (make-hash-table :test #'equal)) ; Parsed context: IRI→name,etc.
-        (rev-ctx (make-hash-table :test #'equal)) ; Inversed ctx: name→IRI
+  (let ((ctx    (make-hash-table :test #'equal))
         (parsed (yason:parse str)))
-    (values (parse-item parsed ctx rev-ctx)
+    (values (parse-item parsed ctx)
             ctx)))
 
-(defun parse-item (item &optional ctx rev-ctx)
+(defun parse-item (item &optional ctx)
   "Parse an individual ITEM of a YASON-decoded JSON-LD document."
   (typecase item
-    (hash-table (parse-table item ctx rev-ctx))
+    (hash-table (parse-object item ctx))
     (list       (mapcar (lambda (a) (parse-item a ctx)) item))
     (T          item)))
 
-(defun parse-table (table &optional ctx rev-ctx)
+(defun parse-object (table &optional ctx)
   "Parse a JSON “node object” (as decoded by YASON into a hash-TABLE."
   (let ((ctx (parse-context (gethash "@context" table) ctx)))
-    ;; Update our inverted context-table, so we can resolve property-names→IRIs.
-    (when (not (eq (hash-table-count rev-ctx)
-                   (hash-table-count ctx)))
-      (copy-hash-table-to ctx rev-ctx)
-      (invert-hash-table rev-ctx (lambda (val)
-                                   (getf val :id))))
-    ;; Now, actually parse.
-    (let* ((parsed-table (parse-table-inplace table ctx))
-           (type         (identify-json-type table ctx rev-ctx))
-           (typedef      (gethash type *json-types*)))
-      (if typedef
-          (parse-table-into-object parsed-table typedef ctx rev-ctx) ; We prefer this!
-          parsed-table)))) ; … but just in case you wanna use an undefined type…
-
-(defun parse-table-inplace (table ctx)
-  "Expand a YASON-parsed JSON-LD node-object in TABLE. That is, replace all
-property-names (like, say, “duration”) with their uncompacted-IRI forms
-(like “https://www.w3.org/ns/activitystreams#duration”).
-CTX should be the parsed-context corresponding to the table."
-  (maphash
-   (lambda (old-key val)
-     (let* ((key-ctx  (gethash old-key ctx))
-            (key-iri  (getf key-ctx :id))
-            (key-type (getf key-ctx :type))
-            (new-key  (or key-iri old-key)))
-       (when key-ctx
-         (if (not (equal old-key new-key))
-             (remhash old-key table))
-         (setf (gethash new-key table)
-               (parse-item
-                val
-                (or (and (hash-table-p val) (alexandria:copy-hash-table ctx))
-                    ctx))))))
-   table)
-  table)
-
-(defun parse-table-into-object (table type-def ctx rev-ctx)
-  "Parse an expanded-form JSON-LD object (TABLE) into a CLOS object.
-TYPE-DEF is a type-definition list of the form found in *JSON-TYPES* and made
-by REGISTER-JSON-TYPE.
-CTX is the according parsed-context, and REV-CTX is the reversed
-(IRI → property-name) context."
-  (let ((obj (make-instance (caar type-def))))
     (maphash
-     (lambda (property value)
-       (let* ((property-def  (assoc property type-def :test #'equal))
-              (slot-name     (second property-def))
-              (etc-value     (slot-value obj 'etc)))
-         (if property-def
-             (setf (slot-value obj slot-name) value)
-             (setf (slot-value obj 'etc)
-                   (append etc-value
-                           (list (cons property value)))))))
+     (lambda (old-key val)
+       (let* ((key-ctx  (gethash old-key ctx))
+              (key-iri  (getf key-ctx :id))
+              (key-type (getf key-ctx :type))
+              (new-key  (or key-iri old-key)))
+         (when key-ctx
+           (if (not (equal old-key new-key))
+               (remhash old-key table))
+           (setf (gethash new-key table)
+                 (parse-item
+                  val
+                  (or (and (hash-table-p val) (alexandria:copy-hash-table ctx))
+                      ctx))))))
      table)
-    (setf (slot-value obj '@context) (gethash "@context" table))
-    obj))
-
-(defun identify-json-type (table ctx rev-ctx)
-  "Given an parsed JSON-LD object’s hash-TABLE, return the name/IRI of the
-JSON-type that best suits the object — using the types registered into
-*JSON-TYPES* with REGISTER-JSON-TYPE."
-  (let* ((type (gethash "@type" table)))
-    (or (getf (gethash type ctx) :id)
-        type)))
+    table))
 
 
 
@@ -339,7 +226,7 @@ yet been parsed into CTX."
   (typecase item
    (string     (parse-remote-context ctx item))
    (hash-table (parse-context-map    ctx item))
-   (T           nil)))
+   (:otherwise nil)))
 
 (defun parse-remote-context (ctx uri)
   "Parse a remote JSON-LD context at URI, adding its terms to the CTX
@@ -472,47 +359,3 @@ returned."
 (defun http-get (uri &key headers)
   "Makes a GET request to URI, returning the resultant string."
   (dexador:get uri :headers headers :force-string 't))
-
-(defun invert-hash-table (table &optional tf)
-  "Return a copy of TABLE with the keys and values inverted.
-All values are the new keys for the old keys, and all old keys are…
-wait, I’m getting confused now. Oh, whatever, you know what’s up!
-
-Optionally, a TF function can be provided, which will be executed
-with the new key as its parameter, and whose return-value will be
-the key. Useful for sanitization!"
-  (let ((new-table (alexandria:copy-hash-table table)))
-    (maphash (lambda (old-key old-val)
-               (let ((new-key (if tf (funcall tf old-val) old-val)))
-                 (remhash old-key new-table)
-                 (setf (gethash new-key new-table) old-key)))
-             new-table)
-    new-table))
-
-(defun copy-hash-table-to (from to &optional (clobber nil))
-  "Shallowly copies the keys+values of hash-table FROM into TO.
-If CLOBBER is set, old-values in TO will be overwritten."
-  (maphash (lambda (key val)
-             (let ((in-to (gethash key to)))
-               (when (or (and clobber in-to)
-                         (not in-to))
-                     (setf (gethash key to) val))))
-           from)
-  to)
-
-(defun plist-keys (plist)
-  "Return a list of keys in a property list."
-  (remove-if #'not
-   (loop for item in plist
-         for i from 0
-         collect (when (evenp i) item))))
-
-(defun merge-plists (a b)
-  "Merge two property lists, favouring adding all properties of A to B not
-pre-existing in B."
-  (let ((a-keys (plist-keys a))
-        (b-keys (plist-keys b)))
-    (loop for key in a-keys
-          do (when (not (find key b-keys))
-               (setf (getf b key) (getf a key))))
-    b))