;;;; 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 iri-compaction)
  #:use-module (jsonld context)
  #:use-module (jsonld iri)
  #:use-module (jsonld json)
  #:use-module (jsonld term-selection)
  #:export (iri-compaction))

(define-syntax set-cond!
  (syntax-rules ()
    ((_ var val)
     (unless var
       (set! var val)))))

(define* (iri-compaction active-context inverse-context var
                         #:key value vocab? reverse? processing-mode)
  ;; not specified, but sometimes the spec leads to var being an array, so
  ;; in that case we iri-compact each part of it and return an array.
  (cond
    ;; 2
    ((equal? var #nil)
      #nil)
    ((json-array? var)
     (list->array 1
       (map
         (lambda (val)
           (iri-compaction active-context inverse-context val
                           #:value value
                           #:vocab? vocab?
                           #:reverse? reverse?
                           #:processing-mode processing-mode))
         (array->list var))))
    (else
     (begin
       (let ((result #f))
         ;; 2
         (when (and vocab? (json-has-key? inverse-context var))
           (let ((default-language
                   ;; 2.1
                   (if (or (active-context-direction active-context)
                           (active-context-language active-context))
                       (string-append
                         (or (active-context-language active-context) "")
                         "_"
                         (or (active-context-direction active-context) ""))
                       "@none"))
                 ;; 2.3
                 (containers '())
                 ;; 2.4
                 (type/language "@language")
                 (type/language-value "@null")
                 ;; 2.14
                 (preferred-values '()))
             ;; 2.2
             (when (json-has-key? value "@preserve")
               (set! value (assoc-ref value "@preserve")))
             ;; 2.5
             (when (and (json-has-key? value "@index")
                        (not (graph-object? value)))
               (set! containers
                 (append containers '("@index" "@index@set"))))
             (cond
               ;; 2.6
               (reverse?
                 (set! type/language "@type")
                 (set! type/language-value "@reverse")
                 (set! containers (append containers '("@set"))))
               ;; 2.7
               ((list-object? value)
                ;; 2.7.1
                (unless (json-has-key? value "@index")
                  (set! containers (append containers '("@list"))))
                ;; 2.7.2
                (let ((lst (array->list (assoc-ref value "@list")))
                      ;; 2.7.3
                      (common-type #nil)
                      (common-language #nil))
                  (when (null? lst)
                    (set! common-language default-language))
                  ;; 2.7.4
                  (for-each
                    (lambda (item)
                      ;; 2.7.4.1
                      (let ((item-language "@none")
                            (item-type "@none"))
                        (if (json-has-key? item "@value")
                            ;; 2.7.4.2
                            (cond
                              ((json-has-key? item "@direction")
                               (set! item-language
                                 (string-append
                                   (or (assoc-ref item "@language") "")
                                   "_"
                                   (assoc-ref item "@direction"))))
                              ((json-has-key? item "@language")
                               (set! item-language (assoc-ref item "@language")))
                              ((json-has-key? item "@type")
                               (set! item-type (assoc-ref item "@type")))
                              (else
                                (set! item-language "@null")))
                            ;; 2.7.4.3
                            (set! item-type "@id"))
                        ;; 2.7.4.4
                        (if (equal? common-language #nil)
                            (set! common-language item-language)
                            (unless (or (equal? common-language item-language)
                                        (not (json-has-key? item "@value")))
                              (set! common-language "@none")))
                        ;; 2.7.4.6
                        (if (equal? common-type #nil)
                            (set! common-type item-type)
                            (unless (equal? common-type item-type)
                              (set! common-type "@none")))))
                    lst)
                  ;; 2.7.5
                  (when (equal? common-language #nil)
                    (set! common-language "@none"))
                  (when (equal? common-type #nil)
                    (set! common-type "@none"))
                  (if (not (equal? common-type "@none"))
                      (begin
                        (set! type/language "@type")
                        (set! type/language-value common-type))
                      (set! type/language-value common-language))))
               ;; 2.8
               ((graph-object? value)
                ;; 2.8.1
                (when (json-has-key? value "@index")
                  (set! containers
                    (append containers '("@graph@index" "@graph@index@set"))))
                ;; 2.8.2
                (when (json-has-key? value "@id")
                  (set! containers
                    (append containers '("@graph@id" "@graph@id@set"))))
                ;; 2.8.3
                (set! containers
                  (append containers '("@graph" "@graph@set" "@set")))
                ;; 2.8.4
                (unless (json-has-key? value "@index")
                  (set! containers
                    (append containers '("@graph@index" "@graph@index@set"))))
                ;; 2.8.5
                (unless (json-has-key? value "@id")
                  (set! containers
                    (append containers '("@graph@id" "@graph@id@set"))))
                ;; 2.8.6
                (set! containers
                  (append containers '("@index" "@index@set")))
                ;; 2.8.7
                (set! type/language "@type")
                (set! type/language-value "@id"))
               ;; 2.9.1 and 2.9.3
               ((json-has-key? value "@value")
                (cond
                  ((and (json-has-key? value "@direction")
                        (not (json-has-key? value "@index")))
                   (set! type/language-value
                     (string-append
                       (or (assoc-ref value "@language") "")
                       "_"
                       (assoc-ref value "@direction")))
                   (set! containers
                     (append containers '("@language" "@language@set"))))
                  ((and (json-has-key? value "@language")
                        (not (json-has-key? value "@index")))
                   (set! type/language-value (assoc-ref value "@language"))
                   (set! containers
                     (append containers '("@language" "@language@set"))))
                  ((json-has-key? value "@type")
                   (set! type/language-value (assoc-ref value "@type"))
                   (set! type/language "@type")))
                (set! containers (append containers '("@set"))))
               ;; 2.9.2 and 2.9.3
               (else
                (set! type/language "@type")
                (set! type/language-value "@id")
                (set! containers
                  (append containers '("@id" "@id@set" "@type" "@set@type" "@set")))))
             ;;2.10
             (set! containers (append containers '("@none")))
             ;; 2.11
             (unless (processing-mode-1.0? processing-mode)
               (unless (json-has-key? value "@index")
                 (set! containers (append containers '("@index" "@index@set"))))
               ;; 2.12
               (when (and (json-has-key? value "@value")
                          (null? (filter (lambda (kp) (not (equal? (car kp) "@value")))
                                         value)))
                 (set! containers (append containers '("@language" "@language@set")))))
             ;; 2.13
             (when (equal? type/language-value #nil)
               (set! type/language-value "@null"))
             ;; 2.15
             (when (equal? type/language-value "@reverse")
               (set! preferred-values (append preferred-values '("@reverse"))))
             ;; 2.16
             (if (and (or (equal? type/language-value "@reverse")
                          (equal? type/language-value "@id"))
                      (json-has-key? value "@id"))
               (let* ((compacted-iri (iri-compaction active-context inverse-context
                                                     (assoc-ref value "@id")
                                                     #:vocab? #t
                                                     #:processing-mode processing-mode))
                      (def (term-definition-ref active-context compacted-iri))
                      (iri (if def (term-definition-iri def) #f)))
                 (if (equal? iri (assoc-ref value "@id"))
                     (set! preferred-values
                       (append preferred-values '("@vocab" "@id" "@none")))
                     (set! preferred-values
                       (append preferred-values '("@id" "@vocab" "@none")))))
               ;; 2.17
               (begin
                 (when (equal? (assoc-ref value "@list") #())
                   (set! type/language "@any"))
                 (set! preferred-values
                   (append preferred-values (list type/language-value "@none")))))
             ;; 2.18
             (set! preferred-values (append preferred-values '("@any")))
             ;; 2.19
             (let* ((underscore-vals (filter
                                       (lambda (s)
                                         (string-index s #\_))
                                       preferred-values))
                    (underscore (if (null? underscore-vals) #f (car underscore-vals))))
               (when underscore
                 (set! preferred-values
                   (append
                     preferred-values
                     (list
                       (string-join
                         (cons "" (cdr (string-split underscore #\_))) "_"))))))
             ;; 2.20
             (let ((term (term-selection inverse-context var containers type/language preferred-values)))
               (when term
                 (set-cond! result term)))))
         ;; 3
         (when (and vocab? (active-context-vocab active-context))
           (let ((vocab (active-context-vocab active-context)))
             (when (and (>= (string-length var) (string-length vocab))
                        (equal? (substring var 0 (string-length vocab)) vocab))
               (let ((suffix (substring var (string-length vocab))))
                 (unless (term-definition-ref active-context suffix)
                   (set-cond! result suffix))))))
         ;; 4
         (let ((compact-iri #nil))
           ;; 5
           (for-each-pair
             (lambda (term def)
               ;; 5.1
               (unless (or (equal? (term-definition-iri def) #nil)
                           (equal? (term-definition-iri def) var)
                           (not (string? var))
                           (< (string-length var) (string-length (term-definition-iri def)))
                           (not (equal?
                                  (substring
                                    var 0
                                    (string-length (term-definition-iri def)))
                                  (term-definition-iri def)))
                           (not (term-definition-prefix? def)))
                 ;; 5.2
                 (let ((candidate (string-append term ":"
                                                 (substring
                                                   var
                                                   (string-length
                                                     (term-definition-iri def))))))
                   ;; 5.3
                   (when (or (equal? compact-iri #nil)
                             (< (string-length candidate) (string-length compact-iri))
                             (and (= (string-length candidate)
                                     (string-length compact-iri))
                                  (string<=? candidate compact-iri)))
                     (let ((def (term-definition-ref active-context candidate)))
                       (when (or (not def)
                                 (and (not value)
                                      (equal? (term-definition-iri def) var)))
                         (set! compact-iri candidate)))))))
             (active-context-definitions active-context))
           ;; 6
           (when compact-iri
             (set-cond! result compact-iri)))
         ;; 7
         (unless result
           (let* ((components (string-split var #\:))
                  (prefix (car components))
                  (suffix (string-join (cdr components) ":")))
             (unless (null? (filter
                              (lambda (kp)
                                (and
                                  (equal? prefix (car kp))
                                  (term-definition-prefix? (cdr kp))))
                              (active-context-definitions active-context)))
               (unless (and (> (string-length suffix) 2)
                            (equal? (substring suffix 0 2) "//"))
                 (throw 'iri-confused-with-prefix)))))
         ;; 8
         (unless vocab?
           (when (and (active-context-base active-context) (absolute-iri? var))
             (set-cond! result
               (make-relative-iri var (active-context-base active-context)))))
         ;; 9
         (set-cond! result var)
         result)))))