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*
            modify-as-document

            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-syntax modify-as-document
  (lambda (x)
    (syntax-case x (set-property remove-property  remove-property*)
      ((_ doc)
       #`doc)
      ((_ doc (set-property key value) spec ...)
       #`(modify-as-document
           (as-document-set doc key value)
           spec ...))
      ((_ doc (remove-property key) spec ...)
       #`(modify-as-document
           (as-document-delete doc key)
           spec ...))
      ((_ doc (remove-property* key) spec ...)
       #`(modify-as-document
           (as-document-delete* doc key)
           spec ...)))))

(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	modify-as-document
73
74	json->as-document
75	uri->as-document
76	as-document->json
77	as-document->graphviz))
78
79	(define-record-type <ontology>
80	(make-ontology context datatypes properties)
81	ontology?
82	(context ontology-context)
83	(datatypes ontology-datatypes)
84	(properties ontology-properties))
85
86	(define as-vocab "https://www.w3.org/ns/activitystreams#")
87
88	(define-record-type as-type
89	(make-as-type label uri comment subclass-of)
90	as-type?
91	(label as-type-label)
92	(uri as-type-uri)
93	(comment as-type-comment)
94	(subclass-of as-type-subclass-of))
95
96	(define* (build-as-type label #:key (uri (string-append as-vocab label))
97	(comment "") (subclass-of '()))
98	(make-as-type label uri comment subclass-of))
99
100	(define-record-type as-property
101	(make-as-property label uri range domain functional? subproperty-of comment)
102	as-property?
103	(label as-property-label)
104	(uri as-property-uri)
105	(domain as-property-domain)
106	(range as-property-range)
107	(functional? as-property-functional?)
108	(subproperty-of as-property-subproperty-of)
109	(comment as-property-comment))
110
111	(define* (build-as-property label domain range
112	#:key (uri (string-append as-vocab label))
113	(functional? #f) (subproperty-of '()) (comment ""))
114	(make-as-property label uri range domain functional? subproperty-of comment))
115
116	(define-record-type as-document
117	(make-as-document types properties)
118	as-document?
119	(types as-document-types)
120	(properties as-document-properties))
121
122	(define-record-type as-string
123	(make-as-string value language direction)
124	as-string?
125	(value as-string-value)
126	(language as-string-language)
127	(direction as-string-direction))
128
129	(define-record-type as-typed-value
130	(make-as-typed-value value type)
131	as-typed-value?
132	(value as-typed-value-value)
133	(type as-typed-value-type))
134
135	(define (uniq lst)
136	(let loop ((lst lst) (result '()))
137	(match lst
138	(() result)
139	((elem lst ...)
140	(if (member elem result)
141	(loop lst result)
142	(loop lst (cons elem result)))))))
143
144	(define (alist-set lst key value)
145	(match lst
146	(() `((,key . ,value)))
147	(((k . v) lst ...)
148	(if (equal? k key)
149	(cons (cons key value) lst)
150	(cons (cons k v) (alist-set lst key value))))))
151
152	(define (as-alist-set lst key value)
153	(match lst
154	(() `((,key . ,value)))
155	(((k . v) lst ...)
156	(if (equal? (as-property-uri k) (as-property-uri key))
157	(cons (cons key value) lst)
158	(cons (cons k v) (as-alist-set lst key value))))))
159
160	(define (as-alist-delete lst key)
161	(match lst
162	(() '())
163	(((k . v) lst ...)
164	(if (equal? (as-property-uri k) (as-property-uri key))
165	lst
166	(cons (cons k v) (as-alist-delete lst key))))))
167
168	(define (as-alist-delete* lst key)
169	(match lst
170	(() '())
171	(((k . v) lst ...)
172	(if (subproperty? k key)
173	(as-alist-delete* lst key)
174	(cons (cons k v) (as-alist-delete lst key))))))
175
176	(define (merge-domains d1 d2)
177	(uniq
178	(if (list? d1)
179	(if (list? d2)
180	(append d1 d2)
181	(cons d2 d1))
182	(if (list? d2)
183	(cons d1 d2)
184	(list d1 d2)))))
185
186	(define (merge-ranges r1 r2)
187	(uniq
188	(if (list? r1)
189	(if (list? r2)
190	(append r1 r2)
191	(cons r2 r1))
192	(if (list? r2)
193	(cons r1 r2)
194	(list r1 r2)))))
195
196	(define (fix-types datatypes)
197	(define (fix-datatype type)
198	(if (as-type? type)
199	(let ((candidates
200	(filter (lambda (t) (equal? (as-type-uri t) (as-type-uri type)))
201	datatypes)))
202	(if (null? candidates)
203	type
204	(car candidates)))
205	type))
206
207	(let loop ((to-fix datatypes) (result '()))
208	(match to-fix
209	(() result)
210	((type to-fix ...)
211	(loop
212	to-fix
213	(cons
214	(make-as-type
215	(as-type-label type)
216	(as-type-uri type)
217	(as-type-comment type)
218	(map fix-datatype (as-type-subclass-of type)))
219	result))))))
220
221	(define (merge-datatypes datatypes)
222	(let loop ((result '()) (datatypes (apply append datatypes)))
223	(match datatypes
224	(() (map cdr result))
225	((type datatypes ...)
226	(loop
227	(let ((previous (assoc-ref result (as-type-uri type))))
228	(if previous
229	(alist-set result
230	(as-type-uri type)
231	(make-as-type
232	(as-type-label type)
233	(as-type-uri type)
234	(or (as-type-comment previous) (as-type-comment type))
235	(uniq (append (as-type-subclass-of previous)
236	(as-type-subclass-of type)))))
237	(cons (cons (as-type-uri type) type) result)))
238	datatypes)))))
239
240	(define (fix-properties datatypes properties)
241	(define (fix-datatype type)
242	(if (as-type? type)
243	(let ((candidates
244	(filter (lambda (t) (equal? (as-type-uri t) (as-type-uri type)))
245	datatypes)))
246	(if (null? candidates)
247	type
248	(car candidates)))
249	type))
250
251	(define (fix-property prop)
252	(if (as-property? prop)
253	(let ((candidates
254	(filter (lambda (p) (equal? (as-property-uri p) (as-property-uri prop)))
255	properties)))
256	(if (null? candidates)
257	prop
258	(car candidates)))
259	prop))
260
261	(let loop ((to-fix properties) (result '()))
262	(match to-fix
263	(() result)
264	((prop to-fix ...)
265	(let ((domain (as-property-domain prop))
266	(range (as-property-range prop)))
267	(loop
268	to-fix
269	(cons
270	(make-as-property
271	(as-property-label prop)
272	(as-property-uri prop)
273	(if (list? domain)
274	(map fix-property (map fix-datatype domain))
275	(fix-property (fix-datatype domain)))
276	(if (list? range)
277	(map fix-property (map fix-datatype range))
278	(fix-property (fix-datatype range)))
279	(as-property-functional? prop)
280	(map fix-property (as-property-subproperty-of prop))
281	(as-property-comment prop))
282	result)))))))
283
284	(define (merge-properties properties)
285	(let loop ((result '()) (properties (apply append properties)))
286	(match properties
287	(() (map cdr result))
288	((prop properties ...)
289	(loop
290	(let ((previous (assoc-ref result (as-property-uri prop))))
291	(if previous
292	(alist-set result
293	(as-property-uri prop)
294	(make-as-property
295	(as-property-label prop)
296	(as-property-uri prop)
297	(merge-domains (as-property-domain previous)
298	(as-property-domain prop))
299	(merge-ranges (as-property-range previous)
300	(as-property-range prop))
301	(and (as-property-functional? previous)
302	(as-property-functional? prop))
303	(uniq (append (as-property-subproperty-of previous)
304	(as-property-subproperty-of prop)))
305	(or (as-property-comment previous)
306	(as-property-comment prop))))
307	(cons (cons (as-property-uri prop) prop) result)))
308	properties)))))
309
310	(define* (merge-ontologies . ontologies)
311	(let ((datatypes (merge-datatypes (map ontology-datatypes ontologies)))
312	(properties (merge-properties (map ontology-properties ontologies))))
313	(make-ontology
314	(filter (lambda (a) a) (append-map ontology-context ontologies))
315	(fix-types datatypes)
316	(fix-properties datatypes properties))))
317
318	(define (subproperty? property other)
319	"Is @code{property} a subproperty of @code{other}?"
320	(or
321	(equal? property other)
322	(equal? (as-property-uri property) other)
323	(and (as-property? other)
324	(equal? (as-property-uri property) (as-property-uri other)))
325	(let loop ((superproperties (as-property-subproperty-of property)))
326	(match superproperties
327	(() #f)
328	((superproperty superproperties ...)
329	(if (subproperty? superproperty other)
330	#t
331	(loop superproperties)))))))
332
333	(define (subtype? type other)
334	"Is @code{type} a subtype of @code{other}?"
335	(or
336	(equal? type other)
337	(let loop ((supertypes (as-type-subclass-of type)))
338	(match supertypes
339	(() #f)
340	((supertype supertypes ...)
341	(if (subtype? supertype other)
342	#t
343	(loop supertypes)))))))
344
345	(define (as-ref document key)
346	"Takes a parsed document and returns the value associated with the property.
347	This takes care of subproperties: if you look for a property that's not in the
348	document directly, but the document has a subproperty of it, this will be
349	returned. The key must be a proper label as defined in the ontology."
350	(define (is-candidate kv)
351	(match kv
352	((k . v)
353	(subproperty? k key))))
354	(let ((candidates (filter is-candidate
355	(if (as-document? document)
356	(as-document-properties document)
357	document))))
358	(map cdr candidates)))
359
360	(define (as-document-set document key value)
361	(make-as-document
362	(as-document-types document)
363	(as-alist-set (as-document-properties document) key value)))
364
365	(define (as-document-delete document key)
366	(make-as-document
367	(as-document-types document)
368	(as-alist-delete (as-document-properties document) key)))
369
370	(define (as-document-delete* document key)
371	(make-as-document
372	(as-document-types document)
373	(as-alist-delete* (as-document-properties document) key)))
374
375	(define-syntax modify-as-document
376	(lambda (x)
377	(syntax-case x (set-property remove-property remove-property*)
378	((_ doc)
379	#`doc)
380	((_ doc (set-property key value) spec ...)
381	#`(modify-as-document
382	(as-document-set doc key value)
383	spec ...))
384	((_ doc (remove-property key) spec ...)
385	#`(modify-as-document
386	(as-document-delete doc key)
387	spec ...))
388	((_ doc (remove-property* key) spec ...)
389	#`(modify-as-document
390	(as-document-delete* doc key)
391	spec ...)))))
392
393	(define (json->as-document ontology document)
394	(define (uri->datatype type)
395	(let ((candidates (filter (lambda (t) (equal? (as-type-uri t) type))
396	(ontology-datatypes ontology))))
397	(cond
398	((null? candidates)
399	#f)
400	((> (length candidates) 1)
401	(throw 'multiple-datatypes-with-same-uri candidates))
402	(else
403	(car candidates)))))
404
405	(define (uri->property property)
406	(let ((candidates (filter (lambda (p) (equal? (as-property-uri p) property))
407	(ontology-properties ontology))))
408	(cond
409	((null? candidates)
410	#f)
411	((> (length candidates) 1)
412	(throw 'multiple-properties-with-same-uri candidates))
413	(else (car candidates)))))
414
415	(define (scalar->as-value value)
416	(cond
417	((or (json-has-key? value "@language") (json-has-key? value "@direction"))
418	(make-as-string
419	(assoc-ref value "@value")
420	(assoc-ref value "@language")
421	(assoc-ref value "@direction")))
422	((json-has-key? value "@type")
423	(let* ((types (assoc-ref value "@type"))
424	(types (if (string? types) (list types) (array->list types)))
425	(types (map uri->datatype types)))
426	(make-as-typed-value (assoc-ref value "@value") types)))
427	(else
428	(assoc-ref value "@value"))))
429
430	(cond
431	((scalar? document)
432	document)
433	((json-has-key? document "@value")
434	(scalar->as-value document))
435	((json-array? document)
436	;; XXX: this filter is not correct if one of the values is the litteral
437	;; "false"
438	(filter
439	(lambda (a) a)
440	(map (lambda (doc) (json->as-document ontology doc))
441	(array->list document))))
442	((list? document)
443	(let* ((types (or (assoc-ref document "@type") #()))
444	(types (if (string? types) (list types) (array->list types)))
445	(types (filter (lambda (a) a) (map uri->datatype types))))
446	(make-as-document
447	types
448	(filter
449	(lambda (a) a)
450	(map
451	(match-lambda
452	((key . value)
453	(let ((property (uri->property key))
454	(value (json->as-document ontology value)))
455	(if (and property (not (equal? key "@type")) value)
456	(cons (uri->property key) value)
457	#f))))
458	document)))))))
459
460	(define* (uri->as-document ontology uri #:key (options #f))
461	(if options
462	(json->as-document ontology (expand uri #:options options))
463	(json->as-document ontology (expand uri))))
464
465	(define* (as-document->json ontology doc #:key (options #f))
466	(define (as-document->proper-json doc)
467	(append
468	`(("@type" . ,(list->array 1 (map as-type-uri (as-document-types doc)))))
469	(map
470	(match-lambda
471	((key . value)
472	(cons (as-property-uri key) (as-value->proper-json value))))
473	(as-document-properties doc))))
474
475	(define (as-value->proper-json doc)
476	(cond
477	((as-document? doc)
478	(as-document->proper-json doc))
479	((list? doc)
480	(list->array 1 (map as-value->proper-json doc)))
481	((string? doc)
482	doc)
483	((as-typed-value? doc)
484	`(("@value" . ,(as-typed-value-value doc))
485	("@type" . ,(as-type-uri (as-typed-value-type doc)))))
486	((as-string? doc)
487	`(("@value" . ,(as-string-value doc))
488	,@(if (as-string-direction doc)
489	`(("@direction" . ,(as-string-direction doc)))
490	'())
491	,@(if (as-string-language doc)
492	`(("@language" . ,(as-string-language doc)))
493	'())))
494	(else doc)))
495
496	(let ((proper-json (as-value->proper-json doc))
497	(context `(("@context" . ,(list->array 1 (ontology-context ontology))))))
498	(if options
499	(compact proper-json context #:options options)
500	(compact proper-json context))))
501
502	(define* (as-document->graphviz doc #:key (label "n"))
503	(cond
504	((as-document? doc)
505	(let* ((id (as-ref (as-document-properties doc) "@id"))
506	(id (if (string? id) id (if (null? id) "" (car id))))
507	(types (as-document-types doc))
508	(name (if (null? types)
509	id
510	(string-append id " ("
511	(string-join (map as-type-label types) ", ")
512	")"))))
513	(format #t " ~a [label=\"~a\"];~%" label name)
514	(let loop ((children (as-document-properties doc)) (suffix 0))
515	(match children
516	(() (format #t "~%"))
517	(((key . value) children ...)
518	(let ((child-label (string-append label (number->string suffix))))
519	(format #t " ~a -> ~a [label=\"~a\"];~%"
520	label child-label
521	(if (string? key) key (as-property-label key)))
522	(as-document->graphviz value #:label child-label)
523	(loop children (+ suffix 1))))))))
524	((string? doc)
525	(format #t " ~a [label=\"~a\"];~%" label doc))
526	((list? doc)
527	(let loop ((children doc) (suffix 0))
528	(match children
529	(() (format #t "~%"))
530	((value children ...)
531	(let ((child-label (string-append label (number->string suffix))))
532	(format #t " ~a -> ~a;~%" label child-label)
533	(as-document->graphviz value #:label child-label)
534	(loop children (+ suffix 1)))))))
535	((as-typed-value? doc)
536	(format #t " ~a [label=\"~a\"];~%"
537	label (string-append (as-typed-value-value doc) "^^"
538	(as-type-label (as-typed-value-type doc)))))
539	((as-string? doc)
540	(let* ((str (as-string-value doc))
541	(str (if (or (as-string-language doc) (as-string-direction doc))
542	(string-append str "@")
543	str))
544	(str (string-append str (as-string-language doc)))
545	(str (if (as-string-direction doc)
546	(string-append str "_" (as-string-direction doc))
547	str)))
548	(format #t " ~a [label=\"~a\"];~%"
549	label str)))
550	(else doc)))
551