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