Tweaks ActivityVocabulary types/inheritance

Now most all parsing+encoding tests pass! Hura!

activity-servist.asd

@@ -87,7 +87,7 @@
   :author "Jaidyn Ann <jadedctrl@posteo.at>"
   :description "Tests for all activity-servist subpacakges."
 
-  :depends-on (:activity-servist/tests/activity-streams
+  :depends-on (:activity-servist/tests/activity-vocabulary
                :activity-servist/tests/json-ld
                :activity-servist/tests/signatures
                :alexandria :lisp-unit2)

src/activity-vocabulary.lisp

@@ -81,7 +81,13 @@ Items of DIRECT-CHILDREN should be of the form,
 ;; https://www.w3.org/ns/activitystreams#Object
 ;; The root of all evil in the world.
 (json-ld::define-json-type (object "Object") () "https://www.w3.org/ns/activitystreams"
-  ((attachment
+  ((@id
+    "id"
+    :documentation "Provides the globally unique identifier for an Object.")
+   (@type
+    "type"
+    :documentation "Identifies the Object type. Multiple values may be specified.")
+   (attachment
     "attachment"
     :documentation "Identifies a resource attached or related to an object that potentially requires special handling. The intent is to provide a model that is at least semantically similar to attachments in email.")
    (attributed-to
@@ -170,7 +176,13 @@ The notion of “context” used is intentionally vague. The intended function i
 ;; looking at Link’s properties), but it’s implied by the Mention example.
 (json-ld:define-json-type (link "Link") ()
   "https://www.w3.org/ns/activitystreams"
-  ((height
+  ((@id
+    "id"
+    :documentation "Provides the globally unique identifier for a Link.")
+   (@type
+    "type"
+    :documentation "Identifies the Link type. Multiple values may be specified.")
+   (height
     "height"
     :documentation "On a Link, specifies a hint as to the rendering height in device-independent pixels of the linked resource.")
    (href
@@ -180,7 +192,7 @@ The notion of “context” used is intentionally vague. The intended function i
     "hreflang"
     :documentation "Hints as to the language used by the target resource. Value MUST be a [BCP47] Language-Tag.")
    (media-type
-    "media-type"
+    "mediaType"
     :documentation "Identifies the MIME media type of the referenced resource.")
    (name
     "name"
@@ -432,10 +444,13 @@ Either of the ANY-OF and ONE-OF properties MAY be used to express possible answe
   "https://www.w3.org/ns/activitystreams"
   ((subject
     "subject"
-    :documentation "On a Relationship object, the subject property identifies one of the connected individuals. For instance, for a Relationship object describing “John is related to Sally”, subject would refer to John.")
+    :documentation "The subject property identifies one of the connected individuals. For instance, for a Relationship object describing “John is related to Sally”, subject would refer to John.")
+   (object
+    "object"
+    :documentation "Describes the entity to which the subject is related.")
    (relationship
     "relationship"
-    :documentation "On a Relationship object, the relationship property identifies the kind of relationship that exists between subject and object."))
+    :documentation "The relationship property identifies the kind of relationship that exists between subject and object."))
   (:documentation "Describes a relationship between two individuals. The subject and object properties are used to identify the connected individuals."))
 
 

src/json-ld.lisp

@@ -19,7 +19,12 @@
   (:use #:cl)
   (:nicknames "AS/JSON-LD" "JSON-LD")
   (:export
+   ;; Functions/Macros
    #:parse #:define-json-type
+   ;; Symbols
+   #:no-@context
+   ;; Globals
+   #:*default-json-type*
    ;; Accessors
    #:json-ld-context #:json-ld-etc #:json-ld-id #:json-ld-type
    ;; Slots
@@ -30,6 +35,13 @@
 
 ;;; Globals
 ;;; ————————————————————————————————————————
+(defvar *default-json-type* "*"
+  "When parsing JSON-LD, objects of unrecognized types will be assumed to be
+of this type. Should be a string, the IRI corresponding to a registered type.
+For example: “https://www.w3.org/ns/activitystreams#Object”
+
+The default value “*” refers to the base JSON-LD-OBJECT type.")
+
 (defvar *http-cache* (make-hash-table :test #'equal))
 (defvar *json-types* (make-hash-table :test #'equal))
 
@@ -79,10 +91,13 @@ 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."))
 
 (defmethod json-ld-context ((obj json-ld-object))
-  (or (slot-value obj '@context)
-      "https://www.w3.org/ns/activitystreams"))
+  (let ((slot-@context (slot-value obj '@context)))
+    (unless (eq slot-@context 'no-@context)
+      (or slot-@context
+          "https://www.w3.org/ns/activitystreams"))))
 
 (defmethod yason:encode-slots progn ((obj json-ld-object))
+  (flatten-contained-contexts obj)
   (let ((context (json-ld-context obj))
         (id      (json-ld-id obj))
         (type    (json-ld-type obj)))
@@ -247,10 +262,9 @@ name, though it might be unresolved if context was unprovided or lacking."
    (reduce (lambda (slots-a slots-b)
              (append slots-a slots-b))
            (mapcar (lambda (class-name)
-                     (let* ((type-name     (class-json-type-name class-name))
-                            (type-registry (gethash type-name *json-types*)))
-                       (if type-registry
-                           type-registry)))
+                     (let* ((type-def (class-json-type-definition class-name)))
+                       (when type-def
+                         (cdr type-def))))
                    direct-superclasses))))
 
 (defun parse (str)
@@ -272,9 +286,9 @@ name, though it might be unresolved if context was unprovided or lacking."
   (let ((ctx (parse-context (gethash "@context" table) ctx)))
     ;; Now, actually parse.
     (let* ((parsed-table (parse-table-inplace table ctx))
-           (type         (identify-json-type table ctx))
-           (type-def      (or (gethash type *json-types*)
-                              (gethash "*"  *json-types*))))
+           (type         (identify-json-type parsed-table ctx))
+           (type-def     (or (gethash type                *json-types*)
+                             (gethash *default-json-type* *json-types*))))
       (parse-table-into-object parsed-table type-def ctx))))
 
 (defun parse-table-inplace (table ctx)
@@ -334,6 +348,12 @@ JSON-type that best suits the object — using the types registered into
         if (eq class-name (caar registry))
           return iri))
 
+(defun class-json-type-definition (class-name)
+  "Return the type-definition from the the registry of JSON types (*JSON-TYPES*),
+based on a CLOS class-name. It is of the form,
+  ((CLASS-NAME TYPE-NAME) (SLOT-NAME PROPERTY-NAME) ⋯ (SLOT-NAME PROPERTY-NAME))"
+  (gethash (class-json-type-name class-name) *json-types*))
+
 
 
 ;;; Context-parsing
@@ -417,6 +437,72 @@ IRI values whose prefix hasn’t yet been parsed into CTX."
     unresolvable))
 
 
+
+;;; Context-normalization
+;;; ————————————————————————————————————————
+(defun flatten-contained-contexts (obj)
+  "“Flattens” the @CONTEXTs of a JSON-LD object and the @CONTEXTs of any contained
+objects, recursively. That is, redundant @CONTEXT-definitions are removed — we
+try to concentrate everything in the top-level object’s @CONTEXT slot.
+This is useful for ensuring the same @CONTEXT doesn’t get output a million times
+during JSON-encoding with YASON:ENCODE."
+  (loop for subobj in (cdr (contained-json-objects obj))
+        do
+           (progn
+             (let ((old-context    (json-ld-context obj))
+                   (old-subcontext (json-ld-context subobj)))
+               (when (and old-subcontext
+                          (not (equal old-context old-subcontext)))
+                 (setf (slot-value obj '@context)
+                       (append (if (listp old-context)
+                                   old-context
+                                   (list old-context))
+                               old-subcontext))))
+             (setf (slot-value subobj '@context) 'no-@context))))
+
+(defun json-slot-values (obj)
+  "Return the values of all registered slots/properties of a JSON-LD-OBJECT.
+Unregistered slots that don’t get encoded/decoded are ignored."
+  (let* ((type-def  (class-json-type-definition (class-name (class-of obj))))
+         (slot-defs (cdr type-def)))
+    (remove-if
+     #'not
+     (append
+      (mapcar (lambda (slot-def)
+                (let* ((slot-name  (cadr slot-def)))
+                  (and (slot-exists-p obj slot-name)
+                       (slot-boundp obj slot-name)
+                       (slot-value obj slot-name))))
+              slot-defs)
+      (mapcar (lambda (etc-cons)
+                (cdr etc-cons))
+              (slot-value obj '.etc))))))
+
+(defun contained-json-objects (item)
+  "Given ITEM of arbitrary type, return all JSON-LD-OBJECTs contained within,
+recursively. Lists, hash-tables, and the slots of JSON-LD-OBJECTs are explored."
+  (typecase item
+    (cons           (reduce
+                     (lambda (a b)
+                       (append a b))
+                     (mapcar (lambda (a) (contained-json-objects a))
+                             item)))
+    (hash-table     (let ((ret '()))
+                      (maphash
+                       (lambda (k v)
+                         (setq ret
+                               (append ret (contained-json-objects v))))
+                       item)
+                      ret))
+    (json-ld-object (append
+                     (list item)
+                     (reduce
+                      (lambda (b c)
+                       (append b c))
+                      (mapcar (lambda (a) (contained-json-objects a))
+                              (json-slot-values item)))))))
+
+
 
 ;;; IRI/keywords
 ;;; ————————————————————————————————————————

t/activity-vocabulary.lisp

@@ -24,7 +24,8 @@
 
 (defun run ()
   "Run all ACTIVITY-VOCABULARY tests."
-  (lisp-unit2:run-tests :package :activity-servist/tests/activity-vocabulary))
+  (let ((json-ld:*default-json-type* "https://www.w3.org/ns/activitystreams#Object"))
+    (lisp-unit2:run-tests :package :activity-servist/tests/activity-vocabulary)))
 
 (defun run-with-summary ()
   "Run tests with summary for ACTIVITY-VOCABULARY."
@@ -37,7 +38,7 @@
 ;;; ————————————————————————————————————————
 (defmacro relative-pathname (path)
   "Return an absolute path adding the relative PATH to the system’s path."
-  `(asdf:system-relative-pathname :activity-servist/tests/activity-streams ,path))
+  `(asdf:system-relative-pathname :activity-servist/tests/activity-vocabulary ,path))
 
 (defmacro define-json-test (path tags)
   "Define a lisp-unit2 test for parsing of the given JSON file.