(module sqdb
(open-database
 close-database
 call-with-database
 fetch store add add*
 exists?
 incr decr
 update
 delete
 with-transaction begin-transaction commit rollback
 set-busy-timeout!
 sqdb-handle

 list-keys
 map-items
 for-each-item
 fold-items
 fetch-alist         ;; convenience
 fetch-hash-table    ;; convenience
 )

;; TODO: Probably need own database record to hold precompiled SQL / hash table name
;; if we want to support multiple hash tables per database.
 
(import scheme chicken)
(use (prefix sql-de-lite sdl:))
(use (only sql-de-lite query sql exec fetch-value))
(use (only data-structures alist-ref))
(use (only srfi-69 make-hash-table hash-table-set!))   ;; for fetch-hash-table

;;; syntax

(define-syntax begin0                 ; multiple values discarded
    (syntax-rules () ((_ e0 e1 ...)
                      (let ((tmp e0)) e1 ... tmp))))

;;; main
(define (sqdb-handle db)
  db)

(define (open-database file)
  (let ((db (sdl:open-database file)))
    ;; Type BLOB lets us store and retrieve integer, real, blob, and text values without conversion.
    ;; Type TEXT always converts to text or blob, and type NUMERIC prefers numbers (when possible).
    (exec (sql db "CREATE TABLE IF NOT EXISTS sqdb_ht_1(k TEXT PRIMARY KEY, v BLOB);"))
    db))
(define (close-database db)
  (sdl:close-database db))

(define (call-with-database filename proc)
  (let ((db (open-database filename)))
    (let ((c (current-exception-handler)))
      (begin0
          (with-exception-handler
           (lambda (ex) (close-database db) (c ex))
           (lambda () (proc db)))
        (close-database db)))))

(define-inline (->key k) (if (symbol? k) (##sys#symbol->string k) k))

(define (fetch db k)
  (let ((k (->key k)))
    ;; query fetch-value nicer, but needs unreleased sql-de-lite
    (sdl:first-column (exec (sql db "SELECT v FROM sqdb_ht_1 WHERE k=?") k))))
(define (store db k v)
  (let ((k (->key k)))
    (exec (sql db "INSERT OR REPLACE INTO sqdb_ht_1(k,v) VALUES(?,?)")
          k v)
    (void)))

(define (add db k v)       ;; add or return #f
  (let ((k (->key k)))
    (or (= 1 (exec (sql db "INSERT OR IGNORE INTO sqdb_ht_1(k,v) VALUES(?,?)")
                   k v)))))
;; Note: since fetch does not throw error, perhaps add should not either. 
(define (add* db k v)
  (or (add db k v)
      (error 'add* "key already exists" db k)))
;; (define (add db k v)        ;; add or throw sqlite error
;;   (let ((k (->key k)))
;;     (exec (sql db "INSERT INTO sqdb_ht_1(k,v) VALUES(?,?)")
;;           k v)))

(define (exists? db k)
  (let ((k (->key k)))
    (and 
     (query fetch-value (sql db "SELECT 1 FROM sqdb_ht_1 WHERE k=?") k)
     #t)))

;; increment or decrement k by n (default 1); returns #t if key exists, #f if not (e.g. no changes made).
(define (incr db k #!optional (n 1))
  (let ((k (->key k)))
    (and (= 1 (exec (sql db "UPDATE sqdb_ht_1 SET V=V+? WHERE K=?") n k))
         #t)))
(define (decr db k #!optional (n 1))           ;; convenience; or use incr with negative
  (let ((k (->key k)))
    (and (= 1 (exec (sql db "UPDATE sqdb_ht_1 SET V=V-? WHERE K=?") n k))
         #t)))

;; proc will receive #f if the key did not exist.
(define (update db k proc)
  (sdl:with-immediate-transaction
   db (lambda ()
        (store db k
               (proc (fetch db k))))))

(define (delete db k)
  (let ((k (->key k)))
    (and (= 1 (exec (sql db "DELETE FROM sqdb_ht_1 WHERE k=?") k)) #t)))

;; I wonder what the default type should be
(define (with-transaction db thunk #!optional (type 'deferred))
  (sdl:with-transaction db thunk type))

;; sql-de-lite doesn't provide begin-transaction
(define begin-transaction
  (let ((tsqls '((deferred . "begin;")
                 (immediate . "begin immediate;")
                 (exclusive . "begin exclusive;"))))
    (lambda (db #!optional (type 'deferred))
      ;; nested transactions will be disallowed by the database
      (exec (sql db (or (alist-ref type tsqls)
                        (error 'begin-transaction
                               "invalid transaction type" type))))
      (void))))
(define (commit db) (sdl:commit db) (void))
(define (rollback db) (sdl:rollback db) (void))

(define (set-busy-timeout! db ms)
  (sdl:set-busy-handler! db
                         (and ms (sdl:busy-timeout ms))))



;;; multikey traversal

;; Returns a list of string keys matching string PATTERN, a sqlite LIKE pattern.
;; If PATTERN is not given, all keys are returned.
;; (It's possible this should be called fetch-keys.)
(define (list-keys db #!optional pattern)
  (if pattern
      (query sdl:fetch-column
             (sql db "SELECT k FROM sqdb_ht_1 WHERE k LIKE ?") pattern)      
      (query sdl:fetch-column
             (sql db "SELECT k FROM sqdb_ht_1"))))

;; Return alist mapping symbolic keys -> values, optionally constrained by pattern.
(define (fetch-alist db #!optional pattern)
  (map-items db (lambda (k v) (cons (string->symbol k) v))
            pattern))
;; fetch-items, if it existed, would return (("key" . val) ...)
;; fetch-values, if it existed, woudl return (val ...)

;; Return hash table of string keys -> values, optionally constrained by pattern.
(define (fetch-hash-table db #!optional pattern)
  (let ((ht (make-hash-table string=?)))
    (for-each-item db (lambda (k v) (hash-table-set! ht k v))
                   pattern)
    ht))

;; Internal.  Can be inlined.
(define (query-kv db proc pattern)
  (if pattern
      (query proc (sql db "SELECT k, v FROM sqdb_ht_1 WHERE k LIKE ?") pattern)
      (query proc (sql db "SELECT k, v FROM sqdb_ht_1"))))

(define (map-items db proc #!optional pattern)
  (query-kv db (sdl:map-rows (lambda (L) (proc (car L) (cadr L))))   ;; or (sdl:map-rows* proc)
            pattern))

;; ex: (for-each-item db2 (lambda (k v) (printf "key: ~S val: ~S\n" k v)) "ctr%")
;; key: "ctr2" val: 11.5
;; key: "ctr3" val: 0
;; key: "ctr" val: -7
(define (for-each-item db proc #!optional pattern)
  (query-kv db (sdl:for-each-row (lambda (L) (proc (car L) (cadr L))))
            pattern)
  (void))

(define (fold-items db kons knil #!optional pattern)
  (query-kv db (sdl:fold-rows (lambda (L seed)
                                (kons (car L) (cadr L) seed))
                              knil)
            pattern))

)