Fix encoding of aliased @ID, @CONTEXT, and @TYPE

Previously, aliasing them (like ActivityVocab’s
ID→@ID) would cause them to get encoded twice.
This commit is contained in:
Jaidyn Ann 2024-09-03 11:05:59 -05:00
parent 22ad087a97
commit 8faeb1afd2

View File

@ -61,12 +61,10 @@ The method JSON-LD-CONTEXT is how the contents of encoded @context is
determined; to change a classes default/calculated @context, override that determined; to change a classes default/calculated @context, override that
method. This slot is for changing a specific objects @context.") method. This slot is for changing a specific objects @context.")
(@id (@id
:initform nil
:accessor json-ld-id :accessor json-ld-id
:documentation :documentation
"Provides the globally unique identifier for an object.") "Provides the globally unique identifier for an object.")
(@type (@type
:initform nil
:accessor json-ld-type :accessor json-ld-type
:documentation :documentation
"Identifies the type of an object. Used to determine the corresponding CLOS-object.") "Identifies the type of an object. Used to determine the corresponding CLOS-object.")
@ -101,15 +99,25 @@ If you would like to change it on an object-level, set the @CONTEXT slot."))
(defmethod yason:encode-slots progn ((obj json-ld-object)) (defmethod yason:encode-slots progn ((obj json-ld-object))
(flatten-contained-contexts obj) (flatten-contained-contexts obj)
(let ((context (json-ld-context obj)) ;; We only want to encode @context, @id, and @type if the child class doesnt
(id (json-ld-id obj)) ;; have its own alias for them.
(type (json-ld-type obj))) (flet ((aliased-prop-p (property-name type-def)
(when context (not (equal property-name
(yason:encode-object-element "@context" (json-ld-context obj))) (cddr (assoc property-name type-def :test #'equal))))))
(when id (let* ((class-name (class-name (class-of obj)))
(yason:encode-object-element "@id" (json-ld-id obj))) (type-def (cdr (class-json-type-definition class-name)))
(when type (no-context-p (aliased-prop-p "@context" type-def))
(yason:encode-object-element "@type" (json-ld-type obj)))) (no-id-p (aliased-prop-p "@id" type-def))
(no-type-p (aliased-prop-p "@type" type-def))
(context (json-ld-context obj))
(id (and (slot-boundp obj '@id) (json-ld-id obj)))
(type (and (slot-boundp obj '@type) (json-ld-type obj))))
(when (and context (not no-context-p))
(yason:encode-object-element "@context" context))
(when (and id (not no-id-p))
(yason:encode-object-element "@id" id))
(when (and type (not no-type-p))
(yason:encode-object-element "@type" type))))
(mapcar (lambda (alist-cell) (mapcar (lambda (alist-cell)
(yason:encode-object-element (car alist-cell) (yason:encode-object-element (car alist-cell)
(cdr alist-cell))) (cdr alist-cell)))
@ -269,6 +277,7 @@ corresponding CLOS class) of a node."
(TYPE-IRI (PROPERTY-NAME SLOT-NAME) (PROPERTY-NAME SLOT-NAME)) (TYPE-IRI (PROPERTY-NAME SLOT-NAME) (PROPERTY-NAME SLOT-NAME))
where TYPE-IRI is the (hopefully) fully-resolved IRI form of the node-types where TYPE-IRI is the (hopefully) fully-resolved IRI form of the node-types
name, though it might be unresolved if context was unprovided or lacking." name, though it might be unresolved if context was unprovided or lacking."
(remove-duplicates
(append (append
;; The class-name and type-name. ;; The class-name and type-name.
(list (cons (car names) (cadr names))) (list (cons (car names) (cadr names)))
@ -290,10 +299,14 @@ name, though it might be unresolved if context was unprovided or lacking."
(let* ((type-def (class-json-type-definition class-name))) (let* ((type-def (class-json-type-definition class-name)))
(when type-def (when type-def
(cdr type-def)))) (cdr type-def))))
direct-superclasses)))) direct-superclasses)))
:test (lambda (a b) (equal (car a) (car b)))
:from-end 't))
(defun parse (str) (defun parse (str &optional always-object)
"Parse the JSON-LD document contained in STR." "Parse the JSON-LD document contained in STR.
If ALWAYS-OBJECT is non-nil, even invalid JSON-LD objects (which would normally be
parsed into hash-tables) will be parsed into CLOS objects."
(let ((ctx (make-hash-table :test #'equal)) ; Parsed context (let ((ctx (make-hash-table :test #'equal)) ; Parsed context
(parsed (yason:parse str))) (parsed (yason:parse str)))
(values (parse-item parsed ctx) (values (parse-item parsed ctx)