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

  #:use-module (ice-9 match)

  #:use-module (srfi srfi-9)

  #:export (as:type

            as:type?

            as:type-label

            as:type-uri

            as:type-comment

            as:type-subclass-of

            as:property

            as:property?

            as:property-label

            as:property-uri

            as:property-range

            as:property-domain

            as:property-functional?

            as:property-subproperty-of

            as:property-comment

            make-as-type

            make-as-property

            make-ontological-parser

            as-ref

            as:type-of-type?

            as:property-of-type?))

(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* (make-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* (make-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 (make-ontological-parser ontology)

  "Creates a parser from an ontology: takes json document as input and outputs

the best possible document as an alist (or array of alists) whose keys are an

as:property and value is the associated expanded value.  It also perfoms type

checking to ensure the document is well-parsed.  When the document doesn't respect

the ontology, throws an exception.  Type is in the key @type and its value

is a as:type."

  (define (candidate-type type)

    (filter

      (lambda (o)

        (and

          (as:type? o)

          (equal? (as:type-uri o) type)))

      ontology))

  (define (candidate-property name)

    (filter

      (lambda (p)

        (and

          (as:property? p)

          (equal? (as:property-uri p) name)))

      ontology))

  (define (in-range property value)

    (match (as:property-range property)

      ((? string? type)

       (as:type-of-type? (assoc-ref value "@type") type))

      ((? procedure? proc)

       (proc value))

      (()

       #f)

      ((? list? l)

       (or (in-range (car l) value) (in-range (cdr l) value)))

      (range (throw 'invalid-property-range range))))

  (define (in-domain property type)

    (match (as:property-domain property)

      ((? string? parent)

       (as:type-of-type? type parent))

      ((? procedure? proc)

       (proc type))

      (()

       #f)

      ((? list? l)

       (or (in-domain (car l) type) (in-domain (cdr l) type)))))

  (define (parse json)

    (if (assoc-ref json "@value")

      json

      ;; TODO: there might be more than one @type...

      (let ((type (car (candidate-type (assoc-ref json "@type")))))

        (let loop ((result `(("@type" . ,type))) (json json))

          (match json

            (() result)

            (((k . v) json ...)

             (let ((candidates (candidate-property k)))

               (cond

                 ((equal? k "@type")

                  (loop result json))

                 ((null? candidates)

                  (loop result json))

                 (else

                   (let ((property (car candidates))

                         (value (parse v)))

                     (unless (in-range property value)

                       (throw 'value-type-mismatch property value))

                     (unless (in-domain property type)

                       (throw 'property-not-supported property value))

                     (loop (cons (cons property value) result) json)))))))))))

  parse)

(define (as:property-of-type? property label)

  (or (equal? (as:property-label property) label)

      (let loop ((subproperties (as:property-subproperty-of property)))

        (match subproperties

          (() #f)

          ((property subproperties ...)

           (or (as:property-of-type? property label)

               (loop subproperties)))))))

(define (as:type-of-type? type label)

  (or (equal? (as:type-label type) label)

      (let loop ((subclasses (as:type-subclass-of type)))

        (match subclasses

          (() #f)

          ((type subclasses ...)

           (or (as:type-of-type? type label)

               (loop subclasses)))))))

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

       (as:property-of-type? k key))))

  (let ((candidates (filter is-candidate document)))

    (map cdr candidates)))