Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/encoding/json-ld/json-ld.lisp

KindCoveredAll%
expression35173 20.2
branch06 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-
2
 
3
 (in-package :org.datagraph.spocq.implementation)
4
 ;;; (load "patches/20160722-jsonld/json-ld.lisp")
5
 
6
 (:documentation
7
  "the operators which encode terms as json-ld manifest several issues:
8
  - distinctions between three term classes: blank node, iri, literal
9
  - compact v/s expanded encoding
10
  - term definitions aspects re datatype and language which figure in compact encodings
11
    (nb. when the language tag is present, the datatype is null)
12
  - limit fetched external strings and heap versions be relying on type term numbers and encoding direct from external values
13
 ")
14
 
15
 ;;; (load (compile-file "LIBRARY:org;datagraph;spocq;src;core;encoding;json-ld.lisp" :output-file "json-ld.fasl"))
16
 
17
 (defmacro with-numbered-term-literal ((%literal) term-number &body body)
18
   `(with-numbered-term (%term ,term-number)
19
      (let ((,%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value)))
20
        ,@body)))
21
 
22
 (cffi:defcstruct term
23
   (type :unsigned-long)
24
   (value :unsigned-long)
25
   (language :unsigned-long)
26
   (datatype :unsigned-long))
27
 
28
 ;;; json-ld encoding operators for respective term types - both expanded and compact
29
 
30
 (defgeneric encode-json-ld-blank-node (label stream)
31
   (:documentation "blank node encoding is the same for expanded and compact forms")
32
   (:method ((node spocq:blank-node) stream)
33
     (encode-json-ld-blank-node (spocq:blank-node-label node) stream))
34
   (:method ((label string) stream)
35
     (format stream "\"_:~@[~a_~]~a\""
36
             (blank-node-prefix)
37
             label))
38
   (:method ((%label sb-sys:system-area-pointer) stream)
39
     (declare (dynamic-extent %label))
40
     (format stream "\"_:~@[~a_~]" (blank-node-prefix))
41
     (stream-write-external-utf8-string-json-bytes stream %label)
42
     (write-char #\" stream))
43
   (:method ((term-number integer) stream)
44
     (let* ((%term (rlmdb:shard-term-fetch term-number))
45
            (term-type (rlmdb:%shard-term-type %term))
46
            (%term-data (rlmdb:%shard-term-data %term)))
47
       (declare (type cffi:foreign-pointer %term)
48
                (type symbol term-type)
49
                (type cffi:foreign-pointer %term-data))
50
       (case term-type
51
         (:node
52
          (ecase (rlmdb:%shard-term-subtype-node-subtype %term)
53
            (:node-genid
54
             (format stream "\"~@[~a_~]genid~d\""
55
                     (blank-node-prefix)
56
                     (rlmdb:%shard-term-data-node-genid %term-data)))
57
            (:node-gensym
58
             (format stream "\"~@[~a_~]~V/%format-json-string/~d\""
59
                     (blank-node-prefix)
60
                     4  (rlmdb:%shard-term-data-node-gensym-prefix %term-data)
61
                     (rlmdb:%shard-term-data-node-gensym-suffix %term-data)))
62
            (:node-short
63
             (format stream "\"~@[~a_~]~V/%format-json-string/\""
64
                     (blank-node-prefix)
65
                     8  (rlmdb:%shard-term-data-node-label %term-data)))
66
            ((:node-long :none)
67
             (format stream "\"~@[~a_~]~/format-json-string-id/\""
68
                     (blank-node-prefix)
69
                     (rlmdb:%shard-term-data-node-label-offset %term-data)))))
70
         (t
71
          (log-warn "encode-json-ld-blank-node term number does not designate a blank node: ~s" term-number)
72
          (write-string "\"\"" stream))))))
73
 
74
 
75
 (defgeneric encode-json-ld-iri (namestring stream)
76
   (:documentation "encode the iri namestring as just theat with quote delimiters.")
77
   (:method ((iri spocq:iri) stream)
78
     (encode-json-ld-iri (spocq:iri-lexical-form iri) stream))
79
   (:method ((iri symbol) stream)
80
     (encode-json-ld-iri (iri-lexical-form iri) stream))
81
   (:method ((namestring string) stream)
82
     (write-char #\" stream)
83
     (stream-write-utf8-string-as-json stream namestring)
84
     (write-char #\" stream))
85
   (:method ((%namestring sb-sys:system-area-pointer) stream)
86
     (declare (dynamic-extent %namestring))
87
     (write-char #\" stream)
88
     (stream-write-external-utf8-string-json-bytes stream %namestring)
89
     (write-char #\" stream))
90
   (:method ((term-number integer) stream)
91
     (let* ((%term (rlmdb:shard-term-fetch term-number))
92
            (term-type (rlmdb:%shard-term-type %term))
93
            (%term-data (rlmdb:%shard-term-data %term)))
94
       (declare (type cffi:foreign-pointer %term)
95
                (type symbol term-type)
96
                (type cffi:foreign-pointer %term-data))
97
       (case term-type
98
         (:uri
99
          (encode-json-ld-iri-id-or-qname-compact (rlmdb:%shard-term-data-uri-string-offset %term-data) stream))
100
         (t
101
          (log-warn "encode-json-ld-iri term number does not designate an iri: ~s" term-number)
102
          (write-string "\"\"" stream))))))
103
 
104
 (defun encode-json-ld-iri-or-qname-compact (iri-namestring stream &optional (frame json-ld:*frame*))
105
   ;; look for a prefixed name
106
   (let ((prefixed-name (and frame (json-ld:compact-iri frame iri-namestring))))
107
     (if prefixed-name
108
         (format stream "\"~a\"" prefixed-name)
109
         (encode-json-ld-iri iri-namestring stream))))
110
 
111
 (defun encode-json-ld-iri-or-qname (iri-namestring stream)
112
   "encode an iri as either a literal namestring or as the sname per context.
113
  Accept iri in any form: model instance, internal or external string."
114
   (if json-ld:*compact*
115
       (encode-json-ld-iri-or-qname-compact iri-namestring stream)
116
       (encode-json-ld-iri iri-namestring stream)))
117
 
118
 (undefgeneric encode-json-ld-string (term stream)
119
   (:method ((term-number integer) stream)
120
     (with-numbered-term-literal (%term-literal) term-number
121
       ;; encode just the literal string
122
       (write-char #\" stream)
123
       (stream-write-external-utf8-string-json-bytes stream %term-literal)
124
       (write-char #\" stream)))
125
   (:method ((literal string) stream)
126
     ;; encode just the literal string
127
     (write-char #\" stream)
128
     (stream-write-utf8-string-as-json stream literal)
129
     (write-char #\" stream))
130
   (:method ((%literal sb-sys:system-area-pointer) stream)
131
     (write-char #\" stream)
132
     (stream-write-external-utf8-string-json-bytes stream %literal)
133
     (write-char #\" stream)))
134
 
135
 (undefgeneric encode-json-ld-lang-string (term stream)
136
   (:method ((term-number integer) stream)
137
     (with-numbered-term (%term term-number)
138
       (encode-json-ld-lang-string %term stream)))
139
   (:method ((%term sb-sys:system-area-pointer) stream)
140
     (let ((%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value))
141
           (%language (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::language)))
142
       (declare (dynamic-extent %literal %language)
143
                (type sb-sys:system-area-pointer %language %literal))
144
       ;; in this context, always encode the language tag
145
       (write-string "{\"@language\":\"" stream)
146
       (stream-write-external-utf8-string-json-bytes stream %language)
147
       (write-string "\", \"@value\":" stream)
148
       (encode-json-ld-string %literal stream)
149
       (write-char #\} stream)))
150
   (:method ((literal spocq:plain-literal) stream)
151
     (write-string "{\"@language\":\"" stream)
152
     (write-string (spocq:plain-literal-language-tag literal))
153
     (write-string "\", \"@value\":" stream)
154
     (encode-json-ld-string (spocq:plain-literal-lexical-form literal) stream)
155
     (write-char #\} stream)))
156
   
157
 
158
 ;;; id values include both blank nodes and iri, but nothing else.
159
 
160
 (defgeneric encode-json-ld-id (term stream)
161
   (:documentation "Given either a term object or a term number, encode the value as a json-ld id.
162
    The value must denote either an iri or a blank node. The encoding is that of the lexical form,
163
    as a string:
164
    - a blank node appears as, eg. \"_:blank\"
165
    - an iri appears as \"http://example.org/x\" - or, when compact, as a defined q-name
166
   ")
167
   #+(or) ;; superceded in shard-term
168
   (:method ((term-number integer) stream)
169
     (with-numbered-term-aspects ((term-type term-literal term-language-tag term-datatype) term-number)
170
       (case term-type
171
         (:node (encode-json-ld-blank-node term-literal stream))
172
         (:uri (encode-json-ld-iri-or-qname term-literal stream))
173
         (t
174
          (log-warn "encode-json-ld-id: Invalid json-ld id type: ~s" term-type)
175
          (encode-json-ld-term-aspects term-type term-literal term-language-tag term-datatype stream)))))
176
   (:method ((object spocq:blank-node) stream)
177
     (encode-json-ld-blank-node (spocq:blank-node-label object) stream))
178
   (:method ((object spocq:iri) stream)
179
     (encode-json-ld-iri-or-qname (spocq:iri-lexical-form object) stream))
180
   (:method ((object symbol) stream)
181
     (cond ((eq object :|null|)
182
             (write-string (symbol-name object) stream))
183
           ((eq object +null-term+)
184
            (write-string "{}" stream))
185
           ((let ((uri-namestring (symbol-uri-namestring object)))
186
              (when uri-namestring
187
                (encode-json-ld-iri-or-qname uri-namestring stream)
188
                uri-namestring)))
189
           (t
190
            (call-next-method))))
191
   (:method ((object t) stream)
192
     (log-warn "encode-json-ld-id: Invalid json-ld id type: ~s" object)
193
     (encode-json-term object stream)))
194
 
195
 (defun cl-user::format-json-ld-id (stream id &optional option arg)
196
   (declare (ignore option arg))
197
   (encode-json-ld-id id stream))
198
 
199
 
200
 ;;; define encoding operator specialized by datatype term id
201
 
202
 (undefgeneric encode-json-ld-term-number-compact-typed (number datatype-id stream)
203
   (:documentation
204
     "Encode a json-ld value for the given (term-number x datatype-term-id) combination.
205
     This will include methods specialized for the immediate type, which avoid retrieving
206
     the datatype string and encode type-specific abbreviations.")
207
   (:argument-precedence-order datatype-id number stream)
208
   (:method ((term-number t) (datatype-id t) (stream stream))
209
     "The default method, to be used when nothing is defined for the given datatype id,
210
      uses the generic logic to encode the term in EXPANDED form, but without frame or definition"
211
     (encode-json-ld-term-number-expanded term-number stream nil nil)))
212
 
213
 
214
 (undefun define-encode-json-ld-compact-operators ()
215
   (macrolet ((defnumerics (&rest names)
216
                 `(progn ,@(loop for type in names
217
                             collect `(defmethod encode-json-ld-term-number-compact-typed (term-number (datatype-term-number (eql (symbol-term-id ',type))) stream)
218
                                        (with-numbered-term-literal (%term-literal) term-number
219
                                          ;; encode just the literal string
220
                                          (stream-write-external-utf8-string-json-bytes stream %term-literal)))
221
                                      )))
222
              (defstrings (&rest names)
223
                 `(progn ,@(loop for type in names
224
                             collect `(defmethod encode-json-ld-term-number-compact-typed (term-number (datatype-term-number (eql (symbol-term-id ',type))) stream)
225
                                        ;; encode just the literal string
226
                                        (encode-json-ld-string-compact term-number stream))
227
                                      ))))
228
                                          
229
     (defnumerics
230
         |http://www.w3.org/2001/XMLSchema|:|boolean|
231
         |http://www.w3.org/2001/XMLSchema|:|byte|
232
       |http://www.w3.org/2001/XMLSchema|:|decimal|
233
       |http://www.w3.org/2001/XMLSchema|:|double|
234
       |http://www.w3.org/2001/XMLSchema|:|float|
235
       |http://www.w3.org/2001/XMLSchema|:|int|
236
       |http://www.w3.org/2001/XMLSchema|:|integer|
237
       |http://www.w3.org/2001/XMLSchema|:|long|
238
       |http://www.w3.org/2001/XMLSchema|:|nonNegativeInteger|
239
       |http://www.w3.org/2001/XMLSchema|:|nonPositiveInteger|
240
       |http://www.w3.org/2001/XMLSchema|:|negativeInteger|
241
       |http://www.w3.org/2001/XMLSchema|:|positiveInteger|
242
       |http://www.w3.org/2001/XMLSchema|:|short|
243
       |http://www.w3.org/2001/XMLSchema|:|unsignedByte|
244
       |http://www.w3.org/2001/XMLSchema|:|unsignedInt|
245
       |http://www.w3.org/2001/XMLSchema|:|unsignedLong|
246
       |http://www.w3.org/2001/XMLSchema|:|unsignedShort|)
247
   ;; these should not occur, as the datatype should not be present, but for completness
248
     (defstrings |rdf|:|langString| |xsd|:|string|)))
249
 
250
 
251
 (undefun ensure-encode-json-ld-compact-operators ()
252
   (unless (cdr (c2mop:generic-function-methods #'encode-json-ld-term-number-compact-typed))
253
     (define-encode-json-ld-compact-operators))
254
   t)
255
 
256
 
257
 ;;; principle interface operators accept a term number which they map to the respective term strcture and
258
 ;;; perform either an extended encoding or a compact one depending on wheter a frame/term-definition pair are supplied
259
 
260
 #+(or) ;superceded
261
 (defun encode-json-ld-term-number-expanded (term-number stream)
262
   (with-numbered-term (%term term-number)
263
     (ecase (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::type)
264
       (:none (write-string "{}" stream))
265
       (:node                            ; encode a blank node
266
        (let ((%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value)))
267
          (declare (dynamic-extent %literal)
268
                   (type sb-sys:system-area-pointer %literal))
269
          (write-string "{\"@type\":\"bnode\", \"@value\":" stream)
270
          (encode-json-ld-blank-node %literal stream)
271
          (write-char #\} stream)))
272
       (:literal                         ; encode a typed or language-tagged literal
273
        (let ((%language (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::language)))
274
          (declare (dynamic-extent %language)
275
                   (type sb-sys:system-area-pointer %language ))
276
          (cond ((not (cffi:null-pointer-p %language))
277
                 (encode-json-ld-lang-string %term stream))
278
                (t
279
                 (let ((%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value))
280
                       (%datatype (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::datatype)))
281
                   (declare (dynamic-extent %literal %datatype)
282
                            (type sb-sys:system-area-pointer %literal %datatype))
283
                   (cond ((not (cffi:null-pointer-p %datatype))
284
                          ;; given a type, write out the full type
285
                          (write-string "{\"@type\":\"" stream)
286
                          (stream-write-external-utf8-string-json-bytes stream %datatype)
287
                          (write-string "\", \"@value\":" stream)
288
                          (encode-json-ld-string %literal stream)
289
                          (write-char #\} stream))
290
                         (json-ld::encode-simple-string-datatype*
291
                          ;; nexperii#180: encode a typed value and add the string type url to simple form strings
292
                          (write-string "{\"@type\":\"" stream)
293
                          ;;; (stream-write-external-utf8-string-json-bytes stream (|%http://www.w3.org/2001/XMLSchema#string|))
294
                          (write-string "http://www.w3.org/2001/XMLSchema#string" stream)
295
                          (write-string "\", \"@value\":" stream)
296
                          (encode-json-ld-string %literal stream)
297
                          (write-char #\} stream))
298
                         (t
299
                          ;; otherwise, just write a string value
300
                          (encode-json-ld-string %literal stream))))))))
301
       (:uri                             ; encode a uri
302
        (let ((%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value)))
303
          (declare (dynamic-extent %literal))
304
          (write-string "{\"@id\":" stream)
305
          (encode-json-ld-iri %literal stream)
306
          (write-char #\} stream))))))
307
 
308
 
309
 (undefun encode-json-ld-term-number-compact (term-number stream frame term-definition)
310
   (with-numbered-term (%term term-number)
311
     (ecase (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::type)
312
       (:none (write-string "{}" stream))
313
       (:node
314
        ;; encode a blank node
315
        (let ((%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value)))
316
          (declare (dynamic-extent %literal)
317
                   (type sb-sys:system-area-pointer %literal))
318
          (encode-json-ld-blank-node %literal stream)))
319
       (:literal
320
        ;; encode a typed or language-tagged literal
321
        (let ((%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value))
322
              (%language (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::language)))
323
          (declare (dynamic-extent %literal %language)
324
                   (type sb-sys:system-area-pointer %language %literal))
325
          (cond ((not (cffi:null-pointer-p %language))
326
                 ;; possible elide the language tag
327
                 (let ((language (call-with-term-string #'identity %language))
328
                       (context-language (if term-definition
329
                                             (json-ld:term-definition-language term-definition)
330
                                             (json-ld:context-language frame))))
331
                   (cond ((string-equal language context-language)
332
                          (encode-json-ld-string %literal stream))
333
                         (t
334
                          (write-string "{\"@language\":\"" stream)
335
                          (stream-write-external-utf8-string-json-bytes stream %language)
336
                          (write-string "\", \"@value\":\"" stream)
337
                          (stream-write-external-utf8-string-json-bytes stream %literal)
338
                          (write-string "\"}" stream)))))
339
                (t
340
                 (let ((term-datatype-id (dydra-ndk:term-datatype-id term-number)))
341
                   (cond ((typep term-datatype-id '(integer 1))
342
                          (cond ((eql term-datatype-id (json-ld::term-definition-type-term-number term-definition))
343
                                 (encode-json-ld-string %literal stream))
344
                                ((eql term-datatype-id (symbol-term-id '|xsd|:|string|))
345
                                 (encode-json-ld-string %literal stream))
346
                                (t
347
                                 ;; (print (list number (dydra-ndk:term-datatype-id number)))
348
                                 (encode-json-ld-term-number-compact-typed term-number term-datatype-id stream))))
349
                         (t
350
                          ;; otherwise, just write a string value
351
                          (encode-json-ld-string %literal stream))))))))
352
       (:uri                             ; encode a uri
353
        (let ((%literal (cffi:foreign-slot-value %term '(:struct rdfcache::term) 'rdfcache::value)))
354
          ;;((%literal (sb-sys:int-sap (cffi:foreign-slot-value %term '(:struct term) 'value))))
355
          (declare (dynamic-extent %literal))
356
          (encode-json-ld-iri-or-qname-compact %literal stream))))))
357
 
358
 
359
 (defparameter *encode-json-ld-term-number.operators* nil)
360
 
361
 (defun encode-json-ld-term-number (term-number stream &optional frame term-definition)
362
   ;; (print (list term-number (dydra-ndk:term-datatype-id term-number)))
363
   (cond ((and frame term-definition)
364
          (encode-json-ld-term-number-compact term-number stream frame term-definition))
365
         (t
366
          (encode-json-ld-term-number-expanded term-number stream frame term-definition))))
367
 
368
 
369
 ;;; encode a destructured term either
370
 ;;; - encode-json-ld-term-aspects, based on components, or
371
 ;;; - encode-json-ld-term, based on the term structure
372
 
373
 (undefun encode-json-ld-term-aspects (term-type term-literal term-language-tag term-datatype stream)
374
   "Encode a term for json-ld, which is syntactically similar to json, but with different
375
    compound constructs for values and iri and contingent upon the framing context. The context
376
    figures in tow ways:
377
    - the individual term definition determines whether a value must be expanded or can be emitted in a concise form
378
    - the context prefix bindings determine whether to emit compact or absolute iri."
379
 
380
   (ecase term-type
381
     (:none (write-string "{}" stream))
382
     (:node                            ; encode a blank node
383
      (write-string "{\"@type\":\"bnode\", \"@value\":" stream)
384
      (encode-json-ld-blank-node term-literal stream)
385
      (write-char #\} stream))
386
     (:literal                         ; encode a typed or language-tagged literal
387
      (cond ((not (cffi:null-pointer-p term-language-tag))
388
             ;; always encode the language tag
389
             (write-string "{\"@language\":\"" stream)
390
             (stream-write-external-utf8-string-json-bytes stream term-language-tag)
391
             (write-string "\", \"@value\":\"" stream)
392
             (stream-write-external-utf8-string-json-bytes stream term-literal)
393
             (write-string "\"}" stream))
394
            ((not (cffi:null-pointer-p term-datatype))
395
             ;; given a type, write out the full type
396
             (write-string "{\"@type\":\"" stream)
397
             (stream-write-external-utf8-string-json-bytes stream term-datatype)
398
             (write-string "\", \"@value\":\"" stream)
399
             (stream-write-external-utf8-string-json-bytes stream term-literal)
400
             (write-string "\"}" stream))
401
            (t
402
             ;; otherwise, just write a string value
403
             (encode-json-ld-string term-literal stream))))
404
     (:uri                             ; encode a uri
405
      (write-string "{\"@id\":" stream)
406
      (encode-json-ld-iri-or-qname term-literal stream)
407
      (write-char #\} stream))))
408
 
409
 (undefun encode-json-ld-term-aspects-compact (term-type term-literal stream &optional (frame json-ld:*frame*))
410
   "Encode a term for json-ld, which is syntactically similar to json, but in compact form is
411
    contingent upon the framing context in two ways:
412
    - the individual term definition determines whether a value must be expanded or can be emitted in a concise form
413
    - the context prefix bindings determine whether to emit a q-name or absolute iri."
414
   
415
   (ecase term-type
416
     (:none (write-string "{}" stream))
417
     (:node
418
      ;; encode a blank node
419
      (encode-json-ld-blank-node term-literal stream))
420
     (:literal
421
      ;; just write a string value
422
      (write-char #\" stream)
423
      (stream-write-external-utf8-string-json-bytes stream term-literal)
424
      (write-char #\" stream))
425
     (:uri
426
      ;; encode a uri - possible as a q-name
427
      (write-char #\" stream)
428
      (encode-json-ld-iri-or-qname-compact term-literal stream frame)
429
      (write-char #\" stream))))
430