(module sqlite mzscheme
  (require (lib "etc.ss")
           (lib "list.ss")
           (lib "contract.ss") 
           "sqlite-ffi.ss")
  (provide (all-defined))
  
  ; Struct
  (define-struct db (_db_ptr _errMsg_ptr _callback_ptr))
  (define/contract db-handle
    (db? . -> . cpointer?)
    (lambda (db)
      (ptr-ref (db-_db_ptr db) _sqlite3_ptr)))
  (define-struct statement (_stmt_ptr))
  (define/contract statement-handle
    (statement? . -> . cpointer?)
    (lambda (stmt)
      (ptr-ref (statement-_stmt_ptr stmt) _sqlite3_stmt_ptr)))
  
  ; Helpers
  (define/contract list->equal-sublists
    (integer? list? . -> . (listof list?))
    (lambda (n l)
      (let loop ([l l] [i 0] [r `()])
        (if (null? l)
            (reverse r)
            (loop (cdr l) (modulo (+ i 1) n)
                  (if (= i 0)
                      (append (list (list (car l)))
                              r)
                      (append (list (append (car r) (list (car l))))
                              (cdr r)))))))) 
  
  (define/contract sqlite-ok?
    (integer? . -> . boolean?)
    (lambda (s)
      (= s SQLITE_OK)))
  (define/contract wrap-finalizer
    (any/c (any/c . -> . any/c) . -> . any/c)
    (lambda (o f)
      (register-finalizer o f)
      o))
  
  ; Methods
  (define/contract open
    (string? . -> . (union boolean? db?))
    (lambda (db-path)
      (let ([r (wrap-finalizer (make-db (malloc _sqlite3_ptr_ptr)
                                        (malloc _string_ptr)
                                        (malloc _pointer))
                               close)])
        (if (sqlite-ok? (sqlite3_open db-path (db-_db_ptr r)))
            r
            #f))))
  (define/contract close
    (db? . -> . integer?)
    (lambda (db)
      (let ([s SQLITE_MISUSE])
        (when (db-_db_ptr db)
          (set! s (sqlite3_close (db-handle db))))
        (set-db-_db_ptr! db #f)
        (set-db-_errMsg_ptr! db #f)
        (set-db-_callback_ptr! db #f)
        s)))
  
  (define/contract exec
    (db? string? (list? list? . -> . integer?) . -> . integer?)
    (lambda (db sql callback)
      (let ([exec-callback (lambda (arg_ptr column-count_int column-values_ptr column-names_ptr)
                             (callback
                              (cvector->list (make-cvector* column-names_ptr _string column-count_int))
                              (cvector->list (make-cvector* column-values_ptr _string column-count_int))))])
        (sqlite3_exec (db-handle db)
                      sql
                      (contract
                       (cpointer? integer? cpointer? cpointer? . -> . integer?)
                       exec-callback
                       'positive 'negative)
                      (db-_callback_ptr db)
                      (db-_errMsg_ptr db)))))
  (define/contract exec/ignore
    (db? string? . -> . integer?)
    (lambda (db sql)
      (exec db sql (lambda (c v) 0))))
  (define/contract select
    (db? string? . -> . (listof list?))
    (lambda (db sql)
      (let ([result_ptr_ptr (wrap-finalizer (malloc _string_array_ptr) 
                                            (lambda (ptr)
                                              (when ptr
                                                (sqlite3_free_table (ptr-ref ptr _string_array)))))]
            [row-count_ptr (malloc _int_ptr)]
            [column-count_ptr (malloc _int_ptr)])
        (if (sqlite3_get_table (db-handle db)
                               sql
                               result_ptr_ptr
                               row-count_ptr
                               column-count_ptr
                               (db-_errMsg_ptr db))
            (list->equal-sublists (ptr-ref column-count_ptr _int)
                                  (cvector->list (make-cvector* (ptr-ref result_ptr_ptr _string_array) _string 
                                                                (* (+ (ptr-ref row-count_ptr _int) 1)
                                                                   (ptr-ref column-count_ptr _int)))))
            `()))))
  
  (define/contract prepare
    (db? string? . -> . statement?)
    (lambda (db sql)
      (let ([stmt (wrap-finalizer (make-statement (malloc _sqlite3_stmt_ptr_ptr))
                                  finalize)])
        (if (sqlite-ok? (sqlite3_prepare (db-handle db)
                                         sql
                                         (string-length sql)
                                         (statement-_stmt_ptr stmt)
                                         (db-_errMsg_ptr db)))
            stmt
            #f))))
  (define/contract load-params
    ((statement?) (listof string?) . ->* . (integer?))
    (lambda (stmt . params)
      (if (sqlite-ok? (sqlite3_reset (statement-handle stmt)))
        (let ([SQLITE_TRANSIENT/sleaziness -1])
          (foldl 
           + 0
           (map
            (lambda (i)
              (sqlite3_bind_text (statement-handle stmt) (+ i 1)
                                 (list-ref params i)
                                 (string-length (list-ref params i))
                                 SQLITE_TRANSIENT/sleaziness))
            (build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity))))
        SQLITE_ERROR)))
  (define/contract step
    (statement? . -> . (listof string?))
    (lambda (stmt)
      (let ([s (sqlite3_step (statement-handle stmt))])
         (if (= s SQLITE_ROW)
             (map (lambda (i) (sqlite3_column_text (statement-handle stmt) i))
                  (build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity))
             (list)))))
  (define/contract run
    ((statement?) (listof string?) . ->* . (integer?))
    (lambda (stmt . params)
      (if (apply load-params stmt params)
          (sqlite3_step (statement-handle stmt))
          SQLITE_ERROR)))
  (define/contract finalize
    (statement? . -> . integer?)
    (lambda (stmt)
      (let ([s 1])
        (when (statement-_stmt_ptr stmt)
          (set! s (sqlite3_finalize (statement-handle stmt))))
        (set-statement-_stmt_ptr! stmt #f)
        s)))
  
  (define/contract lock-type->string
    ((symbols 'none 'deferred 'immediate 'exclusive) . -> . string?)
    (lambda (lock-type)
      (case lock-type
        [(none) ""]
        [(deferred) "DEFERRED"]
        [(immediate) "IMMEDIATE"]
        [(exclusive) "EXCLUSIVE"])))
  (define-syntax transaction/lock
    (syntax-rules ()
      [(_ db lock-type fail body ...)
       (let ([end (lambda () (exec/ignore db "ROLLBACK TRANSACTION"))])
         (exec/ignore db (format "BEGIN ~a TRANSACTION" (lock-type->string 'lock-type)))
         (let/ec fail
           body
           ...
           (set! end (lambda () (exec/ignore db "COMMIT TRANSACTION"))))
         (end))]))
  (define-syntax transaction
    (syntax-rules ()
      [(_ db fail body ...)
       (transaction/lock db none fail body ...)]))
  
  (define/contract errmsg
    (db? . -> . string?)
    (lambda (db)
      (sqlite3_errmsg (db-handle db))))
  (define/contract changes-count
    (db? . -> . integer?)
    (lambda (db)
      (sqlite3_changes (db-handle db))))
  (define/contract total-changes-count
    (db? . -> . integer?)
    (lambda (db)
      (sqlite3_total_changes (db-handle db)))))