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