;;;; 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 context-processing)
  #:use-module (jsonld context)
  #:use-module (jsonld create-term-definition)
  #:use-module (jsonld download)
  #:use-module (jsonld iri)
  #: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 (context-processing))

(define* (context-processing
           active-context local-context base-url
           #:key (remote-contexts '()) (override-protected? #f) (propagate? #t)
           (validate-scoped-context? #t)
           (options (new-jsonld-options)))
  "Process a context.  This is an implementation of the context processing
algorithm defined in the JsonLD API specification.

See @url{https://www.w3.org/TR/2014/REC-json-ld-api-20140116}."
  ;; 1
  (define result active-context)
  ;; 2
  (when (json-has-key? local-context "@propagate")
    (set! propagate? (assoc-ref local-context "@propagate")))
  ;; 3
  (unless (or propagate? (active-context-previous active-context))
    (set! result (update-active-context result #:previous active-context)))
  ;; 4
  (if (json-array? local-context)
      (set! local-context (array->list local-context))
      (set! local-context (list local-context)))
  ;; 5
  (for-each
    (lambda (context)
      (match context
        ;; 5.1
        (#nil
         (unless (or override-protected?
                     (null? (filter
                              term-definition-protected?
                              (map cdr (active-context-definitions result)))))
           (throw 'invalid-context-nullification))
         (let ((original-base (active-context-original-base active-context)))
           (if propagate?
             (set! result (new-active-context #:previous result
                                              #:base original-base
                                              #:original-base original-base))
             (set! result (new-active-context #:base original-base
                                              #:original-base original-base)))))
        ;; 5.2
        ((? string? context)
         ;; 5.2.1
         (set! context (resolve-iri base-url context))
         (unless (absolute-iri? context)
           (throw 'loading-document-failed context))
         ;; 5.2.2
         ;; A processor-defined limit, here we choose 10
         (when (> (length remote-contexts) 10)
           (throw 'context-overflow-error))
         (set! remote-contexts (cons context remote-contexts))
         ;; 5.2.3
         (when validate-scoped-context?
           ;; 5.2.4
           (let ((context-document #f))
             (catch #t
               (lambda ()
                 (set! context-document
                   ((jsonld-options-document-loader options)
                      context
                      #:profile "http://www.w3.org/ns/json-ld#context"
                      #:request-profile "http://www.w3.org/ns/json-ld#context"))
                 (set! context (json-document-document context-document)))
               (lambda (key . value)
                 (apply throw 'loading-remote-context-failed key value)))
             ;; 5.2.5
             (if (json-has-key? context "@context")
               (set! context (assoc-ref context "@context"))
               (throw 'invalid-remote-context))
             ;; 5.2.6
             (set! result (context-processing
                            result context
                            (json-document-document-url context-document)
                            #:remote-contexts remote-contexts
                            #:validate-scoped-context? validate-scoped-context?
                            #:options options)))))
        ;; 5.4: if it's a Json object (also see below, if it's not, for 5.3)
        ((? json-object? context)
         ;; 5.5: If it has an @version key...
         (when (json-has-key? context "@version")
           ;; 5.5.1
           (unless (equal? (assoc-ref context "@version") 1.1)
             (throw 'invalid-@version-value (assoc-ref context "@version")))
           ;; 5.5.2
           (when (processing-mode-1.0? (jsonld-options-processing-mode options))
             (throw 'processing-mode-conflict)))

         ;; 5.6: If it has an @import key...
         (when (json-has-key? context "@import")
           ;; 5.6.1
           (when (processing-mode-1.0? (jsonld-options-processing-mode options))
             (throw 'invalid-context-entry))
           ;; 5.6.2
           (unless (string? (assoc-ref context "@import"))
             (throw 'invalid-@import-value))
           ;; 5.6.3
           (let ((import (resolve-iri
                           base-url
                           (assoc-ref context "@import"))))
             ;; 5.6.4
             (catch #t
               (lambda ()
                 (set! import ((jsonld-options-document-loader options)
                                 import
                                 #:profile "http://www.w3.org/ns/json-ld#context"
                                 #:request-profile "http://www.w3.org/ns/json-ld#context"))
                 (set! import (json-document-document import)))
               (lambda (key . value)
                 (apply throw 'loading-remote-context-failed key value)))
             ;; 5.6.6
             (unless (and (json-has-key? import "@context")
                          (json-object? (assoc-ref import "@context")))
               (throw 'invalid-remote-context import))
             (let ((import-context (assoc-ref import "@context")))
               ;; 5.6.7
               (when (json-has-key? import-context "@import")
                 (throw 'invalid-context-entry))
               ;; 5.6.8
               (set! context (merge-json context import-context)))))

         ;; 5.7: If it has an @base key...
         (when (and (json-has-key? context "@base") (null? remote-contexts))
           ;; 5.7.1
           (let ((value (assoc-ref context "@base")))
             (cond
               ;; 5.7.2
               ((equal? value #nil)
                (set! result (update-active-context result #:base #nil)))
               ;; 5.7.3
               ((absolute-iri? value)
                (set! result (update-active-context result #:base value)))
               (else
                 (let ((iri (resolve-iri (active-context-base result) value)))
                   (if (and (absolute-iri? iri)
                            (active-context-base result))
                     ;; 5.7.4
                     (set! result (update-active-context result #:base iri))
                     ;; 5.7.5
                     (throw 'invalid-base-iri iri (active-context-base result))))))))

         ;; 5.8: If it has an @vocab key...
         (when (json-has-key? context "@vocab")
           ;; 5.8.1
           (let ((value (assoc-ref context "@vocab")))
             (if (equal? value #nil)
               ;; 5.8.2
               (set! result (update-active-context result #:vocab #f))
               ;; 5.8.3
               (let ((value
                       (assoc-ref
                         (iri-expansion result value
                                        #:vocab? #t
                                        #:document-relative? #t)
                         "iri")))
                 (if (or (absolute-iri? value) (blank-node? value))
                   (set! result (update-active-context result #:vocab value))
                   (throw 'invalid-vocab-mapping value))))))

         ;; 5.9: If it has an @language key...
         (when (json-has-key? context "@language")
           ;; 5.9.1
           (let ((value (assoc-ref context "@language")))
             (if (equal? value #nil)
               ;; 5.9.2
               (set! result (update-active-context result #:language #f))
               ;; 5.9.3
               (if (string? value)
                 (set! result (update-active-context result #:language value))
                 (throw 'invalid-default-language)))))

         ;; 5.10: If it has an @direction key...
         (when (json-has-key? context "@direction")
           ;; 5.10.1
           (when (processing-mode-1.0? (jsonld-options-processing-mode options))
             (throw 'invalid-context-entry))
           (let ((value (assoc-ref context "@direction")))
             (if (equal? value #nil)
               ;; 5.10.2
               (set! result (update-active-context result #:direction #f))
               ;; 5.10.3
               (if (member value '("ltr" "rtl"))
                 (set! result (update-active-context result #:direction value))
                 (throw 'invalid-base-direction value)))))

         ;; 5.11: If it has an @propagate key...
         (when (json-has-key? context "@propagate")
           ;; 5.11.1
           (when (processing-mode-1.0? (jsonld-options-processing-mode options))
             (throw 'invalid-context-entry))
           ;; 5.11.2
           (unless (member (assoc-ref context "@propagate") '(#t #f))
             (throw 'invalid-@propagate-value)))

         ;; and now loop over key-value pair that are not @base, @vocab nor @language
         ;; 5.12
         (let ((defined '()))
           ;; 5.13
           (for-each-pair
             (lambda (key value)
               (unless (member key '("@base" "@direction" "@import" "@language"
                                     "@propagate" "@protected" "@version"
                                     "@vocab"))
                 (let* ((term-res (create-term-definition
                                    result context key defined
                                    #:base-url base-url
                                    #:protected? (assoc-ref context "@protected")
                                    #:override-protected? override-protected?
                                    #:remote-contexts remote-contexts
                                    #:validate-scoped-context? validate-scoped-context?
                                    #:options options)))
                   (set! defined (assoc-ref term-res "defined"))
                   (set! result (assoc-ref term-res "active-context")))))
             context)))
        ;; 5.3: if it's not a Json object
        (_ (throw 'invalid-local-context context))))
    local-context)
  result)