;;; 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

            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 (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 (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)

  (json->as-document ontology (expand uri)))

(define (as-document->json ontology doc)

  (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)

       (map

         (match-lambda

           ((key . value)

            (cons

              (if (string? key)

                  key

                  (as-property-uri key))

              (as-value->proper-json value))))

         doc))

      ((string? doc)

       doc)

      ((array? doc)

       (list->array 1 (map as-value->proper-json (array->list 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)))

  (compact (as-value->proper-json doc)

           `(("@context" . ,(list->array 1 (ontology-context ontology))))))

(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)))