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

  #:use-module (jsonld context)

  #:use-module (jsonld context-processing)

  #:use-module (jsonld inverse-context-creation)

  #:use-module (jsonld iri-compaction)

  #:use-module (jsonld iri-expansion)

  #:use-module (jsonld json)

  #:use-module (jsonld value-compaction)

  #:export (compaction))

(define-syntax update-result

  (syntax-rules ()

    ((_ result nest-term nest-result)

     (set! result

       (if nest-term

           (alist-set result nest-term nest-result)

           nest-result)))))

(define (add-value object key value as-array?)

  (let* ((value (if (json-array? value)

                    (array->list value)

                    (list value)))

         (original (if (json-has-key? object key)

                       (assoc-ref object key)

                       #()))

         (original (if (json-array? original)

                       (array->list original)

                       (list original)))

         (new-value (append original value))

         (new-value

           (if (and (= (length new-value) 1) (not as-array?))

               (car new-value)

               (list->array 1 new-value))))

    (alist-set object key new-value)))

(define* (compaction active-context inverse-context active-property element

                     #:key (compact-arrays? #f) (ordered? #f) processing-mode)

  (pk 'compaction element)

  ;; 1

  (let ((type-scoped-context active-context)

        (def (term-definition-ref active-context active-property)))

    (cond

      ;; 2

      ((scalar? element)

       element)

      ;; 3

      ((json-array? element)

       ;; 3.1

       (let ((result '()))

         ;; 3.2

         (for-each

           (lambda (item)

             ;; 3.2.1

             (let ((compacted-item (compaction active-context inverse-context

                                               active-property item

                                               #:compact-arrays? compact-arrays?

                                               #:ordered? ordered?

                                               #:processing-mode processing-mode)))

               ;; 3.2.2

               (unless (json-null? compacted-item)

                 (set! result (cons compacted-item result)))))

           (array->list element))

         (set! result (reverse result))

         (if (let ((container-mapping

                     (container-mapping active-context active-property)))

               (or (not (= (length result) 1))

                   (equal? compact-arrays? #f)

                   (equal? active-property "@graph")

                   (equal? active-property "@set")

                   (member "@set" container-mapping)

                   (member "@list" container-mapping)))

             ;; 3.3

             (list->array 1 result)

             ;; 3.4

             (car result))))

      ;; 4

      (else

        ;; 5

        (when (not-null-or-false (active-context-previous active-context))

          (unless (or (json-has-key? element "@value")

                      (and (json-has-key? element "@id")

                           (null? (filter (lambda (kp) (not (equal? (car kp) "@id")))

                                          element))))

            (set! active-context (active-context-previous active-context))

            (set! inverse-context (inverse-context-creation active-context))))

        ;; 6

        (when (and (term-definition? def)

                   (not-null-or-false (term-definition-context def)))

          ;; 6.1

          (set! active-context

            (context-processing active-context (term-definition-context def)

                                (term-definition-base-url def)

                                #:override-protected? #t))

          ;; 6.2

          (set! inverse-context (inverse-context-creation active-context)))

        ;; 7

        (cond

          ((and (or (json-has-key? element "@value")

                    (json-has-key? element "@id"))

                (let ((compact

                      (value-compaction active-context inverse-context

                                        active-property element processing-mode)))

                  (or (scalar? compact)

                      (and (term-definition? def)

                           (equal? (term-definition-type def) "@json")))))

           (value-compaction active-context inverse-context active-property

                             element processing-mode))

          ;; 8

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

                (member "@list" (container-mapping active-context active-property)))

           (compaction active-context inverse-context active-property

                       (assoc-ref element "@list")

                       #:compact-arrays? compact-arrays?

                       #:ordered? ordered?))

          ;; 9 and 10

          (else

            (let ((inside-reverse? (equal? active-property "@reverse"))

                  (result '()))

              ;; 11

              (when (json-has-key? element "@type")

                (let* ((types (assoc-ref element "@type"))

                       (types (if (json-array? types)

                                  (array->list types)

                                  (list types)))

                       (compacted-types

                         (map

                           (lambda (type)

                             (iri-compaction active-context inverse-context type

                                             #:vocab? #t #:processing-mode processing-mode))

                           types)))

                  (pk 'compacted-types compacted-types)

                  (for-each

                    (lambda (term)

                      ;; 11.1

                      (when (and

                              (term-definition? (term-definition-ref type-scoped-context term))

                              (term-definition-context

                                (term-definition-ref type-scoped-context term)))

                        ;; 11.1.1

                        (set! active-context

                          (context-processing

                            active-context

                            (term-definition-context

                              (term-definition-ref type-scoped-context term))

                            (term-definition-base-url

                              (term-definition-ref type-scoped-context term))

                            #:propagate? #f))

                        ;; 11.1.2

                        (set! inverse-context

                          (inverse-context-creation active-context))))

                    (sort compacted-types string<=?))))

              ;; 12

              (for-each-pair

                (lambda (expanded-property expanded-value)

                  (set! result

                    (step-12 active-context inverse-context expanded-property

                             expanded-value result compact-arrays? ordered?

                             inside-reverse? type-scoped-context active-property

                             processing-mode)))

                (if ordered?

                    (alist-sort-by-key element)

                    element))

              ;; 13

              result)))))))

(define (step-12 active-context inverse-context expanded-property expanded-value

                 result compact-arrays? ordered? inside-reverse? type-scoped-context

                 active-property processing-mode)

  (cond

    ;; 12.1

    ((equal? expanded-property "@id")

     (pk 'expanded-value expanded-value)

     ;; XXX: not clear what to do if expanded-value is not a

     ;; string, make sure there is a test

     (let ((compacted-value

             (if (string? expanded-value)

                 (iri-compaction active-context inverse-context expanded-value

                                 #:vocab? #f #:processing-mode processing-mode)

                 expanded-value))

           (alias (iri-compaction active-context inverse-context expanded-property

                                  #:vocab? #t #:processing-mode processing-mode)))

       (pk 'compacted-value compacted-value)

       (pk 'alias alias)

       (set! result

         (alist-set result alias compacted-value))))

    ;; 12.2

    ((equal? expanded-property "@type")

     (let* ((compacted-value #f)

            (alias (iri-compaction active-context inverse-context expanded-property

                                   #:vocab? #t #:processing-mode processing-mode))

            (as-array?

              (or 

                (and

                  (not (processing-mode-1.0? processing-mode))

                  (member "@set" (container-mapping active-context alias)))

                (not compact-arrays?)))

            (type-scoped-inverse-context

              (inverse-context-creation type-scoped-context)))

       (pk 'alias alias)

       (if (string? expanded-value)

           (set! compacted-value

             (iri-compaction type-scoped-context type-scoped-inverse-context

                             expanded-value

                             #:vocab? #t #:processing-mode processing-mode))

           (begin

             (set! expanded-value (array->list expanded-value))

             (set! compacted-value

               (list->array 1

                 (map

                   (lambda (v)

                     (pk 'v (iri-compaction type-scoped-context type-scoped-inverse-context

                                     v

                                     #:vocab? #t #:processing-mode processing-mode)))

                   expanded-value)))))

       (pk 'compacted-value compacted-value)

       (when (and (json-array? compacted-value) (= (array-length compacted-value) 1))

         (set! compacted-value (car (array->list compacted-value))))

       (set! result

         (add-value result alias compacted-value as-array?))))

    ;; 12.3

    ((equal? expanded-property "@reverse")

     (let ((compacted-value

             (compaction active-context inverse-context "@reverse" expanded-value

                         #:compact-arrays? compact-arrays? #:ordered? ordered?)))

       ;; 12.3.2

       (for-each-pair

         (lambda (property value)

           (let ((def (term-definition-ref active-context property)))

             (when (and (term-definition? def) (term-definition-reverse? def))

               (let ((as-array? (or

                                  (member "@set"

                                          (container-mapping active-context property))

                                  (not compact-arrays?))))

                 (set! result

                   (add-value result property value as-array?)))

               (set! compacted-value

                 (alist-remove compacted-value property)))))

         compacted-value)

       ;; 12.3.3

       (unless (null? compacted-value)

         (let ((alias (iri-compaction active-context inverse-context "@reverse"

                                      #:vocab? #t #:processing-mode processing-mode)))

           (pk 'alias alias)

           (set! result (alist-set result alias compacted-value))))))

    ;; 12.4

    ((equal? expanded-property "@preserve")

     (let ((compacted-value

             (compaction active-context inverse-context active-property

                         expanded-value #:compact-arrays? compact-arrays?

                         #:ordered? ordered?)))

       (unless (equal? expanded-value #())

         (set! result (alist-set result "@preserve" compacted-value)))))

    ;; 12.5

    ((and (equal? expanded-property "@index")

          (member "@index"

                  (container-mapping active-context active-property)))

     #t)

    ;; 12.6

    ((or (equal? expanded-property "@direction")

         (equal? expanded-property "@index")

         (equal? expanded-property "@language")

         (equal? expanded-property "@value"))

      (let ((alias (iri-compaction active-context inverse-context expanded-property

                                   #:vocab? #t #:processing-mode processing-mode)))

        (pk 'alias alias)

        (set! result

          (alist-set result alias expanded-value))))

    (else

      ;; 12.7

      (when (equal? expanded-value #())

        (let* ((item-active-property

                 (iri-compaction active-context inverse-context expanded-property

                                 #:value expanded-value

                                 #:vocab? #t

                                 #:reverse? inside-reverse?

                                 #:processing-mode processing-mode))

               (def (term-definition-ref active-context

                                         item-active-property))

               (nest-term (if (term-definition? def) (term-definition-nest def) #f))

               ;; 12.7.4

               (nest-result result))

          (pk 'item-active-property item-active-property)

          ;; 12.7.2

          (when nest-term

            (unless (or (equal? nest-term "@nest")

                        (equal? (expand-key active-context nest-term)

                                "@nest"))

              (throw 'invalid-@nest-value))

            (set! nest-result

              (if (json-has-key? result nest-term)

                  (assoc-ref result nest-term)

                  '())))

          ;; 12.7.4

          (set! nest-result

            (add-value nest-result item-active-property #() #t))

          (update-result result nest-term nest-result)))

      ;; 12.8

      (for-each

        (lambda (expanded-item)

          (let* ((item-active-property

                   (iri-compaction

                     active-context inverse-context expanded-property

                     #:value expanded-item

                     #:vocab? #t

                     #:reverse? inside-reverse?

                     #:processing-mode processing-mode))

                 (def (term-definition-ref active-context item-active-property))

                 (nest-term (if (term-definition? def) (term-definition-nest def) #f))

                 ;; 12.8.3

                 (nest-result result)

                 ;; 12.8.4

                 (container (container-mapping active-context item-active-property))

                 ;; 12.8.5

                 (as-array? (or (member "@set" container)

                                (equal? item-active-property "@list")

                                (equal? item-active-property "@graph")

                                (not compact-arrays?)))

                 ;; 12.8.6

                 (compacted-item

                   (compaction active-context inverse-context item-active-property

                               (if (json-has-key? expanded-item  "@list")

                                   (assoc-ref expanded-item "@list")

                                   (if (graph-object? expanded-item)

                                       (assoc-ref expanded-item "@graph")

                                       expanded-item))

                               #:compact-arrays? compact-arrays?

                               #:ordered? ordered?)))

            (pk 'item-active-property item-active-property)

            ;; 12.8.2

            (when (not-null-or-false nest-term)

              (unless (or (equal? nest-term "@nest")

                          (equal? (expand-key active-context nest-term) "@nest"))

                (throw 'invalid-@nest-value))

              (set! nest-result

                (if (json-has-key? result nest-term)

                    (assoc-ref result nest-term)

                    '())))

            (cond

              ;; 12.8.7

              ((json-has-key? expanded-item "@list")

               ;; 12.8.7.1

               (unless (json-array? compacted-item)

                 (set! compacted-item `#(,compacted-item)))

               (if (member "@list" container)

                 ;; 12.8.7.3

                 (set! nest-result

                   (alist-set nest-result item-active-property compacted-item))

                 ;; 12.8.7.2

                 (begin

                   (set! compacted-item

                     `((,(iri-compaction active-context inverse-context

                                         "@list" #:vocab? #t

                                         #:processing-mode processing-mode) .

                         ,compacted-item)))

                   (when (json-has-key? expanded-item "@index")

                     (set! compacted-item

                       (alist-set

                         compacted-item

                         (iri-compaction active-context inverse-context

                                         "@index" #:vocab? #t

                                         #:processing-mode processing-mode)

                         (assoc-ref expanded-item "@index"))))

                   (set! nest-result

                     (add-value nest-result item-active-property compacted-item

                                as-array?))))

               (update-result result nest-term nest-result))

              ;; 12.8.8

              ((graph-object? expanded-item)

               (cond

                 ;; 12.8.8.1

                 ((and (member "@id" container)

                       (member "@graph" container))

                  (let* ((map-object

                           (or (not-null-or-false (assoc-ref nest-result item-active-property)) '()))

                         (map-key

                           (if (json-has-key? expanded-item "@id")

                               (assoc-ref expanded-item "@id")

                               "@none"))

                         (map-key

                           (iri-compaction

                             active-context inverse-context map-key

                             #:vocab? (not (json-has-key? expanded-item "@id"))

                             #:processing-mode processing-mode)))

                    ;; 12.8.8.1.3

                    (set! map-object

                      (add-value map-object map-key compacted-item as-array?))

                    (set! nest-result

                      (alist-set nest-result item-active-property map-object))

                    (update-result result nest-term nest-result)))

                 ;; 12.8.8.2

                 ((and (member "@graph" container)

                       (member "@index" container)

                       (simple-graph-object? expanded-item))

                  (let ((map-object

                          (or (not-null-or-false (assoc-ref nest-result item-active-property)) '()))

                        (map-key

                          (if (json-has-key? expanded-item "@index")

                              (assoc-ref expanded-item "@index")

                              "@none")))

                    ;; 12.8.8.2.3

                    (set! map-object

                      (add-value map-object map-key compacted-item as-array?))

                    (set! nest-result

                      (alist-set nest-result item-active-property map-object))

                    (update-result result nest-term nest-result)))

                 ;; 12.8.8.3

                 ((and (member "@graph" container)

                       (simple-graph-object? expanded-item))

                  (when (and (json-array? compacted-item)

                             (> (array-length compacted-item) 1))

                    (set! compacted-item

                      `((,(iri-compaction active-context inverse-context "@included"

                                          #:vocab? #t #:processing-mode processing-mode) .

                         ,compacted-item))))

                  (set! nest-result

                    (add-value nest-result item-active-property compacted-item

                               as-array?))

                  (update-result result nest-term nest-result))

                 ;; 12.8.8.4

                 (else

                   ;; 12.8.8.4.1

                   (set! compacted-item

                     `((,(iri-compaction active-context inverse-context "@graph"

                                         #:vocab? #t #:processing-mode processing-mode) .

                        ,compacted-item)))

                   ;; 12.8.8.4.2

                   (when (json-has-key? expanded-item "@id")

                     (set! compacted-item

                       (alist-set

                         compacted-item

                         (iri-compaction active-context inverse-context "@id"

                                         #:vocab? #t

                                         #:processing-mode processing-mode)

                         (iri-compaction active-context inverse-context

                                         (assoc-ref expanded-item "@id")

                                         #:vocab? #f

                                         #:processing-mode processing-mode))))

                   ;; 12.8.8.4.3

                   (when (json-has-key? expanded-item "@index")

                     (set! compacted-item

                       (alist-set

                         compacted-item

                         (iri-compaction active-context inverse-context "@index"

                                         #:vocab? #t

                                         #:processing-mode processing-mode)

                         (assoc-ref expanded-item "@index"))))

                   ;; 12.8.8.4.4

                   (set! nest-result

                     (add-value nest-result item-active-property compacted-item

                                as-array?))

                   (update-result result nest-term nest-result))))

              ;; 12.8.9

              ((and (not (member "@graph" container))

                    (or (member "@language" container)

                        (member "@index" container)

                        (member "@id" container)

                        (member "@type" container)))

               ;; 12.8.9.1

               (let* ((map-object (or (assoc-ref nest-result item-active-property)

                                      '()))

                      ;; 12.8.9.2

                      (container-key (iri-compaction active-context inverse-context

                                                     (cond

                                                       ((member "@language" container) "@language")

                                                       ((member "@index" container) "@index")

                                                       ((member "@id" container) "@id")

                                                       (else "@type"))

                                                     #:vocab? #t))

                      (map-key json-null)

                      ;; 12.8.9.3

                      (def (term-definition-ref active-context item-active-property))

                      (index-key (or (and (term-definition? def)

                                          (term-definition-index def))

                                     "@index")))

                 (cond

                   ;; 12.8.9.4

                   ((and (member "@language" container)

                         (json-has-key? expanded-item "@value"))

                    (set! compacted-item (assoc-ref expanded-item "@value"))

                    (when (json-has-key? expanded-item "@language")

                      (set! map-key (assoc-ref expanded-item "@language"))))

                   ;; 12.8.9.5

                   ((and (member "@index" container)

                         (equal? index-key "@index"))

                    (when (json-has-key? expanded-item "@index")

                      (set! map-key (assoc-ref expanded-item "@index"))))

                   ;; 12.8.9.6

                   ((member "@index" container)

                    ;; 12.8.9.6.1

                    (set! container-key

                      (iri-compaction active-context inverse-context index-key

                                      #:vocab? #t))

                    ;; 12.8.9.6.2

                    (let* ((keys (assoc-ref compacted-item container-key))

                           (keys (if (json-array? keys)

                                     (array->list keys)

                                     (list keys)))

                           (key (and (not (null? keys)) (not-null-or-false (car keys))))

                           (remaining (if key (cdr keys) '())))

                      (when key

                        (unless (string? key)

                          (set! remaining keys)

                          (set! key #f))

                        (when key

                          (set! map-key key)))

                      ;; 12.8.9.6.3

                      (if (null? remaining)

                          (when (json-has-key? compacted-item container-key)

                            (set! compacted-item

                              (alist-remove compacted-item container-key)))

                          (set! compacted-item

                            (alist-set compacted-item container-key

                                       (if (= (length remaining) 1)

                                           (car remaining)

                                           (list->array 1 remaining)))))))

                   ;; 12.8.9.7

                   ((member "@id" container)

                    (when (json-has-key? compacted-item container-key)

                      (set! map-key (assoc-ref compacted-item container-key))

                      (set! compacted-item (alist-remove compacted-item container-key))))

                   ;; 12.8.9.8

                   ((member "@type" container)

                    (let* ((keys (assoc-ref compacted-item container-key))

                           (keys (if (json-array? keys)

                                     (array->list keys)

                                     (list keys)))

                           (key (and (not (null? keys)) (not-null-or-false (car keys))))

                           (remaining (if key (cdr keys) '())))

                      ;; 12.8.9.8.1

                      (when (not-null-or-false key)

                        (set! map-key key))

                      ;; 12.8.9.8.2

                      (if (null? remaining)

                          (set! compacted-item

                            (alist-remove compacted-item container-key))

                          (set! compacted-item

                            (alist-set compacted-item container-key

                                       (if (= (length remaining) 1)

                                           (car remaining)

                                           (list->array 1 remaining)))))

                      (when (and (= (length compacted-item) 1)

                                 (equal?

                                   (expand-key active-context (car (car compacted-item)))

                                   "@id"))

                        (set! compacted-item

                          (compaction

                            active-context inverse-context item-active-property

                            `(("@id" . ,(assoc-ref expanded-item "@id")))))))))

                 ;; 12.8.9.9

                 (when (json-null? map-key)

                   (set! map-key (iri-compaction active-context inverse-context

                                                 "@none" #:vocab? #t)))

                 ;; 12.8.9.10

                 (set! map-object

                   (add-value map-object map-key compacted-item as-array?))

                 (set! nest-result

                   (alist-set nest-result item-active-property map-object))

                 (update-result result nest-term nest-result)))

              ;; 12.8.10

              (else

                (set! nest-result

                  (add-value nest-result item-active-property

                             compacted-item as-array?))

                (update-result result nest-term nest-result)))))

        (array->list expanded-value))))

  result)