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

KindCoveredAll%
expression6251077 58.0
branch50110 45.5
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
 ;;; (load "patches/sparql-results-json.lisp")
3
 
4
 (in-package :org.datagraph.spocq.implementation)
5
 
6
 ;;; replace the json field encoding operator with one which retrieves terms directly from lmdb.
7
 
8
 (defgeneric write-transaction-sparql-results-application+json (transaction page variables stream &optional index start end)
9
   (:method ((transaction lmdb-transaction) page variables stream &optional (index 0) (start 0) end)
10
     (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
11
     (dotimes (page-index (array-dimension page 0))
12
       (when (>= index start)
13
         (when (and end (>= index end))
14
           (return))
15
         (when (> index start)
16
           (write-char #\, stream))
17
         (format stream "~:[~;~%~] {" *print-pretty*)
18
         (loop for value-index from 0
19
           with first = t
20
           for name in variables
21
           do (let ((term-number (aref page page-index value-index)))
22
                (unless (= term-number +null-term-id+)
23
                  (if first (setf first nil) (format stream ", "))
24
                  (format stream "\"~a\": " name)
25
                  (encode-json-term-number-compact term-number stream))))
26
         (write-string " }" stream))
27
       (incf index))
28
     index))
29
 
30
 (defmethod write-sparql-results+json :around ((results solution-generator) (stream t))
31
   (let ((*expand-literal-values* '(or number string boolean))) ;; follow https://www.w3.org/TR/rdf-sparql-json-res/
32
     (rlmdb::with-string-database (sdb)
33
       (call-next-method))))
34
 
35
 (fmakunbound 'write-sparql-results-field+json)
36
 
37
 (defun write-sparql-results-field+json (page variables stream &optional (index 0) (start 0) end)
38
   (let ((*expand-literal-values* '(or number string boolean))) ;; follow https://www.w3.org/TR/rdf-sparql-json-res/ @ nexperia-212
39
     (write-transaction-sparql-results-field+json *transaction* page variables stream index start end)))
40
 
41
 (defgeneric write-transaction-sparql-results-field+json (transaction page variables stream &optional index start end)
42
   ;; this segfaulted for results from materialized repositories
43
   #+(or)
44
   (:method ((transaction rdfcache-transaction) page variables stream &optional (index 0) (start 0) end)
45
     (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
46
     (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
47
              (encode-json-term-aspects term-type term-literal term-language-tag term-datatype stream)))
48
       (declare (dynamic-extent #'term-aspect-encoder))
49
       (let ((term-deconstructor (repository-term-deconstructor transaction)))
50
         (dotimes (page-index (array-dimension page 0))
51
           (when (>= index start)
52
             (when (and end (>= index end))
53
               (return))
54
             (when (> index start)
55
               (write-char #\, stream))
56
             (format stream "~:[~;~%~] {" *print-pretty*)
57
             (loop for value-index from 0
58
               with first = t
59
               for name in variables
60
               do (let ((term-id (aref page page-index value-index)))
61
                    (unless (= term-id +null-term-id+)
62
                      (if first (write-char #\space stream) (format stream ",~:[~;~%~]     " *print-pretty*))
63
                      (setf first nil)
64
                      (format stream "\"~a\": " name)
65
                      (funcall term-deconstructor #'term-aspect-encoder transaction term-id))))
66
             (write-string " }" stream))
67
           (incf index))))
68
     index)
69
 
70
   ;;(:method ((transaction lmdb-transaction) page variables stream &optional (index 0) (start 0) end)
71
   (:method ((transaction transaction) page variables stream &optional (index 0) (start 0) end)
72
     (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
73
     (dotimes (page-index (array-dimension page 0))
74
       (when (>= index start)
75
         (when (and end (>= index end))
76
           (return))
77
         (when (> index start)
78
           (write-char #\, stream))
79
         (format stream "~:[~;~%~] {" *print-pretty*)
80
         (loop for value-index from 0
81
           with first = t
82
           for name in variables
83
           do (let ((term-number (aref page page-index value-index)))
84
                (unless (= term-number +null-term-id+)
85
                  (if first (write-char #\space stream) (format stream ",~:[~;~%~]     " *print-pretty*))
86
                  (setf first nil)
87
                  (format stream "\"~a\": " name)
88
                  (encode-json-term-number term-number stream))))
89
         (write-string " }" stream))
90
       (incf index))
91
     index))
92
 
93
 (defun write-sparql-results-field+ndjson (page variables stream &optional (index 0) (start 0) end)
94
   (write-transaction-sparql-results-field+ndjson *transaction* page variables stream index start end))
95
 
96
 (defgeneric write-transaction-sparql-results-field+ndjson (transaction page variables stream &optional index start end)
97
   (:method ((transaction rdfcache-transaction) page variables stream &optional (index 0) (start 0) end)
98
     (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
99
     (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
100
              ;;(encode-json-term-aspects-compact term-type term-literal term-language-tag term-datatype stream)))
101
              (encode-json-term-aspects term-type term-literal term-language-tag term-datatype stream)))
102
       (declare (dynamic-extent #'term-aspect-encoder))
103
       (let ((term-deconstructor (repository-term-deconstructor *transaction*)))
104
         (dotimes (page-index (array-dimension page 0))
105
           (when (>= index start)
106
             (when (and end (>= index end))
107
               (return))
108
             (write-char #\{ stream)
109
             (loop for value-index from 0
110
               with first = t
111
               for name in variables
112
               do (let ((term-id (aref page page-index value-index)))
113
                    (unless (= term-id +null-term-id+)
114
                      (format stream "~:[, ~; ~]\"~a\": " first name)
115
                      (setf first nil)
116
                      (funcall term-deconstructor #'term-aspect-encoder *transaction* term-id))))
117
             (format stream " }~%"))
118
           (incf index))))
119
     index)
120
   (:method ((transaction lmdb-transaction) page variables stream &optional (index 0) (start 0) end)
121
     (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
122
     (dotimes (page-index (array-dimension page 0))
123
       (when (>= index start)
124
         (when (and end (>= index end))
125
           (return))
126
         (write-char #\{ stream)
127
         (loop for value-index from 0
128
           with first = t
129
           for name in variables
130
           do (let ((term-number (aref page page-index value-index)))
131
                (unless (= term-number +null-term-id+)
132
                  (format stream "~:[, ~; ~]\"~a\": " first name)
133
                  (setf first nil)
134
                  (encode-json-term-number-compact term-number stream))))
135
         (format stream "}~%"))
136
       (incf index))
137
     index))
138
 
139
 (defmethod write-sparql-results+json-columns :around ((results solution-generator) (stream t))
140
   (rlmdb::with-string-database (sdb)
141
     (call-next-method)))
142
 
143
 (fmakunbound 'write-sparql-results-field+json-columns)
144
 
145
 (defun write-sparql-results-field+json-columns (page stream &optional (index 0) (start 0) end)
146
   (write-transaction-sparql-results-field+json-columns *transaction* page stream index start end))
147
 
148
 (defgeneric write-transaction-sparql-results-field+json-columns (transaction page stream &optional index start end)
149
   (:method ((transaction rdfcache-transaction) page stream &optional (index 0) (start 0) end)
150
     (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
151
     (flet ((term-aspect-encoder (term-type term-literal term-language-tag term-datatype)
152
              (encode-json-term-aspects term-type term-literal term-language-tag term-datatype stream)))
153
       (declare (dynamic-extent #'term-aspect-encoder))
154
       (let ((term-deconstructor (repository-term-deconstructor transaction)))
155
         (let ((variable-count (array-dimension page 1)))
156
           (dotimes (page-index (array-dimension page 0))
157
             (when (>= index start)
158
               (when (and end (>= index end))
159
                 (return))
160
               (unless (= index start)
161
                 (write-char #\, stream)
162
                 (terpri stream))
163
               (write-string " [" stream)
164
               (loop for value-index from 0 below variable-count
165
                 do (let ((term-id (aref page page-index value-index)))
166
                      (unless (zerop value-index)
167
                        (write-string ", " stream)
168
                        (terpri stream))
169
                      (cond ((= term-id +null-term-id+)
170
                             (write-string "{}" stream))
171
                            (t
172
                             (funcall term-deconstructor #'term-aspect-encoder transaction term-id)))))
173
               (write-string "]" stream))
174
             (incf index)))))
175
     index)
176
 
177
   (:method ((transaction lmdb-transaction) page stream &optional (index 0) (start 0) end)
178
     (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))
179
     (let ((variable-count (array-dimension page 1)))
180
       (dotimes (page-index (array-dimension page 0))
181
         (when (>= index start)
182
           (when (and end (>= index end))
183
             (return))
184
           (unless (= index start)
185
             (write-char #\, stream)
186
             (terpri stream))
187
           (write-string " [" stream)
188
           (loop for value-index from 0 below variable-count
189
             do (let ((term-id (aref page page-index value-index)))
190
                  (unless (zerop value-index)
191
                    (write-string ", " stream)
192
                    (terpri stream))
193
                  (cond ((= term-id +null-term-id+)
194
                         (write-string "{}" stream))
195
                        (t
196
                         (encode-json-term-number term-id stream)))))
197
           (write-string "]" stream))
198
         (incf index)))
199
     index))
200
 
201
 
202
 (defmethod write-sparql-results+json-columns-streaming ((results solution-generator) (stream t))
203
   (write-transaction-sparql-results+json-columns-streaming *transaction* results stream))
204
 
205
 (defgeneric write-transaction-sparql-results+json-columns-streaming (transaction results stream)
206
   (:method ((transaction lmdb-transaction) (results solution-generator) (stream t))
207
     (rlmdb::with-string-database (sdb)
208
       (let* ((dimensions (solution-generator-dimensions results))
209
              (channel (solution-generator-channel results))
210
              (variable-count (length dimensions))
211
              (index 0)
212
              (start (or (response-offset) 0))
213
              (end (response-end))
214
              (*expand-literal-values* t)
215
              (*encode-json-term.type-members* t))
216
         (do-pages (page channel)
217
                   (if (and end (>= index end))
218
                       (return)
219
                       (if (>= (+ index (array-dimension page 0)) start)
220
                           (cond ((= variable-count (array-dimension page 1))
221
                                  (dotimes (page-index (array-dimension page 0))
222
                                    (when (>= index start)
223
                                      (when (and end (>= index end))
224
                                        (return))
225
                                      (write-string "[" stream)
226
                                      (loop for value-index from 0 below variable-count
227
                                        do (progn (unless (zerop value-index) (write-string ", " stream))
228
                                             (let ((term-id (aref page page-index value-index)))
229
                                               (cond ((= term-id +null-term-id+)
230
                                                      (write-string "{}" stream))
231
                                                     (t
232
                                                      (encode-json-term-number term-id stream))))))
233
                                      (write-string "]" stream)
234
                                      (terpri stream))
235
                                    (incf index)))
236
                                 (t
237
                                  (log-warn "field width mismatch: ~s : ~s."
238
                                            dimensions (array-dimension page 1))
239
                                  (incf index (array-dimension page 0))))
240
                           ; otherwise skip the entire page
241
                           (incf index (array-dimension page 0)))))
242
         (incf-stat *statements-returned* index)))))
243
 
244
 
245
 (defmethod write-sparql-results+jsonp ((results solution-generator) (stream t) &key operation)
246
   (write-transaction-sparql-results+jsonp *transaction* results stream :operation operation))
247
 
248
 (defgeneric write-transaction-sparql-results+jsonp (transaction results stream &key operation)
249
   (:method ((transaction lmdb-transaction) results stream &key operation)
250
     (rlmdb::with-string-database (sdb)
251
       (let* ((*expand-literal-values* '(or number string boolean)) ;; encode as simple expansion without datatype
252
              (dimensions (solution-generator-dimensions results))
253
              (channel (solution-generator-channel results))
254
              (base-width (length dimensions))
255
              (index 0)
256
              (start (or (response-offset) 0))
257
              (end (response-end))
258
              (terms (make-hash-table :test #'equalp)))
259
         (setf (gethash 0 terms) 0)
260
         (write-sparql-results+jsonp-prologue stream dimensions operation)
261
         (format stream "~%  \"rows\": [")
262
         (do-pages (page channel)
263
                   (if (and end (>= index end))
264
                       (return)
265
                       (if (>= (+ index (array-dimension page 0)) start)
266
                           (cond ((= base-width (array-dimension page 1))
267
                                  ;; this write just the term index references into the eventual table
268
                                  (setf index (write-sparql-results-field+jsonp page dimensions stream terms index start end)))
269
                                 (t
270
                                  (log-warn "field width mismatch: ~s : ~s."
271
                                            dimensions (array-dimension page 1))
272
                                  (incf index (array-dimension page 0))))
273
                           ; otherwise skip the entire page
274
                           (incf index (array-dimension page 0)))))
275
         (write-string "]," stream)
276
         ;; emit the remainder of the wrapper: type, prefixes and terms        "columns": ["g", "o", "p", "s"],
277
         (format stream "~%  \"terms\": [")
278
         (loop for (index . term-id) in (sort (loop for term being each hash-key of terms
279
                                                using (hash-value index)
280
                                                collect (cons index term))
281
                                              #'<
282
                                              :key #'first)
283
           for comma = nil then (write-string ", " stream)
284
           do (case term-id
285
                (-1 (write-string "{\"type\":\"uri\", \"value\":\"urn:dydra:default\"}" stream))
286
                (0 (write-string "null" stream))
287
                (t
288
                 (encode-json-term-number term-id stream))))
289
         (write-string "]," stream)
290
         (write-sparql-results+jsonp-epilogue stream *namespace-bindings* operation)
291
         (terpri stream)
292
         (incf-stat *statements-returned* index)
293
         index))))
294
 
295
 ;;; string encoding
296
 
297
 (defun write-json-char (char stream)
298
   (case char
299
     (#\" (write-string "\\\"" stream))
300
     (#\\ (write-string "\\\\" stream))
301
     (#\backspace (write-string "\\b" stream))
302
     (#\page (write-string "\\f" stream))
303
     (#\linefeed (write-string "\\n" stream))
304
     (#\return (write-string "\\r" stream))
305
     (#\tab (write-string "\\t" stream))
306
     (t (let ((code (char-code char)))
307
          (cond ((<= code #x1f)      ; C0 control : http://en.wikipedia.org/wiki/Control_character
308
                 (format stream "\\u~4,'0x" code))
309
                ((<= code #x80)
310
                 (write-char char stream))
311
                ((<= code #x9f)        ; C1 control
312
                 (format stream "\\u~4,'0x" code))
313
                (t
314
                 (write-char char stream)))))))
315
 
316
 (defun %write-json-string (%string stream byte-count)
317
   "Emit an external character data string to an utf-8 encoded stream with json escaping.
318
  This escapes the string terminator, whitespace-format, and control characters.
319
  All else is passed to the stream for utf-8 encoding."
320
   (unless byte-count (setf byte-count most-positive-fixnum)) ;; presume null-terminated
321
   (let ((dsu:*utf8-iso8859-allowed* t)
322
         (dsu:*utf8-surrogates-allowed* t)
323
         (decoder (load-time-value (dsu:content-encoding-byte-decoder (dsu:content-encoding :utf-8))))
324
         (i 0))
325
     (declare (type (function (function cffi:foreign-pointer) (or character null)) decoder)
326
              (type cffi:foreign-pointer %string)
327
              (type fixnum byte-count)
328
              (optimize (speed 3) (safety 0)))
329
     (flet ((get-byte (%string)
330
              (declare (type cffi:foreign-pointer %string))
331
              (when (< i byte-count)
332
                (let ((byte (cffi:mem-aref %string :uint8 i)))
333
                  (incf i)
334
                  ;; test if 0-terminated
335
                  (when (plusp byte) byte)))))
336
       (loop for char = (funcall decoder #'get-byte %string)
337
         while char
338
         do (write-json-char char stream))
339
       i)))
340
 
341
 (defun write-json-string-id (string-id stream)
342
   "Given an rdf db string id, retrieve the external data and write it
343
   to the stream as json in utf8."
344
   (flet ((%write-string-data (k raw-value)
345
            (declare (ignore k))
346
            (let* ((size (rlmdb.i::%mdb-val-size raw-value))
347
                   (%data (rlmdb.i::%mdb-val-data raw-value)))
348
              (%write-json-string %data stream size)
349
              t)))
350
     (declare (dynamic-extent #'%write-string-data))
351
     (rlmdb::call-with-shard-string string-id #'%write-string-data)))
352
 
353
 (defun cl-user::format-json-string-id (stream string-id &optional option arg)
354
   (declare (ignore option arg))
355
   (write-json-string-id string-id stream))
356
 
357
 (defun cl-user::%format-json-string (stream %string &optional option arg byte-count)
358
   (declare (ignore option arg))
359
   (assert (integerp byte-count))
360
   (%write-json-string %string stream byte-count))
361
 
362
 
363
 (defun encode-json-term-number (term-number stream)
364
   (encode-json-term-number-expanded term-number stream))
365
 
366
 (defun encode-json-term-number-expanded (term-number stream)
367
   "Given a term number and a stream, encode the stored term properties
368
    (type, string, immediate value) to the given stream as json.
369
    Durations are now not handled as times, but instead are treated as uninterned literals"
370
   (declare (type fixnum term-number))
371
   (let* ((%term (rlmdb:shard-term-fetch term-number))
372
          (term-type (rlmdb:%shard-term-type %term))
373
          (%term-data (rlmdb:%shard-term-data %term)))
374
     (declare (type cffi:foreign-pointer %term)
375
              (type symbol term-type)
376
              (type cffi:foreign-pointer %term-data))
377
     (ecase term-type
378
       (:node
379
        (ecase (rlmdb:%shard-term-subtype-node-subtype %term)
380
          (:node-genid
381
           (format stream "{\"type\":\"bnode\", \"value\":\"~@[~a_~]genid~d\"}"
382
                   (blank-node-prefix)
383
                    (rlmdb:%shard-term-data-node-genid %term-data)))
384
          (:node-gensym
385
           (format stream "{\"type\":\"bnode\", \"value\":\"~@[~a_~]~V/%format-turtle-string/~d\"}"
386
                   (blank-node-prefix)
387
                   ;; need a byte-count limited version of stream-write-turtle-external-utf8-string
388
                   4 (rlmdb:%shard-term-data-node-gensym-prefix %term-data)
389
                   (rlmdb:%shard-term-data-node-gensym-suffix %term-data)))
390
          (:node-short
391
           (format stream "{\"type\":\"bnode\", \"value\":\"~@[~a_~]~V/%format-json-string/\"}"
392
                   (blank-node-prefix)
393
                   8 (rlmdb:%shard-term-data-node-label %term-data)))
394
          ((:node-long :none)
395
           (format stream "{\"type\":\"bnode\", \"value\":\"~@[~a_~]~/format-json-string-id/\"}"
396
                   (blank-node-prefix)
397
                   (rlmdb:%shard-term-data-node-label-offset %term-data)))))
398
       (:uri
399
        (format stream "{\"type\":\"uri\", \"value\":\"~/format-json-string-id/\"}"
400
                (rlmdb:%shard-term-data-uri-string-offset %term-data)))
401
       (:string
402
        (ecase (rlmdb:%shard-term-subtype-string-subtype %term)
403
          (:string-short
404
           (if (typep "" *expand-literal-values*) 
405
               (if (typep "" *encode-json-term.type-members*)
406
                   (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", \"value\":\"~V/%format-json-string/\"}"
407
                           8 %term-data)
408
                   (format stream "{\"type\":\"literal\", \"value\":\"~V/%format-json-string/\"}" 8 %term-data))
409
               (format stream "\"~V/%format-json-string/\"" 8 %term-data)))
410
          (:string-long
411
           (let* ((string-offset (rlmdb:%shard-term-data-string-value-offset %term-data))
412
                  (language-offset (rlmdb:%shard-term-data-string-language-offset %term-data)))
413
             (if (plusp language-offset)
414
                 (format stream "{\"type\":\"literal\", \"xml:lang\":\"~/format-json-string-id/\", \"value\":\"~/format-json-string-id/\"}"
415
                         language-offset string-offset)
416
                 (if (typep "" *expand-literal-values*) 
417
                     (if (typep "" *encode-json-term.type-members*)
418
                         (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", \"value\":\"~/format-json-string-id/\"}"
419
                                 string-offset)
420
                         (format stream "{\"type\":\"literal\", \"value\":\"~/format-json-string-id/\"}" string-offset))
421
                     (format stream "\"~/format-json-string-id/\"" string-offset)))))))
422
       (:boolean
423
        (let ((value (rlmdb:%shard-term-data-boolean %term-data)))
424
          (if (subtypep 'boolean *expand-literal-values*)
425
              (if (subtypep 'boolean *encode-json-term.type-members*)
426
                  (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#boolean\", \"value\":\"~:[false~;true~]\"}"
427
                          value)
428
                  (format stream "{\"type\":\"literal\", \"value\":\"~:[false~;true~]\"}" value))
429
              (format stream "~:[false~;true~]" value))))
430
       (:literal
431
        ;; expanded encoding for otherwise-native terms is ok
432
        (let ((string-offset (rlmdb:%shard-term-data-string-value-offset %term-data))
433
              (datatype-string-id (rlmdb:%shard-term-data-literal-datatype-offset %term-data)))
434
          (if (is-string-datatype-string-id datatype-string-id)
435
              (if (typep "" *expand-literal-values*)
436
                  (if (typep "" *encode-json-term.type-members*)
437
                      (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#string\", \"value\":\"~/format-json-string-id/\"}"
438
                              string-offset)
439
                      (format stream "{\"type\":\"literal\", \"value\":\"~/format-json-string-id/\"}" string-offset))
440
                  (format stream "\"~/format-json-string-id/\"" string-offset))
441
              (format stream "{\"type\":\"literal\", \"datatype\":\"~/format-json-string-id/\", \"value\":\"~/format-json-string-id/\"}"
442
                      datatype-string-id string-offset))))
443
       (:integer
444
        (encode-json-term  (rlmdb:%shard-term-data-integer %term-data)
445
                           stream))
446
       (:decimal
447
        (ecase (rlmdb:%shard-term-subtype-decimal-subtype %term)
448
          (:decimal-scaled
449
           (let* ((options (rlmdb:%shard-term-options %term))
450
                  (minusp (zerop (logand options #x01)))
451
                  (scale (ash options -1))
452
                  (value (rlmdb:%shard-term-data-integer %term-data)))
453
             (when minusp (setf value (- value)))
454
             (setf scale (if (zerop value) 1 (expt 10 scale)))
455
             (setf value
456
                   #+sbcl (sb-kernel::%make-ratio value scale)
457
                   #-sbcl (/ value scale))
458
             (encode-json-term value stream)))
459
          ((:broken :none)
460
           (let* ((integer (rlmdb:%shard-term-data-decimal-integer %term-data))
461
                  (fraction (if (zerop integer) 1 (rlmdb:%shard-term-data-decimal-fraction %term-data))))
462
             (if (typep 1/3 *expand-literal-values*)
463
                 (format stream "{\"type\":\"literal\", \"datatype\":\"http://www.w3.org/2001/XMLSchema#decimal\", \"value\":\"~d.~d\"}"
464
                         integer fraction)
465
                 (format stream "~d.~d" integer fraction))))))
466
       (:float
467
        (encode-json-term (rlmdb:%shard-term-data-float %term-data)
468
                          stream))
469
       (:double
470
        (encode-json-term (rlmdb:%shard-term-data-double %term-data)
471
                          stream))
472
       (:datetime
473
        (encode-json-term (timeline-location-date-time (rlmdb:%shard-term-data-time %term-data)) stream))
474
       (:date
475
        (encode-json-term (timeline-location-date (rlmdb:%shard-term-data-time %term-data)) stream))
476
       (:time
477
        (encode-json-term (timeline-location-time (rlmdb:%shard-term-data-time %term-data)) stream))
478
        (:none
479
         (write-string "{}" stream))
480
        )))
481
 
482
 (defun encode-json-term-number-compact (term-number stream)
483
   "Given a term number and a stream, encode the stored term properties
484
    (type, string, immediate value) to the given stream as compact json.
485
    That means, just the value components of a full sparql-results+json encoding.
486
    Durations are now not handled as times, but instead are treated as uninterned literals"
487
   (declare (type fixnum term-number))
488
   (let* ((%term (rlmdb:shard-term-fetch term-number))
489
          (term-type (rlmdb:%shard-term-type %term))
490
          (%term-data (rlmdb:%shard-term-data %term)))
491
     (declare (type cffi:foreign-pointer %term)
492
              (type symbol term-type)
493
              (type cffi:foreign-pointer %term-data))
494
     (ecase term-type
495
       (:node
496
        (ecase (rlmdb:%shard-term-subtype-node-subtype %term)
497
          (:node-genid
498
           (format stream "\"~@[~a_~]genid~d\""
499
                   (blank-node-prefix)
500
                   (rlmdb:%shard-term-data-node-genid %term-data)))
501
          (:node-gensym
502
           (format stream "\"~@[~a_~]~V/%format-turtle-string/~d\""
503
                   (blank-node-prefix)
504
                   ;; need a byte-count limited version of stream-write-turtle-external-utf8-string
505
                   4 (rlmdb:%shard-term-data-node-gensym-prefix %term-data)
506
                   (rlmdb:%shard-term-data-node-gensym-suffix %term-data)))
507
          (:node-short
508
           (format stream "\"~@[~a_~]~V/%format-json-string/\""
509
                   (blank-node-prefix)
510
                   8 (rlmdb:%shard-term-data-node-label %term-data)))
511
          ((:node-long :none)
512
           (format stream "\"~@[~a_~]~/format-json-string-id/\""
513
                   (blank-node-prefix)
514
                    (rlmdb:%shard-term-data-node-label-offset %term-data)))))
515
       (:uri
516
        (format stream "\"~/format-json-string-id/\""
517
                (rlmdb:%shard-term-data-uri-string-offset %term-data)))
518
       (:string
519
        (ecase (rlmdb:%shard-term-subtype-string-subtype %term)
520
          (:string-short
521
           (format stream "\"~V/%format-json-string/\"" 8 %term-data))
522
          (:string-long
523
           (let* ((string-offset (rlmdb:%shard-term-data-string-value-offset %term-data))
524
                  (language-offset (rlmdb:%shard-term-data-string-language-offset %term-data)))
525
             (if (plusp language-offset)
526
                 (format stream "{\"xml:lang\":\"~/format-json-string-id/\", \"value\":\"~/format-json-string-id/\"}"
527
                         language-offset string-offset)
528
                 (format stream "\"~/format-json-string-id/\"" string-offset))))))
529
       (:boolean
530
        (let ((value (rlmdb:%shard-term-data-boolean %term-data)))
531
          (format stream "~:[false~;true~]" value)))
532
       (:literal
533
        (let ((lexical-form-id (rlmdb:%shard-term-data-literal-value-offset %term-data)))
534
          (format stream "\"~/format-json-string-id/\"" lexical-form-id)))
535
       (:integer
536
        (format stream "~a" (rlmdb:%shard-term-data-integer %term-data)))
537
       (:decimal
538
        (ecase (rlmdb:%shard-term-subtype-decimal-subtype %term)
539
          (:decimal-scaled
540
           (let* ((options (rlmdb:%shard-term-options %term))
541
                  (minusp (zerop (logand options #x01)))
542
                  (scale (ash options -1))
543
                  (value (rlmdb:%shard-term-data-integer %term-data)))
544
             (when minusp (setf value (- value)))
545
             (setf scale (if (zerop value) 1 (expt 10 scale)))
546
             (setf value
547
                   #+sbcl (sb-kernel::%make-ratio value scale)
548
                   #-sbcl (/ value scale))
549
             (let ((*read-default-float-format* 'single-float))
550
               (format stream "~f" (float value 1.0s0)))))
551
          ((:broken :none)
552
           (let* ((integer (rlmdb:%shard-term-data-decimal-integer %term-data))
553
                  (fraction (if (zerop integer) 1 (rlmdb:%shard-term-data-decimal-fraction %term-data))))
554
             (format stream "~d.~d" integer fraction)))))
555
       (:float
556
        (format stream "~f" (rlmdb:%shard-term-data-float %term-data)))
557
       (:double
558
        (format stream "~f" (rlmdb:%shard-term-data-double %term-data)))
559
       (:datetime
560
        (format stream "\"~a\"" 
561
                (term-lexical-form (timeline-location-date-time (rlmdb:%shard-term-data-time %term-data)))))
562
       (:date
563
        (format stream "\"~a\"" 
564
                (term-lexical-form (timeline-location-date (rlmdb:%shard-term-data-time %term-data)))))
565
       (:time
566
        (format stream "\"~a\"" 
567
                (term-lexical-form (timeline-location-time (rlmdb:%shard-term-data-time %term-data)))))
568
       (:none
569
        (write-string "{}" stream))
570
       )))
571