;;;; 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 serialize-rdf)
  #:use-module (ice-9 match)
  #:use-module (iri iri)
  #:use-module (jsonld deserialize-jsonld)
  #:use-module (jsonld json)
  #:use-module (jsonld object-to-rdf)
  #:use-module (jsonld rdf-to-object)
  #:use-module (json)
  #:use-module ((rdf rdf) #:hide (blank-node?))
  #:use-module ((rdf rdf) #:select (blank-node?) #:prefix rdf:)
  #:use-module (srfi srfi-1)
  #:export (serialize-rdf))

(define (uniq lst)
  (match lst
    (() '())
    ((element lst ...)
     (if (member element lst)
         (uniq lst)
         (cons element (uniq lst))))))

(define (jsonld-ref object spec)
  (match spec
    (() object)
    (((? string? key) spec ...)
     (jsonld-ref (assoc-ref object key) spec))
    (((? number? key) spec ...)
     (jsonld-ref (if (array? object) (array-ref object key) #f) spec))))

(define (jsonld-set object spec value)
  (match spec
    (() value)
    (((? string? key) spec ...)
     (alist-set object key (jsonld-set (assoc-ref object key) spec value)))
    (((? number? key) spec ...)
     (array-set! object (jsonld-set (array-ref object key) spec value) key)
     object)))

(define (convert-blank-nodes dataset)
  (define (node-convert-blank-nodes node)
    (if (rdf:blank-node? node)
        (string-append "_:b" (number->string node))
        node))

  (define (graph-convert-blank-nodes graph)
    (map
      (match-lambda
        (($ rdf-triple subject predicate object)
         (make-rdf-triple
           (node-convert-blank-nodes subject)
           (node-convert-blank-nodes predicate)
           (node-convert-blank-nodes object))))
      graph))

  (make-rdf-dataset
    (graph-convert-blank-nodes (rdf-dataset-default-graph dataset))
    (map
      (lambda (ng)
        (cons (car ng)
              (graph-convert-blank-nodes (cdr ng))))
      (rdf-dataset-named-graphs dataset))))

(define (single-element-array? object)
  (and (array? object) (not (string? object))
       (equal? (array-length object) 1)))

(define* (serialize-rdf dataset
                        #:key
                        ordered? rdf-direction use-native-types? use-rdf-type?
                        processing-mode)
  (set! dataset (convert-blank-nodes dataset))
  (set! dataset
    (make-rdf-dataset
      (uniq (rdf-dataset-default-graph dataset))
      (map
        (lambda (ng)
          (cons (car ng)
                (uniq (cdr ng))))
        (rdf-dataset-named-graphs dataset))))
  ;; 1
  (let ((default-graph '())
        ;; 2
        (graph-map `(("@default" . ())))
        ;; 3
        (referenced-once '())
        ;; 4
        (compound-literal-subjects '()))
    ;; 5
    (for-each-pair
      (lambda (name graph)
        ;; 5.2
        (unless (json-has-key? graph-map name)
          (set! graph-map (alist-set graph-map name '())))
        ;; 5.3
        (unless (json-has-key? compound-literal-subjects name)
          (set! compound-literal-subjects
            (alist-set compound-literal-subjects name '())))
        (set! default-graph (assoc-ref graph-map "@default"))
        ;; 5.4
        (unless (or (equal? name "@default")
                    (json-has-key? default-graph name))
          (set! default-graph (alist-set (assoc-ref graph-map "@default")
                                         name `(("@id" . ,name))))
          (set! graph-map (alist-set graph-map "@default" default-graph)))
        ;; 5.5
        (let ((node-map (assoc-ref graph-map name))
              ;; 5.6
              (compound-map (assoc-ref compound-literal-subjects name)))
          (for-each
            (match-lambda
              (($ rdf-triple subject predicate object)
               ;; 5.7.1
               (unless (json-has-key? node-map subject)
                 (set! node-map (alist-set node-map subject `(("@id" . ,subject)))))
                 ;; 5.7.2
               (let ((node-ref (list name subject))
                     (node (assoc-ref node-map subject))
                     (continue? #t))
                 ;; 5.7.3
                 (when (and (equal? rdf-direction "compound-literal")
                            (equal? predicate (rdf-iri "direction")))
                   (set! compound-map (alist-set compound-map subject #t)))
                 (when (or (absolute-iri? object) (blank-node? object))
                   ;; 5.7.4
                   (unless (json-has-key? node-map object)
                     (set! node-map (alist-set node-map object `(("@id" . ,object)))))
                   ;; 5.7.5
                   (when (and (equal? predicate (rdf-iri "type"))
                              (not use-rdf-type?))
                     (let* ((types (or (assoc-ref node "@type") #()))
                            (types (array->list types))
                            (types (if (member object types)
                                       types
                                       (append types (list object))))
                            (types (list->array 1 types)))
                       (set! node (alist-set node "@type" types))
                       (set! node-map (alist-set node-map subject node))
                       (set! continue? #f))))
                 ;; 5.7.6
                 (when continue?
                   (let* ((value (rdf-to-object object rdf-direction use-native-types?
                                                #:processing-mode
                                                processing-mode))
                          (value-ref (append node-ref (list predicate)))
                          ;; 5.7.7
                          (node-value (or (assoc-ref node predicate) #()))
                          (node-value (array->list node-value)))
                     ;; 5.7.8
                     (let loop ((nodes node-value) (num 0))
                       (match nodes
                         (()
                          (set! node-value (cons value node-value))
                          (set! value-ref (append value-ref (list num))))
                         ((n nodes ...)
                          (if (identical-json? value n)
                              (set! value-ref (append value-ref (list num)))
                              (loop nodes (1+ num))))))
                     ;; 5.7.7
                     (set! node (alist-set node predicate (list->array 1 node-value)))
                     (set! node-map (alist-set node-map subject node))
                     (cond
                        ;; 5.7.9
                       ((equal? object (rdf-iri "nil"))
                        (let* ((usages (or (assoc-ref (assoc-ref node-map object)
                                                      "usages")
                                           #()))
                               (usages (array->list usages)))
                          (set! usages
                            (append
                              usages
                              (list `(("node" . ,node-ref)
                                      ("property" . ,predicate)
                                      ("value" . ,value-ref)))))
                          (set! node-map
                            (jsonld-set
                              node-map (list object "usages")
                              (list->array 1 usages)))))
                       ;; 5.7.10
                       ((json-has-key? referenced-once object)
                        (set! referenced-once
                          (alist-set referenced-once object #f)))
                       ((blank-node? object)
                        (set! referenced-once
                          (alist-set referenced-once object
                                     `(("node" . ,node-ref)
                                       ("property" . ,predicate)
                                       ("value" . ,value-ref)))))))))))
            graph)
          (set! graph-map (alist-set graph-map name node-map))
          (set! compound-literal-subjects
            (alist-set compound-literal-subjects name compound-map))))
      (cons (cons "@default" (rdf-dataset-default-graph dataset))
            (rdf-dataset-named-graphs dataset)))
    (set! default-graph (assoc-ref graph-map "@default"))
    ;; 6
    (for-each-pair
      (lambda (name graph-object)
        ;; 6.1
        (when (list? (assoc-ref compound-literal-subjects name))
          (for-each-pair
            (lambda (cl _)
              ;; 6.1.1
              (let ((cl-entry (assoc-ref referenced-once cl)))
                (when (list? cl-entry)
                  ;; 6.1.2
                  (let* ((node-ref (assoc-ref cl-entry "node"))
                         (node (jsonld-ref graph-map node-ref))
                         ;; 6.1.3
                         (property (assoc-ref cl-entry "property"))
                         ;; 6.1.4
                         (value-ref (assoc-ref cl-entry "value"))
                         (value (jsonld-ref graph-map value-ref))
                         ;; 6.1.5
                         (cl-node (assoc-ref graph-object cl)))
                    (set! graph-object (alist-remove graph-object cl))
                    (when (equal? name "@default")
                      (set! default-graph graph-object))
                    (set! graph-map (alist-set graph-map name graph-object))
                    (when (list? cl-node)
                      ;; 6.1.6
                      (let* ((refs (array->list (assoc-ref node property))))
                        (set! refs
                          (map
                            (lambda (cl-reference)
                              (when (equal? (assoc-ref cl-reference "@id") cl)
                                ;; 6.1.6.1
                                (set! cl-reference (alist-remove cl-reference "@id"))
                                ;; 6.1.6.2
                                (let* ((value (assoc-ref cl-node (rdf-iri "value")))
                                       (value (array-ref value 0))
                                       (value (assoc-ref value "@value")))
                                  (set! cl-reference
                                    (alist-set cl-reference "@value" value)))
                                ;; 6.1.6.3
                                (let ((language (assoc-ref cl-node (rdf-iri "language"))))
                                  (when language
                                    (let* ((language (array-ref language 0))
                                           (language (assoc-ref language "@value")))
                                      (set! cl-reference
                                        (alist-set cl-reference "@language" language))
                                      (unless (well-formed-language-tag? language)
                                        (throw 'invalid-language-tagged-string language)))))
                                ;; 6.1.6.4
                                (let ((direction (assoc-ref cl-node (rdf-iri "direction"))))
                                  (when direction
                                    (let* ((direction (array-ref direction 0))
                                           (direction (assoc-ref direction "@value")))
                                      (set! cl-reference
                                        (alist-set cl-reference "@direction" direction))
                                      (unless (member direction '("ltr" "rtl"))
                                        (throw 'invalid-base-direction direction))))))
                              cl-reference)
                            refs))
                        (set! node (alist-set node property (list->array 1 refs))))
                      (set! graph-map (jsonld-set graph-map node-ref node)))))))
            (assoc-ref compound-literal-subjects name)))
        ;; 6.2
        (when (json-has-key? graph-object (rdf-iri "nil"))
          ;; 6.3
          (let* ((nil (assoc-ref graph-object (rdf-iri "nil")))
                 (usages (array->list (or (assoc-ref nil "usages") #()))))
            (set! usages
              (sort usages (lambda (a b)
                             (or (not (equal? (assoc-ref a "node") (assoc-ref b "node")))
                                 (and (equal? (assoc-ref a "property") (rdf-iri "first"))
                                      (equal? (assoc-ref b "property") (rdf-iri "rest")))))))
            ;; 6.4
            (for-each
              (lambda (usage)
                (let* ((node-ref (assoc-ref usage "node"))
                       (node (jsonld-ref graph-map node-ref))
                       (property (assoc-ref usage "property"))
                       (head-ref (assoc-ref usage "value"))
                       (head (jsonld-ref graph-map head-ref))
                       ;; 6.4.2
                       (lst '())
                       (list-nodes '()))
                  ;; 6.4.3
                  (let loop ()
                    (when (and (equal? property (rdf-iri "rest"))
                               (blank-node? (assoc-ref node "@id"))
                               (list? (assoc-ref referenced-once
                                                 (assoc-ref node "@id")))
                               (single-element-array? (assoc-ref node (rdf-iri "first")))
                               (single-element-array? (assoc-ref node (rdf-iri "rest")))
                               (null? (filter
                                        (lambda (e)
                                          (not (member (car e) 
                                                       (list (rdf-iri "first")
                                                             (rdf-iri "rest")
                                                             "@type"
                                                             "@id"))))
                                        node))
                               (or (not (json-has-key? node "@type"))
                                   (null?
                                     (filter
                                       (lambda (t)
                                         (not (equal? t (rdf-iri "List"))))
                                       (array->list (assoc-ref node "@type"))))))
                      ;; 6.4.3.1
                      (set! lst
                        (cons (array-ref (assoc-ref node (rdf-iri "first")) 0)
                              lst))
                      ;; 6.4.3.2
                      (set! list-nodes
                        (cons (assoc-ref node "@id") list-nodes))
                      ;; 6.4.3.3
                      (let ((node-usage (assoc-ref referenced-once
                                                   (assoc-ref node "@id"))))
                        ;; 6.4.3.4
                        (set! node-ref (assoc-ref node-usage "node"))
                        (set! node (jsonld-ref graph-map node-ref))
                        (set! property (assoc-ref node-usage "property"))
                        (set! head-ref (assoc-ref node-usage "value"))
                        (set! head (jsonld-ref graph-map head-ref))
                        (loop))))
                  ;; 6.4.4
                  (set! head (alist-remove head "@id"))
                  ;; 6.4.6
                  (set! head (alist-set head "@list" (list->array 1 lst)))
                  (set! graph-map (jsonld-set graph-map head-ref head))
                  ;; 6.4.7
                  (for-each
                    (lambda (node-id)
                      (set! graph-object (alist-remove graph-object node-id))
                      (when (equal? name "@default")
                        (set! default-graph graph-object))
                      (set! graph-map (alist-set graph-map name graph-object)))
                    list-nodes)))
              usages))))
      graph-map)
    (set! default-graph (assoc-ref graph-map "@default"))
    ;; 7
    (let ((result '()))
      ;; 8
      (for-each-pair
        (lambda (subject node)
          ;; 8.1
          (when (json-has-key? graph-map subject)
            (let ((new-graph '()))
              (for-each-pair
                (lambda (s n)
                  ;; 8.1.2
                  (unless (null? (filter
                                   (lambda (e)
                                     (not (member (car e) '("usages" "@id"))))
                                   n))
                    (set! new-graph
                      (append new-graph (list (alist-remove n "usages"))))))
                (if ordered?
                    (alist-sort-by-key (or (assoc-ref graph-map subject) '()))
                    (or (assoc-ref graph-map subject) '())))
              ;; 8.1.1
              (set! node (alist-set node "@graph" (list->array 1 new-graph)))))
          ;; 8.2
          (unless (null? (filter
                           (lambda (e)
                             (not (member (car e) '("usages" "@id"))))
                           node))
            (set! result
              (append result (list (alist-remove node "usages"))))))
        (if ordered?
            (alist-sort-by-key default-graph)
            default-graph))
      ;; 9
      (list->array 1 result))))