;;;; Copyright (C) 2019, 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 create-term-definition)
  #:use-module (iri iri)
  #:use-module (jsonld context)
  #:use-module (jsonld context-processing)
  #:use-module (jsonld iri-expansion)
  #:use-module (jsonld json)
  #:use-module (jsonld options)
  #:use-module (json)
  #:use-module (web uri)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:export (create-term-definition))

(define* (create-term-definition active-context local-context term defined
                                 #:key (base-url #f) (protected? #f)
                                 (override-protected? #f)
                                 (remote-contexts '())
                                 (validate-scoped-context? #t)
                                 (options (new-jsonld-options)))
  "Create a term definition.  This is an implementation of the create term
definition algorithm defined in the JsonLD API specification."
  (match (assoc-ref defined term)
    ;; 1
    ('true #t)
    ('false (throw 'cyclic-iri-mapping))
    (_
     (begin
       ;; 2
       (when (equal? term "")
         (throw 'invalid-term-definition))
       ;; 2: This indicates that the term definition is now being created but
       ;; is not yet complete.
       (set! defined (alist-set defined term 'false))  
       ;; 3
       (let ((value (assoc-ref local-context term)))
         ;; 4
         (when (and (equal? term "@type")
                    (processing-mode-1.0? (jsonld-options-processing-mode options)))
           (throw 'keyword-redefinition))
         ;; 4
         (if (equal? term "@type")
           (unless (and (json-object? value)
                        (or (not (json-has-key? value "@container"))
                            (equal? (assoc-ref value "@container") "@set"))
                        (not (null? value))
                        (null? (filter
                                 (lambda (kp)
                                   (not (member (car kp) '("@container" "@protected"))))
                                 value)))
             (throw 'keyword-redefinition))
           ;; 5
           (if (json-keyword? term)
               (throw 'keyword-redefinition)))
         ;; 5 TODO: generate a warning if it's a keyword-form but not @type
         (unless (and (keyword-form? term) (not (equal? term "@type")))
           ;; 6
           (let ((previous-definition (term-definition-ref active-context term))
                 (simple-term? #t)
                 ;; 10
                 (definition (new-term-definition #:protected? protected?)))
             (cond
               ;; 7
               ((json-null? value)
                (set! value `(("@id" . ,json-null))))
               ;; 8
               ((string? value)
                (set! value `(("@id" . ,value))))
               ;; 9
               ((json-object? value) (set! simple-term? #f))
               (else (throw 'invalid-term-definition)))
             ;; 11
             (when (json-has-key? value "@protected")
               (when (processing-mode-1.0? (jsonld-options-processing-mode options))
                 (throw 'invalid-term-definition))
               (set! definition (update-term-definition
                                  definition
                                  #:protected? (assoc-ref value "@protected")))
               (unless (member (assoc-ref value "@protected") '(#t #f))
                 (throw 'invalid-@protected-value)))
             ;; 12: if value contains the key @type
             (when (json-has-key? value "@type")
               ;; 12.1
               (let ((type (assoc-ref value "@type")))
                 (unless (string? type)
                   (throw 'invalid-type-mapping))
                 ;; 12.2
                 (let ((result (iri-expansion active-context type
                                              #:vocab? #t
                                              #:local-context local-context
                                              #:defined defined
                                              #:options options)))
                   (set! active-context (assoc-ref result "active-context"))
                   (set! defined (assoc-ref result "defined"))
                   (set! type (assoc-ref result "iri")))
                 ;; 12.3
                 (when (and (member type '("@json" "@none"))
                            (processing-mode-1.0? (jsonld-options-processing-mode options)))
                   (throw 'invalid-type-mapping))
                 ;; 12.4
                 (unless (or (member type '("@id" "@vocab" "@json" "@none"))
                             (absolute-iri? type))
                   (throw 'invalid-type-mapping value type))
                 ;; 12.5
                 (set! definition (update-term-definition definition #:type type))))

             ;; 13: if value contains the key @reverse
             (if (json-has-key? value "@reverse")
               (begin
                 ;; 13.1
                 (when (or (json-has-key? value "@id") (json-has-key? value "@nest"))
                   (throw 'invalid-reverse-property))
                 ;; 13.2
                 (unless (string? (assoc-ref value "@reverse"))
                   (throw 'invalid-iri-mapping))
                 ;; 13.3
                 (if (and (keyword-form? (assoc-ref value "@reverse"))
                          (not (json-keyword? (assoc-ref value "@reverse"))))
                     #t;; TODO: generate a warning before returning
                     (begin
                       ;; 13.4
                       (let* ((result (iri-expansion active-context
                                                     (assoc-ref value "@reverse")
                                                     #:vocab? #t
                                                     #:local-context local-context
                                                     #:defined defined
                                                     #:options options))
                              (iri (assoc-ref result "iri")))
                         (unless (or (absolute-iri? iri) (blank-node? iri))
                           (throw 'invalid-iri-mapping))
                         (set! active-context (assoc-ref result "active-context"))
                         (set! defined (assoc-ref result "defined"))
                         ;; 13.5
                         (when (json-has-key? value "@container")
                           (let ((container (assoc-ref value "@container")))
                             (unless (member container `("@set" "@index" ,json-null))
                               (throw 'invalid-reverse-property))
                             (set! definition (update-term-definition definition
                                                #:container container))))
                         ;; 13.4 (cont.) and 13.6
                         (set! definition (update-term-definition definition
                                            #:iri iri #:reverse? #t))
                         ;; 13.7: we return
                         (set! active-context (update-active-context
                                                active-context
                                                #:definitions
                                                (alist-set
                                                  (active-context-definitions
                                                    active-context)
                                                  term definition)))
                         (set! defined (alist-set defined term 'true))))))
               ;; (not 13): otherwise, we continue
               (begin
                 (let ((return? #f))
                   (cond
                     ;; 14
                     ((and (json-has-key? value "@id")
                           (not (equal? (assoc-ref value "@id") term)))
                      ;; 14.1
                      (if (json-null? (assoc-ref value "@id"))
                        (set! definition (update-term-definition definition
                                                                 #:iri json-null))
                        ;; 14.2
                        (begin
                          ;; 14.2.1
                          (unless (string? (assoc-ref value "@id"))
                            (throw 'invalid-iri-mapping))
                          ;; 14.2.2
                          (if (and (not (json-keyword? (assoc-ref value "@id")))
                                   (keyword-form? (assoc-ref value "@id")))
                            (set! return? #t);; return, should generate a warning
                            ;; 14.2.3
                            (let* ((result (iri-expansion
                                             active-context
                                             (assoc-ref value "@id")
                                             #:vocab? #t
                                             #:local-context local-context
                                             #:defined defined
                                             #:options options))
                                   (iri (assoc-ref result "iri")))
                              (set! active-context (assoc-ref result "active-context"))
                              (set! defined (assoc-ref result "defined"))
                              (set! definition (update-term-definition definition
                                                 #:iri iri))
                              (unless (or (json-keyword? iri) (absolute-iri? iri)
                                          (blank-node? iri))
                                (throw 'invalid-iri-mapping))
                              (when (equal? iri "@context")
                                (throw 'invalid-keyword-alias))
                              ;; 14.2.4
                              (if (or
                                    (and
                                      (> (string-length term) 1)
                                      (string-index (substring term 1 (- (string-length term) 1)) #\:))
                                    (string-index term #\/))
                                  (begin
                                    ;; 14.2.4.1
                                    (set! defined (alist-set defined term 'true))
                                    ;; 14.2.4.2
                                    (let ((result (iri-expansion
                                                    active-context
                                                    term
                                                    #:local-context local-context
                                                    #:defined defined
                                                    #:vocab? #t
                                                    #:options options)))
                                      (set! active-context (assoc-ref result "active-context"))
                                      (set! defined (assoc-ref result "defined"))
                                      (unless (equal?
                                                (assoc-ref result "iri")
                                                iri)
                                        (throw 'invalid-iri-mapping
                                               term
                                               iri
                                               (assoc-ref result "iri")))))
                                  (when (and simple-term?
                                             (or (blank-node? iri)
                                                 (gen-delim? (substring iri (- (string-length iri) 1)))))
                                    (set! definition (update-term-definition
                                                       definition
                                                       #:prefix? #t)))))))))
                     ;; 15
                     ((and (> (string-length term) 1)
                           (string-index (substring term 1) #\:))
                      (let ((prefix (car (string-split term #\:)))
                            (suffix (apply string-append (cdr (string-split term #\:)))))
                        ;; 15.1
                        (when (json-has-key? local-context prefix)
                          (let ((result (create-term-definition
                                          active-context local-context prefix defined)))
                            (set! defined (assoc-ref result "defined"))
                            (set! active-context (assoc-ref result "active-context"))))
                        (if (not-null-or-false (term-definition-ref active-context prefix))
                          ;; 15.2
                          (set! definition (update-term-definition definition
                                             #:iri (string-append
                                                     (term-definition-iri
                                                       (term-definition-ref active-context prefix))
                                                     suffix)))
                          ;; 15.3
                          (set! definition (update-term-definition definition
                                             #:iri term)))))
                     ;; 16
                     ((string-index term #\/)
                      (let* ((result (iri-expansion active-context term
                                                    #:vocab? #t
                                                    #:options options))
                             (iri (assoc-ref result "iri")))
                        (set! active-context (assoc-ref result "active-context"))
                        (set! defined (assoc-ref result "defined"))
                        (unless (absolute-iri? iri)
                          (throw 'invalid-iri-mapping))
                        (set! definition (update-term-definition definition
                                                                 #:iri iri))))
                     ;; 17
                     ((equal? term "@type")
                      (set! definition (update-term-definition
                                         definition #:iri "@type")))
                     ;; 18
                     ((not-null-or-false (active-context-vocab active-context))
                      (set! definition (update-term-definition definition
                                         #:iri (string-append
                                                 (active-context-vocab active-context)
                                                 term))))
                     (else (throw 'invalid-iri-mapping)))
                   (unless return?
                     ;; 19
                     (when (json-has-key? value "@container")
                       ;; 19.1
                       (let ((container (assoc-ref value "@container")))
                         (match container
                           ((? string? container)
                            (unless (member container
                                            '("@graph" "@id" "@index" "@language"
                                              "@list" "@set" "@type"))
                              (throw 'invalid-container-mapping))
                            ;; 19.2
                            (when (and (member container '("@graph" "@id" "@type"))
                                       (processing-mode-1.0?
                                         (jsonld-options-processing-mode options)))
                              (throw 'invalid-container-mapping)))
                           ((? json-array? container)
                            (let ((container (array->list container)))
                              (unless (or
                                        (and
                                          (= (length container) 1)
                                          (member (car container)
                                            '("@graph" "@id" "@index" "@language"
                                              "@list" "@set" "@type")))
                                        (and
                                          (member "@graph" container)
                                          (or
                                            (member "@id" container)
                                            (member "@index" container))
                                          (null?
                                            (filter
                                              (lambda (p)
                                                (not (member p
                                                       '("@id" "@index" "@graph"
                                                         "@set"))))
                                              container)))
                                        (and
                                          (member "@set" container)
                                          (or
                                            (member "@index" container)
                                            (member "@graph" container)
                                            (member "@id" container)
                                            (member "@type" container)
                                            (member "@language" container))))
                                (throw 'invalid-container-mapping))
                              ;; 19.2
                              (when (processing-mode-1.0?
                                      (jsonld-options-processing-mode options))
                                (throw 'invalid-container-mapping))))
                           (_ (throw 'invalid-container-mapping)))
                         ;; 19.3
                         (set! container (if (json-array? container)
                                             container
                                             `#(,container)))
                         (set! definition (update-term-definition definition
                                            #:container container))
                         ;; 19.4
                         (when (member "@type" (array->list container))
                           ;; 19.4.1
                           (unless (term-definition-type definition)
                             (set! definition
                               (update-term-definition definition
                                                       #:type "@id")))
                           ;; 19.4.2
                           (unless (member (term-definition-type definition)
                                           '("@id" "@vocab"))
                             (throw 'invalid-type-mapping)))))
                     ;; 20
                     (when (json-has-key? value "@index")
                       ;; 20.1
                       (when (or (processing-mode-1.0?
                                   (jsonld-options-processing-mode options))
                                 (not (member
                                        "@index"
                                        (array->list
                                          (or (term-definition-container
                                                 definition)
                                              #())))))
                         (throw 'invalid-term-definition))
                       ;; 20.2
                       (let* ((index (assoc-ref value "@index"))
                              (extended-index
                                (assoc-ref
                                  (iri-expansion active-context index
                                                 #:vocab? #t
                                                 #:options options)
                                  "iri")))
                         (unless (and (string? extended-index)
                                      (absolute-iri? extended-index))
                           (throw 'invalid-term-definition))
                         ;; 20.3
                         (set! definition
                           (update-term-definition definition #:index index))))
                     ;; 21
                     (when (json-has-key? value "@context")
                       ;; 21.1
                       (when (processing-mode-1.0? (jsonld-options-processing-mode options))
                         (throw 'invalid-term-definition))
                       ;; 21.2
                       (let ((context (assoc-ref value "@context")))
                         ;; the result is discarded, it will be reprocessed if
                         ;; used. It is only here to detect errors
                         (catch #t
                           (lambda ()
                             (context-processing active-context context base-url
                                                 #:override-protected? #t
                                                 #:remote-contexts remote-contexts
                                                 #:validate-scoped-context? #f
                                                 #:options options))
                           (lambda (key . value)
                             (apply throw 'invalid-scoped-context key value)))
                         (set! definition
                           (update-term-definition definition #:context context
                                                   #:base-url base-url))))
                     ;; 22
                     (when (and (json-has-key? value "@language")
                                (not (json-has-key? value "@type")))
                       ;; 22.1
                       (let ((language (assoc-ref value "@language")))
                         (unless (or (string? language) (json-null? language))
                           (throw 'invalid-language-mapping))
                         ;; a warning should be thrown if not bcp-47 compliant
                         ;; 22.2
                         (when (string? language)
                           (set! language (string-downcase language)))
                         (set! definition (update-term-definition definition
                                            #:language language))))
                     ;; 23
                     (when (and (json-has-key? value "@direction")
                                (not (json-has-key? value "@type")))
                       ;; 23.1
                       (let ((direction (assoc-ref value "@direction")))
                         (unless (member direction `("ltr" "rtl" ,json-null))
                           (throw 'invalid-base-direction))
                         ;; 23.2
                         (set! definition (update-term-definition definition
                                            #:direction direction))))
                     ;; 24
                     (when (json-has-key? value "@nest")
                       ;; 24.1
                       (when (processing-mode-1.0? (jsonld-options-processing-mode options))
                         (throw 'invalid-term-definition))
                       ;; 24.2
                       (let ((nest (assoc-ref value "@nest")))
                         (when (or (not (string? nest))
                                   (and (json-keyword? nest)
                                        (not (equal? nest "@nest"))))
                           (throw 'invalid-@nest-value))
                         (set! definition
                           (update-term-definition definition #:nest nest))))
                     ;; 25
                     (when (json-has-key? value "@prefix")
                       ;; 25.1
                       (when (or (processing-mode-1.0?
                                   (jsonld-options-processing-mode options))
                                 (string-index term #\:)
                                 (string-index term #\/))
                         (throw 'invalid-term-definition))
                       ;; 25.2
                       (let ((prefix? (assoc-ref value "@prefix")))
                         (unless (member prefix? '(#t #f))
                           (throw 'invalid-@prefix-value))
                         (set! definition
                           (update-term-definition definition #:prefix? prefix?))
                         ;; 25.3
                         (when (and prefix?
                                    (json-keyword? (term-definition-iri definition)))
                           (throw 'invalid-term-definition))))
                     ;; 26
                     (unless (null? (filter
                                      (lambda (kp)
                                        (not (member (car kp)
                                                     '("@id" "@reverse" "@container"
                                                       "@context" "@direction"
                                                       "@index" "@language"
                                                       "@nest" "@prefix"
                                                       "@protected" "@type"))))
                                      value))
                       (throw 'invalid-term-definition))
                     ;; 27
                     (unless (or override-protected?
                                 (not (not-null-or-false previous-definition))
                                 (not (term-definition-protected? previous-definition)))
                       ;; 27.1
                       (unless (term-definition-equal?
                                 (update-term-definition definition #:protected? #t)
                                 previous-definition)
                         (throw 'protected-term-redefinition))
                       ;; 27.2
                       (set! definition previous-definition))
                     ;; 28
                     (set! defined (alist-set defined term 'true))
                     (set! active-context
                       (update-active-context
                         active-context
                         #:definitions
                         (alist-set (active-context-definitions active-context)
                                    term definition)))))))))))))
  ;; return an alist of potentially modified objects: defined and active-context.
  `(("defined" . ,defined) ("active-context" . ,active-context)))