;;;; sqlite3.scm
;;;; bindings to the SQLite3 database library

;; Notes
;;
;; - Due to 'usual-integrations' the 'string-length' procedure is rewritten
;; to the "core" implementation. So even if the utf-8 module is "imported"
;; into the top-level a byte length will result.

(define-extension sqlite3
  (export
    ;; classes
    initialize
    <sqlite3:database>
    <sqlite3:statement>
    ;; methods & procedures
    sqlite3:open
    sqlite3:define-collation
    sqlite3:define-function
    sqlite3:set-busy-timeout!
    sqlite3:interrupt!
    sqlite3:auto-committing?
    sqlite3:changes
    sqlite3:last-insert-rowid
    sqlite3:finalize!
    sqlite3:prepare
    sqlite3:repair!
    sqlite3:reset!
    sqlite3:bind-parameter-count
    sqlite3:bind-parameter-index
    sqlite3:bind-parameter-name
    sqlite3:bind!
    sqlite3:bind-parameters!
    sqlite3:step!
    sqlite3:column-count
    sqlite3:column-type
    sqlite3:column-declared-type
    sqlite3:column-name
    sqlite3:column-data
    sqlite3:call-with-temporary-statements
    sqlite3:exec
    sqlite3:update
    sqlite3:first-result
    sqlite3:first-row
    sqlite3:fold-row
    sqlite3:for-each-row
    sqlite3:map-row
    sqlite3:with-transaction
    sqlite3:complete?
    sqlite3:library-version
    ;; null type
    sqlite3:null
    sqlite3:null-value?
    sqlite3:null-value) )

(declare
  (usual-integrations)
  (fixnum-arithmetic)
  (no-procedure-checks-for-usual-bindings)
  ; redefinition of imported variable `initialize' from `tinyclos'
  (disable-warning redef)
  (unused
    ; global variable '...' is never used
    chicken_sqlite3_function_stub
    chicken_sqlite3_collation_stub
    chicken_sqlite3_final_stub
    chicken_sqlite3_step_stub )
  (bound-to-procedure
    ##sys#expand-home-path
    #;##sys#pathname-resolution
    sqlite3:errmsg ) )

#>#include <sqlite3.h><#

(use srfi-1 srfi-12 srfi-13 srfi-18 srfi-26 extras lolevel)
(use tinyclos synch miscmacros)

;;;

;; Only works when the invoked object is a procedure.
;; Macros & values will not work.
(define-macro thunker cut)

;;; Foreign types & values

;; Enumeration and constant definitions

