guile-jsonld

iri-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 iri-compaction)
  #:use-module (iri iri)
  #:use-module (jsonld context)
  #:use-module (jsonld inverse-context-creation)
  #:use-module (jsonld json)
  #:use-module (jsonld term-selection)
  #:export (iri-compaction))

(define-syntax set-cond!
  (syntax-rules ()
    ((_ var val)
     (unless var
       (set! var val)))))

(define* (iri-compaction active-context var
                         #:key value vocab? reverse? processing-mode)
  ;; not specified, but sometimes the spec leads to var being an array, so
  ;; in that case we iri-compact each part of it and return an array.
  (cond
    ;; 1
    ((json-null? var) json-null)
    ;; XXX: addition to spec
    ((json-array? var)
     (list->array 1
       (map
         (lambda (val)
           (iri-compaction active-context val
                           #:value value
                           #:vocab? vocab?
                           #:reverse? reverse?
                           #:processing-mode processing-mode))
         (array->list var))))
    (else
     (begin
       ;; 2
       (when (json-null? (active-context-inverse-context active-context))
         (set! active-context
           (update-active-context active-context
                                  #:inverse-context
                                  (inverse-context-creation active-context))))
       ;; 3
       (let* ((inverse-context (active-context-inverse-context active-context))
              (result #f))
         ;; 4
         (when (and vocab? (json-has-key? inverse-context var))
           (let ((default-language
                   ;; 4.1
                   (if (not-null-or-false (active-context-direction active-context))
                       (string-append
                         (string-downcase
                           (or (not-null-or-false (active-context-language active-context))
                               ""))
                         "_"
                         (active-context-direction active-context))
                       (string-downcase
                         (or (not-null-or-false (active-context-language active-context))
                             "@none"))))
                 ;; 4.3
                 (containers '())
                 ;; 4.4
                 (type/language "@language")
                 (type/language-value "@null")
                 ;; 4.14
                 (preferred-values '()))
             ;; 4.2
             (when (json-has-key? value "@preserve")
               (let ((preserve (assoc-ref value "@preserve")))
                 (set! value
                   (if (json-array? preserve)
                       (car (array->list preserve))
                       preserve))))
             ;; 4.5
             (when (and (json-has-key? value "@index")
                        (not (graph-object? value)))
               (set! containers
                 (append containers '("@index" "@index@set"))))
             (cond
               ;; 4.6
               (reverse?
                 (set! type/language "@type")
                 (set! type/language-value "@reverse")
                 (set! containers (append containers '("@set"))))
               ;; 4.7
               ((list-object? value)
                ;; 4.7.1
                (unless (json-has-key? value "@index")
                  (set! containers (append containers '("@list"))))
                ;; 4.7.2
                (let ((lst (array->list (assoc-ref value "@list")))
                      ;; 4.7.3
                      (common-type json-null)
                      (common-language json-null))
                  (when (null? lst)
                    (set! common-language default-language))
                  ;; 4.7.4
                  (for-each
                    (lambda (item)
                      ;; 4.7.4.1
                      (let ((item-language "@none")
                            (item-type "@none"))
                        (if (json-has-key? item "@value")
                            ;; 4.7.4.2
                            (cond
                              ((json-has-key? item "@direction")
                               (set! item-language
                                 (string-append
                                   (or (assoc-ref item "@language") "")
                                   "_"
                                   (assoc-ref item "@direction"))))
                              ((json-has-key? item "@language")
                               (set! item-language (assoc-ref item "@language")))
                              ((json-has-key? item "@type")
                               (set! item-type (assoc-ref item "@type")))
                              (else
                                (set! item-language "@null")))
                            ;; 4.7.4.3
                            (set! item-type "@id"))
                        ;; 4.7.4.4
                        (if (json-null? common-language)
                            (set! common-language item-language)
                            (unless (or (equal? common-language item-language)
                                        (not (json-has-key? item "@value")))
                              (set! common-language "@none")))
                        ;; 4.7.4.6
                        (if (json-null? common-type)
                            (set! common-type item-type)
                            (unless (equal? common-type item-type)
                              (set! common-type "@none")))))
                    lst)
                  ;; 4.7.5
                  (when (json-null? common-language)
                    (set! common-language "@none"))
                  (when (json-null? common-type)
                    (set! common-type "@none"))
                  (if (not (equal? common-type "@none"))
                      (begin
                        (set! type/language "@type")
                        (set! type/language-value common-type))
                      (set! type/language-value common-language))))
               ;; 4.8
               ((graph-object? value)
                ;; 4.8.1
                (when (json-has-key? value "@index")
                  (set! containers
                    (append containers '("@graph@index" "@graph@index@set"))))
                ;; 4.8.2
                (when (json-has-key? value "@id")
                  (set! containers
                    (append containers '("@graph@id" "@graph@id@set"))))
                ;; 4.8.3
                (set! containers
                  (append containers '("@graph" "@graph@set" "@set")))
                ;; 4.8.4
                (unless (json-has-key? value "@index")
                  (set! containers
                    (append containers '("@graph@index" "@graph@index@set"))))
                ;; 4.8.5
                (unless (json-has-key? value "@id")
                  (set! containers
                    (append containers '("@graph@id" "@graph@id@set"))))
                ;; 4.8.6
                (set! containers
                  (append containers '("@index" "@index@set")))
                ;; 4.8.7
                (set! type/language "@type")
                (set! type/language-value "@id"))
               ;; 4.9.1 and 4.9.3
               ((json-has-key? value "@value")
                (cond
                  ((and (json-has-key? value "@direction")
                        (not (json-has-key? value "@index")))
                   (set! type/language-value
                     (string-append
                       (or (assoc-ref value "@language") "")
                       "_"
                       (assoc-ref value "@direction")))
                   (set! containers
                     (append containers '("@language" "@language@set"))))
                  ((and (json-has-key? value "@language")
                        (not (json-has-key? value "@index")))
                   (set! type/language-value (assoc-ref value "@language"))
                   (set! containers
                     (append containers '("@language" "@language@set"))))
                  ((json-has-key? value "@type")
                   (set! type/language-value (assoc-ref value "@type"))
                   (set! type/language "@type")))
                (set! containers (append containers '("@set"))))
               ;; 4.9.2 and 4.9.3
               (else
                (set! type/language "@type")
                (set! type/language-value "@id")
                (set! containers
                  (append containers '("@id" "@id@set" "@type" "@set@type" "@set")))))
             ;; 4.10
             (set! containers (append containers '("@none")))
             ;; 4.11
             (unless (processing-mode-1.0? processing-mode)
               (unless (json-has-key? value "@index")
                 (set! containers (append containers '("@index" "@index@set"))))
               ;; 4.12
               (when (and (json-has-key? value "@value")
                          (null? (filter (lambda (kp) (not (equal? (car kp) "@value")))
                                         value)))
                 (set! containers (append containers '("@language" "@language@set")))))
             ;; 4.13
             (when (equal? type/language-value json-null)
               (set! type/language-value "@null"))
             ;; 4.15
             (when (equal? type/language-value "@reverse")
               (set! preferred-values (append preferred-values '("@reverse"))))
             ;; 4.16
             (if (and (or (equal? type/language-value "@reverse")
                          (equal? type/language-value "@id"))
                      (json-has-key? value "@id"))
               (let* ((compacted-iri (iri-compaction active-context
                                                     (assoc-ref value "@id")
                                                     #:vocab? #t
                                                     #:processing-mode processing-mode))
                      (def (term-definition-ref active-context compacted-iri))
                      (iri (if (term-definition? def)
                               (term-definition-iri def)
                               #f)))
                 (if (equal? iri (assoc-ref value "@id"))
                     (set! preferred-values
                       (append preferred-values '("@vocab" "@id" "@none")))
                     (set! preferred-values
                       (append preferred-values '("@id" "@vocab" "@none")))))
               ;; 4.17
               (begin
                 (when (equal? (assoc-ref value "@list") #())
                   (set! type/language "@any"))
                 (set! preferred-values
                   (append preferred-values (list type/language-value "@none")))))
             ;; 4.18
             (set! preferred-values (append preferred-values '("@any")))
             ;; 4.19
             (let* ((underscore-vals (filter
                                       (lambda (s)
                                         (string-index s #\_))
                                       preferred-values))
                    (underscore (if (null? underscore-vals) #f (car underscore-vals))))
               (when (not-null-or-false underscore)
                 (set! preferred-values
                   (append
                     preferred-values
                     (list
                       (string-join
                         (cons "" (cdr (string-split underscore #\_))) "_"))))))
             ;; 4.20
             (let ((term (term-selection active-context var containers
                                         type/language preferred-values)))
               (when (not-null-or-false term)
                 (set-cond! result term)))))
         ;; 5
         (when (and vocab? (not-null-or-false (active-context-vocab active-context)))
           (let ((vocab (active-context-vocab active-context)))
             (when (and (>= (string-length var) (string-length vocab))
                        (equal? (substring var 0 (string-length vocab)) vocab))
               (let ((suffix (substring var (string-length vocab))))
                 (when (not (not-null-or-false (term-definition-ref active-context suffix)))
                   (set-cond! result suffix))))))
         ;; 6
         (let ((compact-iri json-null))
           ;; 7
           (for-each-pair
             (lambda (term def)
               ;; 7.1
               (unless (or (json-null? (term-definition-iri def))
                           (equal? (term-definition-iri def) var)
                           (not (string? var))
                           (< (string-length var) (string-length (term-definition-iri def)))
                           (not (equal?
                                  (substring
                                    var 0
                                    (string-length (term-definition-iri def)))
                                  (term-definition-iri def)))
                           (not (term-definition-prefix? def)))
                 ;; 7.2
                 (let ((candidate (string-append term ":"
                                                 (substring
                                                   var
                                                   (string-length
                                                     (term-definition-iri def))))))
                   ;; 7.3
                   (when (or (json-null? compact-iri)
                             (< (string-length candidate) (string-length compact-iri))
                             (and (= (string-length candidate)
                                     (string-length compact-iri))
                                  (string<=? candidate compact-iri)))
                     (let ((def (term-definition-ref active-context candidate)))
                       (when (or (not (term-definition? def))
                                 (and (not (not-null-or-false value))
                                      (equal? (term-definition-iri def) var)))
                         (set! compact-iri candidate)))))))
             (active-context-definitions active-context))
           ;; 8
           (when (not-null-or-false compact-iri)
             (set-cond! result compact-iri)))
         ;; 9
         (unless result
           (let* ((components (string-split var #\:))
                  (prefix (car components))
                  (suffix (string-join (cdr components) ":")))
             (unless (null? (filter
                              (lambda (kp)
                                (and
                                  (equal? prefix (car kp))
                                  (term-definition-prefix? (cdr kp))))
                              (active-context-definitions active-context)))
               (unless (and (> (string-length suffix) 2)
                            (equal? (substring suffix 0 2) "//"))
                 (throw 'iri-confused-with-prefix)))))
         ;; 10
         (unless vocab?
           (when (and (not-null-or-false (active-context-base active-context))
                      (absolute-iri? var))
             (let ((iri (make-relative-iri var (active-context-base active-context))))
               (if (keyword-form? iri)
                   (set-cond! result (string-append "./" iri))
                   (set-cond! result iri)))))
         ;; 11
         (set-cond! result var)
         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 iri-compaction)
19	#:use-module (iri iri)
20	#:use-module (jsonld context)
21	#:use-module (jsonld inverse-context-creation)
22	#:use-module (jsonld json)
23	#:use-module (jsonld term-selection)
24	#:export (iri-compaction))
25
26	(define-syntax set-cond!
27	(syntax-rules ()
28	((_ var val)
29	(unless var
30	(set! var val)))))
31
32	(define* (iri-compaction active-context var
33	#:key value vocab? reverse? processing-mode)
34	;; not specified, but sometimes the spec leads to var being an array, so
35	;; in that case we iri-compact each part of it and return an array.
36	(cond
37	;; 1
38	((json-null? var) json-null)
39	;; XXX: addition to spec
40	((json-array? var)
41	(list->array 1
42	(map
43	(lambda (val)
44	(iri-compaction active-context val
45	#:value value
46	#:vocab? vocab?
47	#:reverse? reverse?
48	#:processing-mode processing-mode))
49	(array->list var))))
50	(else
51	(begin
52	;; 2
53	(when (json-null? (active-context-inverse-context active-context))
54	(set! active-context
55	(update-active-context active-context
56	#:inverse-context
57	(inverse-context-creation active-context))))
58	;; 3
59	(let* ((inverse-context (active-context-inverse-context active-context))
60	(result #f))
61	;; 4
62	(when (and vocab? (json-has-key? inverse-context var))
63	(let ((default-language
64	;; 4.1
65	(if (not-null-or-false (active-context-direction active-context))
66	(string-append
67	(string-downcase
68	(or (not-null-or-false (active-context-language active-context))
69	""))
70	"_"
71	(active-context-direction active-context))
72	(string-downcase
73	(or (not-null-or-false (active-context-language active-context))
74	"@none"))))
75	;; 4.3
76	(containers '())
77	;; 4.4
78	(type/language "@language")
79	(type/language-value "@null")
80	;; 4.14
81	(preferred-values '()))
82	;; 4.2
83	(when (json-has-key? value "@preserve")
84	(let ((preserve (assoc-ref value "@preserve")))
85	(set! value
86	(if (json-array? preserve)
87	(car (array->list preserve))
88	preserve))))
89	;; 4.5
90	(when (and (json-has-key? value "@index")
91	(not (graph-object? value)))
92	(set! containers
93	(append containers '("@index" "@index@set"))))
94	(cond
95	;; 4.6
96	(reverse?
97	(set! type/language "@type")
98	(set! type/language-value "@reverse")
99	(set! containers (append containers '("@set"))))
100	;; 4.7
101	((list-object? value)
102	;; 4.7.1
103	(unless (json-has-key? value "@index")
104	(set! containers (append containers '("@list"))))
105	;; 4.7.2
106	(let ((lst (array->list (assoc-ref value "@list")))
107	;; 4.7.3
108	(common-type json-null)
109	(common-language json-null))
110	(when (null? lst)
111	(set! common-language default-language))
112	;; 4.7.4
113	(for-each
114	(lambda (item)
115	;; 4.7.4.1
116	(let ((item-language "@none")
117	(item-type "@none"))
118	(if (json-has-key? item "@value")
119	;; 4.7.4.2
120	(cond
121	((json-has-key? item "@direction")
122	(set! item-language
123	(string-append
124	(or (assoc-ref item "@language") "")
125	"_"
126	(assoc-ref item "@direction"))))
127	((json-has-key? item "@language")
128	(set! item-language (assoc-ref item "@language")))
129	((json-has-key? item "@type")
130	(set! item-type (assoc-ref item "@type")))
131	(else
132	(set! item-language "@null")))
133	;; 4.7.4.3
134	(set! item-type "@id"))
135	;; 4.7.4.4
136	(if (json-null? common-language)
137	(set! common-language item-language)
138	(unless (or (equal? common-language item-language)
139	(not (json-has-key? item "@value")))
140	(set! common-language "@none")))
141	;; 4.7.4.6
142	(if (json-null? common-type)
143	(set! common-type item-type)
144	(unless (equal? common-type item-type)
145	(set! common-type "@none")))))
146	lst)
147	;; 4.7.5
148	(when (json-null? common-language)
149	(set! common-language "@none"))
150	(when (json-null? common-type)
151	(set! common-type "@none"))
152	(if (not (equal? common-type "@none"))
153	(begin
154	(set! type/language "@type")
155	(set! type/language-value common-type))
156	(set! type/language-value common-language))))
157	;; 4.8
158	((graph-object? value)
159	;; 4.8.1
160	(when (json-has-key? value "@index")
161	(set! containers
162	(append containers '("@graph@index" "@graph@index@set"))))
163	;; 4.8.2
164	(when (json-has-key? value "@id")
165	(set! containers
166	(append containers '("@graph@id" "@graph@id@set"))))
167	;; 4.8.3
168	(set! containers
169	(append containers '("@graph" "@graph@set" "@set")))
170	;; 4.8.4
171	(unless (json-has-key? value "@index")
172	(set! containers
173	(append containers '("@graph@index" "@graph@index@set"))))
174	;; 4.8.5
175	(unless (json-has-key? value "@id")
176	(set! containers
177	(append containers '("@graph@id" "@graph@id@set"))))
178	;; 4.8.6
179	(set! containers
180	(append containers '("@index" "@index@set")))
181	;; 4.8.7
182	(set! type/language "@type")
183	(set! type/language-value "@id"))
184	;; 4.9.1 and 4.9.3
185	((json-has-key? value "@value")
186	(cond
187	((and (json-has-key? value "@direction")
188	(not (json-has-key? value "@index")))
189	(set! type/language-value
190	(string-append
191	(or (assoc-ref value "@language") "")
192	"_"
193	(assoc-ref value "@direction")))
194	(set! containers
195	(append containers '("@language" "@language@set"))))
196	((and (json-has-key? value "@language")
197	(not (json-has-key? value "@index")))
198	(set! type/language-value (assoc-ref value "@language"))
199	(set! containers
200	(append containers '("@language" "@language@set"))))
201	((json-has-key? value "@type")
202	(set! type/language-value (assoc-ref value "@type"))
203	(set! type/language "@type")))
204	(set! containers (append containers '("@set"))))
205	;; 4.9.2 and 4.9.3
206	(else
207	(set! type/language "@type")
208	(set! type/language-value "@id")
209	(set! containers
210	(append containers '("@id" "@id@set" "@type" "@set@type" "@set")))))
211	;; 4.10
212	(set! containers (append containers '("@none")))
213	;; 4.11
214	(unless (processing-mode-1.0? processing-mode)
215	(unless (json-has-key? value "@index")
216	(set! containers (append containers '("@index" "@index@set"))))
217	;; 4.12
218	(when (and (json-has-key? value "@value")
219	(null? (filter (lambda (kp) (not (equal? (car kp) "@value")))
220	value)))
221	(set! containers (append containers '("@language" "@language@set")))))
222	;; 4.13
223	(when (equal? type/language-value json-null)
224	(set! type/language-value "@null"))
225	;; 4.15
226	(when (equal? type/language-value "@reverse")
227	(set! preferred-values (append preferred-values '("@reverse"))))
228	;; 4.16
229	(if (and (or (equal? type/language-value "@reverse")
230	(equal? type/language-value "@id"))
231	(json-has-key? value "@id"))
232	(let* ((compacted-iri (iri-compaction active-context
233	(assoc-ref value "@id")
234	#:vocab? #t
235	#:processing-mode processing-mode))
236	(def (term-definition-ref active-context compacted-iri))
237	(iri (if (term-definition? def)
238	(term-definition-iri def)
239	#f)))
240	(if (equal? iri (assoc-ref value "@id"))
241	(set! preferred-values
242	(append preferred-values '("@vocab" "@id" "@none")))
243	(set! preferred-values
244	(append preferred-values '("@id" "@vocab" "@none")))))
245	;; 4.17
246	(begin
247	(when (equal? (assoc-ref value "@list") #())
248	(set! type/language "@any"))
249	(set! preferred-values
250	(append preferred-values (list type/language-value "@none")))))
251	;; 4.18
252	(set! preferred-values (append preferred-values '("@any")))
253	;; 4.19
254	(let* ((underscore-vals (filter
255	(lambda (s)
256	(string-index s #\_))
257	preferred-values))
258	(underscore (if (null? underscore-vals) #f (car underscore-vals))))
259	(when (not-null-or-false underscore)
260	(set! preferred-values
261	(append
262	preferred-values
263	(list
264	(string-join
265	(cons "" (cdr (string-split underscore #\_))) "_"))))))
266	;; 4.20
267	(let ((term (term-selection active-context var containers
268	type/language preferred-values)))
269	(when (not-null-or-false term)
270	(set-cond! result term)))))
271	;; 5
272	(when (and vocab? (not-null-or-false (active-context-vocab active-context)))
273	(let ((vocab (active-context-vocab active-context)))
274	(when (and (>= (string-length var) (string-length vocab))
275	(equal? (substring var 0 (string-length vocab)) vocab))
276	(let ((suffix (substring var (string-length vocab))))
277	(when (not (not-null-or-false (term-definition-ref active-context suffix)))
278	(set-cond! result suffix))))))
279	;; 6
280	(let ((compact-iri json-null))
281	;; 7
282	(for-each-pair
283	(lambda (term def)
284	;; 7.1
285	(unless (or (json-null? (term-definition-iri def))
286	(equal? (term-definition-iri def) var)
287	(not (string? var))
288	(< (string-length var) (string-length (term-definition-iri def)))
289	(not (equal?
290	(substring
291	var 0
292	(string-length (term-definition-iri def)))
293	(term-definition-iri def)))
294	(not (term-definition-prefix? def)))
295	;; 7.2
296	(let ((candidate (string-append term ":"
297	(substring
298	var
299	(string-length
300	(term-definition-iri def))))))
301	;; 7.3
302	(when (or (json-null? compact-iri)
303	(< (string-length candidate) (string-length compact-iri))
304	(and (= (string-length candidate)
305	(string-length compact-iri))
306	(string<=? candidate compact-iri)))
307	(let ((def (term-definition-ref active-context candidate)))
308	(when (or (not (term-definition? def))
309	(and (not (not-null-or-false value))
310	(equal? (term-definition-iri def) var)))
311	(set! compact-iri candidate)))))))
312	(active-context-definitions active-context))
313	;; 8
314	(when (not-null-or-false compact-iri)
315	(set-cond! result compact-iri)))
316	;; 9
317	(unless result
318	(let* ((components (string-split var #\:))
319	(prefix (car components))
320	(suffix (string-join (cdr components) ":")))
321	(unless (null? (filter
322	(lambda (kp)
323	(and
324	(equal? prefix (car kp))
325	(term-definition-prefix? (cdr kp))))
326	(active-context-definitions active-context)))
327	(unless (and (> (string-length suffix) 2)
328	(equal? (substring suffix 0 2) "//"))
329	(throw 'iri-confused-with-prefix)))))
330	;; 10
331	(unless vocab?
332	(when (and (not-null-or-false (active-context-base active-context))
333	(absolute-iri? var))
334	(let ((iri (make-relative-iri var (active-context-base active-context))))
335	(if (keyword-form? iri)
336	(set-cond! result (string-append "./" iri))
337	(set-cond! result iri)))))
338	;; 11
339	(set-cond! result var)
340	result)))))
341