;;;; 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: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: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 )
  (import
    ##sys#expand-home-path
    #;##sys#pathname-resolution )
  (bound-to-procedure
    sqlite3:errmsg ) )

#>#include <sqlite3.h><#

(require-extension
 (srfi 1) (srfi 13) (srfi 18) (srfi 26)
 extras lolevel tinyclos synch)

;;; 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-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-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 stmt params)
  (make-sqlite3-error-condition 'sqlite3:first-result
                                "the statement returned no data"
                                'done
                                stmt params) )

;; Errors

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

(define (signal-null-error loc obj)
  (signal
   (make-sqlite3-error-condition loc
                                 (format #f "bad ~A object, contained pointer is #f"
                                            (class-name (class-of obj)))
                                 'error
                                 obj)) )

(define (check-type loc obj class)
  (unless (instance-of? obj class)
    (abort
     (make-composite-condition
      (make-exn-condition loc
                          (format #f "bad argument type ~A, expected ~A"
		                     (class-name (class-of obj)) (class-name class))
		          obj)
      (make-property-condition 'type)))) )

;; 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)
       (lambda () (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))
       (lambda () (make-hash-table))))
  ht-tree)

(define (hash-table-tree-ref
	 ht-tree keys
	 #!optional (thunk (lambda ()
			     (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))))))
  (call-with-current-continuation
   (lambda (q)
     (let loop ((ht ht-tree) (keys keys))
       (if (null? keys)
	   ht
	   (loop
	    (hash-table-ref ht (car keys) (lambda () (q (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
  (call-with-current-continuation
   (lambda (q)
     (let ((r #f))
       (dynamic-wind
	   noop
	   (lambda ()
	     (handle-exceptions exn
		 (print-error-message
		  exn (current-error-port) "Error in collation function:")
	       (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))
		 (q r)
		 (begin
		   (format
		    (current-error-port)
		    "Error in collation function: invalid return value: ~S~%"
		    r)
		   (q 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-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-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
  (call-with-current-continuation
   (lambda (q)
     (dynamic-wind
	 noop
	 (lambda ()
	   (handle-exceptions exn
	       (print-error-message
		exn (current-error-port) "Error in SQL function:")
	     (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 ()
	   (q (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
  (call-with-current-continuation
   (lambda (q)
     (dynamic-wind
	 noop
	 (lambda ()
	   (handle-exceptions exn
	       (print-error-message
		exn (current-error-port) "Error in step of SQL function:")
	     (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 ()
	   (q (void)))))))

(define-external (chicken_sqlite3_final_stub (c-pointer ctx)) void
  (call-with-current-continuation
   (lambda (q)
     (let ((agc (sqlite3_aggregate_context ctx)))
       (dynamic-wind
	   noop
	   (lambda ()
	     (handle-exceptions exn
		 (print-error-message
		  exn (current-error-port) "Error in final of SQL function:")
	       (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))
	     (q (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-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-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-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-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-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-type 'sqlite3:set-busy-timeout! db <sqlite3:database>)
  (cond
   (((foreign-lambda sqlite3:status "sqlite3_busy_timeout" sqlite3:database int) db ms)
    => (signal-error 'sqlite3:set-busy-timeout! db db ms))))

;; Cancel any running database operation as soon as possible
(define (sqlite3:interrupt! db)
  (check-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-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-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-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-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-type 'sqlite3:prepare db <sqlite3:database>)
  (check-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-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-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-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-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-type 'sqlite3:reset! stmt <sqlite3:statement>)
  (cond
   ((sqlite3_reset stmt)
    => (signal-error 'sqlite3:reset! (slot-ref stmt 'database) stmt))))

;; Get number of bindable parameters
(define (sqlite3:bind-parameter-count stmt)
  (check-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-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-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-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-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-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-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-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-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-error 'sqlite3:bind! (slot-ref stmt 'database) stmt i))))

;; Single-step a prepared statement, return #t if data is available,
;; #f otherwise
(define (sqlite3:step! stmt)
  (check-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-error
		'sqlite3:step! (slot-ref stmt 'database) stmt) s)))))
	(else
	 ((signal-error 'sqlite3:step! (slot-ref stmt 'database) stmt) s))))))

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

(define (sqlite3:column-type stmt i)
  (check-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-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-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-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)
  (sqlite3:reset! stmt)
  (for-each
   (cute sqlite3:bind! stmt <> <>)
   (iota (sqlite3:bind-parameter-count stmt)) params)
  (do () ((not (sqlite3:step! stmt)) sqlite3:null-value)))

(define-method (sqlite3:exec (db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute 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)
  (sqlite3:reset! stmt)
  (for-each
   (cute sqlite3:bind! stmt <> <>)
   (iota (sqlite3:bind-parameter-count stmt)) params)
  (if (sqlite3:step! stmt)
      (let ((r (sqlite3:column-data stmt 0)))
	(sqlite3:reset! stmt)
	r)
      (signal (make-no-data-condition stmt params)) ) )

(define-method (sqlite3:first-result
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute 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)
  (sqlite3:reset! stmt)
  (for-each
   (cute sqlite3:bind! stmt <> <>)
   (iota (sqlite3:bind-parameter-count stmt)) params)
  (if (sqlite3:step! stmt)
      (map
       (cute sqlite3:column-data stmt <>)
       (iota (sqlite3:column-count stmt)))
      (signal (make-no-data-condition stmt params)) ) )

(define-method (sqlite3:first-row
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute 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 discard the results

(define-generic sqlite3:for-each-row)
(define-method (sqlite3:for-each-row
		(proc <procedure-class>) (stmt <sqlite3:statement>) . params)
  (sqlite3:reset! stmt)
  (for-each
   (cute sqlite3:bind! stmt <> <>)
   (iota (sqlite3:bind-parameter-count stmt)) params)
  (do ((cl (iota (sqlite3:column-count stmt))))
      ((not (sqlite3:step! stmt)) sqlite3:null-value)
    (apply proc (map (cute sqlite3:column-data stmt <>) cl))))

(define-method (sqlite3:for-each-row
		(proc <procedure-class>)
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute 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-generic sqlite3:map-row)
(define-method (sqlite3:map-row
		(proc <procedure-class>) (stmt <sqlite3:statement>) . params)
  (sqlite3:reset! stmt)
  (for-each
   (cute sqlite3:bind! stmt <> <>)
   (iota (sqlite3:bind-parameter-count stmt)) params)
  (let ((cl (iota (sqlite3:column-count stmt))))
    (let loop ()
      (if (sqlite3:step! stmt)
	  (cons
	   (apply proc (map (cute sqlite3:column-data stmt <>) cl))
	   (loop))
	  '()))))

(define-method (sqlite3:map-row
		(proc <procedure-class>)
		(db <sqlite3:database>) (sql <string>) . params)
  (sqlite3:call-with-temporary-statements
   (cute 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-type 'sqlite3:with-transaction db <sqlite3:database>)
  (check-type 'sqlite3:with-transaction thunk <procedure-class>)
  (unless (memq type '(deferred immediate exclusive))
    (abort
     (make-composite-condition
      (make-exn-condition 'sqlite3:with-transaction
                          (format #f
                           "bad argument ~A, expected deferred, immediate or exclusive"
		           type)
                          type)
      (make-property-condition 'type))))
  (let ((success? #f))
    (dynamic-wind
	(lambda ()
	  (sqlite3:exec db (format #f "BEGIN ~a TRANSACTION;" type)))
	(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"))