guile-fediverse

guile-fediverse/activitystreams/ontology.scm

ontology.scm

;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 

(define-module (activitystreams ontology)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (jsonld)
  #:use-module (jsonld json)
  #:export (make-ontology
            ontology?
            ontology-context
            ontology-datatypes
            ontology-properties

            make-as-type
            as-type?
            as-type-label
            as-type-uri
            as-type-comment
            as-type-subclass-of
            build-as-type

            make-as-property
            as-property?
            as-property-label
            as-property-uri
            as-property-domain
            as-property-range
            as-property-functional?
            as-property-subproperty-of
            as-property-comment
            build-as-property

            make-as-document
            as-document?
            as-document-types
            as-document-properties

            make-as-string
            as-string?
            as-string-value
            as-string-language
            as-string-direction

            make-as-typed-value
            as-typed-value?
            as-typed-value-value
            as-typed-value-type

            merge-ontologies
            subproperty?
            subtype?
            as-ref
            as-document-set
            as-document-delete
            as-document-delete*

            json->as-document
            uri->as-document
            as-document->json
            as-document->graphviz))

(define-record-type <ontology>
  (make-ontology context datatypes properties)
  ontology?
  (context    ontology-context)
  (datatypes  ontology-datatypes)
  (properties ontology-properties))

(define as-vocab "https://www.w3.org/ns/activitystreams#")

(define-record-type as-type
  (make-as-type label uri comment subclass-of)
  as-type?
  (label       as-type-label)
  (uri         as-type-uri)
  (comment     as-type-comment)
  (subclass-of as-type-subclass-of))

