Normalize/flatten @contexts before encoding
So that json-ld-objects contained in other jons-ld-objects don’t have their @contexs repeated a million times unnecessarily.
This commit is contained in:
parent
e1c1be096a
commit
4964c679ee
|
@ -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
|
||||
;;; ————————————————————————————————————————
|
||||
|
|
Ŝarĝante…
Reference in New Issue