(define-foreign-enum (sqlite3:status int)
  #f ; no aliases
  (ok		    SQLITE_OK	#f)	  ; Successful result
  (error	    SQLITE_ERROR)	  ; SQL error or missing database
  (internal	    SQLITE_INTERNAL)	  ; NOT USED. Internal logic error in SQLite
  (permission	    SQLITE_PERM)	  ; Access permission denied
  (abort	    SQLITE_ABORT)	  ; Callback routine requested an abort
  (busy		    SQLITE_BUSY)	  ; The database file is locked
  (locked	    SQLITE_LOCKED)	  ; A table in the database is locked
  (no-memory	    SQLITE_NOMEM)	  ; A malloc() failed
  (read-only	    SQLITE_READONLY)	  ; Attempt to write a readonly database
  (interrupt	    SQLITE_INTERRUPT)	  ; Operation terminated by sqlite3_interrupt()
  (io-error	    SQLITE_IOERR)	  ; Some kind of disk I/O error occurred
  (corrupt	    SQLITE_CORRUPT)	  ; The database disk image is malformed
  (not-found	    SQLITE_NOTFOUND)	  ; NOT USED. Table or record not found
  (full		    SQLITE_FULL)	  ; Insertion failed because database is full
  (cant-open	    SQLITE_CANTOPEN)	  ; Unable to open the database file
  (protocol	    SQLITE_PROTOCOL)	  ; NOT USED. Database lock protocol error
  (empty	    SQLITE_EMPTY)	  ; Database is empty
  (schema	    SQLITE_SCHEMA)	  ; The database schema changed
  (too-big	    SQLITE_TOOBIG)	  ; String or BLOB exceeds size limit
  (constraint	    SQLITE_CONSTRAINT)	  ; Abort due to contraint violation
  (mismatch	    SQLITE_MISMATCH)	  ; Data type mismatch
  (misuse	    SQLITE_MISUSE)	  ; Library used incorrectly
  (no-lfs	    SQLITE_NOLFS)	  ; Uses OS features not supported on host
  (authorization    SQLITE_AUTH)	  ; Authorization denied
  (format	    SQLITE_FORMAT)	  ; Auxiliary database format error
  (range	    SQLITE_RANGE)	  ; 2nd parameter to sqlite3_bind out of range
  (not-a-database   SQLITE_NOTADB)	  ; File opened that is not a database file
  (row		    SQLITE_ROW)		  ; sqlite3_step() has another row ready
  (done		    SQLITE_DONE) )	  ; sqlite3_step() has finished executing

(define-foreign-enum (sqlite3:type int)
  #f ; no aliases
  (integer  SQLITE_INTEGER)
  (float    SQLITE_FLOAT)
  (text	    SQLITE_TEXT)
  (blob	    SQLITE_BLOB)
  (null	    SQLITE_NULL) )

;; Types

(define-foreign-type sqlite3:context (c-pointer "sqlite3_context"))

(define-foreign-type sqlite3:value (c-pointer "sqlite3_value"))

(define sqlite3:null void)

(define sqlite3:null-value (sqlite3:null))

(define (sqlite3:null-value? obj)
  (eq? sqlite3:null-value obj) )

;;; Classes for databases and statements

(define-class <sqlite3:database> (<c++-object>) ())
(define-foreign-type sqlite3:database
  (instance "sqlite3" <sqlite3:database>)
  (lambda (db)
    (unless (slot-ref db 'this)
      (signal-sqlite3-null-error 'sqlite3:database->c-pointer db))
    db))

(define-class <sqlite3:statement> (<c++-object>) (database sql))
(define-foreign-type sqlite3:statement
  (instance "sqlite3_stmt" <sqlite3:statement>)
  (lambda (stmt)
    (unless (slot-ref stmt 'this)
      (signal-sqlite3-null-error 'sqlite3:statement->c-pointer stmt))
    stmt))

(define-method (initialize (this <sqlite3:statement>) initargs)
  (call-next-method)
  (initialize-slots this initargs) )

;;; Helpers

;; Expand variables in pathname
(define sqlite3:resolve-pathname
  ##sys#expand-home-path
  #; ;not needed, yet
  (cut ##sys#pathname-resolution <> identity) )

;; Conditions

(define (make-exn-condition loc msg . args)
  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )

(define (make-sqlite3-condition sta)
  (make-property-condition 'sqlite3 'status sta) )

(define (make-sqlite3-error-condition loc msg sta . args)
   (make-composite-condition
    (apply make-exn-condition loc msg args)
    (make-sqlite3-condition sta)) )

(define (make-no-data-condition loc stmt params)
  (make-sqlite3-error-condition loc
                                "the statement returned no data"
                                'done
                                stmt params) )

;; Errors

(define ((signal-sqlite3-error loc db . args) sta)
  (signal
   (apply make-sqlite3-error-condition loc
                                       (if db (sqlite3:errmsg db) (symbol->string sta))
                                       sta
                                       args)) )

(define (check-sqlite3-type loc obj class)
  (unless (instance-of? obj class)
    (abort
     (make-composite-condition
      (make-exn-condition loc
                          (string-append
                           "bad argument type " (class-name (class-of obj))
                           ", expected " (class-name class))
		          obj)
      (make-property-condition 'type)
      (make-sqlite3-condition 'error)))) )

(define (signal-sqlite3-null-error loc obj)
  (signal
   (make-sqlite3-error-condition loc
                                 (string-append
                                  "bad " (class-name (class-of obj))
                                  " object, contained pointer is #f")
                                 'error
                                 obj)) )
(define (print-error msg obj)
  (print-error-message obj (current-error-port) (string-append "Error: " msg)) )

;; Tree dictionary

(define (make-hash-table-tree/synch id . args)
  (make-object/synch (apply make-hash-table args) id) )

(define (hash-table-tree-set! ht-tree keys value)
  (if (null? (cdr keys))
      (hash-table-set! ht-tree (car keys) value)
      (hash-table-update!
       ht-tree
       (car keys)
       (cut hash-table-tree-set! <> (cdr keys) value)
       (thunker make-hash-table)) )
  ht-tree )

(define (hash-table-tree-delete! ht-tree keys)
  (if (null? (cdr keys))
      (hash-table-delete! ht-tree (car keys))
      (hash-table-update!
       ht-tree
       (car keys)
       (cut hash-table-tree-delete! <> (cdr keys))
       (thunker make-hash-table)) )
  ht-tree )

(define (hash-table-tree-ref
	 ht-tree keys
	 #!optional
	 (thunk (thunker signal
                         (make-composite-condition
                          (make-exn-condition
                           'hash-table-tree-ref
                           "hash-table-tree does not contain path"
                           ht-tree keys)
                          (make-property-condition 'access)))))
  (let/cc return
    (let loop ((ht ht-tree)
               (keys keys))
      (if (null? keys)
	  ht
	  (loop (hash-table-ref ht (car keys) (thunker return (thunk)))
	        (cdr keys)) ) ) ) )

(define (hash-table-tree-ref/default ht-tree keys default)
  (hash-table-tree-ref ht-tree keys (lambda () default)) )

(define (hash-table-tree-clear! htt id elt-clear)
  (cond ((hash-table-ref/default htt id #f)
         => (cut hash-table-walk <> elt-clear)))
  (hash-table-delete! htt id) )

;; SQL collation sequence interface

(define *sqlite3:collations* (make-hash-table-tree/synch 'sqlite3:collations))

(define-external (chicken_sqlite3_collation_stub (scheme-object qn) (int la)
                                                 (c-pointer da) (int lb)
                                                 (c-pointer db))
                 int
  (let/cc return
    (let ((r #f))
      (dynamic-wind
        noop
        (lambda ()
	  (handle-exceptions exn
	                     (print-error "in collation function" exn)
	    (let ((a (make-string la)) (b (make-string lb)))
              (move-memory! da a la)
	      (move-memory! db b lb)
	      (set! r
		    ((vector-ref (call-with/synch *sqlite3:collations*
		                   (cut hash-table-tree-ref <> qn))
		                 1)
		     a b)))))
        (lambda ()
          (if (and (integer? r) (exact? r))
              (return r)
              (begin
                (print-error "in collation function: invalid return value" (->string r))
                (return 0))))) ) ) )

(define sqlite3_create_collation
  (foreign-lambda* sqlite3:status
                  ((sqlite3:database db) (c-string name) (scheme-object qn))
#<<END
  if (qn == C_SCHEME_FALSE)
    return(sqlite3_create_collation(db, name, SQLITE_UTF8, NULL, NULL));
  else
    return(sqlite3_create_collation(db, name, SQLITE_UTF8,
  				      (void *)qn,
  				      (int (*)(void *,
  					       int, const void *,
  					       int, const void *))
  					&chicken_sqlite3_collation_stub));
END
  ))

(define-generic sqlite3:define-collation)
(define-method (sqlite3:define-collation (db <sqlite3:database>)
					 (name <string>))
  (cond
   ((sqlite3_create_collation db name #f)
    => (signal-sqlite3-error 'sqlite3:define-collation db name))
   (else
    (let ((qn (list (pointer->address (slot-ref db 'this)) name)))
      (call-with/synch *sqlite3:collations*
	(lambda (col)
	  (cond
	   ((hash-table-tree-ref/default col qn #f)
	    => (lambda (info)
		 (hash-table-tree-delete! col qn)
		 (object-release (vector-ref info 0))))))) ) ) ) )

(define-method (sqlite3:define-collation (db <sqlite3:database>)
					  (name <string>)
					  (proc <procedure-class>))
  (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    (cond
     ((sqlite3_create_collation db name qn)
      => (lambda (s)
	   (object-release qn)
	   ((signal-sqlite3-error 'sqlite3:define-collation db name proc) s)))
     (else
      (call-with/synch *sqlite3:collations*
	(cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )

;;; SQL function interface

(define *sqlite3:functions* (make-hash-table-tree/synch 'sqlite3:functions))

(define *sqlite3:seeds* (make-hash-table-tree/synch 'sqlite3:seeds))

(define (sqlite3:parameter-data n args)
  (let loop ((i 0))
    (if (< i n)
	(cons
	 (case ((foreign-lambda* sqlite3:type
                                 (((c-pointer sqlite3:value) args) (int i))
		 "return(sqlite3_value_type(args[i]));")
		args i)
	   ((integer)
	    ((foreign-lambda* integer
                              (((c-pointer sqlite3:value) args) (int i))
	      "return(sqlite3_value_double(args[i]));")
	     args i))
	   ((float)
	    ((foreign-lambda* double
	                      (((c-pointer sqlite3:value) args) (int i))
	      "return(sqlite3_value_double(args[i]));")
	     args i))
	   ((text)
	    ((foreign-primitive scheme-object
                                (((c-pointer sqlite3:value) args) (int i))
	      "int n = sqlite3_value_bytes(args[i]);"
	      "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
	      "return(C_string(&s, n, (char *)sqlite3_value_text(args[i])));")
	     args i))
	   ((blob)
	    ((foreign-primitive scheme-object
                                (((c-pointer sqlite3:value) args) (int i))
	      "int n = sqlite3_value_bytes(args[i]);"
	      "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
	      "return(C_bytevector(&s, n, (char *)sqlite3_value_blob(args[i])));")
	     args i))
	   (else
	    sqlite3:null-value))
	 (loop (add1 i)))
	'() ) ) )

(define-generic sqlite3:set-result!)
(define-method (sqlite3:set-result! (ctx <pointer>) (v <blob>))
  ((foreign-lambda* void
                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
   ctx v (blob-size v)) )

; Deprecated
(define-method (sqlite3:set-result! (ctx <pointer>) (v <byte-vector>))
  ((foreign-lambda* void
                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
      "sqlite3_result_blob(ctx, v, n, SQLITE_TRANSIENT);")
   ctx v (byte-vector-length v)) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <exact>))
  ((foreign-lambda void "sqlite3_result_int" sqlite3:context int)
   ctx v) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <number>))
  ((foreign-lambda void "sqlite3_result_double" sqlite3:context double)
   ctx v) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <string>))
  ((foreign-lambda* void
                    ((sqlite3:context ctx) (scheme-pointer v) (int n))
    "sqlite3_result_text(ctx, v, n, SQLITE_TRANSIENT);")
   ctx v (string-length v)) )

(define-method (sqlite3:set-result! (ctx <pointer>) (v <void>))
  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
   ctx) )

(define-method (sqlite3:set-result! (ctx <pointer>))
  ((foreign-lambda void "sqlite3_result_null" sqlite3:context)
   ctx) )

(define sqlite3_user_data
  (foreign-lambda scheme-object "sqlite3_user_data" sqlite3:context))

(define-external (chicken_sqlite3_function_stub (c-pointer ctx) (int n) (c-pointer args))
                 void
  (let/cc return
    (dynamic-wind
      noop
      (lambda ()
        (handle-exceptions exn
                           (print-error "in SQL function" exn)
          (sqlite3:set-result!
           ctx
           (apply
            (vector-ref
             (call-with/synch *sqlite3:functions*
              (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))
             1)
            (sqlite3:parameter-data n args)))))
     (lambda ()
       (return (void)))) ) )

(define sqlite3_aggregate_context
  (foreign-lambda* integer ((sqlite3:context ctx))
   "return((int)sqlite3_aggregate_context(ctx, 1));"))

(define-external (chicken_sqlite3_step_stub (c-pointer ctx) (int n) (c-pointer args))
                 void
  (let/cc return
    (dynamic-wind
      noop
      (lambda ()
        (handle-exceptions exn
                           (print-error "in step of SQL function" exn)
          (let ((info (call-with/synch *sqlite3:functions*
                       (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
            (call-with/synch *sqlite3:seeds*
             (cut hash-table-update!/default
                  <>
                  (sqlite3_aggregate_context ctx)
                  (lambda (seed)
                    (apply (vector-ref info 1) seed (sqlite3:parameter-data n args)))
                  (vector-ref info 2))))))
	 (lambda ()
	   (return (void)))) ) )

(define-external (chicken_sqlite3_final_stub (c-pointer ctx))
                 void
  (let/cc return
    (let ((agc (sqlite3_aggregate_context ctx)))
      (dynamic-wind
	noop
	(lambda ()
	  (handle-exceptions exn
	                     (print-error "in final of SQL function" exn)
	    (let ((info (call-with/synch *sqlite3:functions*
			 (cut hash-table-tree-ref <> (sqlite3_user_data ctx)))))
	      (cond
	        (((vector-ref info 3)
		  (call-with/synch *sqlite3:seeds*
		   (cut hash-table-ref/default <> agc (vector-ref info 2))))
		 => (cut sqlite3:set-result! ctx <>))
		(else
		  (sqlite3:set-result! ctx))))))
	(lambda ()
	  (call-with/synch *sqlite3:seeds*
	   (cut hash-table-delete! <> agc))
	  (return (void)))) ) ) )

(define-generic sqlite3:define-function)
(define-method (sqlite3:define-function (db <sqlite3:database>)
					 (name <string>)
					 (n <exact>)
					 (proc <procedure-class>))
  (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    (cond
     (((foreign-lambda* sqlite3:status
                        ((sqlite3:database db) (c-string name) (int n) (scheme-object qn))
#<<END
        return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
  				       (void *)qn,
  				       (void (*)(sqlite3_context *, int,
  				                 sqlite3_value **))
  				       &chicken_sqlite3_function_stub,
  				       NULL,
  				       NULL));
END
       )
       db name n qn)
      => (lambda (s)
	   (object-release qn)
	   ((signal-sqlite3-error 'sqlite3:define-function db name n proc) s)))
     (else
      (call-with/synch *sqlite3:functions*
	(cut hash-table-tree-set! <> qn (vector qn proc))) ) ) ) )

(define-method (sqlite3:define-function (db <sqlite3:database>)
					 (name <string>)
					 (n <exact>)
					 (step-proc <procedure-class>)
					 (seed <top>)
					 #!optional (final-proc identity))
  (check-sqlite3-type 'sqlite3:define-function final-proc <procedure-class>)
  (let ((qn (object-evict (list (pointer->address (slot-ref db 'this)) name))))
    (cond
     (((foreign-lambda* sqlite3:status
                        ((sqlite3:database db) (c-string name) (int n) (scheme-object qn))
#<<END
        return(sqlite3_create_function(db, name, n, SQLITE_UTF8,
  				       (void *)qn,
  				       NULL,
  				       (void (*)(sqlite3_context *, int,
  				                 sqlite3_value **))
  				       &chicken_sqlite3_step_stub,
  				       ((void (*)(sqlite3_context *))
  				         &chicken_sqlite3_final_stub)));
END
       )
       db name n qn)
      => (lambda (s)
	   (object-release qn)
	   ((signal-sqlite3-error
	      'sqlite3:define-function db name n step-proc seed final-proc)
	    s)))
     (else
      (call-with/synch *sqlite3:functions*
	(cut hash-table-tree-set! <> qn (vector qn step-proc seed final-proc))) ) ) ) )

;;; Database interface

;; Get any error message
(define sqlite3:errmsg
  (foreign-lambda c-string "sqlite3_errmsg" sqlite3:database) )

;; Open a database
(define (sqlite3:open path)
  (check-sqlite3-type 'sqlite3:open path <string>)
  (let-location ((db c-pointer))
    (cond
     (((foreign-lambda sqlite3:status "sqlite3_open"
                                      nonnull-c-string (c-pointer sqlite3:database))
       (sqlite3:resolve-pathname path) (location db))
      => (signal-sqlite3-error 'sqlite3:open #f path))
     (else
      (make <sqlite3:database> 'this db) ) ) ) )

;; Set a timeout until a busy error is thrown
(define (sqlite3:set-busy-timeout! db #!optional (ms 0))
  (check-sqlite3-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
  (cond
   (((foreign-lambda sqlite3:status "sqlite3_busy_timeout" sqlite3:database int) db ms)
    => (signal-sqlite3-error 'sqlite3:set-busy-timeout! db db ms))) )

;; Cancel any running database operation as soon as possible
(define (sqlite3:interrupt! db)
  (check-sqlite3-type 'sqlite3:interrupt! db <sqlite3:database>)
  ((foreign-lambda void "sqlite3_interrupt" sqlite3:database) db) )

;; Check whether the database is in autocommit mode
(define (sqlite3:auto-committing? db)
  (check-sqlite3-type 'sqlite3:auto-committing? db <sqlite3:database>)
  ((foreign-lambda bool "sqlite3_get_autocommit" sqlite3:database) db) )

;; Get the number of changes made to the database
(define (sqlite3:changes db #!optional (total #f))
  (check-sqlite3-type 'sqlite3:changes db <sqlite3:database>)
  (if total
      ((foreign-lambda number "sqlite3_total_changes" sqlite3:database) db)
      ((foreign-lambda number "sqlite3_changes" sqlite3:database) db) ) )

;; Get the row ID of the last inserted row
(define (sqlite3:last-insert-rowid db)
  (check-sqlite3-type 'sqlite3:last-insert-rowid db <sqlite3:database>)
  ((foreign-lambda number "sqlite3_last_insert_rowid" sqlite3:database) db) )

;; Close a database
(define-generic sqlite3:finalize!)
(define-method (sqlite3:finalize! (db <sqlite3:database>))
  (cond
   ((not (slot-ref db 'this))
    (void))
   (((foreign-lambda sqlite3:status "sqlite3_close" sqlite3:database) db)
    => (signal-sqlite3-error 'sqlite3:finalize! db db))
   (else
    (let ((id (pointer->address (slot-ref db 'this)))
	  (release-qns (lambda (_ info) (object-release (vector-ref info 0)))))
      (call-with/synch *sqlite3:collations*
        (cut hash-table-tree-clear! <> id release-qns))
      (call-with/synch *sqlite3:functions*
        (cut hash-table-tree-clear! <> id release-qns)) )
    (slot-set! db 'this #f) ) ) )

;;; Statement interface

;; Create a new statement
(define (sqlite3:prepare db sql)
  (check-sqlite3-type 'sqlite3:prepare db <sqlite3:database>)
  (check-sqlite3-type 'sqlite3:prepare sql <string>)
  (let-location ((stmt c-pointer) (tail c-string))
    (cond
     (((foreign-lambda sqlite3:status "sqlite3_prepare"
                                      sqlite3:database scheme-pointer int
	                              (c-pointer sqlite3:statement)
	                              (c-pointer (const c-string)))
       db sql (string-length sql) (location stmt) (location tail))
      => (signal-sqlite3-error 'sqlite3:prepare db db sql))
     (else
      (values
       (make <sqlite3:statement> 'this stmt 'database db 'sql sql)
       tail) ) ) ) )

;; Recompile an existing statement and transfer all bindings
(define (sqlite3:repair! stmt)
  (check-sqlite3-type 'sqlite3:repair! stmt <sqlite3:statement>)
  (let ((fresh (sqlite3:prepare
		(slot-ref stmt 'database) (slot-ref stmt 'sql))))
    (dynamic-wind
	noop
	(lambda ()
	  (let ((old (slot-ref stmt 'this))
		(new (slot-ref fresh 'this)))
	    (cond
	     (((foreign-lambda sqlite3:status "sqlite3_transfer_bindings"
		                              c-pointer c-pointer)
	       old new)
	      => (signal-sqlite3-error 'sqlite3:repair! (slot-ref stmt 'database) stmt))
	     (else
	      (slot-set! stmt 'this new)
	      (slot-set! fresh 'this old)))))
	(lambda ()
	  (sqlite3:finalize! fresh))) ) )

;; Discard an existing statement
;; (define-generic sqlite3:finalize!)
(define-method (sqlite3:finalize! (stmt <sqlite3:statement>))
  (cond
   ((not (slot-ref stmt 'this))
    (void))
   (((foreign-lambda sqlite3:status "sqlite3_finalize" sqlite3:statement) stmt)
    => (signal-sqlite3-error 'sqlite3:finalize! (slot-ref stmt 'database) stmt))
   (else
    (slot-set! stmt 'this #f) ) ) )

;; Reset an existing statement to process it again
(define sqlite3_reset
  (foreign-lambda sqlite3:status "sqlite3_reset"sqlite3:statement))

(define (sqlite3:reset! stmt)
  (check-sqlite3-type 'sqlite3:reset! stmt <sqlite3:statement>)
  (cond
   ((sqlite3_reset stmt)
    => (signal-sqlite3-error 'sqlite3:reset! (slot-ref stmt 'database) stmt))) )

;; Get number of bindable parameters
(define (sqlite3:bind-parameter-count stmt)
  (check-sqlite3-type 'sqlite3:bind-parameter-count stmt <sqlite3:statement>)
  ((foreign-lambda int "sqlite3_bind_parameter_count" sqlite3:statement) stmt) )

;; Get index of a bindable parameter or #f if no parameter with the
;; given name exists
(define (sqlite3:bind-parameter-index stmt name)
  (check-sqlite3-type 'sqlite3:bind-parameter-index stmt <sqlite3:statement>)
  (let ((i ((foreign-lambda int "sqlite3_bind_parameter_index"
                                sqlite3:statement nonnull-c-string)
	    stmt name)))
    (if (zero? i)
        #f
        (sub1 i) ) ) )

;; Get the name of a bindable parameter
(define (sqlite3:bind-parameter-name stmt i)
  (check-sqlite3-type 'sqlite3:bind-parameter-name stmt <sqlite3:statement>)
  ((foreign-lambda c-string "sqlite3_bind_parameter_name" sqlite3:statement int) stmt (add1 i)) )

;; Bind data as parameters to an existing statement

(define-generic sqlite3:bind!)
(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <blob>))
  (cond
   (((foreign-lambda* sqlite3:status
                      ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
      "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
     stmt (add1 i) v (blob-size v))
    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )

; Deprecated
(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <byte-vector>))
  (cond
   (((foreign-lambda* sqlite3:status
                      ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
      "return(sqlite3_bind_blob(stmt, i, v, n, SQLITE_TRANSIENT));")
     stmt (add1 i) v (byte-vector-length v))
    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <exact>))
  (cond
   (((foreign-lambda sqlite3:status "sqlite3_bind_int"
                                    sqlite3:statement int int)
     stmt (add1 i) v)
    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <number>))
  (cond
   (((foreign-lambda sqlite3:status "sqlite3_bind_double"
                                    sqlite3:statement int double)
     stmt (add1 i) v)
    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <string>))
  (cond
   (((foreign-lambda* sqlite3:status
                      ((sqlite3:statement stmt) (int i) (scheme-pointer v) (int n))
      "return(sqlite3_bind_text(stmt, i, v, n, SQLITE_TRANSIENT));")
     stmt (add1 i) v (string-length v))
    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i v))))

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>)
			      (v <void>))
  (cond
   (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )

(define-method (sqlite3:bind! (stmt <sqlite3:statement>) (i <exact>))
  (cond
   (((foreign-lambda sqlite3:status "sqlite3_bind_null" sqlite3:statement int) stmt (add1 i))
    => (signal-sqlite3-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))) )

; Helper
(define (bind-parameters! loc stmt params)
  (sqlite3:reset! stmt)
  (let ((cnt (sqlite3:bind-parameter-count stmt)))
    (unless (= cnt (length params))
      (abort
       (make-composite-condition
        (make-exn-condition loc "too few parameters" cnt params)
        (make-property-condition 'arity)
        (make-sqlite3-condition 'error))) )
    (for-each (cut sqlite3:bind! stmt <> <>) (iota cnt) params) ) )

(define (sqlite3:bind-parameters! stmt . params)
  (bind-parameters! 'sqlite3:bind-parameters! stmt params) )

;; Single-step a prepared statement, return #t if data is available,
;; #f otherwise
(define (sqlite3:step! stmt)
  (check-sqlite3-type 'sqlite3:step! stmt <sqlite3:statement>)
  (let retry ()
    (let ((s ((foreign-safe-lambda
	       sqlite3:status "sqlite3_step" sqlite3:statement)
	      stmt)))
      (case s
	((row) #t)
	((done) #f)
	((error)
	 (let ((s (sqlite3_reset stmt)))
	   (case s
	     ((schema)
	      (sqlite3:repair! stmt)
	      (retry))
	     (else
	      ((signal-sqlite3-error
		'sqlite3:step! (slot-ref stmt 'database) stmt) s)))))
	(else
	 ((signal-sqlite3-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s) ) ) ) ) )

;; Retrieve information from a prepared/stepped statement
(define (sqlite3:column-count stmt)
  (check-sqlite3-type 'sqlite3:column-count stmt <sqlite3:statement>)
  ((foreign-lambda int "sqlite3_column_count" sqlite3:statement) stmt) )

(define (sqlite3:column-type stmt i)
  (check-sqlite3-type 'sqlite3:column-type stmt <sqlite3:statement>)
  ((foreign-lambda sqlite3:type "sqlite3_column_type" sqlite3:statement int) stmt i) )

(define (sqlite3:column-declared-type stmt i)
  (check-sqlite3-type 'sqlite3:column-declared-type stmt <sqlite3:statement>)
  ((foreign-lambda c-string "sqlite3_column_decltype" sqlite3:statement int) stmt i) )

(define (sqlite3:column-name stmt i)
  (check-sqlite3-type 'sqlite3:column-name stmt <sqlite3:statement>)
  ((foreign-lambda c-string "sqlite3_column_name" sqlite3:statement int) stmt i) )

;; Retrieve data from a stepped statement
(define (sqlite3:column-data stmt i)
  (case (sqlite3:column-type stmt i)
    ((integer)
     ((foreign-lambda integer "sqlite3_column_double" sqlite3:statement int) stmt i))
    ((float)
     ((foreign-lambda double "sqlite3_column_double" sqlite3:statement int) stmt i))
    ((text)
     ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
       "int n = sqlite3_column_bytes(stmt, i);"
       "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
       "return(C_string(&s, n, (char *)sqlite3_column_text(stmt, i)));")
      stmt i))
    ((blob)
     ((foreign-primitive scheme-object ((sqlite3:statement stmt) (int i))
       "int n = sqlite3_column_bytes(stmt, i);"
       "C_word *s = C_alloc(C_SIZEOF_STRING(n));"
       "return(C_bytevector(&s, n, (char *)sqlite3_column_blob(stmt, i)));")
      stmt i))
    (else
     sqlite3:null-value ) ) )

;;; Easy statement interface

;; Compile a statement and call a procedure on it, then finalize the
;; statement in a dynamic-wind exit block if it hasn't been finalized yet.
(define (sqlite3:call-with-temporary-statements proc db . sqls)
  (check-sqlite3-type 'sqlite3:call-with-temporary-statements db <sqlite3:database>)
  (let ((stmts #f))
    (dynamic-wind
	(lambda ()
	  (unless stmts
	    (set! stmts (map (cut sqlite3:prepare db <>) sqls))))
	(lambda ()
	  (apply proc stmts))
	(lambda ()
	  (when stmts
	    (map sqlite3:finalize! stmts)
	    (set! stmts #f)))) ) )

;; Step through a statement and ignore possible results
(define-generic sqlite3:exec)
(define-method (sqlite3:exec (stmt <sqlite3:statement>) . params)
  (bind-parameters! 'sqlite3:exec stmt params)
  (while (sqlite3:step! stmt))
  sqlite3:null-value )

(define-method (sqlite3:exec (db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cut apply sqlite3:exec <> params)
   db sql) )

;; Step through a statement, ignore possible results and return the
;; count of changes performed by this statement
(define-generic sqlite3:update)
(define-method (sqlite3:update (stmt <sqlite3:statement>) . params)
  (sqlite3:reset! stmt)
  (apply sqlite3:exec stmt params)
  (sqlite3:changes (slot-ref stmt 'database)) )

(define-method (sqlite3:update (db <sqlite3:database>) (sql <string>) . params)
  (apply sqlite3:exec db sql params)
  (sqlite3:changes db) )

;; Return only the first column of the first result row produced by this
;; statement

(define-generic sqlite3:first-result)
(define-method (sqlite3:first-result (stmt <sqlite3:statement>) . params)
  (bind-parameters! 'sqlite3:first-result stmt params)
  (if (sqlite3:step! stmt)
      (let ((r (sqlite3:column-data stmt 0)))
	(sqlite3:reset! stmt)
	r )
      (signal (make-no-data-condition 'sqlite3:first-result stmt params)) ) )

(define-method (sqlite3:first-result
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cut apply sqlite3:first-result <> params)
   db sql) )

;; Return only the first result row produced by this statement as a list

(define-generic sqlite3:first-row)
(define-method (sqlite3:first-row (stmt <sqlite3:statement>) . params)
  (bind-parameters! 'sqlite3:first-row stmt params)
  (if (sqlite3:step! stmt)
      (map (cut sqlite3:column-data stmt <>)
           (iota (sqlite3:column-count stmt)))
      (signal (make-no-data-condition 'sqlite3:first-row stmt params)) ) )

(define-method (sqlite3:first-row
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cut apply sqlite3:first-row <> params)
   db sql))

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulating results.

(define (%fold-row loc proc stmt init params)
  (bind-parameters! loc stmt params)
  (let ((cl (iota (sqlite3:column-count stmt))))
    (let loop ((acc init))
      (if (sqlite3:step! stmt)
          (loop (apply proc acc (map (cut sqlite3:column-data stmt <>) cl)))
          acc ) ) ) )

(define-generic sqlite3:fold-row)
(define-method (sqlite3:fold-row (proc <procedure-class>)
                                 (stmt <sqlite3:statement>)
                                 (init <object>) . params)
  (%fold-row 'sqlite3:fold-row proc stmt init params) )

(define-method (sqlite3:fold-row (proc <procedure-class>)
                                 (db <sqlite3:database>)
                                 (sql <string>)
                                 (init <object>) . params)
  (sqlite3:call-with-temporary-statements
   (cut apply sqlite3:fold-row proc <> init params)
   db sql) )

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and discard the results

(define (for-each-row-proc proc)
  (lambda (acc . cols)
    (apply proc cols)
    acc ) )

(define-generic sqlite3:for-each-row)
(define-method (sqlite3:for-each-row (proc <procedure-class>)
                                     (stmt <sqlite3:statement>) . params)
  (%fold-row 'sqlite3:for-each-row (for-each-row-proc proc) stmt (void) params) )

(define-method (sqlite3:for-each-row (proc <procedure-class>)
                                     (db <sqlite3:database>)
                                     (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cut apply sqlite3:for-each-row proc <> params)
   db sql) )

;; Apply a procedure to the values of the result columns for each result row
;; while executing the statement and accumulate the results in a list

(define (map-row-proc proc)
  (lambda (acc . cols)
    (cons (apply proc cols) acc) ) )

(define-generic sqlite3:map-row)
(define-method (sqlite3:map-row (proc <procedure-class>)
                                (stmt <sqlite3:statement>) . params)
  (reverse! (%fold-row 'sqlite3:map-row (map-row-proc proc) stmt '() params)) )

(define-method (sqlite3:map-row (proc <procedure-class>)
                                (db <sqlite3:database>)
                                (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cut apply sqlite3:map-row proc <> params)
   db sql) )

;;; Utility procedures

;; Run a thunk within a database transaction, commit if return value is
;; true, rollback if return value is false or the thunk is interrupted by
;; an exception
(define (sqlite3:with-transaction db thunk #!optional (type 'deferred))
  (check-sqlite3-type 'sqlite3:with-transaction db <sqlite3:database>)
  (check-sqlite3-type 'sqlite3:with-transaction thunk <procedure-class>)
  (unless (memq type '(deferred immediate exclusive))
    (abort
     (make-composite-condition
      (make-exn-condition 'sqlite3:with-transaction
                          "bad argument: expected deferred, immediate or exclusive"
                          type)
      (make-property-condition 'type))) )
  (let ((success? #f))
    (dynamic-wind
	(lambda ()
	  (sqlite3:exec db
	   (string-append "BEGIN " (symbol->string type) " TRANSACTION;")))
	(lambda ()
	  (set! success? (thunk)))
	(lambda ()
	  (sqlite3:exec db
	   (if success?
               "COMMIT TRANSACTION;"
	       "ROLLBACK TRANSACTION;")))) ) )

;; Check if the given string is a valid SQL statement
(define sqlite3:complete?
  (foreign-lambda bool "sqlite3_complete" nonnull-c-string))

;; Return a descriptive version string
(define sqlite3:library-version
  (foreign-lambda c-string "sqlite3_libversion") )