;;;; 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 (schema.org generate-vocabulary)
  #:use-module (ice-9 match)
  #:use-module (json)
  #:use-module (jsonld)
  #:export (generate-schema))

(define (generate-schema filename description-file)
  (define input (if (equal? description-file "")
                    "https://schema.org/version/8.0/schema.jsonld"
                    (call-with-input-file description-file json->scm)))
  (define definitions (assoc-ref (car (array->list (expand input))) "@graph"))

  (with-output-to-file filename
     (lambda _
       (format #t ";; Module generated by (schema.org generate-vocabulary)~%")
       (format #t ";; from the schema.org jsonld description.")
       (format #t "(define-module (schema.org ~a)~%" (basename filename ".scm"))
       (format #t "  #:use-module (activitystreams predicates)~%")
       (format #t "  #:use-module (activitystreams ontology)~%")
       (format #t "  #:export (schema.org-ontology)~%~%")
       (for-each
         (lambda (definition)
           (let ((types (array->list (assoc-ref definition "@type"))))
             (if (member "http://www.w3.org/2000/01/rdf-schema#Class" types)
                 (unless (datatype? definition)
                   (generate-class definition))
                 (generate-property definition))))
         (array->list definitions))
       (let* ((types (filter
                       (lambda (def)
                         (member "http://www.w3.org/2000/01/rdf-schema#Class"
                                 (array->list (assoc-ref def "@type"))))
                       (array->list definitions)))
              (types (map
                       (lambda (def)
                         (assoc-ref def "http://www.w3.org/2000/01/rdf-schema#label"))
                       types))
              (types (map
                       (lambda (def)
                         (assoc-ref (car (array->list def)) "@value"))
                       types))
              (predicates (filter
                            (lambda (def)
                              (and
                                (not (datatype? def))
                                (not
                                  (member "http://www.w3.org/2000/01/rdf-schema#Class"
                                          (array->list (assoc-ref def "@type"))))))
                            (array->list definitions)))
              (predicates (map
                            (lambda (def)
                              (assoc-ref def "http://www.w3.org/2000/01/rdf-schema#label"))
                            predicates))
              (predicates (map
                            (lambda (def)
                              (assoc-ref (car (array->list def)) "@value"))
                            predicates)))
         (format #t "(define schema.org-ontology~%")
         (format #t "  (make-ontology~%")
         (format #t "    '(\"http://schema.org/\")~%")
         (format #t "    (list ~a)~%" (cut-str-list types 80))
         (format #t "    (list ~a)))~%" (cut-str-list predicates 80))))))

(define (cut-str str n)
  "Cut a string @var{str} at @var{n} characters by placing a @code{\\n}, so that
the string is aligned to @var{n} characters."
  (let loop ((str str))
    (if (< (string-length str) (+ n 1))
        str
        (string-append
          (substring str 0 n)
          "\n"
          (loop (substring str n))))))

(define (cut-str-list lst n)
  (let loop ((lst lst) (result '(())))
    (match lst
      (() (string-join
            (reverse (map (lambda (l) (string-join l " ")) (map reverse result)))
            "\n"))
      ((word lst ...)
       (let ((current-line (car result)))
         (if (> (string-length (string-join (cons word current-line) " ")) n)
             (loop lst (cons (list word) result))
             (loop lst (cons (cons word current-line) (cdr result)))))))))


(define (generate-class definition)
  (let* ((id (assoc-ref definition "@id"))
         (comment (assoc-ref definition "http://www.w3.org/2000/01/rdf-schema#comment"))
         (comment (assoc-ref (car (array->list comment)) "@value"))
         (comment (cut-str comment 76))
         (comment (string-join (string-split comment #\") "\\\""))
         (label (assoc-ref definition "http://www.w3.org/2000/01/rdf-schema#label"))
         (label (assoc-ref (car (array->list label)) "@value"))
         (subclass-of (assoc-ref definition "http://www.w3.org/2000/01/rdf-schema#subClassOf"))
         (subclass-of (if subclass-of (array->list subclass-of) '()))
         (subclass-of (map (lambda (c) (basename (assoc-ref c "@id")))
                           subclass-of)))
    (format #t "(define-public ~a~%" label)
    (format #t "  (build-as-type \"~a\"~%    #:uri \"~a\"~%    #:comment~%    \"~a\""
            label id comment)
    (unless (null? subclass-of)
      (format #t "~%    #:subclass-of (list ~a)" (string-join subclass-of " ")))
    (format #t "))~%~%")))


(define (generate-property definition)
  (let* ((id (assoc-ref definition "@id"))
         (comment (assoc-ref definition "http://www.w3.org/2000/01/rdf-schema#comment"))
         (comment (assoc-ref (car (array->list comment)) "@value"))
         (comment (cut-str comment 76))
         (comment (string-join (string-split comment #\") "\\\""))
         (label (assoc-ref definition "http://www.w3.org/2000/01/rdf-schema#label"))
         (label (assoc-ref (car (array->list label)) "@value"))
         (domain (assoc-ref definition "http://schema.org/domainIncludes"))
         (domain (if domain (array->list domain) '()))
         (domain (map (lambda (c) (basename (assoc-ref c "@id"))) domain))
         (domain (map (lambda (c) (or (assoc-ref datatypes c) c)) domain))
         (range (assoc-ref definition "http://schema.org/rangeIncludes"))
         (range (if range (array->list range) '()))
         (range (map (lambda (c) (basename (assoc-ref c "@id"))) range))
         (range (map (lambda (c) (or (assoc-ref datatypes c) c)) range))
         (subproperty-of (assoc-ref definition "http://www.w3.org/2000/01/rdf-schema#subPropertyOf"))
         (subproperty-of (if subproperty-of (array->list subproperty-of) '()))
         (subproperty-of (map (lambda (c) (basename (assoc-ref c "@id")))
                              subproperty-of)))
    (format #t "(define-public ~a~%" label)
    (format #t "  (build-as-property~%")
    (format #t "    \"~a\" (list ~a) (list ~a)~%" label (string-join domain " ")
            (string-join range " "))
    (format #t "    #:uri \"~a\"~%" id)
    (format #t "    #:comment~%    \"~a\"" comment)
    (unless (null? subproperty-of)
      (format #t "~%    #:subproperty-of (list ~a)" (string-join subproperty-of " ")))
    (format #t "))~%~%")))

(define datatypes
  `(("False" . "(lambda (t) (equal? t #f))")
    ("True" . "(lambda (t) (equal? t #t))")
    ("DataType" . "procedure?")
    ("Boolean" . "boolean?")
    ("Date" . "date?")
    ("DateTime" . "date-time?")
    ("Number" . "number?")
    ("Float" . "number?")
    ("Integer" . "integer?")
    ("Text" . "string-or-lang-string?")
    ("CssSelectorType" . "string?")
    ("PronounceableText" . "string-or-lang-string?")
    ("URL" . "uri?")
    ("XPathType" . "string?")
    ("Time" . "time?")))

(define (datatype? definition)
  (let* ((labels (array->list (assoc-ref definition "http://www.w3.org/2000/01/rdf-schema#label")))
         (label (assoc-ref (car labels) "@value")))
    (member label (map car datatypes))))