(module (wald json)

(open-connection close-connection call-with-transaction
 query-filters query-species)

(import scheme)
(import (chicken base))
(import (srfi 1))
(import (srfi 69))
(import medea)

(define-record connection path config json)
(define-record transaction connection)

(define (open-connection path #!optional (config '()))
  (let ((json (call-with-input-file path read-json)))
    (make-connection path config json)))

(define (call-with-transaction connection proc)
  (proc (make-transaction connection)))

(define (close-connection connection) #f)

(define (vector-for-each proc vec)
  (let ((len (vector-length vec)))
    (let loop ((i 0))
      (when (< i len)
        (proc (vector-ref vec i))
        (loop (add1 i))))))

(define (vector-any pred vec)
  (let ((len (vector-length vec)))
    (let loop ((i 0))
      (if (< i len)
          (let ((item (vector-ref vec i)))
            (or (pred item)
                (loop (add1 i))))
          #f))))

(define (unique list)
  (let ((dedup (make-hash-table)))
    (for-each (lambda (item)
                (hash-table-set! dedup item #t))
              list)
    (hash-table-keys dedup)))

(define (query-filters tx)
  (define (make-cons value)
    (lambda (values)
      (cons value values)))
  (let ((filters (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((attrs (alist-delete 'title (cdr item)))
              (attrs (alist-delete 'name attrs)))
         (for-each
          (lambda (attr)
            (let ((key (symbol->string (car attr)))
                  (values (cdr attr)))
              (vector-for-each
               (lambda (value)
                 (hash-table-update!/default filters key (make-cons value) '()))
               values)))
          attrs)))
     (connection-json (transaction-connection tx)))
    (hash-table-walk filters (lambda (key value)
                               (hash-table-set! filters key (unique value))))
    (append-map (lambda (item)
                  (let ((key (car item))
                        (values (cdr item)))
                    (map (lambda (value)
                           (list key value))
                         values)))
                (hash-table->alist filters))))

(define (group-by key-proc items)
  (define (make-cons value)
    (lambda (values)
      (cons value values)))
  (let ((grouped (make-hash-table)))
    (for-each
     (lambda (item)
       (let ((key (key-proc item)))
         (hash-table-update!/default grouped key (make-cons item) '())))
     items)
    (hash-table->alist grouped)))

(define (query-species tx filters)
  (let ((grouped (group-by car filters)))
    (filter-map
     (lambda (meta)
       (let ((id (symbol->string (car meta)))
             (attrs (cdr meta)))
         (every
          (lambda (group)
            (let* ((key (string->symbol (car group)))
                   (values (map cadr (cdr group)))
                   (match (alist-ref key attrs)))
              (and match
                   (vector-any (lambda (value)
                                 (member value values))
                               match)
                   (alist-ref 'title (cdr meta)))))
          grouped)))
     (connection-json (transaction-connection tx)))))

)