guile-jsonld

compaction.scm

;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 

(define-module (jsonld compaction)
  #:use-module (jsonld context)
  #:use-module (jsonld context-processing)
  #:use-module (jsonld iri-compaction)
  #:use-module (jsonld iri-expansion)
  #:use-module (jsonld json)
  #:use-module (jsonld value-compaction)
  #:export (compaction))

(define-syntax update-result
  (syntax-rules ()
    ((_ result nest-term nest-result)
     (set! result
       (if nest-term
           (alist-set result nest-term nest-result)
           nest-result)))))

(define (add-value object key value as-array?)
  (let* ((value (if (json-array? value)
                    (array->list value)
                    (list value)))
         (original (if (json-has-key? object key)
                       (assoc-ref object key)
                       #()))
         (original (if (json-array? original)
                       (array->list original)
                       (list original)))
         (new-value (append original value))
         (new-value
           (if (and (= (length new-value) 1) (not as-array?))
               (car new-value)
               (list->array 1 new-value))))
    (alist-set object key new-value)))

(define* (compaction active-context active-property element
                     #:key (compact-arrays? #f) (ordered? #f) processing-mode)
  ;; 1
  (let ((type-scoped-context active-context)
        (def (term-definition-ref active-context active-property)))
    (cond
      ;; 2
      ((scalar? element)
       element)
      ;; 3
      ((json-array? element)
       ;; 3.1
       (let ((result '()))
         ;; 3.2
         (for-each
           (lambda (item)
             ;; 3.2.1
             (let ((compacted-item (compaction active-context
                                               active-property item
                                               #:compact-arrays? compact-arrays?
                                               #:ordered? ordered?
                                               #:processing-mode processing-mode)))
               ;; 3.2.2
               (unless (json-null? compacted-item)
                 (set! result (cons compacted-item result)))))
           (array->list element))
         (set! result (reverse result))
         (if (let ((container-mapping
                     (container-mapping active-context active-property)))
               (or (not (= (length result) 1))
                   (equal? compact-arrays? #f)
                   (equal? active-property "@graph")
                   (equal? active-property "@set")
                   (member "@set" container-mapping)
                   (member "@list" container-mapping)))
             ;; 3.3
             (list->array 1 result)
             ;; 3.4
             (car result))))
      ;; 4
      (else
        ;; 5
        (when (not-null-or-false (active-context-previous active-context))
          (unless (or (json-has-key? element "@value")
                      (and (json-has-key? element "@id")
                           (null? (filter (lambda (kp) (not (equal? (car kp) "@id")))
                                          element))))
            (set! active-context (active-context-previous active-context))))
        ;; 6
        (when (and (term-definition? def)
                   (not-null-or-false (term-definition-context def)))
          (set! active-context
            (context-processing active-context (term-definition-context def)
                                (term-definition-base-url def)
                                #:override-protected? #t)))
        ;; 7
        (cond
          ((and (or (json-has-key? element "@value")
                    (json-has-key? element "@id"))
                (let ((compact
                      (value-compaction active-context active-property element
                                        processing-mode)))
                  (or (scalar? compact)
                      (and (term-definition? def)
                           (equal? (term-definition-type def) "@json")))))
           (value-compaction active-context  active-property element
                             processing-mode))
          ;; 8
          ((and (json-has-key? element "@list")
                (member "@list" (container-mapping active-context active-property)))
           (compaction active-context active-property
                       (assoc-ref element "@list")
                       #:compact-arrays? compact-arrays?
                       #:ordered? ordered?))
          ;; 9 and 10
          (else
            (let ((inside-reverse? (equal? active-property "@reverse"))
                  (result '()))
              ;; 11
              (when (json-has-key? element "@type")
                (let* ((types (assoc-ref element "@type"))
                       (types (if (json-array? types)
                                  (array->list types)
                                  (list types)))
                       (compacted-types
                         (map
                           (lambda (type)
                             (iri-compaction active-context type
                                             #:vocab? #t
                                             #:processing-mode processing-mode))
                           types)))
                  (for-each
                    (lambda (term)
                      (when (and
                              (term-definition? (term-definition-ref type-scoped-context term))
                              (term-definition-context
                                (term-definition-ref type-scoped-context term)))
                        (set! active-context
                          (context-processing
                            active-context
                            (term-definition-context
                              (term-definition-ref type-scoped-context term))
                            (term-definition-base-url
                              (term-definition-ref type-scoped-context term))
                            #:propagate? #f))))
                    (sort compacted-types string<=?))))
              ;; 12
              (for-each-pair
                (lambda (expanded-property expanded-value)
                  (set! result
                    (step-12 active-context expanded-property
                             expanded-value result compact-arrays? ordered?
                             inside-reverse? type-scoped-context active-property
                             processing-mode)))
                (if ordered?
                    (alist-sort-by-key element)
                    element))
              ;; 13
              result)))))))

(define (step-12 active-context expanded-property expanded-value
                 result compact-arrays? ordered? inside-reverse? type-scoped-context
                 active-property processing-mode)
  (cond
    ;; 12.1
    ((equal? expanded-property "@id")
     ;; XXX: not clear what to do if expanded-value is not a
     ;; string, make sure there is a test
     (let ((compacted-value
             (if (string? expanded-value)
                 (iri-compaction active-context expanded-value
                                 #:vocab? #f #:processing-mode processing-mode)
                 expanded-value))
           (alias (iri-compaction active-context expanded-property
                                  #:vocab? #t #:processing-mode processing-mode)))
       (set! result
         (alist-set result alias compacted-value))))
    ;; 12.2
    ((equal? expanded-property "@type")
     (let* ((compacted-value #f)
            ;; 12.2.3
            (alias (iri-compaction active-context expanded-property
                                   #:vocab? #t #:processing-mode processing-mode))
            ;; 12.2.4
            (as-array?
              (or 
                (and
                  (processing-mode-1.1? processing-mode)
                  (member "@set" (container-mapping active-context alias)))
                (not compact-arrays?))))
       (if (string? expanded-value)
           ;; 12.1
           (set! compacted-value
             (iri-compaction type-scoped-context
                             expanded-value
                             #:vocab? #t #:processing-mode processing-mode))
           ;; 12.2
           (begin
             (set! expanded-value (array->list expanded-value))
             (set! compacted-value
               (list->array 1
                 (map
                   (lambda (expanded-type)
                     (iri-compaction type-scoped-context expanded-type
                                     #:vocab? #t
                                     #:processing-mode processing-mode))
                   expanded-value)))))
       ;; XXX: not in spec
       (when (and (json-array? compacted-value) (= (array-length compacted-value) 1))
         (set! compacted-value (car (array->list compacted-value))))
       (set! result
         (add-value result alias compacted-value as-array?))))
    ;; 12.3
    ((equal? expanded-property "@reverse")
     ;; 12.3.1
     (let ((compacted-value
             (compaction active-context "@reverse" expanded-value
                         #:compact-arrays? compact-arrays? #:ordered? ordered?)))
       ;; 12.3.2
       (for-each-pair
         (lambda (property value)
           (let ((def (term-definition-ref active-context property)))
             (when (and (term-definition? def) (term-definition-reverse? def))
               ;; 12.3.2.1.1
               (let ((as-array? (or
                                  (member "@set"
                                          (container-mapping active-context property))
                                  (not compact-arrays?))))
                 ;; 12.3.2.1.2
                 (set! result
                   (add-value result property value as-array?)))
               ;; 12.3.2.1.3
               (set! compacted-value
                 (alist-remove compacted-value property)))))
         compacted-value)
       ;; 12.3.3
       (unless (null? compacted-value)
         (let ((alias (iri-compaction active-context "@reverse"
                                      #:vocab? #t #:processing-mode processing-mode)))
           (set! result (alist-set result alias compacted-value))))))
    ;; 12.4
    ((equal? expanded-property "@preserve")
     (let ((compacted-value
             (compaction active-context active-property expanded-value
                         #:compact-arrays? compact-arrays?
                         #:ordered? ordered?)))
       (unless (equal? expanded-value #())
         (set! result (alist-set result "@preserve" compacted-value)))))
    ;; 12.5
    ((and (equal? expanded-property "@index")
          (member "@index"
                  (container-mapping active-context active-property)))
     #t)
    ;; 12.6
    ((or (equal? expanded-property "@direction")
         (equal? expanded-property "@index")
         (equal? expanded-property "@language")
         (equal? expanded-property "@value"))
      (let ((alias (iri-compaction active-context expanded-property
                                   #:vocab? #t #:processing-mode processing-mode)))
        (set! result
          (alist-set result alias expanded-value))))
    (else
      ;; 12.7
      (when (equal? expanded-value #())
        (let* ((item-active-property
                 (iri-compaction active-context expanded-property
                                 #:value expanded-value
                                 #:vocab? #t
                                 #:reverse? inside-reverse?
                                 #:processing-mode processing-mode))
               (def (term-definition-ref active-context
                                         item-active-property))
               (nest-term (if (term-definition? def) (term-definition-nest def) #f))
               ;; 12.7.4
               (nest-result result))
          ;; 12.7.2
          (when nest-term
            (unless (or (equal? nest-term "@nest")
                        (equal? (expand-key active-context nest-term)
                                "@nest"))
              (throw 'invalid-@nest-value))
            (set! nest-result
              (if (json-has-key? result nest-term)
                  (assoc-ref result nest-term)
                  '())))
          ;; 12.7.4
          (set! nest-result
            (add-value nest-result item-active-property #() #t))
          (update-result result nest-term nest-result)))
      ;; 12.8
      (for-each
        (lambda (expanded-item)
          (let* ((item-active-property
                   (iri-compaction
                     active-context expanded-property
                     #:value expanded-item
                     #:vocab? #t
                     #:reverse? inside-reverse?
                     #:processing-mode processing-mode))
                 (def (term-definition-ref active-context item-active-property))
                 (nest-term (if (term-definition? def) (term-definition-nest def) #f))
                 ;; 12.8.3
                 (nest-result result)
                 ;; 12.8.4
                 (container (container-mapping active-context item-active-property))
                 ;; 12.8.5
                 (as-array? (or (member "@set" container)
                                (equal? item-active-property "@list")
                                (equal? item-active-property "@graph")
                                (not compact-arrays?)))
                 ;; 12.8.6
                 (compacted-item
                   (compaction active-context item-active-property
                               (if (json-has-key? expanded-item  "@list")
                                   (assoc-ref expanded-item "@list")
                                   (if (graph-object? expanded-item)
                                       (assoc-ref expanded-item "@graph")
                                       expanded-item))
                               #:compact-arrays? compact-arrays?
                               #:ordered? ordered?)))
            ;; 12.8.2
            (when (not-null-or-false nest-term)
              (unless (or (equal? nest-term "@nest")
                          (equal? (expand-key active-context nest-term) "@nest"))
                (throw 'invalid-@nest-value))
              (set! nest-result
                (if (json-has-key? result nest-term)
                    (assoc-ref result nest-term)
                    '())))
            (cond
              ;; 12.8.7
              ((json-has-key? expanded-item "@list")
               ;; 12.8.7.1
               (unless (json-array? compacted-item)
                 (set! compacted-item `#(,compacted-item)))
               (if (member "@list" container)
                 ;; 12.8.7.3
                 (set! nest-result
                   (alist-set nest-result item-active-property compacted-item))
                 ;; 12.8.7.2
                 (begin
                   (set! compacted-item
                     `((,(iri-compaction active-context "@list" #:vocab? #t
                                         #:processing-mode processing-mode) .
                         ,compacted-item)))
                   (when (json-has-key? expanded-item "@index")
                     (set! compacted-item
                       (alist-set
                         compacted-item
                         (iri-compaction active-context "@index" #:vocab? #t
                                         #:processing-mode processing-mode)
                         (assoc-ref expanded-item "@index"))))
                   (set! nest-result
                     (add-value nest-result item-active-property compacted-item
                                as-array?))))
               (update-result result nest-term nest-result))
              ;; 12.8.8
              ((graph-object? expanded-item)
               (cond
                 ;; 12.8.8.1
                 ((and (member "@id" container)
                       (member "@graph" container))
                  (let* ((map-object
                           (or (not-null-or-false (assoc-ref nest-result item-active-property)) '()))
                         (map-key
                           (if (json-has-key? expanded-item "@id")
                               (assoc-ref expanded-item "@id")
                               "@none"))
                         (map-key
                           (iri-compaction
                             active-context map-key
                             #:vocab? (not (json-has-key? expanded-item "@id"))
                             #:processing-mode processing-mode)))
                    ;; 12.8.8.1.3
                    (set! map-object
                      (add-value map-object map-key compacted-item as-array?))
                    (set! nest-result
                      (alist-set nest-result item-active-property map-object))
                    (update-result result nest-term nest-result)))
                 ;; 12.8.8.2
                 ((and (member "@graph" container)
                       (member "@index" container)
                       (simple-graph-object? expanded-item))
                  (let ((map-object
                          (or (not-null-or-false (assoc-ref nest-result item-active-property)) '()))
                        (map-key
                          (if (json-has-key? expanded-item "@index")
                              (assoc-ref expanded-item "@index")
                              "@none")))
                    ;; 12.8.8.2.3
                    (set! map-object
                      (add-value map-object map-key compacted-item as-array?))
                    (set! nest-result
                      (alist-set nest-result item-active-property map-object))
                    (update-result result nest-term nest-result)))
                 ;; 12.8.8.3
                 ((and (member "@graph" container)
                       (simple-graph-object? expanded-item))
                  (when (and (json-array? compacted-item)
                             (> (array-length compacted-item) 1))
                    (set! compacted-item
                      `((,(iri-compaction active-context "@included"
                                          #:vocab? #t
                                          #:processing-mode processing-mode) .
                         ,compacted-item))))
                  (set! nest-result
                    (add-value nest-result item-active-property compacted-item
                               as-array?))
                  (update-result result nest-term nest-result))
                 ;; 12.8.8.4
                 (else
                   ;; 12.8.8.4.1
                   (set! compacted-item
                     `((,(iri-compaction active-context "@graph"
                                         #:vocab? #t
                                         #:processing-mode processing-mode) .
                        ,compacted-item)))
                   ;; 12.8.8.4.2
                   (when (json-has-key? expanded-item "@id")
                     (set! compacted-item
                       (alist-set
                         compacted-item
                         (iri-compaction active-context "@id"
                                         #:vocab? #t
                                         #:processing-mode processing-mode)
                         (iri-compaction active-context
                                         (assoc-ref expanded-item "@id")
                                         #:vocab? #f
                                         #:processing-mode processing-mode))))
                   ;; 12.8.8.4.3
                   (when (json-has-key? expanded-item "@index")
                     (set! compacted-item
                       (alist-set
                         compacted-item
                         (iri-compaction active-context "@index"
                                         #:vocab? #t
                                         #:processing-mode processing-mode)
                         (assoc-ref expanded-item "@index"))))
                   ;; 12.8.8.4.4
                   (set! nest-result
                     (add-value nest-result item-active-property compacted-item
                                as-array?))
                   (update-result result nest-term nest-result))))
              ;; 12.8.9
              ((and (not (member "@graph" container))
                    (or (member "@language" container)
                        (member "@index" container)
                        (member "@id" container)
                        (member "@type" container)))
               ;; 12.8.9.1
               (let* ((map-object (or (assoc-ref nest-result item-active-property)
                                      '()))
                      ;; 12.8.9.2
                      (container-key (iri-compaction active-context
                                                     (cond
                                                       ((member "@language" container) "@language")
                                                       ((member "@index" container) "@index")
                                                       ((member "@id" container) "@id")
                                                       (else "@type"))
                                                     #:vocab? #t))
                      (map-key json-null)
                      ;; 12.8.9.3
                      (def (term-definition-ref active-context item-active-property))
                      (index-key (or (and (term-definition? def)
                                          (term-definition-index def))
                                     "@index")))
                 (cond
                   ;; 12.8.9.4
                   ((and (member "@language" container)
                         (json-has-key? expanded-item "@value"))
                    (set! compacted-item (assoc-ref expanded-item "@value"))
                    (when (json-has-key? expanded-item "@language")
                      (set! map-key (assoc-ref expanded-item "@language"))))
                   ;; 12.8.9.5
                   ((and (member "@index" container)
                         (equal? index-key "@index"))
                    (when (json-has-key? expanded-item "@index")
                      (set! map-key (assoc-ref expanded-item "@index"))))
                   ;; 12.8.9.6
                   ((member "@index" container)
                    ;; 12.8.9.6.1
                    (set! container-key
                      (iri-compaction active-context
                                      (assoc-ref
                                        (iri-expansion active-context index-key
                                                       #:vocab? #t)
                                        "iri")
                                      #:vocab? #t))
                    ;; 12.8.9.6.2
                    (let* ((keys (assoc-ref compacted-item container-key))
                           (keys (if (json-array? keys)
                                     (array->list keys)
                                     (list keys)))
                           (key (and (not (null? keys)) (not-null-or-false (car keys))))
                           (remaining (if key (cdr keys) '())))
                      (when key
                        (unless (string? key)
                          (set! remaining keys)
                          (set! key #f))
                        (when key
                          (set! map-key key)))
                      ;; 12.8.9.6.3
                      (if (null? remaining)
                          (when (json-has-key? compacted-item container-key)
                            (set! compacted-item
                              (alist-remove compacted-item container-key)))
                          (set! compacted-item
                            (alist-set compacted-item container-key
                                       (if (= (length remaining) 1)
                                           (car remaining)
                                           (list->array 1 remaining)))))))
                   ;; 12.8.9.7
                   ((member "@id" container)
                    (when (json-has-key? compacted-item container-key)
                      (set! map-key (assoc-ref compacted-item container-key))
                      (set! compacted-item (alist-remove compacted-item container-key))))
                   ;; 12.8.9.8
                   ((member "@type" container)
                    (let* ((keys (assoc-ref compacted-item container-key))
                           (keys (if (json-array? keys)
                                     (array->list keys)
                                     (list keys)))
                           (key (and (not (null? keys)) (not-null-or-false (car keys))))
                           (remaining (if key (cdr keys) '())))
                      ;; 12.8.9.8.1
                      (when (not-null-or-false key)
                        (set! map-key key))
                      ;; 12.8.9.8.2
                      (if (null? remaining)
                          (set! compacted-item
                            (alist-remove compacted-item container-key))
                          (set! compacted-item
                            (alist-set compacted-item container-key
                                       (if (= (length remaining) 1)
                                           (car remaining)
                                           (list->array 1 remaining)))))
                      (when (and (= (length compacted-item) 1)
                                 (equal?
                                   (expand-key active-context (car (car compacted-item)))
                                   "@id"))
                        (set! compacted-item
                          (compaction
                            active-context item-active-property
                            `(("@id" . ,(assoc-ref expanded-item "@id")))))))))
                 ;; 12.8.9.9
                 (when (json-null? map-key)
                   (set! map-key (iri-compaction active-context "@none"
                                                 #:vocab? #t)))
                 ;; 12.8.9.10
                 (set! map-object
                   (add-value map-object map-key compacted-item as-array?))
                 (set! nest-result
                   (alist-set nest-result item-active-property map-object))
                 (update-result result nest-term nest-result)))
              ;; 12.8.10
              (else
                (set! nest-result
                  (add-value nest-result item-active-property
                             compacted-item as-array?))
                (update-result result nest-term nest-result)))))
        (array->list expanded-value))))
  result)


1	;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2	;;;;
3	;;;; This library is free software; you can redistribute it and/or
4	;;;; modify it under the terms of the GNU Lesser General Public
5	;;;; License as published by the Free Software Foundation; either
6	;;;; version 3 of the License, or (at your option) any later version.
7	;;;;
8	;;;; This library is distributed in the hope that it will be useful,
9	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11	;;;; Lesser General Public License for more details.
12	;;;;
13	;;;; You should have received a copy of the GNU Lesser General Public
14	;;;; License along with this library; if not, write to the Free Software
15	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16	;;;;
17
18	(define-module (jsonld compaction)
19	#:use-module (jsonld context)
20	#:use-module (jsonld context-processing)
21	#:use-module (jsonld iri-compaction)
22	#:use-module (jsonld iri-expansion)
23	#:use-module (jsonld json)
24	#:use-module (jsonld value-compaction)
25	#:export (compaction))
26
27	(define-syntax update-result
28	(syntax-rules ()
29	((_ result nest-term nest-result)
30	(set! result
31	(if nest-term
32	(alist-set result nest-term nest-result)
33	nest-result)))))
34
35	(define (add-value object key value as-array?)
36	(let* ((value (if (json-array? value)
37	(array->list value)
38	(list value)))
39	(original (if (json-has-key? object key)
40	(assoc-ref object key)
41	#()))
42	(original (if (json-array? original)
43	(array->list original)
44	(list original)))
45	(new-value (append original value))
46	(new-value
47	(if (and (= (length new-value) 1) (not as-array?))
48	(car new-value)
49	(list->array 1 new-value))))
50	(alist-set object key new-value)))
51
52	(define* (compaction active-context active-property element
53	#:key (compact-arrays? #f) (ordered? #f) processing-mode)
54	;; 1
55	(let ((type-scoped-context active-context)
56	(def (term-definition-ref active-context active-property)))
57	(cond
58	;; 2
59	((scalar? element)
60	element)
61	;; 3
62	((json-array? element)
63	;; 3.1
64	(let ((result '()))
65	;; 3.2
66	(for-each
67	(lambda (item)
68	;; 3.2.1
69	(let ((compacted-item (compaction active-context
70	active-property item
71	#:compact-arrays? compact-arrays?
72	#:ordered? ordered?
73	#:processing-mode processing-mode)))
74	;; 3.2.2
75	(unless (json-null? compacted-item)
76	(set! result (cons compacted-item result)))))
77	(array->list element))
78	(set! result (reverse result))
79	(if (let ((container-mapping
80	(container-mapping active-context active-property)))
81	(or (not (= (length result) 1))
82	(equal? compact-arrays? #f)
83	(equal? active-property "@graph")
84	(equal? active-property "@set")
85	(member "@set" container-mapping)
86	(member "@list" container-mapping)))
87	;; 3.3
88	(list->array 1 result)
89	;; 3.4
90	(car result))))
91	;; 4
92	(else
93	;; 5
94	(when (not-null-or-false (active-context-previous active-context))
95	(unless (or (json-has-key? element "@value")
96	(and (json-has-key? element "@id")
97	(null? (filter (lambda (kp) (not (equal? (car kp) "@id")))
98	element))))
99	(set! active-context (active-context-previous active-context))))
100	;; 6
101	(when (and (term-definition? def)
102	(not-null-or-false (term-definition-context def)))
103	(set! active-context
104	(context-processing active-context (term-definition-context def)
105	(term-definition-base-url def)
106	#:override-protected? #t)))
107	;; 7
108	(cond
109	((and (or (json-has-key? element "@value")
110	(json-has-key? element "@id"))
111	(let ((compact
112	(value-compaction active-context active-property element
113	processing-mode)))
114	(or (scalar? compact)
115	(and (term-definition? def)
116	(equal? (term-definition-type def) "@json")))))
117	(value-compaction active-context active-property element
118	processing-mode))
119	;; 8
120	((and (json-has-key? element "@list")
121	(member "@list" (container-mapping active-context active-property)))
122	(compaction active-context active-property
123	(assoc-ref element "@list")
124	#:compact-arrays? compact-arrays?
125	#:ordered? ordered?))
126	;; 9 and 10
127	(else
128	(let ((inside-reverse? (equal? active-property "@reverse"))
129	(result '()))
130	;; 11
131	(when (json-has-key? element "@type")
132	(let* ((types (assoc-ref element "@type"))
133	(types (if (json-array? types)
134	(array->list types)
135	(list types)))
136	(compacted-types
137	(map
138	(lambda (type)
139	(iri-compaction active-context type
140	#:vocab? #t
141	#:processing-mode processing-mode))
142	types)))
143	(for-each
144	(lambda (term)
145	(when (and
146	(term-definition? (term-definition-ref type-scoped-context term))
147	(term-definition-context
148	(term-definition-ref type-scoped-context term)))
149	(set! active-context
150	(context-processing
151	active-context
152	(term-definition-context
153	(term-definition-ref type-scoped-context term))
154	(term-definition-base-url
155	(term-definition-ref type-scoped-context term))
156	#:propagate? #f))))
157	(sort compacted-types string<=?))))
158	;; 12
159	(for-each-pair
160	(lambda (expanded-property expanded-value)
161	(set! result
162	(step-12 active-context expanded-property
163	expanded-value result compact-arrays? ordered?
164	inside-reverse? type-scoped-context active-property
165	processing-mode)))
166	(if ordered?
167	(alist-sort-by-key element)
168	element))
169	;; 13
170	result)))))))
171
172	(define (step-12 active-context expanded-property expanded-value
173	result compact-arrays? ordered? inside-reverse? type-scoped-context
174	active-property processing-mode)
175	(cond
176	;; 12.1
177	((equal? expanded-property "@id")
178	;; XXX: not clear what to do if expanded-value is not a
179	;; string, make sure there is a test
180	(let ((compacted-value
181	(if (string? expanded-value)
182	(iri-compaction active-context expanded-value
183	#:vocab? #f #:processing-mode processing-mode)
184	expanded-value))
185	(alias (iri-compaction active-context expanded-property
186	#:vocab? #t #:processing-mode processing-mode)))
187	(set! result
188	(alist-set result alias compacted-value))))
189	;; 12.2
190	((equal? expanded-property "@type")
191	(let* ((compacted-value #f)
192	;; 12.2.3
193	(alias (iri-compaction active-context expanded-property
194	#:vocab? #t #:processing-mode processing-mode))
195	;; 12.2.4
196	(as-array?
197	(or
198	(and
199	(processing-mode-1.1? processing-mode)
200	(member "@set" (container-mapping active-context alias)))
201	(not compact-arrays?))))
202	(if (string? expanded-value)
203	;; 12.1
204	(set! compacted-value
205	(iri-compaction type-scoped-context
206	expanded-value
207	#:vocab? #t #:processing-mode processing-mode))
208	;; 12.2
209	(begin
210	(set! expanded-value (array->list expanded-value))
211	(set! compacted-value
212	(list->array 1
213	(map
214	(lambda (expanded-type)
215	(iri-compaction type-scoped-context expanded-type
216	#:vocab? #t
217	#:processing-mode processing-mode))
218	expanded-value)))))
219	;; XXX: not in spec
220	(when (and (json-array? compacted-value) (= (array-length compacted-value) 1))
221	(set! compacted-value (car (array->list compacted-value))))
222	(set! result
223	(add-value result alias compacted-value as-array?))))
224	;; 12.3
225	((equal? expanded-property "@reverse")
226	;; 12.3.1
227	(let ((compacted-value
228	(compaction active-context "@reverse" expanded-value
229	#:compact-arrays? compact-arrays? #:ordered? ordered?)))
230	;; 12.3.2
231	(for-each-pair
232	(lambda (property value)
233	(let ((def (term-definition-ref active-context property)))
234	(when (and (term-definition? def) (term-definition-reverse? def))
235	;; 12.3.2.1.1
236	(let ((as-array? (or
237	(member "@set"
238	(container-mapping active-context property))
239	(not compact-arrays?))))
240	;; 12.3.2.1.2
241	(set! result
242	(add-value result property value as-array?)))
243	;; 12.3.2.1.3
244	(set! compacted-value
245	(alist-remove compacted-value property)))))
246	compacted-value)
247	;; 12.3.3
248	(unless (null? compacted-value)
249	(let ((alias (iri-compaction active-context "@reverse"
250	#:vocab? #t #:processing-mode processing-mode)))
251	(set! result (alist-set result alias compacted-value))))))
252	;; 12.4
253	((equal? expanded-property "@preserve")
254	(let ((compacted-value
255	(compaction active-context active-property expanded-value
256	#:compact-arrays? compact-arrays?
257	#:ordered? ordered?)))
258	(unless (equal? expanded-value #())
259	(set! result (alist-set result "@preserve" compacted-value)))))
260	;; 12.5
261	((and (equal? expanded-property "@index")
262	(member "@index"
263	(container-mapping active-context active-property)))
264	#t)
265	;; 12.6
266	((or (equal? expanded-property "@direction")
267	(equal? expanded-property "@index")
268	(equal? expanded-property "@language")
269	(equal? expanded-property "@value"))
270	(let ((alias (iri-compaction active-context expanded-property
271	#:vocab? #t #:processing-mode processing-mode)))
272	(set! result
273	(alist-set result alias expanded-value))))
274	(else
275	;; 12.7
276	(when (equal? expanded-value #())
277	(let* ((item-active-property
278	(iri-compaction active-context expanded-property
279	#:value expanded-value
280	#:vocab? #t
281	#:reverse? inside-reverse?
282	#:processing-mode processing-mode))
283	(def (term-definition-ref active-context
284	item-active-property))
285	(nest-term (if (term-definition? def) (term-definition-nest def) #f))
286	;; 12.7.4
287	(nest-result result))
288	;; 12.7.2
289	(when nest-term
290	(unless (or (equal? nest-term "@nest")
291	(equal? (expand-key active-context nest-term)
292	"@nest"))
293	(throw 'invalid-@nest-value))
294	(set! nest-result
295	(if (json-has-key? result nest-term)
296	(assoc-ref result nest-term)
297	'())))
298	;; 12.7.4
299	(set! nest-result
300	(add-value nest-result item-active-property #() #t))
301	(update-result result nest-term nest-result)))
302	;; 12.8
303	(for-each
304	(lambda (expanded-item)
305	(let* ((item-active-property
306	(iri-compaction
307	active-context expanded-property
308	#:value expanded-item
309	#:vocab? #t
310	#:reverse? inside-reverse?
311	#:processing-mode processing-mode))
312	(def (term-definition-ref active-context item-active-property))
313	(nest-term (if (term-definition? def) (term-definition-nest def) #f))
314	;; 12.8.3
315	(nest-result result)
316	;; 12.8.4
317	(container (container-mapping active-context item-active-property))
318	;; 12.8.5
319	(as-array? (or (member "@set" container)
320	(equal? item-active-property "@list")
321	(equal? item-active-property "@graph")
322	(not compact-arrays?)))
323	;; 12.8.6
324	(compacted-item
325	(compaction active-context item-active-property
326	(if (json-has-key? expanded-item "@list")
327	(assoc-ref expanded-item "@list")
328	(if (graph-object? expanded-item)
329	(assoc-ref expanded-item "@graph")
330	expanded-item))
331	#:compact-arrays? compact-arrays?
332	#:ordered? ordered?)))
333	;; 12.8.2
334	(when (not-null-or-false nest-term)
335	(unless (or (equal? nest-term "@nest")
336	(equal? (expand-key active-context nest-term) "@nest"))
337	(throw 'invalid-@nest-value))
338	(set! nest-result
339	(if (json-has-key? result nest-term)
340	(assoc-ref result nest-term)
341	'())))
342	(cond
343	;; 12.8.7
344	((json-has-key? expanded-item "@list")
345	;; 12.8.7.1
346	(unless (json-array? compacted-item)
347	(set! compacted-item `#(,compacted-item)))
348	(if (member "@list" container)
349	;; 12.8.7.3
350	(set! nest-result
351	(alist-set nest-result item-active-property compacted-item))
352	;; 12.8.7.2
353	(begin
354	(set! compacted-item
355	`((,(iri-compaction active-context "@list" #:vocab? #t
356	#:processing-mode processing-mode) .
357	,compacted-item)))
358	(when (json-has-key? expanded-item "@index")
359	(set! compacted-item
360	(alist-set
361	compacted-item
362	(iri-compaction active-context "@index" #:vocab? #t
363	#:processing-mode processing-mode)
364	(assoc-ref expanded-item "@index"))))
365	(set! nest-result
366	(add-value nest-result item-active-property compacted-item
367	as-array?))))
368	(update-result result nest-term nest-result))
369	;; 12.8.8
370	((graph-object? expanded-item)
371	(cond
372	;; 12.8.8.1
373	((and (member "@id" container)
374	(member "@graph" container))
375	(let* ((map-object
376	(or (not-null-or-false (assoc-ref nest-result item-active-property)) '()))
377	(map-key
378	(if (json-has-key? expanded-item "@id")
379	(assoc-ref expanded-item "@id")
380	"@none"))
381	(map-key
382	(iri-compaction
383	active-context map-key
384	#:vocab? (not (json-has-key? expanded-item "@id"))
385	#:processing-mode processing-mode)))
386	;; 12.8.8.1.3
387	(set! map-object
388	(add-value map-object map-key compacted-item as-array?))
389	(set! nest-result
390	(alist-set nest-result item-active-property map-object))
391	(update-result result nest-term nest-result)))
392	;; 12.8.8.2
393	((and (member "@graph" container)
394	(member "@index" container)
395	(simple-graph-object? expanded-item))
396	(let ((map-object
397	(or (not-null-or-false (assoc-ref nest-result item-active-property)) '()))
398	(map-key
399	(if (json-has-key? expanded-item "@index")
400	(assoc-ref expanded-item "@index")
401	"@none")))
402	;; 12.8.8.2.3
403	(set! map-object
404	(add-value map-object map-key compacted-item as-array?))
405	(set! nest-result
406	(alist-set nest-result item-active-property map-object))
407	(update-result result nest-term nest-result)))
408	;; 12.8.8.3
409	((and (member "@graph" container)
410	(simple-graph-object? expanded-item))
411	(when (and (json-array? compacted-item)
412	(> (array-length compacted-item) 1))
413	(set! compacted-item
414	`((,(iri-compaction active-context "@included"
415	#:vocab? #t
416	#:processing-mode processing-mode) .
417	,compacted-item))))
418	(set! nest-result
419	(add-value nest-result item-active-property compacted-item
420	as-array?))
421	(update-result result nest-term nest-result))
422	;; 12.8.8.4
423	(else
424	;; 12.8.8.4.1
425	(set! compacted-item
426	`((,(iri-compaction active-context "@graph"
427	#:vocab? #t
428	#:processing-mode processing-mode) .
429	,compacted-item)))
430	;; 12.8.8.4.2
431	(when (json-has-key? expanded-item "@id")
432	(set! compacted-item
433	(alist-set
434	compacted-item
435	(iri-compaction active-context "@id"
436	#:vocab? #t
437	#:processing-mode processing-mode)
438	(iri-compaction active-context
439	(assoc-ref expanded-item "@id")
440	#:vocab? #f
441	#:processing-mode processing-mode))))
442	;; 12.8.8.4.3
443	(when (json-has-key? expanded-item "@index")
444	(set! compacted-item
445	(alist-set
446	compacted-item
447	(iri-compaction active-context "@index"
448	#:vocab? #t
449	#:processing-mode processing-mode)
450	(assoc-ref expanded-item "@index"))))
451	;; 12.8.8.4.4
452	(set! nest-result
453	(add-value nest-result item-active-property compacted-item
454	as-array?))
455	(update-result result nest-term nest-result))))
456	;; 12.8.9
457	((and (not (member "@graph" container))
458	(or (member "@language" container)
459	(member "@index" container)
460	(member "@id" container)
461	(member "@type" container)))
462	;; 12.8.9.1
463	(let* ((map-object (or (assoc-ref nest-result item-active-property)
464	'()))
465	;; 12.8.9.2
466	(container-key (iri-compaction active-context
467	(cond
468	((member "@language" container) "@language")
469	((member "@index" container) "@index")
470	((member "@id" container) "@id")
471	(else "@type"))
472	#:vocab? #t))
473	(map-key json-null)
474	;; 12.8.9.3
475	(def (term-definition-ref active-context item-active-property))
476	(index-key (or (and (term-definition? def)
477	(term-definition-index def))
478	"@index")))
479	(cond
480	;; 12.8.9.4
481	((and (member "@language" container)
482	(json-has-key? expanded-item "@value"))
483	(set! compacted-item (assoc-ref expanded-item "@value"))
484	(when (json-has-key? expanded-item "@language")
485	(set! map-key (assoc-ref expanded-item "@language"))))
486	;; 12.8.9.5
487	((and (member "@index" container)
488	(equal? index-key "@index"))
489	(when (json-has-key? expanded-item "@index")
490	(set! map-key (assoc-ref expanded-item "@index"))))
491	;; 12.8.9.6
492	((member "@index" container)
493	;; 12.8.9.6.1
494	(set! container-key
495	(iri-compaction active-context
496	(assoc-ref
497	(iri-expansion active-context index-key
498	#:vocab? #t)
499	"iri")
500	#:vocab? #t))
501	;; 12.8.9.6.2
502	(let* ((keys (assoc-ref compacted-item container-key))
503	(keys (if (json-array? keys)
504	(array->list keys)
505	(list keys)))
506	(key (and (not (null? keys)) (not-null-or-false (car keys))))
507	(remaining (if key (cdr keys) '())))
508	(when key
509	(unless (string? key)
510	(set! remaining keys)
511	(set! key #f))
512	(when key
513	(set! map-key key)))
514	;; 12.8.9.6.3
515	(if (null? remaining)
516	(when (json-has-key? compacted-item container-key)
517	(set! compacted-item
518	(alist-remove compacted-item container-key)))
519	(set! compacted-item
520	(alist-set compacted-item container-key
521	(if (= (length remaining) 1)
522	(car remaining)
523	(list->array 1 remaining)))))))
524	;; 12.8.9.7
525	((member "@id" container)
526	(when (json-has-key? compacted-item container-key)
527	(set! map-key (assoc-ref compacted-item container-key))
528	(set! compacted-item (alist-remove compacted-item container-key))))
529	;; 12.8.9.8
530	((member "@type" container)
531	(let* ((keys (assoc-ref compacted-item container-key))
532	(keys (if (json-array? keys)
533	(array->list keys)
534	(list keys)))
535	(key (and (not (null? keys)) (not-null-or-false (car keys))))
536	(remaining (if key (cdr keys) '())))
537	;; 12.8.9.8.1
538	(when (not-null-or-false key)
539	(set! map-key key))
540	;; 12.8.9.8.2
541	(if (null? remaining)
542	(set! compacted-item
543	(alist-remove compacted-item container-key))
544	(set! compacted-item
545	(alist-set compacted-item container-key
546	(if (= (length remaining) 1)
547	(car remaining)
548	(list->array 1 remaining)))))
549	(when (and (= (length compacted-item) 1)
550	(equal?
551	(expand-key active-context (car (car compacted-item)))
552	"@id"))
553	(set! compacted-item
554	(compaction
555	active-context item-active-property
556	`(("@id" . ,(assoc-ref expanded-item "@id")))))))))
557	;; 12.8.9.9
558	(when (json-null? map-key)
559	(set! map-key (iri-compaction active-context "@none"
560	#:vocab? #t)))
561	;; 12.8.9.10
562	(set! map-object
563	(add-value map-object map-key compacted-item as-array?))
564	(set! nest-result
565	(alist-set nest-result item-active-property map-object))
566	(update-result result nest-term nest-result)))
567	;; 12.8.10
568	(else
569	(set! nest-result
570	(add-value nest-result item-active-property
571	compacted-item as-array?))
572	(update-result result nest-term nest-result)))))
573	(array->list expanded-value))))
574	result)
575