guile-jsonld/jsonld/expansion.scm

expansion.scm

1
;;;; Copyright (C) 2019, 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 expansion)
19
  #:use-module (jsonld context)
20
  #:use-module (jsonld context-processing)
21
  #:use-module (jsonld iri-expansion)
22
  #:use-module (jsonld value-expansion)
23
  #:use-module (jsonld json)
24
  #:use-module (jsonld options)
25
  #:use-module (ice-9 match)
26
  #:use-module (srfi srfi-1)
27
  #:use-module (web uri)
28
  #:export (expansion))
29
30
;; 13.7
31
(define* (execute-when-language active-context key value expanded-property
32
                                active-property expanded-value result options)
33
  ;; 13.7.2
34
  (let ((direction (active-context-direction active-context)))
35
    ;; 13.7.1
36
    (set! expanded-value '())
37
    ;; 13.7.3
38
    (when (term-definition? (term-definition-ref active-context key))
39
      (set! direction (term-definition-direction
40
                        (term-definition-ref active-context key)))
41
      (when (equal? direction #f)
42
        (set! direction (active-context-direction active-context))))
43
    ;; 13.7.4
44
    (for-each-pair
45
      (lambda (language language-value)
46
        ;; 13.7.4.1
47
        (if (json-array? language-value)
48
          (set! language-value (array->list language-value))
49
          (set! language-value (list language-value)))
50
        ;; 13.7.4.2
51
        (for-each
52
          (lambda (item)
53
            ;; 13.7.4.2.1
54
            (unless (json-null? item)
55
              ;; 13.7.4.2.2
56
              (unless (string? item)
57
                (throw 'invalid-language-map-value))
58
              ;; 13.7.4.2.3
59
              (let ((v `(("@value" . ,item)
60
                         ("@language" . ,(string-downcase language)))))
61
                ;; TODO: if @language is not a bcp-47 one, we should issue a warning
62
                (when (equal? (expand-key active-context language) "@none")
63
                  (set! v (alist-remove v "@language")))
64
                (when (not-null-or-false direction)
65
                  (set! v (alist-set v "@direction" direction)))
66
                (set! expanded-value
67
                  (append expanded-value (list v))))))
68
          language-value))
69
      (if (jsonld-options-ordered? options)
70
        (alist-sort-by-key value)
71
        value))
72
    (set! expanded-value (list->array 1 expanded-value)))
73
  `(("expanded-value" . ,expanded-value)))
74
75
;; 13.8
76
(define* (execute-when-index active-context key value expanded-property
77
                             active-property expanded-value result
78
                             container-mapping base-url options)
79
  ;; 13.8.1
80
  (set! expanded-value '())
81
  ;; 13.8.2
82
  (let ((index-key
83
          (if (term-definition? (term-definition-ref active-context key))
84
              (or (term-definition-index
85
                    (term-definition-ref active-context key))
86
                  "@index")
87
              "@index"))
88
        ;; Should not be null, if it fails because of that, there's a weird corner case
89
        (map-context json-null)
90
        (expanded-index json-null))
91
    ;; 13.8.3
92
    (for-each-pair
93
      (lambda (index index-value)
94
        ;; 13.8.3.1
95
        (when (or (member "@id" container-mapping)
96
                  (member "@type" container-mapping))
97
          (let ((previous (active-context-previous active-context)))
98
            (set! map-context (or (if (not-null-or-false previous) previous #f)
99
                                  active-context))))
100
        ;; 13.8.3.2
101
        (when (and (member "@type" container-mapping)
102
                   (term-definition? (term-definition-ref map-context index))
103
                   (not (equal? (term-definition-context
104
                                  (term-definition-ref map-context index))
105
                                #f)))
106
          (set! map-context
107
            (context-processing map-context
108
                                (term-definition-context
109
                                  (term-definition-ref map-context index))
110
                                (term-definition-base-url
111
                                  (term-definition-ref map-context index))
112
                                #:options options)))
113
        ;; 13.8.3.3
114
        (when (json-null? map-context)
115
          (set! map-context active-context))
116
        ;; 13.8.3.4
117
        (set! expanded-index (assoc-ref
118
                               (iri-expansion active-context index
119
                                              ; XXX: or map-context?
120
                                              #:vocab? #t
121
                                              #:options options)
122
                               "iri"))
123
        ;; 13.8.3.5
124
        (unless (json-array? index-value)
125
          (set! index-value `#(,index-value)))
126
        ;; 13.8.3.6
127
        (set! index-value (expansion map-context key index-value base-url
128
                                     #:options options))
129
        ;; 13.8.3.7
130
        (for-each
131
          (lambda (item)
132
            ;; 13.8.3.7.1
133
            (when (member "@graph" container-mapping)
134
              (set! item
135
                (if (json-has-key? item "@graph")
136
                    item
137
                    `(("@graph" . ,(if (json-array? item) item `#(,item)))))))
138
            (cond
139
              ;; 13.8.3.7.2
140
              ((and (member "@index" container-mapping)
141
                    (not (equal? index-key "@index"))
142
                    (not (equal? expanded-index "@none")))
143
               (let* (;; 13.8.3.7.2.1
144
                      (re-expanded-index (value-expansion active-context index-key index))
145
                      ;; 13.8.3.7.2.2
146
                      (expanded-index-key
147
                        (assoc-ref
148
                          (iri-expansion active-context index-key
149
                                         #:vocab? #t
150
                                         #:options options)
151
                          "iri"))
152
                      ;; 13.8.3.7.2.3
153
                      (index-key-values (assoc-ref item expanded-index-key))
154
                      (index-key-values (or index-key-values #()))
155
                      (index-key-values (if (json-array? index-key-values)
156
                                            (array->list index-key-values)
157
                                            (list index-key-values)))
158
                      (index-property-values
159
                        (cons re-expanded-index index-key-values)))
160
                 (set! item
161
                   (alist-set item expanded-index-key
162
                              (list->array 1 index-property-values)))
163
                 (when (json-has-key? item "@value")
164
                   (unless (null? (filter
165
                                    (lambda (kv)
166
                                      (not (equal? (car kv) "@value")))
167
                                    item))
168
                     (throw 'invalid-value-object)))))
169
              ;; 13.8.3.7.3
170
              ((and (member "@index" container-mapping)
171
                    (not (json-has-key? item "@index"))
172
                    (not (equal? expanded-index "@none")))
173
               (set! item (alist-set item "@index" index)))
174
              ;; 13.8.3.7.4
175
              ((and (member "@id" container-mapping)
176
                    (not (json-has-key? item "@id"))
177
                    (not (equal? expanded-index "@none")))
178
               (set! expanded-index
179
                 (assoc-ref
180
                   (iri-expansion active-context index
181
                                  #:vocab? #f
182
                                  #:document-relative? #t
183
                                  #:options options)
184
                   "iri"))
185
               (set! item (alist-set item "@id" expanded-index)))
186
              ;; 13.8.3.7.5
187
              ((member "@type" container-mapping)
188
               (let* ((types (assoc-ref item "@type"))
189
                      (types (or types #()))
190
                      (types (if (json-array? types)
191
                                 (array->list types)
192
                                 (list types)))
193
                      (types (if (equal? expanded-index "@none")
194
                                 types
195
                                 (cons expanded-index types))))
196
                 (unless (equal? (length types) 0)
197
                   (set! item (alist-set item "@type" (list->array 1 types))))))
198
              (else #t))
199
            (set! expanded-value (append expanded-value (list item))))
200
          (array->list index-value)))
201
      (if (jsonld-options-ordered? options)
202
        (alist-sort-by-key value)
203
        value))
204
  (set! expanded-value (list->array 1 expanded-value))
205
  `(("expanded-value" . ,expanded-value))))
206
207
;; 13.4
208
(define (execute-when-keyword active-context key value expanded-property
209
                              active-property expanded-value continue? result
210
                              type-scoped-context input-type nests base-url options)
211
  (cond
212
    ;; 13.4.1
213
    ((equal? active-property "@reverse")
214
     (throw 'invalid-reverse-property-map))
215
    ;; 13.4.2
216
    ((and (json-has-key? result expanded-property)
217
          (or (processing-mode-1.0? (jsonld-options-processing-mode options))
218
              (not (member expanded-property '("@included" "@type")))))
219
     (throw 'colliding-keywords))
220
    ;; 13.4.3
221
    ((equal? expanded-property "@id")
222
     (unless (or (string? value)
223
                 (and (jsonld-options-frame-expansion? options)
224
                      (or (equal? value '())
225
                          (not (equal? value #()))
226
                          (string-array? value))))
227
       (throw 'invalid-@id-value))
228
     (cond
229
       ((string? value)
230
        (set! expanded-value (assoc-ref
231
                               (iri-expansion active-context value
232
                                              #:document-relative? #t
233
                                              #:options options)
234
                               "iri"))
235
        (when (jsonld-options-frame-expansion? options)
236
          (set! expanded-value `#(,expanded-value))))
237
       ((equal? value '())
238
        ;; XXX: is the the right thing to do?
239
        (set! expanded-value `#(())))
240
       ((json-array? value)
241
        (set! expanded-value
242
          (map
243
            (lambda (v)
244
              (assoc-ref
245
                (iri-expansion active-context v
246
                               #:document-relative? #t
247
                               #:options options)
248
                "iri"))
249
            (array->list value)))
250
        (set! expanded-value (list->array 1 expanded-value)))))
251
    ;; 13.4.4
252
    ((equal? expanded-property "@type")
253
     ;; 13.4.4.1
254
     (unless (or (string? value)
255
                 (string-array? value)
256
                 (and
257
                   (jsonld-options-frame-expansion? options)
258
                   (or
259
                     (equal? value '())
260
                     (and (json-object? value)
261
                          (json-has-key? value "@default")))))
262
       (throw 'invalid-type-value))
263
     (cond
264
       ;; 13.4.4.2
265
       ((equal? value '())
266
        (set! expanded-value '()))
267
       ;; 13.4.4.3
268
       ((json-has-key? value "@default")
269
        (let ((iri (assoc-ref
270
                     (iri-expansion type-scoped-context (assoc-ref value "@default")
271
                                    #:vocab? #t
272
                                    #:document-relative? #t
273
                                    #:options options)
274
                     "iri")))
275
          (unless (absolute-iri? iri)
276
            (throw 'invalid-type-value))
277
          (set! expanded-value (alist-set value "@default" iri))))
278
       ;; 13.4.4.4
279
       ((string? value)
280
        (set! expanded-value
281
          (assoc-ref
282
            (iri-expansion type-scoped-context value
283
                           #:vocab? #t
284
                           #:document-relative? #t
285
                           #:options options)
286
            "iri")))
287
       ((string-array? value)
288
        (set! expanded-value
289
          (list->array 1
290
            (map
291
              (lambda (v)
292
                (assoc-ref
293
                  (iri-expansion type-scoped-context v
294
                                 #:vocab? #t
295
                                 #:document-relative? #t
296
                                 #:options options)
297
                  "iri"))
298
              (array->list value))))))
299
     ;; 13.4.4.5
300
     (when (json-has-key? result "@type")
301
       (set! expanded-value
302
         (list->array 1 (append
303
                          (array->list
304
                            (if (json-array? (assoc-ref result "@type"))
305
                                (assoc-ref result "@type")
306
                                `#(,(assoc-ref result "@type"))))
307
                          (array->list
308
                            (if (json-array? expanded-value)
309
                                expanded-value
310
                                `#(,expanded-value))))))))
311
    ;; 13.4.5
312
    ((equal? expanded-property "@graph")
313
     (set! expanded-value (expansion active-context "@graph" value base-url
314
                                     #:options options))
315
     (unless (json-array? expanded-value)
316
       (set! expanded-value `#(,expanded-value))))
317
    ;; 13.4.6
318
    ((equal? expanded-property "@included")
319
     (if (processing-mode-1.0? (jsonld-options-processing-mode options))
320
       (set! continue? #f))
321
       (begin
322
         ;; 13.4.6.2
323
         (set! expanded-value
324
           (expansion active-context active-property value base-url
325
                      #:options options))
326
         (if (json-array? expanded-value)
327
             (set! expanded-value (array->list expanded-value))
328
             (set! expanded-value (list expanded-value)))
329
         ;; 13.4.6.3
330
         (unless (null? (filter
331
                          (lambda (v)
332
                            (not (node-object? v)))
333
                          expanded-value))
334
           (throw 'invalid-@included-value))
335
         ;; 13.4.6.4
336
         (set! expanded-value
337
           (append
338
             (if (json-has-key? result "@included")
339
                 (array->list (assoc-ref result "@included"))
340
                 '())
341
             expanded-value))
342
         (set! expanded-value (list->array 1 expanded-value))))
343
    ;; 13.4.7
344
    ((equal? expanded-property "@value")
345
     ;; 13.4.7.1
346
     (if (equal? input-type "@json")
347
         (begin
348
           (set! expanded-value value)
349
           (when (processing-mode-1.0? (jsonld-options-processing-mode options))
350
             (throw 'invalid-value-object-value)))
351
         ;; 13.4.7.2
352
         (begin
353
           (unless (or (scalar? value)
354
                       (json-null? value)
355
                       (and (jsonld-options-frame-expansion? options)
356
                            (or (equal? value '())
357
                                (scalar-array? value))))
358
             (throw 'invalid-value-object-value))))
359
     ;; 13.4.7.3
360
     (set! expanded-value value)
361
     (when (jsonld-options-frame-expansion? options)
362
       (when (equal? expanded-value '())
363
         (set! expanded-value #(())))
364
       (when (scalar? expanded-value)
365
         (set! expanded-value #(,expanded-value))))
366
     ;; 13.4.7.4
367
     (when (json-null? expanded-value)
368
       (set! continue? #f)
369
       (set! result (alist-set result "@value" json-null))))
370
    ;; 13.4.8
371
    ((equal? expanded-property "@language")
372
     (unless (or (string? value)
373
                 (and (jsonld-options-frame-expansion? options)
374
                      (or (string-array? value)
375
                          (equal? value '()))))
376
       (throw 'invalid-language-tagged-string))
377
     ;; TODO: warning when value is to bcp-47 compliant
378
     (cond
379
       ((string? value)
380
        (set! expanded-value (string-downcase value))
381
        (when (jsonld-options-frame-expansion? options)
382
          (set! expanded-value `#(,expanded-value))))
383
       ((equal? value '())
384
        (set! expanded-value #(())))
385
       ((string-array? value)
386
        (set! expanded-value value))))
387
    ;; 13.4.9
388
    ((equal? expanded-property "@direction")
389
     (if (processing-mode-1.0? (jsonld-options-processing-mode options))
390
       (set! continue? #f)
391
       (begin
392
         (unless (or (equal? value "ltr") (equal? value "rtl")
393
                     (and (jsonld-options-frame-expansion? options)
394
                          (or (string-array? value)
395
                              (equal? value '()))))
396
           (throw 'invalid-base-direction))
397
         (cond
398
           ((string? value)
399
            (set! expanded-value value)
400
            (when (jsonld-options-frame-expansion? options)
401
              (set! expanded-value `#(,expanded-value))))
402
           ((equal? value '())
403
            (set! expanded-value #(())))
404
           ((string-array? value)
405
            (set! expanded-value value))))))
406
    ;; 13.4.10
407
    ((equal? expanded-property "@index")
408
     (if (string? value)
409
       (set! expanded-value value)
410
       (throw 'invalid-@index-value)))
411
    ;; 13.4.11
412
    ((equal? expanded-property "@list")
413
     (if (or (equal? active-property "@graph") (json-null? active-property))
414
       ;; 13.4.11.1
415
       (set! continue? #f)
416
       (begin
417
         ;; 13.4.11.2
418
         (set! expanded-value
419
           (expansion active-context active-property value base-url
420
                      #:options options))
421
         ;; Not in spec, but expected from the tests and implemented elsewhere
422
         (unless (json-array? expanded-value)
423
           (set! expanded-value `#(,expanded-value))))))
424
    ;; 13.4.12
425
    ((equal? expanded-property "@set")
426
     (set! expanded-value (expansion active-context active-property value base-url
427
                                  #:options options)))
428
    ;; 13.4.13
429
    ((equal? expanded-property "@reverse")
430
     (unless (json-object? value)
431
       (throw 'invalid-@reverse-value))
432
     ;; 13.4.13.2
433
     (set! expanded-value (expansion active-context "@reverse" value base-url
434
                                     #:options options))
435
     ;; 13.4.13.3
436
     (when (json-has-key? expanded-value "@reverse")
437
       (for-each-pair
438
         (lambda (property item)
439
           (if (json-has-key? result property)
440
             (set! result
441
               (alist-set result property
442
                          (list->array 1
443
                            (append
444
                              (array->list (assoc-ref result property))
445
                              (list item)))))
446
             (set! result
447
               (alist-set result property
448
                          (if (json-array? item) item `#(,item))))))
449
         (assoc-ref expanded-value "@reverse")))
450
     ;; 13.4.13.4
451
     (unless (null? (filter
452
                      (lambda (p) (not (equal? (car p) "@reverse")))
453
                      expanded-value))
454
       ;; 13.4.13.4.1 and 13.4.13.4.2
455
       (let ((reverse-map
456
               (if (json-has-key? result "@reverse")
457
                   (assoc-ref result "@reverse")
458
                   '())))
459
         (for-each-pair
460
           ;; 13.4.13.4.3
461
           (lambda (property items)
462
             (unless (equal? property "@reverse")
463
               (for-each
464
                 ;; 13.4.13.4.3.1
465
                 (lambda (item)
466
                   ;; 13.4.13.4.3.1.1
467
                   (when (json-has-key? item "@value")
468
                     (throw 'invalid-reverse-property-value))
469
                   (when (json-has-key? item "@list")
470
                     (throw 'invalid-reverse-property-value))
471
                   (if (json-has-key? reverse-map property)
472
                     ;; 13.4.13.4.3.1.2
473
                     (set! reverse-map
474
                       (alist-set reverse-map property
475
                                  (list->array 1
476
                                    (append
477
                                      (array->list
478
                                        (assoc-ref reverse-map property))
479
                                      (list item)))))
480
                     ;; 13.4.13.4.3.1.3
481
                     (set! reverse-map
482
                       (alist-set reverse-map property `#(,item)))))
483
                 (array->list items))))
484
           expanded-value)
485
         (set! result (alist-set result "@reverse" reverse-map))))
486
     ;; 13.4.13.5
487
     (set! continue? #f))
488
    ;; 13.4.14
489
    ((equal? expanded-property "@nest")
490
     (set! nests (cons key (or nests '())))
491
     (set! continue? #f))
492
    ;; 13.4.15
493
    ((and (jsonld-options-frame-expansion? options)
494
          (member expanded-property '("@explicit" "@default" "@embed"
495
                                      "@omitDefault" "@requireAll")))
496
     (set! expanded-value (expansion active-context active-property value base-url
497
                                     #:options options))))
498
  ;; 13.4.16
499
  (unless (or (not continue?)
500
              (and (json-null? expanded-value)
501
                   (equal? expanded-property "@value")
502
                   (equal? input-type "@json")))
503
    (set! result (alist-set result expanded-property expanded-value)))
504
  `(("result" . ,result) ("nests" . ,nests)))
505
506
(define (execute-13 active-context active-property element property-scoped-context
507
                    type-scoped-context result nests input-type base-url options)
508
  (for-each-pair
509
    (lambda (key value)
510
      ;; 13.1: skip is @context
511
      (unless (equal? key "@context")
512
        ;; 13.2
513
        (let ((expanded-property
514
                (assoc-ref (iri-expansion active-context key
515
                                          #:vocab? #t
516
                                          #:options options)
517
                           "iri"))
518
              (expanded-value json-null)
519
              ;; whether we continue evaluating this key or not.  #f means go
520
              ;; immediately to processing the next key-value pair.
521
              (continue? #t)
522
              (container-mapping #f))
523
          (cond
524
            ;; 13.3
525
            ((or (json-null? expanded-property)
526
                 (not (or (json-keyword? expanded-property)
527
                          (string-index expanded-property #\:))))
528
             (set! continue? #f))
529
            ;; 13.4
530
            ((json-keyword? expanded-property)
531
             (let ((exec-result (execute-when-keyword
532
                                  active-context key value expanded-property
533
                                  active-property expanded-value continue? result
534
                                  type-scoped-context input-type nests base-url
535
                                  options)))
536
               (set! result (assoc-ref exec-result "result"))
537
               (set! nests (assoc-ref exec-result "nests")))
538
             (set! continue? #f))
539
            ;; 13.5
540
            (else
541
              (set! container-mapping
542
                (let* ((def (term-definition-ref active-context key))
543
                       (container (and (term-definition? def)
544
                                       (term-definition-container def))))
545
                  (and (term-definition? def)
546
                       (if (json-array? container)
547
                           (array->list container)
548
                           (if container (list container) '())))))
549
              (cond
550
                ;; 13.6
551
                ((and
552
                   (term-definition? (term-definition-ref active-context key))
553
                   (equal?
554
                     (term-definition-type
555
                       (term-definition-ref active-context key))
556
                     "@json"))
557
                 (set! expanded-value `(("@value" . ,value) ("@type" . "@json"))))
558
                ;; 13.7
559
                ((and container-mapping
560
                      (member "@language" container-mapping)
561
                      (json-object? value))
562
                 (let ((exec-result (execute-when-language
563
                                      active-context key value expanded-property
564
                                      active-property expanded-value result
565
                                      options)))
566
                   (set! expanded-value (assoc-ref exec-result "expanded-value"))))
567
                ;; 13.8
568
                ((and container-mapping
569
                      (or
570
                        (member "@index" container-mapping)
571
                        (member "@type" container-mapping)
572
                        (member "@id" container-mapping))
573
                      (json-object? value))
574
                 (let ((exec-result (execute-when-index
575
                                      active-context key value expanded-property
576
                                      active-property expanded-value result
577
                                      container-mapping base-url options)))
578
                   (set! expanded-value (assoc-ref exec-result "expanded-value"))))
579
                ;; 13.9
580
                (else
581
                  (set! expanded-value
582
                    (expansion active-context key value base-url
583
                               #:options options))))))
584
          ;; 13.10 and previous (via continue?): do we process further, or
585
          ;; go to the next key immediately?
586
          (when (and continue? (not (json-null? expanded-value)))
587
            ;; 13.11
588
            (when (and container-mapping
589
                       (member "@list" container-mapping)
590
                       (not (json-has-key? expanded-value "@list")))
591
              (set! expanded-value
592
                `(("@list" . ,(if (json-array? expanded-value)
593
                                  expanded-value
594
                                  `#(,expanded-value))))))
595
            ;; 13.12
596
            (when (and container-mapping
597
                       (member "@graph" container-mapping)
598
                       (not (member "@id" container-mapping))
599
                       (not (member "@index" container-mapping)))
600
              (if (json-array? expanded-value)
601
                (set! expanded-value (array->list expanded-value))
602
                (set! expanded-value (list expanded-value)))
603
              (set! expanded-value
604
                (map
605
                  (lambda (ev)
606
                    `(("@graph" . ,(if (json-array? ev) ev `#(,ev)))))
607
                  expanded-value))
608
              (set! expanded-value (list->array 1 expanded-value)))
609
            ;; 13.13
610
            (if (and (term-definition?
611
                       (term-definition-ref active-context key))
612
                     (term-definition-reverse?
613
                       (term-definition-ref active-context key)))
614
              ;; 13.13.1 and 13.13.2
615
              (let ((reverse-map
616
                      (if (json-has-key? result "@reverse")
617
                          (assoc-ref result "@reverse")
618
                          '())))
619
                (for-each
620
                  ;; 13.13.4
621
                  (lambda (item)
622
                    ;; 13.13.4.1
623
                    (when (json-has-key? item "@value")
624
                      (throw 'invalid-reverse-property-value))
625
                    ;; 13.13.4.1
626
                    (when (json-has-key? item "@list")
627
                      (throw 'invalid-reverse-property-value))
628
                    ;; 13.13.4.2 and 13.13.4.3
629
                    (set! reverse-map
630
                      (alist-set reverse-map expanded-property
631
                                 (list->array 1
632
                                   (append
633
                                     (array->list
634
                                       (if (json-has-key? reverse-map expanded-property)
635
                                           (assoc-ref reverse-map expanded-property)
636
                                           #()))
637
                                     (list item))))))
638
                  ;; 13.13.3
639
                  (if (json-array? expanded-value)
640
                    (array->list expanded-value)
641
                    (list expanded-value)))
642
                (set! result (alist-set result "@reverse" reverse-map)))
643
              ;; 13.14
644
              (set! result
645
                (alist-set result expanded-property
646
                           (list->array 1
647
                             (if (json-array? expanded-value)
648
                               (append
649
                                 (array->list
650
                                   (if (json-has-key? result expanded-property)
651
                                       (assoc-ref result expanded-property)
652
                                       #()))
653
                                 (array->list expanded-value))
654
                               (append
655
                                 (array->list
656
                                   (if (json-has-key? result expanded-property)
657
                                       (assoc-ref result expanded-property)
658
                                       #()))
659
                                 (list expanded-value)))))))))))
660
    (if (jsonld-options-ordered? options)
661
        (alist-sort-by-key element)
662
        element))
663
  `(("result" . ,result)
664
    ("nests" . ,nests)))
665
666
(define (execute-14 active-context active-property element property-scoped-context
667
                    type-scoped-context result nests input-type base-url options)
668
  ;; 14
669
  (for-each
670
    (lambda (nesting-key)
671
      ;; 14.1
672
      (let ((nested-values (assoc-ref element nesting-key)))
673
        (unless (json-array? nested-values)
674
          (set! nested-values `#(,nested-values)))
675
        ;; 14.2
676
        (for-each
677
          (lambda (nested-value)
678
            ;; 14.2.1
679
            (unless (and (json-object? nested-value)
680
                         ;; XXX: "expand to @value"
681
                         (not (json-key-expanded-to? active-context nested-value "@value")))
682
              (throw 'invalid-@nest-value))
683
            ;; 14.2.2
684
            (let* ((active-property nesting-key)
685
                   (active-property-term-definition
686
                     (term-definition-ref active-context active-property))
687
                   (property-scoped-context
688
                     (if (and (term-definition? active-property-term-definition)
689
                              (not (equal? (term-definition-context active-property-term-definition) #f)))
690
                         (term-definition-context active-property-term-definition)
691
                         property-scoped-context))
692
                   (active-context
693
                     (if property-scoped-context
694
                         (context-processing active-context property-scoped-context
695
                                             base-url
696
                                             #:override-protected? #t
697
                                             #:options options)
698
                         active-context))
699
                   (exec-result
700
                     (execute-13 active-context active-property
701
                                 nested-value property-scoped-context
702
                                 type-scoped-context result '()
703
                                 input-type base-url options)))
704
              (set! result (assoc-ref exec-result "result"))
705
              (set! nests (assoc-ref exec-result "nests"))
706
              (let ((exec-result
707
                      (execute-14 active-context active-property
708
                                  nested-value property-scoped-context
709
                                  type-scoped-context result nests input-type
710
                                  base-url options)))
711
                (set! result (assoc-ref exec-result "result")))))
712
          (array->list nested-values))))
713
    ;; nests was built with cons, so we have to reverse it
714
    (reverse nests))
715
  `(("result" . ,result)))
716
717
(define* (expansion active-context active-property element base-url
718
                    #:key (from-map? #f) (options (new-jsonld-options)))
719
  "Expand a JsonLD document.  This is an implementation of the expansion
720
algorithm defined in the JsonLD API specification.
721
722
See @url{https://www.w3.org/TR/2014/REC-json-ld-api-20140116}."
723
  ;; 3
724
  (define property-scoped-context
725
    (if (term-definition? (term-definition-ref active-context active-property))
726
        ;; can be null, so we cannot use `or` here
727
        (term-definition-context (term-definition-ref
728
                                   active-context active-property))
729
        #f))
730
  ;; 2
731
  (when (equal? active-property "@default")
732
    (set! options (update-jsonld-options options #:frame-expansion? #f)))
733
  (cond
734
    ;; 1
735
    ((json-null? element) json-null)
736
    ;; 4
737
    ((scalar? element)
738
     (if (member active-property `(,json-null "@graph"))
739
       ;; 4.1
740
       json-null
741
       (begin
742
         ;; 4.2
743
         (unless (equal? property-scoped-context #f)
744
           (set! active-context
745
             (context-processing active-context property-scoped-context base-url)))
746
         ;; 4.3
747
         (value-expansion active-context active-property element #:options options))))
748
    ;; 5
749
    ((array? element)
750
     ;; 5.1
751
     (let ((result '()))
752
       ;; 5.2
753
       (for-each
754
         (lambda (item)
755
           ;; 5.2.1
756
           (let ((expanded-item (expansion active-context active-property item base-url
757
                                           #:from-map? from-map?
758
                                           #:options options)))
759
             ;; 5.2.2
760
             (when (and
761
                     (term-definition? (term-definition-ref active-context active-property))
762
                     (term-definition-container (term-definition-ref active-context active-property))
763
                     (member "@list" (array->list (term-definition-container (term-definition-ref active-context active-property))))
764
                     (json-array? expanded-item))
765
               (set! expanded-item `(("@list" . ,expanded-item))))
766
             ;; 5.2.3
767
             (if (json-array? expanded-item)
768
               (set! result (append result (array->list expanded-item)))
769
               (unless (json-null? expanded-item)
770
                 (set! result (append result (list expanded-item)))))))
771
         (array->list element))
772
       ;; 5.3
773
       (list->array 1 result)))
774
    ;; 6
775
    (else
776
      ;; 7
777
      (unless (json-null? (active-context-previous active-context))
778
        (let ((previous (active-context-previous active-context)))
779
          (unless (or from-map? (json-key-expanded-to? active-context element "@value")
780
                      (and
781
                        (= (length element) 1)
782
                        (json-key-expanded-to? previous element "@id")))
783
            (set! active-context (active-context-previous active-context)))))
784
      ;; 8
785
      (unless (equal? property-scoped-context #f)
786
        (let* ((def (term-definition-ref active-context active-property))
787
               (base-url
788
                 (if (term-definition? def)
789
                     (term-definition-base-url def)
790
                     base-url)))
791
          (set! active-context
792
            (context-processing active-context property-scoped-context base-url
793
                                #:override-protected? #t
794
                                #:options options))))
795
      ;; 9
796
      (when (json-has-key? element "@context")
797
        (set! active-context
798
          (context-processing active-context (assoc-ref element "@context")
799
                              base-url #:options options)))
800
      ;; 10, 12
801
      (let ((type-scoped-context active-context)
802
            (result '())
803
            (nests '())
804
            (input-type json-null)
805
            (found-first-entry? #f))
806
        ;; 11
807
        (for-each-pair
808
          (lambda (key value)
809
            (when (equal? (expand-key active-context key) "@type")
810
              ;; 12
811
              (unless found-first-entry?
812
                (match value
813
                  ((? json-array? value)
814
                   (set! input-type (car (reverse (array->list value)))))
815
                  (_ (set! input-type value)))
816
                (set! input-type
817
                  (assoc-ref
818
                    (iri-expansion active-context input-type #:vocab? #t)
819
                    "iri")))
820
              (set! found-first-entry? #t)
821
              ;; 11.1
822
              (unless (json-array? value)
823
                (set! value `#(,value)))
824
              ;; 11.2
825
              (for-each
826
                (lambda (term)
827
                  (when (and (term-definition? (term-definition-ref type-scoped-context term))
828
                             (not (equal?
829
                                    (term-definition-context
830
                                      (term-definition-ref type-scoped-context term))
831
                                    #f)))
832
                    (set! active-context
833
                      (context-processing active-context
834
                                          (term-definition-context
835
                                            (term-definition-ref type-scoped-context
836
                                                                 term))
837
                                          (term-definition-base-url
838
                                            (term-definition-ref type-scoped-context
839
                                                                 term))
840
                                          #:propagate? #f
841
                                          #:options options))))
842
                (sort (filter string? (array->list value)) string<=?))))
843
          (alist-sort-by-key element))
844
        ;; 13
845
        (let ((exec-result
846
                (execute-13 active-context active-property element
847
                            property-scoped-context type-scoped-context result
848
                            nests input-type base-url options)))
849
          (set! result (assoc-ref exec-result "result"))
850
          (set! nests (assoc-ref exec-result "nests")))
851
        ;; 14
852
        (let ((exec-result
853
                (execute-14 active-context active-property element
854
                            property-scoped-context type-scoped-context result
855
                            nests input-type base-url options)))
856
          (set! result (assoc-ref exec-result "result")))
857
        (cond
858
          ;; 15
859
          ((json-has-key? result "@value")
860
            (begin
861
             ;; 15.1
862
             (unless (null?
863
                       (filter
864
                         (lambda (p)
865
                           (not
866
                             (member (car p)
867
                                     '("@direction" "@value" "@type" "@language" "@index"))))
868
                         result))
869
               (throw 'invalid-value-object))
870
             (when (and
871
                     (or
872
                       (json-has-key? result "@language")
873
                       (json-has-key? result "@direction"))
874
                     (json-has-key? result "@type"))
875
               (throw 'invalid-value-object))
876
             ;; 15.2
877
             (unless (equal? (assoc-ref result "@type") "@json")
878
               ;; 15.3
879
               (when (json-null? (assoc-ref result "@value"))
880
                 (set! result json-null))
881
               ;; 15.4
882
               (unless (or
883
                         (string? (assoc-ref result "@value"))
884
                         (not (json-has-key? result "@language")))
885
                 (throw 'invalid-language-tagged-value))
886
               ;; 15.5
887
               (unless (or
888
                         (not (json-has-key? result "@type"))
889
                         (absolute-iri? (assoc-ref result "@type")))
890
                 ;; XXX: what if it's a list? is it valid?
891
                 (throw 'invalid-typed-value)))))
892
          ;; 16
893
          ((json-has-key? result "@type")
894
           (unless (json-array? (assoc-ref result "@type"))
895
             (set! result
896
               (alist-set result "@type" `#(,(assoc-ref result "@type"))))))
897
          ;; 17
898
          ((json-has-key? result "@list")
899
           ;; 17.1
900
           (unless (null?
901
                     (filter
902
                       (lambda (p)
903
                         (not (member (car p) '("@list" "@index"))))
904
                       result))
905
             (throw 'invalid-set-or-list-object)))
906
          ;; 17
907
          ((json-has-key? result "@set")
908
           ;; 17.1
909
           (unless (null?
910
                     (filter
911
                       (lambda (p)
912
                         (not (member (car p) '("@set" "@index"))))
913
                       result))
914
             (throw 'invalid-set-or-list-object))
915
           ;; 17.2
916
           (set! result (assoc-ref result "@set")))
917
          (else #t))
918
        (cond
919
          ;; 18
920
          ((and (json-has-key? result "@language")
921
                (null? (filter (lambda (p) (not (equal? (car p) "@language")))
922
                               result)))
923
           (set! result json-null))
924
          ;; 19
925
          ((or (json-null? active-property) (equal? active-property "@graph"))
926
           (if (or (equal? result '())
927
                   (json-has-key? result "@value")
928
                   (json-has-key? result "@list"))
929
               (set! result json-null)
930
               (when (and
931
                       (not (jsonld-options-frame-expansion? options))
932
                       (json-has-key? result "@id")
933
                       (null? (filter (lambda (p) (not (equal? (car p) "@id")))
934
                                      result)))
935
                 (set! result json-null))))
936
          ;; 20
937
          (else #t))
938
        result))))
939