;;; 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)
    (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 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"
     (list->array 1
       (filter
         (lambda (a) a)
         (map (lambda (doc) (json->as-document ontology doc))
              (array->list document)))))
    ((json-has-key? document "@type")
     (let* ((types (assoc-ref document "@type"))
            (types (if (string? types) (list types) (array->list types)))
            (types (filter (lambda (a) a) (map uri->datatype types))))
       (if (null? types)
           #f
           (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))))))
    (else
      (map
        (match-lambda
          ((key . value)
           (cons key (json->as-document ontology value))))
        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))))))))
    ((list? doc)
     (format #t "  ~a [label=\"\"];~%" label)
     (let loop ((children 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))
    ((array? doc)
     (let loop ((children (array->list 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)))