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