(define* (build-as-type label #:key (uri (string-append as-vocab label))
                        (comment "") (subclass-of '()))
  (make-as-type label uri comment subclass-of))

(define-record-type as-property
  (make-as-property label uri range domain functional? subproperty-of comment)
  as-property?
  (label          as-property-label)
  (uri            as-property-uri)
  (domain         as-property-domain)
  (range          as-property-range)
  (functional?    as-property-functional?)
  (subproperty-of as-property-subproperty-of)
  (comment        as-property-comment))

(define* (build-as-property label domain range
                            #:key (uri (string-append as-vocab label))
                            (functional? #f) (subproperty-of '()) (comment ""))
  (make-as-property label uri range domain functional? subproperty-of comment))

(define-record-type as-document
  (make-as-document types properties)
  as-document?
  (types      as-document-types)
  (properties as-document-properties))

(define-record-type as-string
  (make-as-string value language direction)
  as-string?
  (value     as-string-value)
  (language  as-string-language)
  (direction as-string-direction))

(define-record-type as-typed-value
  (make-as-typed-value value type)
  as-typed-value?
  (value as-typed-value-value)
  (type  as-typed-value-type))

(define (uniq lst)
  (let loop ((lst lst) (result '()))
    (match lst
      (() result)
      ((elem lst ...)
       (if (member elem result)
           (loop lst result)
           (loop lst (cons elem result)))))))

(define (alist-set lst key value)
  (match lst
    (() `((,key . ,value)))
    (((k . v) lst ...)
     (if (equal? k key)
         (cons (cons key value) lst)
         (cons (cons k v) (alist-set lst key value))))))

(define (as-alist-set lst key value)
  (match lst
    (() `((,key . ,value)))
    (((k . v) lst ...)
     (if (equal? (as-property-uri k) (as-property-uri key))
         (cons (cons key value) lst)
         (cons (cons k v) (as-alist-set lst key value))))))

(define (as-alist-delete lst key)
  (match lst
    (() '())
    (((k . v) lst ...)
     (if (equal? (as-property-uri k) (as-property-uri key))
         lst
         (cons (cons k v) (as-alist-delete lst key))))))

(define (as-alist-delete* lst key)
  (match lst
    (() '())
    (((k . v) lst ...)
     (if (subproperty? k key)
         (as-alist-delete* lst key)
         (cons (cons k v) (as-alist-delete lst key))))))

(define (merge-domains d1 d2)
  (uniq
    (if (list? d1)
        (if (list? d2)
            (append d1 d2)
            (cons d2 d1))
        (if (list? d2)
            (cons d1 d2)
            (list d1 d2)))))

(define (merge-ranges r1 r2)
  (uniq
    (if (list? r1)
        (if (list? r2)
            (append r1 r2)
            (cons r2 r1))
        (if (list? r2)
            (cons r1 r2)
            (list r1 r2)))))

(define (fix-types datatypes)
  (define (fix-datatype type)
    (if (as-type? type)
        (let ((candidates
                (filter (lambda (t) (equal? (as-type-uri t) (as-type-uri type)))
                        datatypes)))
          (if (null? candidates)
              type
              (car candidates)))
        type))

  (let loop ((to-fix datatypes) (result '()))
    (match to-fix
      (() result)
      ((type to-fix ...)
       (loop
         to-fix
         (cons
           (make-as-type
             (as-type-label type)
             (as-type-uri type)
             (as-type-comment type)
             (map fix-datatype (as-type-subclass-of type)))
           result))))))

(define (merge-datatypes datatypes)
  (let loop ((result '()) (datatypes (apply append datatypes)))
    (match datatypes
      (() (map cdr result))
      ((type datatypes ...)
       (loop
         (let ((previous (assoc-ref result (as-type-uri type))))
           (if previous
               (alist-set result
                 (as-type-uri type)
                 (make-as-type
                   (as-type-label type)
                   (as-type-uri type)
                   (or (as-type-comment previous) (as-type-comment type))
                   (uniq (append (as-type-subclass-of previous)
                                 (as-type-subclass-of type)))))
               (cons (cons (as-type-uri type) type) result)))
         datatypes)))))

(define (fix-properties datatypes properties)
  (define (fix-datatype type)
    (if (as-type? type)
        (let ((candidates
                (filter (lambda (t) (equal? (as-type-uri t) (as-type-uri type)))
                        datatypes)))
          (if (null? candidates)
              type
              (car candidates)))
        type))

  (define (fix-property prop)
    (if (as-property? prop)
        (let ((candidates
                (filter (lambda (p) (equal? (as-property-uri p) (as-property-uri prop)))
                        properties)))
          (if (null? candidates)
              prop
              (car candidates)))
        prop))

  (let loop ((to-fix properties) (result '()))
    (match to-fix
      (() result)
      ((prop to-fix ...)
       (let ((domain (as-property-domain prop))
             (range (as-property-range prop)))
         (loop
           to-fix
           (cons
             (make-as-property
               (as-property-label prop)
               (as-property-uri prop)
               (if (list? domain)
                   (map fix-property (map fix-datatype domain))
                   (fix-property (fix-datatype domain)))
               (if (list? range)
                   (map fix-property (map fix-datatype range))
                   (fix-property (fix-datatype range)))
               (as-property-functional? prop)
               (map fix-property (as-property-subproperty-of prop))
               (as-property-comment prop))
             result)))))))

(define (merge-properties properties)
  (let loop ((result '()) (properties (apply append properties)))
    (match properties
      (() (map cdr result))
      ((prop properties ...)
       (loop
         (let ((previous (assoc-ref result (as-property-uri prop))))
           (if previous
               (alist-set result
                 (as-property-uri prop)
                 (make-as-property
                   (as-property-label prop)
                   (as-property-uri prop)
                   (merge-domains (as-property-domain previous)
                                  (as-property-domain prop))
                   (merge-ranges (as-property-range previous)
                                 (as-property-range prop))
                   (and (as-property-functional? previous)
                        (as-property-functional? prop))
                   (uniq (append (as-property-subproperty-of previous)
                                 (as-property-subproperty-of prop)))
                   (or (as-property-comment previous)
                       (as-property-comment prop))))
               (cons (cons (as-property-uri prop) prop) result)))
         properties)))))

(define* (merge-ontologies . ontologies)
  (let ((datatypes (merge-datatypes (map ontology-datatypes ontologies)))
        (properties (merge-properties (map ontology-properties ontologies))))
    (make-ontology
      (filter (lambda (a) a) (append-map ontology-context ontologies))
      (fix-types datatypes)
      (fix-properties datatypes properties))))

(define (subproperty? property other)
  "Is @code{property} a subproperty of @code{other}?"
  (or
    (equal? property other)
    (equal? (as-property-uri property) other)
    (and (as-property? other)
         (equal? (as-property-uri property) (as-property-uri other)))
    (let loop ((superproperties (as-property-subproperty-of property)))
      (match superproperties
        (() #f)
        ((superproperty superproperties ...)
         (if (subproperty? superproperty other)
             #t
             (loop superproperties)))))))

(define (subtype? type other)
  "Is @code{type} a subtype of @code{other}?"
  (or
    (equal? type other)
    (let loop ((supertypes (as-type-subclass-of type)))
      (match supertypes
        (() #f)
        ((supertype supertypes ...)
         (if (subtype? supertype other)
             #t
             (loop supertypes)))))))

(define (as-ref document key)
  "Takes a parsed document and returns the value associated with the property.
This takes care of subproperties: if you look for a property that's not in the
document directly, but the document has a subproperty of it, this will be
returned.  The key must be a proper label as defined in the ontology."
  (define (is-candidate kv)
    (match kv
      ((k . v)
       (subproperty? k key))))
  (let ((candidates (filter is-candidate
                            (if (as-document? document)
                                (as-document-properties document)
                                document))))
    (map cdr candidates)))

(define (as-document-set document key value)
  (make-as-document
    (as-document-types document)
    (as-alist-set (as-document-properties document) key value)))

(define (as-document-delete document key)
  (make-as-document
    (as-document-types document)
    (as-alist-delete (as-document-properties document) key)))

(define (as-document-delete* document key)
  (make-as-document
    (as-document-types document)
    (as-alist-delete* (as-document-properties document) key)))

(define (json->as-document ontology document)
  (define (uri->datatype type)
    (let ((candidates (filter (lambda (t) (equal? (as-type-uri t) type))
                              (ontology-datatypes ontology))))
      (cond
        ((null? candidates)
         #f)
        ((> (length candidates) 1)
         (throw 'multiple-datatypes-with-same-uri candidates))
        (else
         (car candidates)))))

  (define (uri->property property)
    (let ((candidates (filter (lambda (p) (equal? (as-property-uri p) property))
                              (ontology-properties ontology))))
      (cond
        ((null? candidates)
         #f)
        ((> (length candidates) 1)
         (throw 'multiple-properties-with-same-uri candidates))
        (else (car candidates)))))

  (define (scalar->as-value value)
    (cond
      ((or (json-has-key? value "@language") (json-has-key? value "@direction"))
       (make-as-string
         (assoc-ref value "@value")
         (assoc-ref value "@language")
         (assoc-ref value "@direction")))
      ((json-has-key? value "@type")
       (let* ((types (assoc-ref value "@type"))
              (types (if (string? types) (list types) (array->list types)))
              (types (map uri->datatype types)))
         (make-as-typed-value (assoc-ref value "@value") types)))
      (else
        (assoc-ref value "@value"))))

  (cond
    ((scalar? document)
     document)
    ((json-has-key? document "@value")
     (scalar->as-value document))
    ((json-array? document)
     ;; XXX: this filter is not correct if one of the values is the litteral
     ;; "false"
     (filter
       (lambda (a) a)
       (map (lambda (doc) (json->as-document ontology doc))
            (array->list document))))
    ((list? document)
     (let* ((types (or (assoc-ref document "@type") #()))
            (types (if (string? types) (list types) (array->list types)))
            (types (filter (lambda (a) a) (map uri->datatype types))))
       (make-as-document
         types
         (filter
           (lambda (a) a)
           (map
             (match-lambda
               ((key . value)
                (let ((property (uri->property key))
                      (value (json->as-document ontology value)))
                  (if (and property (not (equal? key "@type")) value)
                      (cons (uri->property key) value)
                      #f))))
             document)))))))

(define* (uri->as-document ontology uri #:key (options #f))
  (if options
      (json->as-document ontology (expand uri #:options options))
      (json->as-document ontology (expand uri))))

(define* (as-document->json ontology doc #:key (options #f))
  (define (as-document->proper-json doc)
    (append
      `(("@type" . ,(list->array 1 (map as-type-uri (as-document-types doc)))))
      (map
        (match-lambda
          ((key . value)
           (cons (as-property-uri key) (as-value->proper-json value))))
        (as-document-properties doc))))

  (define (as-value->proper-json doc)
    (cond
      ((as-document? doc)
       (as-document->proper-json doc))
      ((list? doc)
       (list->array 1 (map as-value->proper-json doc)))
      ((string? doc)
       doc)
      ((as-typed-value? doc)
       `(("@value" . ,(as-typed-value-value doc))
         ("@type" . ,(as-type-uri (as-typed-value-type doc)))))
      ((as-string? doc)
       `(("@value" . ,(as-string-value doc))
         ,@(if (as-string-direction doc)
               `(("@direction" . ,(as-string-direction doc)))
               '())
         ,@(if (as-string-language doc)
               `(("@language" . ,(as-string-language doc)))
               '())))
      (else doc)))

  (let ((proper-json (as-value->proper-json doc))
        (context `(("@context" . ,(list->array 1 (ontology-context ontology))))))
    (if options
        (compact proper-json context #:options options)
        (compact proper-json context))))

(define* (as-document->graphviz doc #:key (label "n"))
  (cond
    ((as-document? doc)
     (let* ((id (as-ref (as-document-properties doc) "@id"))
            (id (if (string? id) id (if (null? id) "" (car id))))
            (types (as-document-types doc))
            (name (if (null? types)
                      id
                      (string-append id " ("
                                     (string-join (map as-type-label types) ", ")
                                     ")"))))
       (format #t "  ~a [label=\"~a\"];~%" label name)
       (let loop ((children (as-document-properties doc)) (suffix 0))
         (match children
           (() (format #t "~%"))
           (((key . value) children ...)
            (let ((child-label (string-append label (number->string suffix))))
              (format #t "  ~a -> ~a [label=\"~a\"];~%"
                      label child-label
                      (if (string? key) key (as-property-label key)))
              (as-document->graphviz value #:label child-label)
              (loop children (+ suffix 1))))))))
    ((string? doc)
     (format #t "  ~a [label=\"~a\"];~%" label doc))
    ((list? doc)
     (let loop ((children doc) (suffix 0))
       (match children
         (() (format #t "~%"))
         ((value children ...)
          (let ((child-label (string-append label (number->string suffix))))
            (format #t "  ~a -> ~a;~%" label child-label)
            (as-document->graphviz value #:label child-label)
            (loop children (+ suffix 1)))))))
    ((as-typed-value? doc)
     (format #t "  ~a [label=\"~a\"];~%"
             label (string-append (as-typed-value-value doc) "^^"
                                (as-type-label (as-typed-value-type doc)))))
    ((as-string? doc)
     (let* ((str (as-string-value doc))
            (str (if (or (as-string-language doc) (as-string-direction doc))
                     (string-append str "@")
                     str))
            (str (string-append str (as-string-language doc)))
            (str (if (as-string-direction doc)
                     (string-append str "_" (as-string-direction doc))
                     str)))
     (format #t "  ~a [label=\"~a\"];~%"
             label str)))
    (else doc)))


1	;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2	;;;;
3	;;;; This library is free software; you can redistribute it and/or
4	;;;; modify it under the terms of the GNU Lesser General Public
5	;;;; License as published by the Free Software Foundation; either
6	;;;; version 3 of the License, or (at your option) any later version.
7	;;;;
8	;;;; This library is distributed in the hope that it will be useful,
9	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11	;;;; Lesser General Public License for more details.
12	;;;;
13	;;;; You should have received a copy of the GNU Lesser General Public
14	;;;; License along with this library; if not, write to the Free Software
15	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16	;;;;
17
18	(define-module (activitystreams ontology)
19	#:use-module (ice-9 match)
20	#:use-module (srfi srfi-1)
21	#:use-module (srfi srfi-9)
22	#:use-module (jsonld)
23	#:use-module (jsonld json)
24	#:export (make-ontology
25	ontology?
26	ontology-context
27	ontology-datatypes
28	ontology-properties
29
30	make-as-type
31	as-type?
32	as-type-label
33	as-type-uri
34	as-type-comment
35	as-type-subclass-of
36	build-as-type
37
38	make-as-property
39	as-property?
40	as-property-label
41	as-property-uri
42	as-property-domain
43	as-property-range
44	as-property-functional?
45	as-property-subproperty-of
46	as-property-comment
47	build-as-property
48
49	make-as-document
50	as-document?
51	as-document-types
52	as-document-properties
53
54	make-as-string
55	as-string?
56	as-string-value
57	as-string-language
58	as-string-direction
59
60	make-as-typed-value
61	as-typed-value?
62	as-typed-value-value
63	as-typed-value-type
64
65	merge-ontologies
66	subproperty?
67	subtype?
68	as-ref
69	as-document-set
70	as-document-delete
71	as-document-delete*
72
73	json->as-document
74	uri->as-document
75	as-document->json
76	as-document->graphviz))
77
78	(define-record-type <ontology>
79	(make-ontology context datatypes properties)
80	ontology?
81	(context ontology-context)
82	(datatypes ontology-datatypes)
83	(properties ontology-properties))
84
85	(define as-vocab "https://www.w3.org/ns/activitystreams#")
86
87	(define-record-type as-type
88	(make-as-type label uri comment subclass-of)
89	as-type?
90	(label as-type-label)
91	(uri as-type-uri)
92	(comment as-type-comment)
93	(subclass-of as-type-subclass-of))
94
95	(define* (build-as-type label #:key (uri (string-append as-vocab label))
96	(comment "") (subclass-of '()))
97	(make-as-type label uri comment subclass-of))
98
99	(define-record-type as-property
100	(make-as-property label uri range domain functional? subproperty-of comment)
101	as-property?
102	(label as-property-label)
103	(uri as-property-uri)
104	(domain as-property-domain)
105	(range as-property-range)
106	(functional? as-property-functional?)
107	(subproperty-of as-property-subproperty-of)
108	(comment as-property-comment))
109
110	(define* (build-as-property label domain range
111	#:key (uri (string-append as-vocab label))
112	(functional? #f) (subproperty-of '()) (comment ""))
113	(make-as-property label uri range domain functional? subproperty-of comment))
114
115	(define-record-type as-document
116	(make-as-document types properties)
117	as-document?
118	(types as-document-types)
119	(properties as-document-properties))
120
121	(define-record-type as-string
122	(make-as-string value language direction)
123	as-string?
124	(value as-string-value)
125	(language as-string-language)
126	(direction as-string-direction))
127
128	(define-record-type as-typed-value
129	(make-as-typed-value value type)
130	as-typed-value?
131	(value as-typed-value-value)
132	(type as-typed-value-type))
133
134	(define (uniq lst)
135	(let loop ((lst lst) (result '()))
136	(match lst
137	(() result)
138	((elem lst ...)
139	(if (member elem result)
140	(loop lst result)
141	(loop lst (cons elem result)))))))
142
143	(define (alist-set lst key value)
144	(match lst
145	(() `((,key . ,value)))
146	(((k . v) lst ...)
147	(if (equal? k key)
148	(cons (cons key value) lst)
149	(cons (cons k v) (alist-set lst key value))))))
150
151	(define (as-alist-set lst key value)
152	(match lst
153	(() `((,key . ,value)))
154	(((k . v) lst ...)
155	(if (equal? (as-property-uri k) (as-property-uri key))
156	(cons (cons key value) lst)
157	(cons (cons k v) (as-alist-set lst key value))))))
158
159	(define (as-alist-delete lst key)
160	(match lst
161	(() '())
162	(((k . v) lst ...)
163	(if (equal? (as-property-uri k) (as-property-uri key))
164	lst
165	(cons (cons k v) (as-alist-delete lst key))))))
166
167	(define (as-alist-delete* lst key)
168	(match lst
169	(() '())
170	(((k . v) lst ...)
171	(if (subproperty? k key)
172	(as-alist-delete* lst key)
173	(cons (cons k v) (as-alist-delete lst key))))))
174
175	(define (merge-domains d1 d2)
176	(uniq
177	(if (list? d1)
178	(if (list? d2)
179	(append d1 d2)
180	(cons d2 d1))
181	(if (list? d2)
182	(cons d1 d2)
183	(list d1 d2)))))
184
185	(define (merge-ranges r1 r2)
186	(uniq
187	(if (list? r1)
188	(if (list? r2)
189	(append r1 r2)
190	(cons r2 r1))
191	(if (list? r2)
192	(cons r1 r2)
193	(list r1 r2)))))
194
195	(define (fix-types datatypes)
196	(define (fix-datatype type)
197	(if (as-type? type)
198	(let ((candidates
199	(filter (lambda (t) (equal? (as-type-uri t) (as-type-uri type)))
200	datatypes)))
201	(if (null? candidates)
202	type
203	(car candidates)))
204	type))
205
206	(let loop ((to-fix datatypes) (result '()))
207	(match to-fix
208	(() result)
209	((type to-fix ...)
210	(loop
211	to-fix
212	(cons
213	(make-as-type
214	(as-type-label type)
215	(as-type-uri type)
216	(as-type-comment type)
217	(map fix-datatype (as-type-subclass-of type)))
218	result))))))
219
220	(define (merge-datatypes datatypes)
221	(let loop ((result '()) (datatypes (apply append datatypes)))
222	(match datatypes
223	(() (map cdr result))
224	((type datatypes ...)
225	(loop
226	(let ((previous (assoc-ref result (as-type-uri type))))
227	(if previous
228	(alist-set result
229	(as-type-uri type)
230	(make-as-type
231	(as-type-label type)
232	(as-type-uri type)
233	(or (as-type-comment previous) (as-type-comment type))
234	(uniq (append (as-type-subclass-of previous)
235	(as-type-subclass-of type)))))
236	(cons (cons (as-type-uri type) type) result)))
237	datatypes)))))
238
239	(define (fix-properties datatypes properties)
240	(define (fix-datatype type)
241	(if (as-type? type)
242	(let ((candidates
243	(filter (lambda (t) (equal? (as-type-uri t) (as-type-uri type)))
244	datatypes)))
245	(if (null? candidates)
246	type
247	(car candidates)))
248	type))
249
250	(define (fix-property prop)
251	(if (as-property? prop)
252	(let ((candidates
253	(filter (lambda (p) (equal? (as-property-uri p) (as-property-uri prop)))
254	properties)))
255	(if (null? candidates)
256	prop
257	(car candidates)))
258	prop))
259
260	(let loop ((to-fix properties) (result '()))
261	(match to-fix
262	(() result)
263	((prop to-fix ...)
264	(let ((domain (as-property-domain prop))
265	(range (as-property-range prop)))
266	(loop
267	to-fix
268	(cons
269	(make-as-property
270	(as-property-label prop)
271	(as-property-uri prop)
272	(if (list? domain)
273	(map fix-property (map fix-datatype domain))
274	(fix-property (fix-datatype domain)))
275	(if (list? range)
276	(map fix-property (map fix-datatype range))
277	(fix-property (fix-datatype range)))
278	(as-property-functional? prop)
279	(map fix-property (as-property-subproperty-of prop))
280	(as-property-comment prop))
281	result)))))))
282
283	(define (merge-properties properties)
284	(let loop ((result '()) (properties (apply append properties)))
285	(match properties
286	(() (map cdr result))
287	((prop properties ...)
288	(loop
289	(let ((previous (assoc-ref result (as-property-uri prop))))
290	(if previous
291	(alist-set result
292	(as-property-uri prop)
293	(make-as-property
294	(as-property-label prop)
295	(as-property-uri prop)
296	(merge-domains (as-property-domain previous)
297	(as-property-domain prop))
298	(merge-ranges (as-property-range previous)
299	(as-property-range prop))
300	(and (as-property-functional? previous)
301	(as-property-functional? prop))
302	(uniq (append (as-property-subproperty-of previous)
303	(as-property-subproperty-of prop)))
304	(or (as-property-comment previous)
305	(as-property-comment prop))))
306	(cons (cons (as-property-uri prop) prop) result)))
307	properties)))))
308
309	(define* (merge-ontologies . ontologies)
310	(let ((datatypes (merge-datatypes (map ontology-datatypes ontologies)))
311	(properties (merge-properties (map ontology-properties ontologies))))
312	(make-ontology
313	(filter (lambda (a) a) (append-map ontology-context ontologies))
314	(fix-types datatypes)
315	(fix-properties datatypes properties))))
316
317	(define (subproperty? property other)
318	"Is @code{property} a subproperty of @code{other}?"
319	(or
320	(equal? property other)
321	(equal? (as-property-uri property) other)
322	(and (as-property? other)
323	(equal? (as-property-uri property) (as-property-uri other)))
324	(let loop ((superproperties (as-property-subproperty-of property)))
325	(match superproperties
326	(() #f)
327	((superproperty superproperties ...)
328	(if (subproperty? superproperty other)
329	#t
330	(loop superproperties)))))))
331
332	(define (subtype? type other)
333	"Is @code{type} a subtype of @code{other}?"
334	(or
335	(equal? type other)
336	(let loop ((supertypes (as-type-subclass-of type)))
337	(match supertypes
338	(() #f)
339	((supertype supertypes ...)
340	(if (subtype? supertype other)
341	#t
342	(loop supertypes)))))))
343
344	(define (as-ref document key)
345	"Takes a parsed document and returns the value associated with the property.
346	This takes care of subproperties: if you look for a property that's not in the
347	document directly, but the document has a subproperty of it, this will be
348	returned. The key must be a proper label as defined in the ontology."
349	(define (is-candidate kv)
350	(match kv
351	((k . v)
352	(subproperty? k key))))
353	(let ((candidates (filter is-candidate
354	(if (as-document? document)
355	(as-document-properties document)
356	document))))
357	(map cdr candidates)))
358
359	(define (as-document-set document key value)
360	(make-as-document
361	(as-document-types document)
362	(as-alist-set (as-document-properties document) key value)))
363
364	(define (as-document-delete document key)
365	(make-as-document
366	(as-document-types document)
367	(as-alist-delete (as-document-properties document) key)))
368
369	(define (as-document-delete* document key)
370	(make-as-document
371	(as-document-types document)
372	(as-alist-delete* (as-document-properties document) key)))
373
374	(define (json->as-document ontology document)
375	(define (uri->datatype type)
376	(let ((candidates (filter (lambda (t) (equal? (as-type-uri t) type))
377	(ontology-datatypes ontology))))
378	(cond
379	((null? candidates)
380	#f)
381	((> (length candidates) 1)
382	(throw 'multiple-datatypes-with-same-uri candidates))
383	(else
384	(car candidates)))))
385
386	(define (uri->property property)
387	(let ((candidates (filter (lambda (p) (equal? (as-property-uri p) property))
388	(ontology-properties ontology))))
389	(cond
390	((null? candidates)
391	#f)
392	((> (length candidates) 1)
393	(throw 'multiple-properties-with-same-uri candidates))
394	(else (car candidates)))))
395
396	(define (scalar->as-value value)
397	(cond
398	((or (json-has-key? value "@language") (json-has-key? value "@direction"))
399	(make-as-string
400	(assoc-ref value "@value")
401	(assoc-ref value "@language")
402	(assoc-ref value "@direction")))
403	((json-has-key? value "@type")
404	(let* ((types (assoc-ref value "@type"))
405	(types (if (string? types) (list types) (array->list types)))
406	(types (map uri->datatype types)))
407	(make-as-typed-value (assoc-ref value "@value") types)))
408	(else
409	(assoc-ref value "@value"))))
410
411	(cond
412	((scalar? document)
413	document)
414	((json-has-key? document "@value")
415	(scalar->as-value document))
416	((json-array? document)
417	;; XXX: this filter is not correct if one of the values is the litteral
418	;; "false"
419	(filter
420	(lambda (a) a)
421	(map (lambda (doc) (json->as-document ontology doc))
422	(array->list document))))
423	((list? document)
424	(let* ((types (or (assoc-ref document "@type") #()))
425	(types (if (string? types) (list types) (array->list types)))
426	(types (filter (lambda (a) a) (map uri->datatype types))))
427	(make-as-document
428	types
429	(filter
430	(lambda (a) a)
431	(map
432	(match-lambda
433	((key . value)
434	(let ((property (uri->property key))
435	(value (json->as-document ontology value)))
436	(if (and property (not (equal? key "@type")) value)
437	(cons (uri->property key) value)
438	#f))))
439	document)))))))
440
441	(define* (uri->as-document ontology uri #:key (options #f))
442	(if options
443	(json->as-document ontology (expand uri #:options options))
444	(json->as-document ontology (expand uri))))
445
446	(define* (as-document->json ontology doc #:key (options #f))
447	(define (as-document->proper-json doc)
448	(append
449	`(("@type" . ,(list->array 1 (map as-type-uri (as-document-types doc)))))
450	(map
451	(match-lambda
452	((key . value)
453	(cons (as-property-uri key) (as-value->proper-json value))))
454	(as-document-properties doc))))
455
456	(define (as-value->proper-json doc)
457	(cond
458	((as-document? doc)
459	(as-document->proper-json doc))
460	((list? doc)
461	(list->array 1 (map as-value->proper-json doc)))
462	((string? doc)
463	doc)
464	((as-typed-value? doc)
465	`(("@value" . ,(as-typed-value-value doc))
466	("@type" . ,(as-type-uri (as-typed-value-type doc)))))
467	((as-string? doc)
468	`(("@value" . ,(as-string-value doc))
469	,@(if (as-string-direction doc)
470	`(("@direction" . ,(as-string-direction doc)))
471	'())
472	,@(if (as-string-language doc)
473	`(("@language" . ,(as-string-language doc)))
474	'())))
475	(else doc)))
476
477	(let ((proper-json (as-value->proper-json doc))
478	(context `(("@context" . ,(list->array 1 (ontology-context ontology))))))
479	(if options
480	(compact proper-json context #:options options)
481	(compact proper-json context))))
482
483	(define* (as-document->graphviz doc #:key (label "n"))
484	(cond
485	((as-document? doc)
486	(let* ((id (as-ref (as-document-properties doc) "@id"))
487	(id (if (string? id) id (if (null? id) "" (car id))))
488	(types (as-document-types doc))
489	(name (if (null? types)
490	id
491	(string-append id " ("
492	(string-join (map as-type-label types) ", ")
493	")"))))
494	(format #t " ~a [label=\"~a\"];~%" label name)
495	(let loop ((children (as-document-properties doc)) (suffix 0))
496	(match children
497	(() (format #t "~%"))
498	(((key . value) children ...)
499	(let ((child-label (string-append label (number->string suffix))))
500	(format #t " ~a -> ~a [label=\"~a\"];~%"
501	label child-label
502	(if (string? key) key (as-property-label key)))
503	(as-document->graphviz value #:label child-label)
504	(loop children (+ suffix 1))))))))
505	((string? doc)
506	(format #t " ~a [label=\"~a\"];~%" label doc))
507	((list? doc)
508	(let loop ((children doc) (suffix 0))
509	(match children
510	(() (format #t "~%"))
511	((value children ...)
512	(let ((child-label (string-append label (number->string suffix))))
513	(format #t " ~a -> ~a;~%" label child-label)
514	(as-document->graphviz value #:label child-label)
515	(loop children (+ suffix 1)))))))
516	((as-typed-value? doc)
517	(format #t " ~a [label=\"~a\"];~%"
518	label (string-append (as-typed-value-value doc) "^^"
519	(as-type-label (as-typed-value-type doc)))))
520	((as-string? doc)
521	(let* ((str (as-string-value doc))
522	(str (if (or (as-string-language doc) (as-string-direction doc))
523	(string-append str "@")
524	str))
525	(str (string-append str (as-string-language doc)))
526	(str (if (as-string-direction doc)
527	(string-append str "_" (as-string-direction doc))
528	str)))
529	(format #t " ~a [label=\"~a\"];~%"
530	label str)))
531	(else doc)))
532