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