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

KindCoveredAll%
expression4051950 20.8
branch13132 9.8
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
 
5
 ;;; (load (compile-file "classes.lisp"))
6
 
7
 (defparameter *pname_ln-scanner-to-strings*
8
   (cl-ppcre:create-scanner `(:sequence :start-anchor (:register (:greedy-repetition 0 1 pn_prefix)) #\: (:register  pn_local))))
9
 
10
 (defun parse-pname_ln (string)
11
   (apply #'values (coerce (nth-value 1 (cl-ppcre:scan-to-strings *pname_ln-scanner-to-strings* string)) 'list)))
12
 
13
 ;;; (parse-pname_ln "foaf:name")  -> "foaf" "name"
14
 ;;; (parse-pname_ln "foaf://name")  -> nil
15
 ;;; (parse-pname_ln "_:name")
16
 
17
 (defun intern-term-key (key prefix-bindings)
18
   "Intern a memeber key as one of
19
    - json-ld keyword, iff it begins with @,
20
    - blank node or iri, iff it contains a ':',
21
    - a variable which names a result dimensions, otherwise"
22
 
23
   (assert (and (stringp key) (plusp (length key))) ()
24
           "Invalid term key: ~s." key)
25
   (cond ((eql (char key 0) #\@)
26
          (or (find-symbol key :@)
27
              (error "Invalid keyword: ~s." key)))
28
         ((position #\: key)
29
          (intern-term-node key nil prefix-bindings))
30
         (t
31
          (intern key *variable-package*))))
32
 
33
 (defun intern-keyword-value (value base prefix-bindings)
34
   "Intern the value of a member for which the key as a json-ld keyword.
35
  The must be either an iri, a blank node, or itself a json-ld keyword."
36
   (if (json-ld:keywordp value)
37
     (intern value :keyword)
38
     (intern-term-node value base prefix-bindings)))
39
 
40
 (defun intern-term-node (value base prefix-bindings)
41
   (flet ((merge-iri (base local-part)
42
            (let* ((puri (puri:merge-uris local-part base))
43
                   (iri-namestring (with-output-to-string (stream) (puri:render-uri puri stream))))
44
              (intern-term-aspects :uri iri-namestring nil nil))))
45
     (cond ((position #\: value)
46
            (if (string-equal "_:" value :end2 (min 2 (length value)))
47
              (intern-blank-node (subseq value 2))
48
              (or (multiple-value-bind (prefix local) (parse-pname_ln value)
49
                    (let ((base (rest (assoc prefix prefix-bindings :test #'string=))))
50
                      (if base
51
                        (merge-iri base local)
52
                        (intern-iri value))))
53
                  (intern-iri value))))
54
           (base
55
            (merge-iri (iri-lexical-form base) value))
56
           (t
57
            (intern-iri value)))))
58
 
59
 (defgeneric parse-qname (string)
60
   (:method ((string string))
61
     (let ((position (position #\: string)))
62
       (if position
63
         (values (subseq string 0 position) (subseq string (1+ position)))
64
         string)))
65
   (:method ((datum symbol))
66
     (parse-qname (symbol-name datum))))  
67
 
68
 
69
 
70
 (defmethod json-ld:lexical-form ((object spocq:blank-node))
71
     (spocq:blank-node-label object))
72
 
73
 (defmethod json-ld:lexical-form ((object spocq:iri))
74
   (spocq:iri-lexical-form object))
75
 
76
 (defmethod json-ld:lexical-form ((object symbol))
77
   (when (iri-p object)
78
     (iri-lexical-form object)))
79
 
80
 (defmethod json-ld:lexical-form ((object t))
81
   nil)                               ;;;!!! need some default form
82
 
83
 
84
 ;;;
85
 ;;; json-ld:object
86
 
87
 (defclass json-ld:object ()
88
   ((id-term-number
89
     :initform nil
90
     :accessor json-ld::object-id-term-number
91
     :documentation "cache the id term number.
92
      nb. this is _not_ the @id member value.")
93
    (id
94
     :initform nil
95
     :reader json-ld:object-id
96
     :writer json-ld::setf-object-id
97
     :documentation "bind the object id")
98
    (type-term-number
99
     :initform nil
100
     :accessor json-ld::object-type-term-number
101
     :documentation "cache the type term number for filtering.
102
      nb. this is _not_ the @type member value.")
103
    (type
104
     :initform nil
105
     :reader json-ld:object-type
106
     :writer json-ld::setf-object-type
107
     :documentation "bind the object type")
108
    (members
109
     :initform () :initarg :members
110
     :accessor json-ld:object-members))
111
   (:documentation "The object class provides the abstract root to represent json data.
112
    It comprises an a-list of members only. This remains in the form as parsed - that is, with
113
    string keys and arbitrary values."))
114
 
115
 (defclass aliasing-object (json-ld:object)
116
   ((alias-map
117
     :initform '()
118
     :accessor json-ld:object-alias-map
119
     :documentation "Associates encoding keywords with terms which should
120
      replace them when encoded. by default (), while leaves keywords unchanged."))
121
   (:documentation "Allow kewords aliases when encoding"))
122
 
123
 (defclass base-object (aliasing-object)
124
   ((base
125
     :initform nil
126
     :reader json-ld:object-base
127
     :writer json-ld::setf-object-base
128
     :documentation "Can be set to an iri to serve as the base to merge any
129
      iri values processed within the context. Otherwise no base is used.")))
130
 
131
 
132
 (defmethod initialize-instance :around ((instance json-ld:object) &rest initargs
133
                                         &key members)
134
   "Wrap the object initialization process with steps to
135
    - canonicalize a member argument, allowing either an instance or list form
136
    - extract initargs from the member, appending them to those known
137
    - canonicalize argument keywords for json-ld keys, prepending them to those known"
138
   (declare (dynamic-extent initargs))
139
   (setf members (json-ld:object-members members))
140
   #+(or) (print (list :around (type-of instance) members))
141
   (apply #'call-next-method instance
142
          :members members
143
          (append (loop for (keyword value) on initargs by #'cddr
144
                    when (json-ld:keywordp keyword)
145
                    append (cons-symbol :keyword (subseq (symbol-name keyword) 1)))
146
                  (append initargs
147
                          (loop for (name . value) in members
148
                            when (json-ld:keywordp name)
149
                            append (list (cons-symbol :keyword (subseq name 1)) value))))))
150
 
151
 (defmethod initialize-instance ((instance json-ld:object)
152
                                 &key (id nil i-s) (type nil t-s))
153
   (when i-s (setf (json-ld:object-id instance) id))
154
   (when t-s (setf (json-ld:object-type instance)
155
                   ;; if specifies null, then mark that with an object
156
                   (or type (make-instance 'json-ld:object))))
157
   #+(or) (when (slot-exists-p instance 'context) (print (list :ii-before (_slot-value instance 'context))))
158
   (call-next-method)
159
   #+(or) (when (slot-exists-p instance 'context) (print (list :ii-after (_slot-value instance 'context))))
160
   #+(or) (print (list :ii.object.members (json-ld:object-members instance))))
161
 
162
 (defmethod initialize-clone ((old json-ld:object) (new json-ld:object) &key
163
                              (id-term-number (_slot-value old 'id-term-number))
164
                              (id (_slot-value old 'id))
165
                              (type-term-number (_slot-value old 'type-term-number))
166
                              (type (_slot-value old 'type))
167
                              (members (_slot-value old 'members)))
168
   (setf (json-ld::object-id-term-number new) id-term-number)
169
   (json-ld::setf-object-id id new)
170
   (setf (json-ld::object-type-term-number new) type-term-number)
171
   (json-ld::setf-object-type type new)
172
   (setf (json-ld:object-members new) members)
173
   (call-next-method))
174
 
175
 (defmethod initialize-instance ((instance aliasing-object) &key )
176
   ;; recognize and accumulate any alias members
177
   (call-next-method)
178
   (loop for (name . value) in (json-ld:object-members instance)
179
     for value-key = (json-ld:keywordp value)
180
     when value-key
181
     do (setf (key-alias instance value-key) name)))
182
 
183
 (defmethod initialize-clone ((old aliasing-object) (new aliasing-object) &key
184
                              (alias-map (_slot-value old 'alias-map)))
185
   (setf (json-ld::object-alias-map new) alias-map)
186
   (call-next-method))
187
 
188
 (defmethod initialize-instance :around ((instance base-object)
189
                                 &key base)
190
   "initialize the base always before anything else, as other can depend onit."
191
   (setf (json-ld:object-base instance) base)
192
   (call-next-method))
193
 
194
 (defmethod initialize-clone ((old base-object) (new base-object) &key
195
                              (base (_slot-value old 'base)))
196
   (setf (slot-value new 'base) base)
197
   (call-next-method))
198
 
199
 
200
 (defmethod print-object ((object json-ld:object) stream)
201
   (_print-unreadable-object (object stream :type t :identity nil)
202
     (format stream "~@[ id: ~a~]~@[=~a~]~@[(~a)~]~@[=~a~]x~d~@[ ~s~]"
203
             (bound-slot-value object 'id)
204
             (bound-slot-value object 'id-term-number)
205
             (bound-slot-value object 'type)
206
             (bound-slot-value object 'type-term-number)
207
             (length (bound-slot-value object 'members))
208
             (bound-slot-value object 'members))))
209
 
210
 (defmethod print-object ((object aliasing-object) stream)
211
   (_print-unreadable-object (object stream :type t :identity nil)
212
     (format stream "~@[ id: ~a~]~@[=~a~]~@[(~a)~]~@[=~a~]x~d~@[ ~s~]~@[-> ~s~]"
213
             (bound-slot-value object 'id)
214
             (bound-slot-value object 'id-term-number)
215
             (bound-slot-value object 'type)
216
             (bound-slot-value object 'type-term-number)
217
             (length (bound-slot-value object 'members))
218
             (bound-slot-value object 'members)
219
             (bound-slot-value object 'alias-map))))
220
 
221
 (defgeneric json-ld:object-p (object)
222
   (:method ((object json-ld:object)) t)
223
   (:method ((object list)) t)
224
   (:method ((object t)) nil))
225
 
226
 (defgeneric json-ld:null-object-p (object)
227
   (:method ((object json-ld:object))
228
     (not (json-ld:object-members object)))
229
   ;; disallow lists 
230
   (:method ((object t)) nil))
231
 
232
 (defun json-ld:make-object (&optional members &rest args)
233
   (apply #'make-instance 'json-ld:object :members members args))
234
 
235
 (defgeneric json-ld:list-object-p (object)
236
   (:method ((object t))
237
     nil)
238
   (:method ((object cons))
239
     (json-ld:object-member object @:|@list|))
240
   (:method ((object json-ld:object))
241
     (json-ld:object-member object @:|@list|)))
242
 
243
 (defgeneric json-ld:set-object-p (object)
244
   (:method ((object t))
245
     nil)
246
   (:method ((object cons))
247
     (json-ld:object-member object @:|@set|))
248
   (:method ((object json-ld:object))
249
     (json-ld:object-member object @:|@set|)))
250
 
251
 (defgeneric json-ld:value-object-p (object)
252
   (:method ((object t))
253
     nil)
254
   (:method ((object cons))
255
     (json-ld:object-member object @:|@value|))
256
   (:method ((object json-ld:object))
257
     (json-ld:object-member object @:|@value|)))
258
 
259
 
260
 (defmethod (setf json-ld:object-member-value) (value (object json-ld:object) (key (eql @:|@id|)))
261
   (setf (json-ld:object-id object) value)
262
   (call-next-method))
263
 (defgeneric (setf json-ld:object-id) (id object)
264
   (:method ((id t) (object json-ld:object))
265
     (json-ld::setf-object-id id object)))
266
 
267
 (defmethod (setf json-ld:object-member-value) (value (object json-ld:object) (key (eql @:|@type|)))
268
   (setf (json-ld:object-type object) value)
269
   (call-next-method))
270
 (defgeneric (setf json-ld:object-type) (type object)
271
   (:method ((type t) (object json-ld:object))
272
     (json-ld::setf-object-type type object)))
273
 
274
 
275
 (defmethod (setf json-ld:object-base) ((value string) (context base-object))
276
   (setf (json-ld:object-base context) (context-expand-iri context value)))
277
 
278
 (defmethod (setf json-ld:object-base) ((value symbol) (context base-object))
279
   (if (iri-p value)
280
     (json-ld::setf-object-base value context)
281
     (error "Invalid base term value: ~s." value)))
282
 
283
 (defmethod (setf json-ld:object-base) ((value spocq:iri) (context base-object))
284
   (json-ld::setf-object-base value context))
285
 
286
 (defmethod (setf json-ld:object-base) ((value null)  (context base-object))
287
   (json-ld::setf-object-base value context))
288
 
289
 
290
 (defmethod json-ld:object-member-names ((object json-ld:object))
291
   (mapcar #'first (json-ld:object-members object)))
292
 
293
 (defmethod json-ld:object-member-values ((object json-ld:object))
294
   (mapcar #'rest (json-ld:object-members object)))
295
 
296
 (defmethod json-ld:object-member ((object json-ld:object) key)
297
   (assoc key (json-ld:object-members object) :test #'json-ld:key=))
298
 
299
 (defmethod json-ld:object-member-value ((object json-ld:object) key)
300
   (rest (assoc key (json-ld:object-members object) :test #'json-ld:key=)))
301
 
302
 (defmethod json-ld:object-member-value-vector ((object json-ld:object) key)
303
   (let ((value (rest (assoc key (json-ld:object-members object) :test #'json-ld:key=))))
304
     (typecase value
305
       (null nil)
306
       (vector value)
307
       (t (make-array 1 :fill-pointer 1 :adjustable t :initial-contents (list value))))))
308
 
309
 (defmethod (setf json-ld:object-member-value) (value (object json-ld:object) key)
310
   (let ((member (assoc key (json-ld:object-members object) :test #'json-ld:key=)))
311
     (if member
312
       (setf (rest member) value)
313
       (setf (json-ld:object-members object) (acons key value (json-ld:object-members object))))
314
     value))
315
 
316
 (defmethod (setf json-ld:object-member-value) (value (object json-ld:object) (key string))
317
   (let ((key-symbol (find-symbol key "@")))
318
     (if key-symbol
319
         (setf (json-ld:object-member-value object key-symbol) value)
320
         (let ((member (assoc key (json-ld:object-members object) :test #'json-ld:key=)))
321
           (if member
322
               (setf (rest member) value)
323
               (setf (json-ld:object-members object) (acons key value (json-ld:object-members object))))
324
           value))))
325
 
326
 (defmethod (setf json-ld:object-member-value) ((value null) (object json-ld:object) key)
327
   (setf (json-ld:object-members object)
328
         (remove key (json-ld:object-members object) :key #'first :test #'json-ld:key=))
329
   nil)
330
 
331
 (defmethod json-ld:append-object-member-value ((object json-ld:object) key value)
332
    (let ((member (assoc key (json-ld:object-members object) :test #'json-ld:key=)))
333
     (cond (member
334
            (let ((member-value (rest member)))
335
              (typecase member-value
336
                (vector (vector-push-extend value member-value))
337
                (t
338
                 (setf (rest member) (make-array 2 :fill-pointer 2 :adjustable t
339
                                                 :initial-contents (list member-value value)))))
340
              value))
341
           (t
342
            (setf  (json-ld:object-members object)
343
                   (acons key value (json-ld:object-members object)))
344
            value))))
345
 
346
 (defmacro json-ld:map-members ((key value) object &body body)
347
   (let ((op (gensym "map-members-")))
348
     `(flet ((,op (,key ,value) ,@body))
349
        (declare (dynamic-extent #',op))
350
        (call-with-object-members #',op ,object))))
351
 
352
 (defgeneric call-with-object-members (op object)
353
   (:method ((op t) (object t))
354
     nil)
355
   (:method ((op t) (object cons))
356
     ;; (declare (dynamic-extent op))
357
     (loop for (key . value) in object
358
       do (funcall op key value)))
359
   (:method ((op t) (object json-ld:object))
360
     ;; (declare (dynamic-extent op))
361
     (call-with-object-members op (json-ld:object-members object))))
362
 
363
 
364
 ;;; alias accessors
365
 (defgeneric key-alias (object key)
366
   (:method ((object aliasing-object) key)
367
     (rest (assoc key (json-ld::object-alias-map object) :test #'json-ld:key=))))
368
 
369
 (defgeneric (setf key-alias) (alias object key)
370
   (:method (alias (object aliasing-object) key)
371
     (setf (json-ld::object-alias-map object)
372
           (acons key alias (json-ld::object-alias-map object)))))
373
 
374
 (defgeneric graph-alias (context)
375
   (:method ((context aliasing-object))
376
     (key-alias context "@graph")))
377
 
378
 (defgeneric (setf graph-alias) (alias context)
379
   (:method (alias (context aliasing-object))
380
     (setf (key-alias context "@graph") alias)))
381
 
382
 (defgeneric id-alias (context)
383
   (:method ((context aliasing-object))
384
     (key-alias context "@id")))
385
 
386
 (defgeneric (setf id-alias) (alias context)
387
   (:method (alias (context aliasing-object))
388
     (setf (key-alias context "@id") alias)))
389
 
390
 (defgeneric type-alias (context)
391
   (:method ((context aliasing-object))
392
     (key-alias context "@type")))
393
 
394
 (defgeneric (setf type-alias) (alias context)
395
   (:method (alias (context aliasing-object))
396
     (setf (key-alias context "@type") alias)))
397
 
398
 
399
 
400
 ;;;
401
 ;;; json-ld:term-definition
402
 
403
 (defclass json-ld:term-definition (base-object)
404
   ((key
405
     :initform (error "key is required.") :initarg :key
406
     :accessor json-ld:term-definition-key)
407
    (term
408
     :initform nil :initarg :term
409
     :accessor term-definition-term
410
     :documentation "The term to be associated with the member key.
411
      This may be an iri or a blank node.")
412
    (term-number
413
     :initform nil
414
     :accessor term-definition-term-number
415
     :documentation "The term number respective the definition's term")
416
    (alias-key
417
     :initform nil
418
     :reader json-ld:term-definition-alias-key
419
     :writer json-ld::setf-term-definition-alias-key
420
     :documentation "The processing role for which the term is to serve as an alias, eg '@id'")
421
    (container
422
     :initform nil :initarg :container
423
     :accessor term-definition-container
424
     :accessor json-ld:term-definition-container)
425
    (language
426
     :initform nil :initarg :language
427
     :reader json-ld:term-definition-language
428
     :writer json-ld::setf-term-definition-language)
429
    (reverse
430
     :initform nil :initarg :reverse
431
     :reader json-ld:term-definition-reverse-property
432
     :writer json-ld::setf-term-definition-reverse-property)
433
    (type
434
     :initform nil :initarg :type
435
     :reader json-ld:term-definition-type
436
     :writer json-ld::setf-term-definition-type))
437
   (:documentation "The term-definition class comprises the information for a json-ld extended term definition.
438
    The equivalent information is also represented in short hand form for elementary iri values and
439
    made available through the respective methods."))
440
 
441
 (defmethod initialize-instance ((instance json-ld:term-definition)
442
                                 &key members
443
                                 (container (json-ld:term-definition-container members))
444
                                 (term (json-ld:term-definition-term members))
445
                                 (term-number (json-ld:term-definition-term-number members))
446
                                 (language (json-ld:term-definition-language members))
447
                                 (reverse (json-ld:term-definition-reverse-property members))
448
                                 (type (json-ld:term-definition-type members)))
449
   (call-next-method)
450
   (setf (json-ld:term-definition-container instance) container)
451
   (setf (json-ld:term-definition-term instance) term)
452
   (setf (json-ld:term-definition-term-number instance) term-number)
453
   (setf (json-ld:term-definition-language instance) language)
454
   (setf (json-ld:term-definition-reverse-property instance) reverse)
455
   (setf (json-ld:term-definition-type instance) type)
456
   )
457
 
458
 (defmethod print-object ((object json-ld:term-definition) stream)
459
   (let ((*print-right-margin* 1000)
460
         (*print-pretty* nil))
461
       (_print-unreadable-object (object stream :type t :identity nil)
462
         (format stream "~s :~@[:= ~s~]~@[(~a)~]~@[ alias-key: ~a~]~@[ type: ~a~]~@[ container: ~a~]~@[ language: ~a~]~@[ reverse: ~a~]"
463
                 (bound-slot-value object 'key)
464
                 (bound-slot-value object 'term)
465
                 (bound-slot-value object 'term-number)
466
                 (bound-slot-value object 'alias-key)
467
                 (bound-slot-value object 'type)
468
                 (bound-slot-value object 'container)
469
                 (bound-slot-value object 'language)
470
                 (bound-slot-value object 'reverse)))))
471
 
472
 (defun json-ld:make-term-definition (&rest args)
473
   (declare (dynamic-extent args))
474
   (apply #'make-instance 'json-ld:term-definition args))
475
 
476
 (defclass id-term-definition (json-ld:term-definition)
477
   ((alias-key :initform :|@id| :allocation :class)))
478
 
479
 (defclass language-term-definition (json-ld:term-definition)
480
   ((alias-key :initform :|@language| :allocation :class)))
481
 
482
 (defclass type-term-definition (json-ld:term-definition)
483
   ((alias-key :initform :|@type| :allocation :class)))
484
 
485
 
486
 (defmethod (setf json-ld:term-definition-container) ((value null)  (term-definition json-ld:term-definition))
487
   (setf (term-definition-container term-definition) value))
488
 (defmethod (setf json-ld:term-definition-container) ((value string) (term-definition json-ld:term-definition))
489
   (setf (json-ld:term-definition-container term-definition)
490
         (or (find-symbol value :@)
491
             (json-ld:invalid-container-mapping-error :datum value))))
492
 (defmethod (setf json-ld:term-definition-container) ((value symbol)  (term-definition json-ld:term-definition))
493
   (if (member value '(@:|@list| @:|@set| @:|@index| @:|@language|))
494
       (setf (term-definition-container term-definition) value)
495
       (json-ld:invalid-container-mapping-error :datum value)))
496
 (defmethod (setf json-ld:term-definition-container) ((value t) (term-definition json-ld:term-definition))
497
   (json-ld:invalid-container-mapping-error :datum value))
498
   
499
 
500
 (defmethod json-ld:term-definition-term ((object list))
501
   (rest (or (assoc "@id" object :test #'json-ld:key=)
502
             (assoc "@term" object :test #'json-ld:key=))))
503
 
504
 (defmethod json-ld:term-definition-term ((definition json-ld:term-definition))
505
   (or (term-definition-term definition)
506
       (let ((number (term-definition-term-number definition)))
507
         (when number
508
           ;; allow neither a term nor a term number
509
           (setf (term-definition-term definition) (json-ld:term-object number))))))
510
 
511
 
512
 (defmethod  (setf json-ld:term-definition-term) ((value string) (term-definition json-ld:term-definition))
513
   (cond ((json-ld:blank-node-p value)
514
          (setf (term-definition-term term-definition) (json-ld:make-blank-node value)))
515
         ((json-ld:absolute-iri-p value)
516
          (setf (term-definition-term term-definition) (json-ld:make-iri value)))
517
         (t (json-ld:invalid-iri-mapping-error :datum value))))
518
 (defmethod  (setf json-ld:term-definition-term) ((value vector) (term-definition json-ld:term-definition))
519
   ;; actual use case
520
   (setf (term-definition-term term-definition) value))
521
 (defmethod  (setf json-ld:term-definition-term) ((value symbol) (term-definition json-ld:term-definition))
522
   (case value
523
     ((nil :|null|)
524
      (setf (term-definition-term-number term-definition) 0
525
            (term-definition-term term-definition) nil))
526
     (t
527
      (cond ((or (iri-p value) (json-ld:keywordp value)
528
                 (variable-p value))
529
             (setf (term-definition-term-number term-definition) nil
530
                   (term-definition-term term-definition) value))
531
            (t
532
             (json-ld:invalid-iri-mapping-error :datum value))))))
533
 (defmethod  (setf json-ld:term-definition-term) ((value spocq:iri) (term-definition json-ld:term-definition))
534
   (setf (term-definition-term-number term-definition) nil
535
         (term-definition-term term-definition) value))
536
 (defmethod  (setf json-ld:term-definition-term) ((value spocq:blank-node) (term-definition json-ld:term-definition))
537
   (setf (term-definition-term-number term-definition) nil
538
         (term-definition-term term-definition) value))
539
 (defmethod  (setf json-ld:term-definition-term) ((value t) (term-definition json-ld:term-definition))
540
   (json-ld:invalid-iri-mapping-error :datum value))
541
 
542
 
543
 (defmethod json-ld:term-definition-term-number ((object list))
544
   (rest (assoc "@termNumber" object :test #'json-ld:key=)))
545
 (defmethod json-ld:term-definition-term-number ((object json-ld:term-definition))
546
   (or (term-definition-term-number object)
547
       (let ((term (term-definition-term object)))
548
         (typecase term
549
           ((or iri spocq:blank-node)
550
            (setf (term-definition-term-number object) (repository-object-term-number *transaction* term)))
551
           (json-ld:keyword
552
            (setf (term-definition-term-number object) 0))
553
           (t
554
            (json-ld:invalid-iri-mapping-error :datum term
555
                                               :clause 'json-ld:term-definition-term-number))))))
556
 
557
 
558
 (defmethod (setf json-ld:term-definition-term-number) ((value integer) (term-definition json-ld:term-definition))
559
   (setf (term-definition-term-number term-definition) value))
560
 (defmethod (setf json-ld:term-definition-term-number) ((value null) (term-definition json-ld:term-definition))
561
   (setf (term-definition-term-number term-definition) nil))
562
 
563
 
564
 (defgeneric json-ld::term-definition-type-term-number (term-definition)
565
   (:method ((term-definition json-ld:term-definition))
566
     (or (json-ld::object-type-term-number term-definition)
567
         (setf (json-ld::object-type-term-number term-definition)
568
               (or (let ((type (json-ld:term-definition-type term-definition)))
569
                     (when type
570
                       (repository-object-term-number *transaction* type)))
571
                   0)))))
572
 
573
 
574
 (defgeneric (setf json-ld:term-definition-alias-key) (value term-definition)
575
   (:method ((value string) (term-definition json-ld:term-definition))
576
     (json-ld::setf-term-definition-alias-key (or (find-symbol value :keyword)
577
                                                  (error "Invalid term alias key: ~s." value))
578
                                              term-definition))
579
   (:method ((value symbol) (term-definition json-ld:term-definition))
580
     (if (member value '(:|@id| :|@type| :|@language|))       ; the supported values
581
       (json-ld::setf-term-definition-alias-key value term-definition)
582
       (error "Invalid term alias key: ~s." value)))
583
   (:method ((value null) (term-definition json-ld:term-definition))
584
     (json-ld::setf-term-definition-alias-key value term-definition)))
585
 
586
 (defgeneric (setf json-ld:term-definition-language) (value term-definition)
587
   (:method ((value string) (term-definition json-ld:term-definition))
588
     (if (is-language-tag value)
589
       (json-ld::setf-term-definition-language value term-definition)
590
       (json-ld:invalid-language-mapping-error :datum value)))
591
   (:method ((value symbol) (term-definition json-ld:term-definition))
592
     (case value
593
       ((nil :|null|) (json-ld::setf-term-definition-language nil term-definition))
594
       (t (json-ld:invalid-language-mapping-error :datum value) )))
595
   (:method ((value t) (term-definition json-ld:term-definition))
596
     (json-ld:invalid-language-mapping-error :datum value)))
597
 
598
 (defgeneric (setf json-ld:term-definition-reverse-property) (value term-definition)
599
   (:method ((value null)  (term-definition json-ld:term-definition))
600
     (json-ld::setf-term-definition-reverse-property nil term-definition))
601
   (:method ((value (eql :|false|))  (term-definition json-ld:term-definition))
602
     (json-ld::setf-term-definition-reverse-property nil term-definition))
603
   (:method ((value (eql t))  (term-definition json-ld:term-definition))
604
     (json-ld::setf-term-definition-reverse-property t term-definition))
605
   (:method ((value (eql :|true|))  (term-definition json-ld:term-definition))
606
     (json-ld::setf-term-definition-reverse-property t term-definition)))
607
 
608
 (defgeneric (setf json-ld:term-definition-type) (value term-definition)
609
   (:method ((value string) (term-definition json-ld:term-definition))
610
     (cond ((json-ld:blank-node-p value)
611
            (json-ld::setf-term-definition-type (json-ld:make-blank-node value) term-definition))
612
           ((json-ld:absolute-iri-p value)
613
            (json-ld::setf-term-definition-type (json-ld:make-iri value) term-definition))
614
           (t
615
            (json-ld:invalid-type-mapping-error :datum value))))
616
   (:method ((value symbol) (term-definition json-ld:term-definition))
617
     (case value
618
       ((nil :|null|) (json-ld::setf-term-definition-type nil term-definition))
619
       ((@:|@id| @:|@vocab|) (json-ld::setf-term-definition-type value term-definition))
620
       (t
621
        (cond ((iri-p value)
622
               (json-ld::setf-term-definition-type value term-definition))
623
              (t
624
               (json-ld:invalid-type-mapping-error :datum value))))))
625
   (:method ((value spocq:iri) (term-definition json-ld:term-definition))
626
     (json-ld::setf-term-definition-type value term-definition))
627
   (:method ((value t)  (term-definition json-ld:term-definition))
628
     (json-ld:invalid-type-mapping-error :datum value)))
629
 
630
 (defgeneric json-ld::term-definition-type-term-number (term-definition)
631
   (:method ((term-definition json-ld:term-definition))
632
     (or (json-ld::object-type-term-number term-definition)
633
         (setf (json-ld::object-type-term-number term-definition)
634
               (or (let ((type (json-ld:term-definition-type term-definition)))
635
                     (when type
636
                       (repository-object-term-number *transaction* type)))
637
                   0)))))
638
 
639
 (defmethod json-ld:term-definition-container ((object list))
640
   (rest (assoc "@container" object :test #'json-ld:key=)))
641
 
642
 (defmethod json-ld:term-definition-language ((object list))
643
   (rest (assoc "@language" object :test #'json-ld:key=)))
644
 
645
 (defmethod json-ld:term-definition-reverse-property ((object list))
646
   (rest (assoc "@reverse" object :test #'json-ld:key=)))
647
 
648
 (defmethod json-ld:term-definition-type ((object list))
649
   (rest (assoc "@type" object :test #'json-ld:key=)))
650
 
651
 
652
 (defgeneric json-ld:term-number (object)
653
   (:documentation "Return the global term number for the object. As the intended objects are iri (either as symbols
654
    or as term objects, the value should be set in the object. If not, retrieve it anew.
655
    Other objects ar handled, but should not appear.")
656
   (:method ((object t))
657
     (repository-object-term-number *repository* object))
658
   (:method ((object json-ld:term-definition))
659
     (json-ld:term-definition-term-number object)))
660
 
661
 (defgeneric json-ld:term-object (number)
662
   (:method ((object t))
663
     (term-number-object object))
664
   (:method ((object json-ld:term-definition))
665
     (json-ld:term-definition-term object)))
666
 
667
 (defgeneric term-definition-equal (d1 d2)
668
   (:method ((d1 json-ld:term-definition) (d2 json-ld:term-definition))
669
     (or (term-definition-equal (json-ld:term-definition-key d1) (json-ld:term-definition-key d2))
670
         (term-definition-equal (json-ld:term-definition-term d1) (json-ld:term-definition-term d2))
671
         (term-definition-equal (json-ld:term-definition-term-number d1) (json-ld:term-definition-term-number d2))))
672
   (:method ((d1 null) (d2 t))
673
     nil)
674
   (:method ((d1 t) (d2 null))
675
     nil)
676
   (:method ((d1 t) (d2 t))
677
     (equalp d1 d2)))
678
 
679
 
680
 ;;;
681
 ;;; output-definition
682
 
683
 (defclass json-ld:output-definition (base-object)
684
   ((term-definition
685
     :initform (error "term-definition is required") :initarg :term-definition
686
     :reader json-ld:output-definition-term-definition)
687
    (frame
688
     :initform (error "frame is required") :initarg :frame
689
     :reader json-ld:output-definition-frame))
690
   (:documentation "Combine a term definition and a frame
691
    to specify how the respective term is to be encoded."))
692
 
693
 (defmethod term-definition-equal ((def1 json-ld:output-definition) (def2 json-ld:term-definition))
694
   (term-definition-equal (json-ld:output-definition-term-definition def1) def2))
695
 
696
 (defmethod term-definition-equal ((def1 json-ld:term-definition) (def2 json-ld:output-definition))
697
   (term-definition-equal def1 (json-ld:output-definition-term-definition def2)))
698
 
699
 (defmethod json-ld:term-definition-key ((definition json-ld:output-definition))
700
   (json-ld:term-definition-key (json-ld:output-definition-term-definition definition)))
701
 
702
 (defmethod json-ld:term-definition-term-number ((definition json-ld:output-definition))
703
   (json-ld:term-definition-term-number (json-ld:output-definition-term-definition definition)))
704
 
705
 ;;;
706
 ;;; term-map
707
 
708
 (defclass term-map (json-ld:object)
709
   ((member-keys
710
     :initform nil
711
     :reader json-ld:term-map-member-keys
712
     :writer json-ld::setf-term-map-member-keys)
713
    (prefix-term-definitions
714
     :initform nil
715
     :accessor json-ld:term-map-prefix-term-definitions
716
     :writer json-ld::setf-term-map-prefix-term-definitions)
717
    (term-definitions
718
     :initform nil :initarg :term-definitions
719
     :reader json-ld:term-map-term-definitions
720
     :writer json-ld::setf-term-map-term-definitions))
721
   (:documentation "Act as mediator for frame and context term definitions.
722
    Mixed into both frame and context classes to represent the context's
723
    mappings and the frame's structural constraints"))
724
 
725
 #+(or)
726
 (defmethod initialize-instance ((instance term-map)
727
                                 &key members term-definitions)
728
   (call-next-method)
729
   (setf (json-ld:term-map-term-definitions instance)
730
         (or term-definitions
731
             (loop for (key . value) in members
732
               ;; configuration is already set, above
733
               unless (or (json-ld:keywordp key) (json-ld:keywordp value)
734
                          (and (consp value) (json-ld:keywordp (rest (assoc "@id" value :test #'equal)))))
735
               collect (compute-term-definition instance key value)))))
736
 
737
 (defmethod initialize-clone ((old term-map) (new term-map) &key
738
                              (member-keys (_slot-value old 'member-keys))
739
                              (prefix-term-definitions (_slot-value old 'prefix-term-definitions))
740
                              (term-definitions (_slot-value old 'term-definitions)))
741
   (setf (slot-value new 'member-keys) member-keys)
742
   (setf (slot-value new 'prefix-term-definitions) prefix-term-definitions)
743
   (setf (slot-value new 'term-definitions) term-definitions)
744
   (call-next-method))
745
 
746
 (defgeneric (setf json-ld:term-map-term-definitions) (members context)
747
   (:method ((definitions list) (context term-map))
748
     (json-ld::setf-term-map-member-keys (loop for definition in definitions
749
                                           for key = (json-ld:term-definition-key definition)
750
                                           when key
751
                                           collect key)
752
                                         context)
753
 
754
     (json-ld::setf-term-map-prefix-term-definitions
755
      (sort (loop for definition in definitions
756
              when (and (not (json-ld:keywordp (json-ld:term-definition-key definition)))
757
                        (iri-p (json-ld:term-definition-term definition)))
758
              collect definition)
759
            #'>
760
            :key (lambda (definition)
761
                   (length (iri-lexical-form (json-ld:term-definition-term definition)))))
762
      context)
763
     (json-ld::setf-term-map-term-definitions definitions context)))
764
 
765
 #+(or)
766
 (defgeneric compute-term-definition (instance key value)
767
   (:documentation "Handle those context/frame keyword values which require coercion
768
    - to iri (as term definition abbreviation)
769
    - to term definition")
770
   (:argument-precedence-order key instance value)
771
   
772
   (:method ((instance term-map) (key string) (value t))
773
     (setf key (intern-term-key key (json-ld:object-members instance)))
774
     (assert (not (keywordp key)) ()
775
             "A json-ld keyword alias may not name a term definition: ~s . ~s" key value)
776
     (compute-term-definition instance key value))
777
 
778
   (:method ((instance term-map) key value)
779
     ;; instantiate a term definition for the named member
780
     (typecase value
781
       (cons
782
        (loop for (key . nil) in value
783
              do (assert (json-ld:keywordp key) ()
784
                         "Invalid term definition value: ~s" value))
785
        (json-ld:make-term-definition :base (json-ld:object-base instance)
786
                                      :key key
787
                                      :members (append value (json-ld:object-members instance))))
788
       (string
789
        (json-ld:make-term-definition :base (json-ld:object-base instance)
790
                                      :key key
791
                                      :term (compute-term-value instance value)))
792
       (iri 
793
        (json-ld:make-term-definition :base nil :key key :term value))
794
       (null
795
        (json-ld:make-term-definition :base nil :key key :term value))
796
       (vector
797
        (assert (and (= 1 (length value)) (null (aref value 0))) ()
798
                "Invalid term definition value: ~s" value)
799
        (json-ld:make-term-definition :base nil :key key :term value))
800
       (t
801
        (error "Invalid term definition value: ~s" value)))))
802
 
803
 
804
 ;;;
805
 ;;; json-ld:context
806
 
807
 (defclass json-ld:context (term-map base-object)
808
   ((id
809
     :accessor json-ld:context-id)
810
    (type
811
     :initform |rdf|:|type|
812
     :accessor json-ld:context-type)
813
    (language
814
     :initform nil :initarg :language
815
     :reader json-ld:context-language
816
     :writer json-ld::setf-context-language)
817
    (vocabulary
818
     :initform nil :initarg :vocabulary :initarg :vocab
819
     :reader json-ld:context-vocabulary
820
     :writer json-ld::setf-context-vocabulary
821
     :documentation "Can specifiy an iri which becomes the base for iri values.")
822
    (location
823
     :initform nil :initarg :location
824
     :accessor json-ld::context-location
825
     :documentation "cache the location from which a context was retrieved")
826
    (lexical-form
827
     :initform nil :initarg :lexical-form
828
     :accessor json-ld::context-lexical-form
829
     :documentation "cache the string from which the context was parsed"))
830
   (:documentation "Combine term definitions, key aliases."))
831
 
832
 
833
 (defmethod initialize-instance ((instance json-ld:context) &key
834
                                 (language nil l-s)
835
                                 (vocab nil v1-s)
836
                                 (vocabulary vocab v2-s))
837
   (when l-s (setf (json-ld:context-language instance) language))
838
   (when (or v1-s v2-s) (setf (json-ld:context-language vocabulary) vocabulary))
839
   (call-next-method))
840
 
841
 (defmethod initialize-clone ((old json-ld:context) (new json-ld:context) &key
842
                              (language (_slot-value old 'language))
843
                              (vocabulary (_slot-value old 'vocabulary)))
844
   (setf (slot-value new 'language) language)
845
   (setf (slot-value new 'vocabulary) vocabulary)
846
   (call-next-method))
847
 
848
 (defmethod print-object ((object json-ld:context) stream)
849
   (let ((*print-right-margin* 1000)
850
         (*print-pretty* nil))
851
     (_print-unreadable-object (object stream :type t :identity t)
852
       ;; do not bother with the immediate members as much of the state coems from merging
853
       (format stream "~{~a~^,~}~@[ base: ~a~]~@[ id: ~a~]~@[ language: ~a~]~@[ type: ~a~]~@[ vocab: ~a~]"
854
               (bound-slot-value object 'member-keys)
855
               (bound-slot-value object 'base)
856
               (bound-slot-value object 'id)
857
               (bound-slot-value object 'language)
858
               (bound-slot-value object 'type)
859
               (bound-slot-value object 'vocabulary)))))
860
 
861
 
862
 (defun json-ld:make-context (&rest args)
863
   "Construct a context given its initialization arguments and then merge it with the
864
  remainder of the argument list, which should be a sequence of context declarations and
865
  remote locations"
866
   (declare (dynamic-extent args))
867
   (if (stringp (first args))
868
       (if (eql (char (first args) 0) #\{)
869
           (let ((context (json-ld:make-context (parse-json (first args)))))
870
             (setf (json-ld::context-lexical-form context) (first args))
871
             context)
872
           (let ((context (json-ld:make-context (json-ld:get-json-ld (first args)))))
873
             (setf (json-ld::context-location context) (first args))))
874
       (let ((initargs ()))
875
         (loop (cond ((keywordp (first args))
876
                      (push (pop args) initargs)
877
                      (push (pop args) initargs))
878
                     (t
879
                      ;; merge the context definition into an instance created w/o members
880
                      (let* ((members (when args (apply #'vector args)))
881
                             (context (json-ld:merge-contexts (apply #'make-instance 'json-ld:context (reverse initargs))
882
                                                              members)))
883
                        (setf (json-ld::context-lexical-form context)
884
                              (if args
885
                                  (if (rest args)
886
                                      members
887
                                      (first args))))
888
                        (return context))))))))
889
 
890
 
891
 (defgeneric context-expand-iri (context iri &key base-iri vocabulary-p)
892
   (:documentation "Intern the lexical form of an iri or a blank node, subject to
893
     combined literal, base and prefix declarations.
894
     A term definition provides just base and prefix definitions while a context
895
     also recognizes literal key equivalence")
896
 
897
   (:method ((context json-ld:context) (iri t) &rest args
898
             &key (base-iri (json-ld:object-base context))
899
             (vocabulary-p t))
900
     (apply #'json-ld:expand-iri context iri :base-iri base-iri :vocabulary-p vocabulary-p
901
            args)))
902
 
903
 
904
 (defgeneric json-ld:compact-iri (context iri)
905
   (:method ((context t) (iri symbol))
906
     (json-ld:compact-iri context (iri-lexical-form iri)))
907
   (:method ((context t) (iri spocq:iri))
908
     (json-ld:compact-iri context (spocq:iri-lexical-form iri)))
909
   (:method ((context t) (%iri sb-sys:system-area-pointer))
910
     (when (json-ld:term-map-prefix-term-definitions context)
911
       (with-term-string (lexical-form %iri)
912
         (json-ld:compact-iri context lexical-form))))
913
 
914
   (:method ((context json-ld::context) (iri-lexical-form string))
915
     (loop with iri-length = (length iri-lexical-form)
916
       for definition in (json-ld:term-map-prefix-term-definitions context)
917
       for definition-lexical-form = (iri-lexical-form (json-ld:term-definition-term definition))
918
       for definition-length = (length definition-lexical-form)
919
       for definition-key = (json-ld:term-definition-key definition)
920
       when (string= iri-lexical-form definition-lexical-form)
921
       return nil
922
       when (and (< definition-length iri-length) ; a prefix is plausible
923
                 (string/= definition-key definition-lexical-form) ; and the definition is a prefix
924
                 (string= iri-lexical-form definition-lexical-form :end1 definition-length) ; and the local part matches
925
                 )
926
       return (concatenate 'string definition-key
927
                           ":" (subseq iri-lexical-form definition-length))))
928
   #+(or) ;; defined with class
929
   (:method ((frame json-ld:frame) (iri-lexical-form t))
930
     (json-ld:compact-iri (json-ld:frame-context frame) iri-lexical-form))
931
   (:method ((context null) (iri-lexical-form t))
932
     nil))
933
 
934
 
935
 (defmethod json-ld:context-graph ((object list))
936
   "the alias definition is reversed: eg, (alias . @graph)"
937
   (loop for (key . definition) in object
938
         when (or (equal "@graph" definition)
939
                  (and (consp definition)
940
                       (equal "@graph" (rest (assoc "@id" definition :test #'equal)))))
941
         return key))
942
 
943
 (defgeneric (setf json-ld:context-graph) (value context)
944
   (:documentation "A graph alias specifies a member key alias for the json-ld '@graph' key")
945
   (:method ((value t)  (context json-ld:context))
946
     (setf (json-ld:object-member-value context @:|@graph|) value)))
947
 
948
 (defmethod json-ld:context-id ((object list))
949
   (loop for (key . definition) in object
950
         when (or (equal "@id" definition)
951
                  (and (consp definition)
952
                       (equal "@id" (rest (assoc "@id" definition :test #'equal)))))
953
         return key))
954
 
955
 (defgeneric (setf json-ld:context-id) (value context)
956
   (:method ((value t)  (context json-ld:context))
957
     (setf (json-ld:object-member-value context @:|@id|) value)))
958
 
959
 (defmethod json-ld:context-language ((object list))
960
   (rest (assoc "@language" object :test #'json-ld:key=)))
961
 
962
 (defgeneric (setf json-ld:context-language) (value context)
963
   (:method ((value string) (context json-ld:context))
964
     (if (is-language-tag value)
965
       (json-ld::setf-context-language value context)
966
       (json-ld:invalid-default-language-error :datum value)))
967
   (:method ((value symbol) (context json-ld:context))
968
     (case value
969
       ((nil :|null|) (json-ld::setf-context-language nil context))
970
       (t (json-ld:invalid-default-language-error :datum value))))
971
   (:method ((value t) (context json-ld:context))
972
     (json-ld:invalid-default-language-error :datum value)))
973
 
974
 (defmethod json-ld:context-type ((object list))
975
   (loop for (key . definition) in object
976
     when (json-ld:key= @:|@type| key)
977
     return definition
978
     when (and (consp definition)
979
               (json-ld:key= @:|@type| (rest (assoc @:|@id| definition :test #'json-ld:key=))))
980
     return (json-ld:object-member-value definition @:|@value|)))
981
 
982
 
983
 (defmethod json-ld:context-vocabulary ((object list))
984
   (rest (assoc "@vocab" object :test #'json-ld:key=)))
985
 
986
 (defgeneric (setf json-ld:context-vocabulary) (value context)
987
   (:method ((value string) (context json-ld:context))
988
     (cond ((json-ld:blank-node-p value)
989
            (json-ld::setf-context-vocabulary (json-ld:make-blank-node value) context))
990
           ((json-ld:absolute-iri-p value)
991
            (json-ld::setf-context-vocabulary (json-ld:make-iri value) context))
992
           (t (json-ld:invalid-vocab-mapping-error :datum value))))
993
   (:method ((value symbol) (context json-ld:context))
994
     (case value
995
       ((nil :|null|) (json-ld::setf-context-vocabulary nil context))
996
       ((iri-p value)
997
        (json-ld::setf-context-vocabulary value context))
998
       (t
999
        (json-ld:invalid-vocab-mapping-error :datum value))))
1000
   (:method ((value spocq:blank-node) (context json-ld:context))
1001
     (json-ld::setf-context-vocabulary value context))
1002
   (:method ((value spocq:iri) (context json-ld:context))
1003
     (json-ld::setf-context-vocabulary value context)))
1004
 
1005
 
1006
 (defmethod (setf json-ld:object-member-value) ((key (eql @:|@graph|)) (instance json-ld:context) graph)
1007
   (call-next-method)
1008
   (setf (key-alias instance key) graph))
1009
 (defmethod (setf json-ld:object-member-value) ((key (eql @:|@id|)) (instance json-ld:context) id)
1010
   (call-next-method)
1011
   (setf (key-alias instance key) id))
1012
 (defmethod (setf json-ld:object-member-value) ((key (eql @:|@type|)) (instance json-ld:context) type)
1013
   (call-next-method)
1014
   (setf (key-alias instance key) type))
1015
 (defmethod (setf json-ld:object-member-value) ((key (eql @:|@language|)) (instance json-ld:context) language)
1016
   (call-next-method)
1017
   (setf (key-alias instance key) language))
1018
 (defmethod (setf json-ld:object-member-value) ((key (eql @:|@vocab|)) (instance json-ld:context) vocabulary)
1019
   (call-next-method)
1020
   (setf (key-alias instance key) vocabulary))
1021
 
1022
 (defmethod json-ld:find-term-definition ((context json-ld:context) (term-key symbol))
1023
   (find term-key (json-ld:term-map-term-definitions context)
1024
         :test #'json-ld:key= :key #'json-ld:term-definition-key))
1025
 (defmethod json-ld:find-term-definition ((context json-ld:context) (term-key spocq:iri))
1026
   (find term-key (json-ld:term-map-term-definitions context)
1027
         :test #'json-ld:key= :key #'json-ld:term-definition-key))
1028
 (defmethod json-ld:find-term-definition ((context json-ld:context) (term-number number))
1029
   (find term-number (json-ld:term-map-term-definitions context)
1030
         :test #'eql :key #'json-ld:term-number))
1031
 (defmethod json-ld:find-term-definition ((context json-ld:context) (term-key string))
1032
   "allow the case where the value of a frame term is mapped bt th context"
1033
   (find term-key (json-ld:term-map-term-definitions context)
1034
         :test #'json-ld:key= :key #'json-ld:term-definition-key))
1035
 
1036
 (defgeneric (setf json-ld:find-term-definition) (definition context term)
1037
   (:documentation "Add or replace the term definition in the given context for the respective term key")
1038
   (:method ((definition json-ld:term-definition) (context json-ld:context) (key t))
1039
     (let ((old (json-ld:find-term-definition context key)))
1040
       (when old (setf (json-ld:term-map-term-definitions context)
1041
                       (remove old (json-ld:term-map-term-definitions context)))))
1042
     (push definition (json-ld:term-map-term-definitions context))
1043
     definition)
1044
   (:method ((definition null) (context json-ld:context) (key t))
1045
     (let ((old (json-ld:find-term-definition context key)))
1046
       (when old (setf (json-ld:term-map-term-definitions context)
1047
                       (remove old (json-ld:term-map-term-definitions context)))))
1048
     definition))
1049
 
1050
 (defmethod json-ld:find-term-definition-container ((context json-ld:context) (key t))
1051
   (let ((definition (json-ld:find-term-definition context key)))
1052
     (typecase definition
1053
       (json-ld:term-definition
1054
        (json-ld:term-definition-container definition))
1055
       (t
1056
        nil))))
1057
 
1058
 (defmethod json-ld:find-term-definition-term ((context json-ld:context) (key t))
1059
   (let ((definition (json-ld:find-term-definition context key)))
1060
         (typecase definition
1061
       (json-ld:term-definition
1062
        (json-ld:term-definition-term definition))
1063
       (t
1064
        nil))))
1065
 
1066
 (defmethod json-ld:find-term-definition-language ((context json-ld:context) (key t))
1067
   (let ((definition (json-ld:find-term-definition context key)))
1068
     (typecase definition
1069
       (json-ld:term-definition
1070
        (json-ld:term-definition-language definition))
1071
       (t
1072
        nil))))
1073
 
1074
 (defmethod json-ld:find-term-definition-reverse-property ((context json-ld:context) (key t))
1075
   (let ((definition (json-ld:find-term-definition context key)))
1076
     (typecase definition
1077
       (json-ld:term-definition
1078
        (json-ld:term-definition-reverse-property definition))
1079
       (t
1080
        nil))))
1081
 
1082
 (defmethod json-ld:find-term-definition-type ((context json-ld:context) (key t))
1083
   (let ((definition (json-ld:find-term-definition context key)))
1084
         (typecase definition
1085
       (json-ld:term-definition
1086
        (json-ld:term-definition-type definition))
1087
       (t
1088
        nil))))
1089
 
1090
 ;;;
1091
 ;;; json-ld:frame
1092
 
1093
 (defclass json-ld:frame (term-map aliasing-object)
1094
   ((context
1095
     :initform nil ;;:initarg :context
1096
     :reader json-ld:frame-context
1097
     :writer json-ld::setf-frame-context)
1098
    (compact
1099
     :initform nil :initarg :compact
1100
     :accessor json-ld:frame-compact
1101
     :type (member :|false| :|true| @:|@embed| nil))
1102
    (default
1103
      :initform nil :initarg :default
1104
      :reader json-ld:frame-default
1105
      :writer json-ld::setf-frame-default)
1106
    (embed
1107
      :initform nil :initarg :enbed
1108
      :accessor json-ld:frame-embed
1109
      :type (member :|false| :|true| nil))
1110
    (explicit
1111
      :initform nil :initarg :explicit
1112
      :reader json-ld:frame-explicit
1113
      :writer json-ld::setf-frame-explicit
1114
      :type (member :|false| :|true| nil))
1115
    (null
1116
      :initform nil :initarg :null
1117
      :reader json-ld:frame-null
1118
      :writer json-ld::setf-frame-null)
1119
    (omit-default
1120
      :initform nil :initarg :omit-default
1121
      :reader json-ld:frame-omit-default
1122
      :writer json-ld::setf-frame-omit-default)
1123
    (type
1124
     :initform nil :type (or null vector json-ld:object)
1125
     :documentation "Can be bound to a vector of terms which constrain the types of
1126
      resources permitted in the frame. see frame-type-predicate for the logic
1127
      effected by the alternative values.")
1128
    (type-predicate
1129
     :initform nil :type (or null function)
1130
     :reader get-frame-type-predicate
1131
     :writer setf-frame-type-predicate)
1132
    ;; cache
1133
    (subjects
1134
     :initform (make-array 128 :adjustable t :fill-pointer 0)
1135
     :reader json-ld:frame-subjects)
1136
    (properties
1137
     :initform (make-hash-table :test 'eql) :initarg :properties
1138
     :reader json-ld:frame-properties)
1139
    (objects
1140
     :initform (make-hash-table :test 'eql) :initarg :objects
1141
     :reader json-ld:frame-objects)
1142
    (types
1143
     :initform (make-hash-table :test 'eql)
1144
     :reader json-ld:frame-types)
1145
    (output-members
1146
     :writer setf-frame-output-members
1147
     :reader frame-output-members))
1148
   (:documentation "Encapsulate the settings, the term map context, and the structural
1149
    constraints for mapping a graph to a json document"))
1150
 
1151
 
1152
 (defmethod initialize-instance ((instance json-ld:frame) &key
1153
                                 (context nil c-s)
1154
                                 (compact nil compact-s)
1155
                                 (default nil d-s)
1156
                                 (embed nil em-s)
1157
                                 (explicit nil ex-s)
1158
                                 (null nil n-s)
1159
                                 (omit-default nil od-s))
1160
   ;; some context must be present for key initialization
1161
   (setf (json-ld:frame-context instance) (or context (json-ld:make-context)))
1162
   (when compact-s (setf (json-ld:frame-compact instance) compact))
1163
   (when d-s (setf (json-ld:frame-default instance) default))
1164
   (when em-s (setf (json-ld:frame-embed instance) embed))
1165
   (when ex-s (setf (json-ld:frame-explicit instance) explicit))
1166
   (when n-s (setf (json-ld:frame-null instance) null))
1167
   (when od-s (setf (json-ld:frame-omit-default instance) omit-default))
1168
   ;; first, bind any keyword members
1169
   (call-next-method)
1170
   ;; then, instantiate any sub-frames
1171
   #+(or) (print (list :ii.frame (json-ld:frame-context instance)))
1172
   #+(or) (print (list :context2 ))
1173
   ;; merge from the context key aliaes
1174
   (setf (json-ld::object-alias-map instance)
1175
         (append (json-ld::object-alias-map instance)
1176
                 (json-ld::object-alias-map (json-ld:frame-context instance))))
1177
   ;; do not change the members, just
1178
   ;; - extract a default context
1179
   ;; - define any terms which appear
1180
   ;; introduce new aliases
1181
   (labels ((compute-sub-frame (value)
1182
              (etypecase value
1183
                (null instance)
1184
                (cons (make-instance 'json-ld:frame
1185
                        :context (if (json-ld:object-member value @:|@context|)
1186
                                     (json-ld:merge-contexts (clone-instance (json-ld:frame-context instance))
1187
                                                             (json-ld:object-member value @:|@context|))
1188
                                     (json-ld:frame-context instance))
1189
                        :members value
1190
                        ;; do not share properties, as the names could be different
1191
                        ;; :properties (json-ld:frame-properties instance)
1192
                        :objects (json-ld:frame-objects instance)))
1193
                (vector (if (plusp (length value)) (compute-sub-frame (aref value 0)) instance)))))
1194
     (setf-frame-output-members
1195
      (loop with property-cache = (json-ld:frame-properties instance)
1196
        with context = (json-ld:frame-context instance)
1197
        for (key . value) in (json-ld:object-members instance)
1198
        if (json-ld:key= @:|@context| key)
1199
        do (unless c-s
1200
             (setf (json-ld:frame-context instance) value))
1201
        else if (and (not (json-ld:keywordp key)) (json-ld:object-p value))
1202
        collect (let* ((td (or (json-ld:find-term-definition instance key)
1203
                               (json-ld:make-term-definition :key key
1204
                                                             :term (json-ld:expand-iri context key)
1205
                                                             :term-number nil)))
1206
                       (od (make-instance 'json-ld:output-definition
1207
                             ; :term-definition (compute-term-definition instance key value)
1208
                             :term-definition td
1209
                             :frame (compute-sub-frame value))))
1210
                  (setf (gethash (term-definition-term-number td) property-cache) od)
1211
                  od))
1212
      instance)))
1213
 
1214
 (defmethod print-object ((object json-ld:frame) stream)
1215
   (let* ((definitions (bound-slot-value object 'term-definitions))
1216
          (properties (bound-slot-value object 'properties)))
1217
     (_print-unreadable-object (object stream :type t :identity t)
1218
       (format stream "definitions: ~:a " definitions)
1219
       (format stream "properties.map: ~:a.~:ax~d.~a:"
1220
               (when properties
1221
                 (loop for definition being each hash-value of properties 
1222
                   collect (json-ld:term-definition-key definition)))
1223
               (mapcar #'first (bound-slot-value object 'alias-map))
1224
               (length (bound-slot-value object 'subjects))
1225
               (bound-slot-value object 'type))
1226
       (format stream "~@[ context: ~a ~]~@[ compact ~]~@[ default: ~a ~]~@[ embed ~]~@[ explicit ~]~@[ id: ~a ~]~@[ null ~]~@[ omit-default ~]"
1227
               (bound-slot-value object 'context)
1228
               (bound-slot-value object 'compact)
1229
               (bound-slot-value object 'default)
1230
               (bound-slot-value object 'embed)
1231
               (bound-slot-value object 'explicit)
1232
               (bound-slot-value object 'id)
1233
               (bound-slot-value object 'null)
1234
               (bound-slot-value object 'omit-default))
1235
       (when json-ld:*verbose* (format stream "~s" (bound-slot-value object 'members)))
1236
       (when definitions
1237
         (format stream " terms:~{ ~s~}" definitions)))))
1238
 
1239
 (defun json-ld:frame-p (object)
1240
   (typep object 'json-ld:frame))
1241
 
1242
 (defun json-ld:make-frame (&rest args)
1243
   (declare (dynamic-extent args))
1244
   (typecase (first args)
1245
     (string
1246
      (if (eql (char (first args) 0) #\{)
1247
          (json-ld:make-frame (parse-json (first args)))
1248
          (json-ld:make-frame (json-ld:get-json-ld (first args)))))
1249
     (pathname
1250
      (json-ld:make-frame (parse-json (first args))))
1251
     (spocq:iri
1252
      (json-ld:make-frame (json-ld:get-json-ld (first args))))
1253
     (t
1254
       (let ((initargs ()))
1255
         (loop (cond ((keywordp (first args))
1256
                      (push (pop args) initargs)
1257
                      (push (pop args) initargs))
1258
                     (t
1259
                      (return (apply #'make-instance 'json-ld:frame :members (first args) (reverse initargs))))))))))
1260
 
1261
 (defmethod frame-type-alias ((frame json-ld:frame))
1262
   (type-alias (json-ld:frame-context frame)))
1263
 
1264
 (defmethod frame-id-alias  ((frame json-ld:frame))
1265
   (id-alias (json-ld:frame-context frame)))
1266
 
1267
 (defmethod context-expand-iri ((frame json-ld:frame) lexical-form &rest args)
1268
   (declare (dynamic-extent args))
1269
   (apply #'context-expand-iri (json-ld:frame-context frame) lexical-form args))
1270
 
1271
 (defmethod json-ld:compact-iri ((frame json-ld:frame) (iri-lexical-form t))
1272
   (json-ld:compact-iri (json-ld:frame-context frame) iri-lexical-form))
1273
 
1274
 (defmethod json-ld:object-base ((frame json-ld:frame))
1275
   (json-ld:object-base (json-ld:frame-context frame)))
1276
 
1277
 (defmethod json-ld:frame-compact ((members list))
1278
   (rest (assoc "@compact" members :test #'json-ld:key=)))
1279
 
1280
 (defgeneric (setf json-ld:frame-compact) (value frame)
1281
   (:method ((value string)  (frame json-ld:frame))
1282
     (assert (equalp value "@embed") () "Invalid @compact value: ~s" value)
1283
     (setf (json-ld:frame-compact frame) @:|@embed|)))
1284
 
1285
 (defmethod json-ld:frame-context ((object list))
1286
   (rest (assoc "@context" object :test #'json-ld:key=)))
1287
 
1288
 (defgeneric (setf json-ld:frame-context) (context frame)
1289
   (:method ((context json-ld:context) (frame json-ld:frame))
1290
     (json-ld::setf-frame-context context frame))
1291
   (:method ((context list) (frame json-ld:frame))
1292
     (json-ld::setf-frame-context (json-ld:make-context context) frame)))
1293
 
1294
 (defmethod json-ld:frame-default ((members list))
1295
   (rest (assoc "@default" members :test #'json-ld:key=)))
1296
 
1297
 (defgeneric (setf json-ld:frame-default) (value frame)
1298
   (:documentation "As the spec says nothing about the nature of the default, accept it verbatim.")
1299
   (:method ((value t) (frame json-ld:frame))
1300
     (json-ld::setf-frame-default value frame)))
1301
 
1302
 (defmethod json-ld:frame-embed ((members list))
1303
   (rest (assoc "@embed" members :test #'json-ld:key=)))
1304
 
1305
 (defmethod json-ld:frame-explicit ((members list))
1306
   (rest (assoc "@explicit" members :test #'json-ld:key=)))
1307
 
1308
 (defgeneric (setf json-ld:frame-explicit) (value frame)
1309
   (:method ((value null)  (frame json-ld:frame))
1310
     (json-ld::setf-frame-explicit nil frame))
1311
   (:method ((value (eql :|false|))  (frame json-ld:frame))
1312
     (json-ld::setf-frame-explicit value frame))
1313
   (:method ((value (eql :|true|))  (frame json-ld:frame))
1314
     (json-ld::setf-frame-explicit value frame)))
1315
 
1316
 #+(or)
1317
 (
1318
 (defmethod json-ld:frame-id ((members list))
1319
   (rest (assoc "@id" members :test #'json-ld:key=)))
1320
 
1321
 (defgeneric (setf json-ld:frame-id) (value context)
1322
   (:method ((value vector) (frame json-ld:frame))
1323
     (flet ((coerce-id (value)
1324
              (context-expand-iri frame value)))
1325
       (declare (dynamic-extent #'coerce-id))
1326
       (setf (frame-id frame) (map 'vector #'coerce-id value))))
1327
   (:method ((value string) (frame json-ld:frame))
1328
     (setf (json-ld:frame-id frame) (vector value)))
1329
   (:method ((value symbol) (frame json-ld:frame))
1330
     (if (iri-p value)
1331
       (setf (frame-id frame) (vector value))
1332
       (error "Invalid id term value: ~s." value)))
1333
   (:method ((value spocq:iri) (frame json-ld:frame))
1334
     (setf (frame-id frame) (vector value)))
1335
   (:method ((value null)  (frame json-ld:frame))
1336
     (setf (frame-id frame) value))))
1337
 
1338
 (defmethod json-ld:frame-null ((members list))
1339
   (rest (assoc "@null" members :test #'json-ld:key=)))
1340
 
1341
 (defgeneric (setf json-ld:frame-null) (value frame)
1342
   (:method ((value null)  (frame json-ld:frame))
1343
     (json-ld::setf-frame-null nil frame))
1344
   (:method ((value (eql :|false|))  (frame json-ld:frame))
1345
     (json-ld::setf-frame-null nil frame))
1346
   (:method ((value (eql :|true|))  (frame json-ld:frame))
1347
     (json-ld::setf-frame-null t frame))
1348
   (:method ((value (eql t))  (frame json-ld:frame))
1349
     (json-ld::setf-frame-null t frame)))
1350
 
1351
 (defmethod json-ld:frame-omit-default ((members list))
1352
   (rest (assoc "@omitDefault" members :test #'json-ld:key=)))
1353
 
1354
 (defgeneric (setf json-ld:frame-omit-default) (value frame)
1355
   (:method ((value null)  (frame json-ld:frame))
1356
     (json-ld::setf-frame-omit-default nil frame))
1357
   (:method ((value (eql :|false|))  (frame json-ld:frame))
1358
     (json-ld::setf-frame-omit-default nil frame))
1359
   (:method ((value (eql :|true|))  (frame json-ld:frame))
1360
     (json-ld::setf-frame-omit-default t frame))
1361
   (:method ((value (eql t))  (frame json-ld:frame))
1362
     (json-ld::setf-frame-omit-default t frame)))
1363
 
1364
 (defmethod json-ld:frame-type ((members list))
1365
   (rest (assoc "@type" members :test #'json-ld:key=)))
1366
 
1367
 
1368
 (defmethod (setf json-ld:object-type) ((value vector) (frame json-ld:frame))
1369
   (flet ((coerce-id (value)
1370
            (context-expand-iri frame value)))
1371
     (declare (dynamic-extent #'coerce-id))
1372
     (json-ld::setf-object-type (map 'vector #'coerce-id value) frame)))
1373
 
1374
 (defmethod (setf json-ld:object-type) ((value string) (frame json-ld:frame))
1375
   (setf (json-ld::object-type frame) (vector value)))
1376
 
1377
 (defmethod (setf json-ld:object-type) ((value symbol) (frame json-ld:frame))
1378
   (if (iri-p value)
1379
       (json-ld::setf-object-type (vector value) frame)
1380
       (json-ld:invalid-type-value-error :datum value)))
1381
 
1382
 (defmethod (setf json-ld:object-type) ((value json-ld:object) (frame json-ld:frame))
1383
   (if (json-ld:null-object-p value)
1384
       (json-ld::setf-object-type value frame)
1385
       (json-ld:invalid-type-value-error :datum value)))
1386
 
1387
 (defmethod (setf json-ld:object-type) ((value spocq:iri) (frame json-ld:frame))
1388
   (json-ld::setf-object-type (vector value) frame))
1389
 
1390
 (defmethod (setf json-ld:object-type) ((value null)  (frame json-ld:frame))
1391
   (json-ld::setf-object-type value frame))
1392
 
1393
 
1394
 (defgeneric json-ld:frame-output-members (frame)
1395
   (:documentation "Construct a mirror of the frame content members in which the
1396
    keys are replaced with term definitions in order to correlate the key and the term number")
1397
 
1398
   (:method ((frame json-ld:frame))
1399
     (labels ((compute-sub-frame (value)
1400
                (etypecase value
1401
                  (null frame)
1402
                  (cons (make-instance 'json-ld:frame
1403
                                            :context (if (json-ld:object-member value @:|@context|)
1404
                                                         (json-ld:merge-contexts (clone-instance (json-ld:frame-context frame))
1405
                                                                                 (json-ld:object-member value @:|@context|))
1406
                                                         (json-ld:frame-context frame))
1407
                                            :members value))
1408
                  (vector (if (plusp (length value)) (compute-sub-frame (aref value 0)) frame)))))
1409
       (if (slot-boundp frame 'output-members)
1410
           (frame-output-members frame)
1411
           (setf-frame-output-members (loop for (key . value ) in (json-ld:object-members frame)
1412
                                        unless (json-ld:keywordp key)
1413
                                        collect (make-instance 'json-ld:output-definition
1414
                                                  :term-definition (or (json-ld:find-term-definition frame key)
1415
                                                                       (json-ld:make-term-definition :key nil
1416
                                                                                                     :term (json-ld:expand-iri
1417
                                                                                                            (json-ld:frame-context frame)
1418
                                                                                                            key)
1419
                                                                                                     :term-number nil))
1420
                                                  :frame (compute-sub-frame value)))
1421
                                      frame)))))
1422
 
1423
 (defmethod (setf json-ld:object-member-value) (context (instance json-ld:frame) (key (eql @:|@context|)))
1424
   (setf (json-ld:frame-context instance) context))
1425
 (defmethod (setf json-ld:object-member-value) (default (instance json-ld:frame) (key (eql @:|@default|)))
1426
   (setf (json-ld:frame-default instance) default))
1427
 (defmethod (setf json-ld:object-member-value) (embed (instance json-ld:frame) (key (eql @:|@embed|)))
1428
   (setf (json-ld:frame-embed instance) embed))
1429
 (defmethod (setf json-ld:object-member-value) (explicit (instance json-ld:frame) (key (eql @:|@explicit|)))
1430
   (setf (json-ld:frame-explicit instance) explicit))
1431
 (defmethod (setf json-ld:object-member-value) (null (instance json-ld:frame) (key (eql @:|@null|)))
1432
   (setf (json-ld:frame-null instance) null))
1433
 (defmethod (setf json-ld:object-member-value) (omit-default (instance json-ld:frame) (key (eql @:|@omitDefault|)))
1434
   (setf (json-ld:frame-omit-default instance) omit-default))
1435
 
1436
 
1437
 (defmethod json-ld:find-term-definition ((frame json-ld:frame) (term-key t))
1438
   (json-ld:find-term-definition (json-ld:frame-context frame) term-key))
1439
 
1440
 
1441
 (defmethod compute-term-definition ((frame json-ld:frame) key value)
1442
   "A framed term definition can describe the structure of a value."
1443
   (typecase value 
1444
     (cons
1445
      (json-ld:make-term-definition :base (json-ld:object-base frame)
1446
                                    :key key
1447
                                    :term (make-instance 'json-ld:frame
1448
                                            :context (if (json-ld:object-member value @:|@context|)
1449
                                                         (json-ld:merge-contexts (clone-instance (json-ld:frame-context frame))
1450
                                                                                 (json-ld:object-member value @:|@context|))
1451
                                                         (json-ld:frame-context frame))
1452
                                            :members value)))
1453
     (string
1454
      (let* ((context (json-ld:frame-context frame))
1455
             (term-definition (json-ld:find-term-definition context value))
1456
             (term (when term-definition (json-ld:term-definition-term term-definition))))
1457
        (if (iri-p term)
1458
          (json-ld:make-term-definition :base nil :key (or key value) :term term)
1459
          (call-next-method))))
1460
     (t
1461
      (call-next-method))))
1462
 
1463
 
1464
 (defmethod (setf json-ld:term-definition-term) ((value json-ld:frame) (term-definition json-ld:term-definition))
1465
   (setf (term-definition-term term-definition) value))
1466
 
1467
 (defgeneric json-ld:context-type-predicate-p (frame term)
1468
   (:documentation "Return true iff the term is a declared type predicate for the frame.
1469
    as the '@type' member key cannot appear in the results, if the frame's context declaration
1470
    specifies no alias, then a member for rdf:type is fabricated.")
1471
 
1472
   (:method ((frame json-ld:frame) (term t))
1473
     (json-ld:context-type-predicate-p (json-ld:frame-context frame) term))
1474
 
1475
   (:method ((context json-ld:context) (term spocq:unbound-variable))
1476
     "guard for unbound variables, especially when encoding non-graph results."
1477
     nil)
1478
 
1479
   (:method ((context json-ld:context) (term-number integer))
1480
     (unless (zerop term-number)
1481
       (let ((context-type (json-ld:context-type context)))
1482
         (if context-type
1483
             (eql term-number (json-ld:term-number context-type))
1484
             (eql term-number (symbol-term-id |rdf|:|type|))))))
1485
 
1486
   (:method ((context json-ld:context) (term symbol))
1487
     (let ((context-type (json-ld:context-type context)))
1488
       (if context-type
1489
         (eq term context-type)
1490
         (eq term |rdf|:|type|))))
1491
 
1492
   (:method ((context json-ld:context) (term spocq:iri))
1493
     (let ((context-type (json-ld:context-type context)))
1494
       (when context-type
1495
         (eq term context-type))))
1496
 
1497
   (:method ((context json-ld:context) (definition json-ld:term-definition))
1498
     (json-ld:context-type-predicate-p context (json-ld:term-definition-term definition)))
1499
 
1500
   (:method ((context json-ld:context) (object t))
1501
     nil))
1502
 
1503
 
1504
 (defgeneric frame-typep (frame node)
1505
   (:documentation "Return true iff either the frame does not constrain types or
1506
    the type is one of those permitted.
1507
    The constraint can be either intentional, in which case the term/term-number
1508
    of the node must be among the declared set, or it can be extensional, in which
1509
    case the node must be a sub-class, as determined by comparing its members with
1510
    the frame's output members.")
1511
 
1512
   (:method ((frame json-ld:frame) (entry node-map-entry))
1513
     (funcall (frame-type-predicate frame) entry)))
1514
 
1515
 (defun frame-type-predicate (frame)
1516
   "Return the appropriate type predicate for the frame's type specification:
1517
    - a sequence of types requires one to match
1518
    - a single null object allows everything
1519
    - any thing else, which means null, matches by extension"
1520
   (or (get-frame-type-predicate frame)
1521
       (setf-frame-type-predicate (compute-frame-type-predicate frame) frame)))
1522
 
1523
 (defun compute-frame-type-predicate (frame)
1524
    (let ((type-constraint (json-ld:object-type frame)))
1525
          ;; (print (list frame type-constraint))
1526
          (flet ((frame-type-by-intention (entry)
1527
                   (log-debug "by intention: test ~s" entry)
1528
                   (when (find (node-map-entry-type entry) type-constraint)
1529
                     t))
1530
                 (frame-type-by-extension (entry)
1531
                   (log-debug "by extension: test ~s" entry)
1532
                   (loop for output-definition in (json-ld:frame-output-members frame)
1533
                     unless (loop for (entry-definition . nil) in (node-map-entry-members entry)
1534
                              do (log-debug "by extension: test ~s ~s" output-definition entry-definition)
1535
                              when (= (json-ld:term-definition-term-number output-definition)
1536
                                      (json-ld:term-definition-term-number entry-definition))
1537
                              return t)
1538
                     return nil
1539
                     finally (return t))))
1540
            (typecase type-constraint
1541
              (vector ; coerce to term numbers and require a match
1542
               (log-debug "compute-frame-type-predicate: by intention: type-constraint: ~s"
1543
                          type-constraint)
1544
               (setf type-constraint (map 'vector #'(lambda (type) (json-ld:term-number type)) type-constraint))
1545
               (log-debug "compute-frame-type-predicate: by intention: type-constraint: ~s"
1546
                          type-constraint)
1547
               #'frame-type-by-intention)
1548
              (json-ld:object ; should be a null object
1549
               (if (json-ld:null-object-p type-constraint)
1550
                   #'(lambda (entry)
1551
                       (log-debug "universally: test ~s" entry)
1552
                       (when (node-map-entry-type entry) t))
1553
                   (json-ld:invalid-type-value-error :datum type-constraint)))
1554
              (t
1555
               (log-debug "compute-frame-type-predicate: by extension: ~s"
1556
                         (json-ld:frame-output-members frame))
1557
               #'frame-type-by-extension)))))
1558
 
1559
 (defgeneric frame-extensional-typep (frame entry)
1560
   (:method ((frame json-ld:frame) (entry node-map-entry))
1561
     (frame-extensional-typep frame (node-map-entry-members entry)))
1562
 
1563
   (:method ((frame json-ld:frame) (entry-members list))
1564
     ))
1565
 
1566
 (defgeneric frame-intentional-typep (frame entry)
1567
   (:method ((frame json-ld:frame) (entry node-map-entry))
1568
     (frame-intentional-typep frame (node-map-entry-type entry)))
1569
   
1570
   (:method ((frame json-ld:frame) (term-number integer))
1571
     (let ((frame-type (json-ld:frame-type frame)))
1572
       (typecase frame-type
1573
         (vector 
1574
          (values (find term-number frame-type :key #'json-ld:term-number)
1575
                  t))
1576
         (json-ld:object ; must be a null object
1577
          (values t t))
1578
         (t
1579
          (values nil nil)))))
1580
   
1581
   (:method ((frame json-ld:frame) (term symbol))
1582
     (let ((frame-type (json-ld:frame-type frame)))
1583
       (typecase frame-type
1584
         (vector 
1585
          (values (find term frame-type)
1586
                  t))
1587
         (json-ld:object ; must be a null object
1588
          (values t t))
1589
         (t
1590
          (values nil nil))))))