;;;; 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 (jsonld inverse-context-creation)

  #:use-module (jsonld context)

  #:use-module (jsonld json)

  #:use-module (ice-9 match)

  #:export (inverse-context-creation))

(define (sort-size-lexico e1 e2)

  "A <=? implementation between two elements of an alist that sort according

to key size first, breaking ties by selecting the lexicographically least one."

  (match `(,e1 . ,e2)

    (((k1 . v1) . (k2 . v2))

     (let ((l1 (string-length k1))

           (l2 (string-length k2)))

       (if (= l1 l2)

         (string<=? k1 k2)

         (< l1 l2))))))

(define* (inverse-context-creation active-context)

  (let ((result '())

        (default-language "@none"))

    ;; 2

    (when (active-context-language active-context)

      (set! default-language (string-downcase (active-context-language

                                                active-context))))

    ;; 3

    (for-each-pair

      (lambda (term term-definition)

        ;; 3.1

        (unless (equal? term-definition #nil)

          ;; 3.2

          (let ((container "@none")

                ;; 3.3

                (var (term-definition-iri term-definition))

                ;; 3.5

                (container-map #f)

                ;; 3.7

                (type/language-map #f)

                ;; 3.8

                (type-map #f)

                ;; 3.10

                (language-map '()))

            (when (term-definition-container term-definition)

              (let ((mapping (term-definition-container term-definition)))

                (set! container

                  (apply string-append

                         (sort

                           (if (json-array? mapping)

                               (array->list mapping)

                               (list mapping))

                           string<=?)))))

            ;; 3.4

            (unless (json-has-key? result var)

              (set! result (alist-set result var '())))

            ;; 3.5

            (set! container-map (assoc-ref result var))

            ;; 3.6

            (unless (json-has-key? container-map container)

              (set! container-map

                (alist-set

                  container-map

                  container

                  `(("@language" . ())

                    ("@type" . ())

                    ("@any" . (("@none" . ,term)))))))

            ;; 3.7

            (set! type/language-map (assoc-ref container-map container))

            ;; 3.12

            (set! language-map (assoc-ref type/language-map "@language"))

            ;; 3.8

            (set! type-map (assoc-ref type/language-map "@type"))

            ;; 3.9

            (cond

              ((term-definition-reverse? term-definition)

               (unless (json-has-key? type-map "@reverse")

                 (set! type-map (alist-set type-map "@reverse" term))))

              ;; 3.10

              ((equal? (term-definition-type term-definition) "@none")

               (set! language-map (assoc-ref type/language-map "@language"))

               (unless (json-has-key? language-map "@any")

                 (set! language-map (alist-set language-map "@any" term)))

               (unless (json-has-key? type-map "@any")

                 (set! type-map (alist-set type-map "@any" term))))

              ;; 3.11

              ((term-definition-type term-definition)

               (unless (json-has-key? type-map

                                      (term-definition-type term-definition))

                 (set! type-map

                   (alist-set type-map (term-definition-type term-definition)

                              term))))

              ;; 3.13

              ((and (not (equal? (term-definition-language term-definition) #f))

                    (not (equal? (term-definition-direction term-definition) #f)))

               (let ((lang-dir #f))

                 (cond

                   ((and (term-definition-language term-definition)

                         (term-definition-direction term-definition))

                    (set! lang-dir

                      (string-downcase

                        (string-append

                          (term-definition-language term-definition)

                          "_"

                          (term-definition-direction term-definition)))))

                   ((term-definition-language term-definition)

                    (set! lang-dir (string-downcase (term-definition-language

                                                      term-definition))))

                   ((term-definition-direction term-definition)

                    (set! lang-dir

                      (string-append

                        "_"

                        (string-downcase (term-definition-language

                                           term-definition)))))

                   (else

                     (set! lang-dir "@null")))

                 (unless (json-has-key? language-map lang-dir)

                   (set! language-map

                     (alist-set language-map lang-dir term)))))

              ;; 3.14

              ((not (equal? (term-definition-language term-definition) #f))

               (let ((language

                       (if (term-definition-language term-definition)

                           (string-downcase

                             (term-definition-language term-definition))

                           "@null")))

                 (unless (json-has-key? language-map language)

                   (set! language-map

                     (alist-set language-map language term)))))

              ;; 3.15

              ((not (equal? (term-definition-direction term-definition) #f))

               (let ((direction

                       (if (term-definition-direction term-definition)

                           (string-append

                             "_"

                             (string-downcase

                               (term-definition-direction term-definition)))

                           "@none")))

                 (unless (json-has-key? language-map direction)

                   (set! language-map

                     (alist-set language-map direction term)))))

              ;; 3.16

              ((not (equal? (active-context-direction active-context) #f))

               (let ((lang-dir

                       (string-downcase

                         (string-append

                           default-language "_"

                           (or (active-context-direction active-context)

                               "")))))

                 (unless (json-has-key? language-map lang-dir)

                   (set! language-map

                     (alist-set language-map lang-dir term)))

                 (unless (json-has-key? language-map "@none")

                   (set! language-map

                     (alist-set language-map "@none" term)))

                 (unless (json-has-key? type-map "@none")

                   (set! type-map

                     (alist-set type-map "@none" term)))))

              ;; 3.17

              (else

                (unless (json-has-key? language-map default-language)

                  (set! language-map

                    (alist-set language-map default-language term)))

                (unless (json-has-key? language-map "@none")

                  (set! language-map

                    (alist-set language-map "@none" term)))

                (unless (json-has-key? type-map "@none")

                  (set! type-map

                    (alist-set type-map "@none" term)))))

            (set! type/language-map (alist-set type/language-map "@language" language-map))

            (set! type/language-map (alist-set type/language-map "@type" type-map))

            (set! container-map (alist-set container-map container type/language-map))

            (set! result (alist-set result var container-map)))))

      (alist-sort-by-key (active-context-definitions active-context)

                         #:less sort-size-lexico))

    ;; 4

    result))