From 4964c679eec5525f9407dd605a28dc1fd9501f2b Mon Sep 17 00:00:00 2001
From: Jaidyn Ann <10477760+JadedCtrl@users.noreply.github.com>
Date: Sat, 24 Aug 2024 11:59:02 -0500
Subject: [PATCH] Normalize/flatten @contexts before encoding
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

So that json-ld-objects contained in other
jons-ld-objects don’t have their @contexs
repeated a million times unnecessarily.
---
 src/json-ld.lisp | 89 ++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 83 insertions(+), 6 deletions(-)

diff --git a/src/json-ld.lisp b/src/json-ld.lisp
index b83288e..6c6cda9 100644
--- a/src/json-ld.lisp
+++ b/src/json-ld.lisp
@@ -19,7 +19,10 @@
   (:use #:cl)
   (:nicknames "AS/JSON-LD" "JSON-LD")
   (:export
+   ;; Functions/Macros
    #:parse #:define-json-type
+   ;; Symbols
+   #:no-@context
    ;; Accessors
    #:json-ld-context #:json-ld-etc #:json-ld-id #:json-ld-type
    ;; Slots
@@ -79,10 +82,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 +253,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)
@@ -334,6 +339,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 +428,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
 ;;; ————————————————————————————————————————