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

  #:use-module (json)

  #:use-module (jsonld download)

  #:use-module (jsonld iri)

  #:use-module (web client)

  #:use-module (web response)

  #:use-module (web uri)

  #:use-module (rnrs bytevectors)

  #:use-module (ice-9 match)

  #:use-module (srfi srfi-1)

  #:use-module (srfi srfi-9)

  #:export (absolute-iri?

            alist-set

            alist-remove

            alist-sort-by-key

            array-add

            array-append

            blank-node?

            for-each-pair

            gen-delim?

            graph-object?

            json-array?

            json-has-key?

            json-keyword?

            json-object?

            jsonld-error->string

            keyword-form?

            list-object?

            make-jsonld-options

            merge-json

            node-object?

            processing-mode-1.0?

            relative-iri?

            same-json?

            scalar?

            scalar-array?

            set-object?

            simple-graph-object?

            string-array?))

;; This module defines a bunch of functions used to test or modify json

;; documents.

(define-syntax for-each-pair

  (syntax-rules ()

    ((_ thunk alist)

     (for-each

       (match-lambda

         ((k . v) (thunk k v)))

       alist))))

(define (alist-set alist key value)

  "Return a new alist that is the same as @var{alist}, but whose @var{key}

is now associated with @var{value}.  This removes the old association of

@var{key} if any."

  (match alist

    (() (list (cons key value)))

    (((k . v) alist ...)

     (if (equal? k key)

       (cons (cons key value) alist)

       (cons (cons k v) (alist-set alist key value))))))

