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