(define (alist-remove alist key)

  "Return a new alist that is the same as @var{alist}, but whose @var{key}

is not associated with anything anymore."

  (match alist

    (() '())

    (((k . v) alist ...)

     (if (equal? key k)

       alist

       (cons (cons k v) (alist-remove alist key))))))

(define (alist-key-less e1 e2)

  (match `(,e1 . ,e2)

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

     (string<=? k1 k2))))

(define* (alist-sort-by-key alist #:key (less alist-key-less))

  "Sort an alist @var{alist} by its keys."

  (sort alist less))

(define (scalar? v)

  "Whether a value is a scalar value, in the sense of the Json specification."

  (or (number? v) (string? v) (member v (list #t #f))))

(define (blank-node? node)

  "Whether a value is a blank node identifier, in the sense of the JsonLD

specification."

  (and (string? node) (> (string-length node) 1) (equal? (substring node 0 2) "_:")))

(define (json-keyword? k)

  "Whether a value @var{k} is a keyword, in the sense of the JsonLD specification,

version 1.1."

  (member

    k

    '(":" "@base" "@container" "@context" "@direction" "@graph" "@id" "@import"

      "@included" "@index" "@json" "@language" "@list" "@nest" "@none"

      "@prefix" "@propagate" "@protected" "@reverse" "@set" "@type" "@value"

      "@version" "@vocab")))

(define (json-array? v)

  "Whether a value is a Json array."

  (and (array? v) (not (string? v))))

(define (json-object? v)

  "Whether a value is a Json object."

  (and (list? v) (not (equal? v #nil))))

(define (json-has-key? obj key)

  "Whether a Json object @var{obj} has a @var{key}."

  (let loop ((obj obj))

    (match obj

      (((k . v) obj ...)

       (or (equal? k key) (loop obj)))

      (_ #f))))

(define (graph-object? v)

  (and (json-has-key? v "@graph")

       (null? (filter (lambda (kp) (not (member (car kp) '("@graph" "@id" "@index"))))

                      v))))

(define (simple-graph-object? v)

  (and (graph-object? v)

       (not (json-has-key? v "@id"))))

(define (list-object? v)

  (and (json-has-key? v "@list")

       (null? (filter (lambda (kp) (not (member (car kp) '("@list" "@index"))))

                      v))))

(define (set-object? v)

  (and (json-has-key? v "@list")

       (null? (filter (lambda (kp) (not (member (car kp) '("@list" "@index"))))

                      v))))

(define (absolute-iri? value)

  "Whether a value is an absolute IRI."

  (and (string? value)

       ;; XXX: actually, must be percent-encoded

       (not (string-any #\space value))

       ;; XXX: actually, this doesn't accept "ρ.ηλ" for instance

       (string->uri value)))

(define (relative-iri? value)

  "Whether a value is a relative IRI."

  (and (string? value) (string->uri-reference value)))

(define (string-array? v)

  (and (array? v) (null? (filter (lambda (v) (not (string? v))) (array->list v)))))

(define (scalar-array? v)

  (and (array? v) (null? (filter (lambda (v) (not (scalar? v))) (array->list v)))))

(define (array-add element array)

  (let ((array (or array #())))

    (list->array 1 (append (array->list array) (list element)))))

(define (array-append a1 a2)

  (let ((a1 (or a1 #()))

        (a2 (or a2 #())))

    (list->array 1 (append (array->list a1) (array->list a2)))))

(define (merge-json a b)

  (match b

    (() a)

    (((k . v) b ...)

     (if (json-has-key? a k)

         (merge-json a b)

         (merge-json (cons (cons k v) a) b)))))

(define (keyword-form? k)

  (and

    (string? k)

    (match (string->list k)

      (((? (lambda (k) (eq? k #\@)) l)

        (? (lambda (m) (char-set-contains? char-set:letter m)) m) ...)

       ;; only if there is actually something after @

       (> (string-length k) 1))

      (_ #f))))

(define (gen-delim? s)

  (string-every (char-set #\: #\/ #\? #\# #\[ #\] #\@) s))

(define (processing-mode-1.0? mode)

  (member mode '("jsonld-1.0" "json-ld-1.0")))

(define (node-object? o)

  (and (json-object? o)

       (not (json-has-key? o "@value"))

       (not (json-has-key? o "@list"))

       (not (json-has-key? o "@set"))))

(define (has-keys-of json other)

  (let loop ((json json) (result #t))

    (match json

      (#f (not other))

      (() result)

      (((key . value) json ...)

       (loop json (and result (same-json? value (assoc-ref other key))))))))

(define (has-same-values json other)

  (let loop ((json json) (other other) (result #t))

    (match json

      (() (if (null? other) result #f))

      ((v json ...)

       (match other

         (() #f)

         ((v2 other ...)

          (loop json other (and result (same-json? v v2)))))))))

(define (same-json? json other)

  "Compare two Json documents and returns whether they are the same, comparing

the keys, their values, their order and their presence in both documents."

  (match json

    ((? array? json)

     (and

       (array? other)

       (has-same-values (array->list json) (array->list other))))

    ((? list? json)

     (and (list? other) (has-keys-of json other) (has-keys-of other json)))

    (_ (equal? json other))))

(define (jsonld-error->string err)

  "Convert an error to a string."

  (match err

    ('colliding-keywords "colliding keywords")

    ('conflicting-indexes "conflicting indexes")

    ('cyclic-iri-mapping "cyclic IRI mapping")

    ('invalid-@id-value "invalid @id value")

    ('invalid-@index-value "invalid @index value")

    ('invalid-@nest-value "invalid @nest value")

    ('invalid-@prefix-value "invalid @prefix value")

    ('invalid-@propagate-value "invalid @propagate value")

    ('invalid-@protected-value "invalid @protected value")

    ('invalid-@reverse-value "invalid @reverse value")

    ('invalid-@import-value "invalid @import value")

    ('invalid-@version-value "invalid @version value")

    ('invalid-base-iri "invalid base IRI")

    ('invalid-base-direction "invalid base direction")

    ('invalid-container-mapping "invalid container mapping")

    ('invalid-context-entry "invalid context entry")

    ('invalid-context-nullification "invalid context nullification")

    ('invalid-default-language "invalid default language")

    ('invalid-@included-value "invalid @included value")

    ('invalid-iri-mapping "invalid IRI mapping")

    ('invalid-json-literal "invalid JSON literal")

    ('invalid-keyword-alias "invalid keyword alias")

    ('invalid-language-map-value "invalid language map value")

    ('invalid-language-mapping "invalid language mapping")

    ('invalid-language-tagged-string "invalid language-tagged string")

    ('invalid-language-tagged-value "invalid language-tagged value")

    ('invalid-local-context "invalid local context")

    ('invalid-remote-context "invalid remote context")

    ('invalid-reverse-property "invalid reverse property")

    ('invalid-reverse-property-map "invalid reverse property map")

    ('invalid-reverse-property-value "invalid reverse property value")

    ('invalid-scoped-context "invalid scoped context")

    ('invalid-script-element "invalid script element")

    ('invalid-set-or-list-object "invalid set or list object")

    ('invalid-term-definition "invalid term definition")

    ('invalid-type-mapping "invalid type mapping")

    ('invalid-type-value "invalid type value")

    ('invalid-typed-value "invalid typed value")

    ('invalid-value-object "invalid value object")

    ('invalid-value-object-value "invalid value object value")

    ('invalid-vocab-mapping "invalid vocab mapping")

    ('iri-confused-with-prefix "IRI confused with prefix")

    ('keyword-redefinition "keyword redefinition")

    ('loading-document-failed "loading document failed")

    ('loading-remote-context-failed "loading remote context failed")

    ('multiple-context-link-headers "multiple context link headers")

    ('processing-mode-conflict "processing mode conflict")

    ('protected-term-redefinition "protected term redefinition")

    ('context-overflow "context overflow")

    (_ (format #f "unknown error ~a" err))))