(module sqlite mzscheme
  (require (lib "etc.ss")
           (lib "list.ss")
           (lib "plt-match.ss")
           (all-except (lib "contract.ss") ->)
           (rename (lib "contract.ss") c-> ->)
           "sqlite-ffi.ss")
  
  ; Struct
  (define-struct (exn:sqlite exn) ())
  (define-struct db (_db_ptr _errMsg_ptr _callback_ptr))
  (define (db-handle db)
    (ptr-ref (db-_db_ptr db) _sqlite3_ptr))
  (define-struct statement (_stmt_ptr))
  (define (statement-handle stmt)
    (ptr-ref (statement-_stmt_ptr stmt) _sqlite3_stmt_ptr))
  
  ; Contracts 
  (provide SQLITE_OK
           SQLITE_ERROR)
  (provide/contract
   [db-handle (db? . c-> . cpointer?)]
   [statement-handle (statement? . c-> . cpointer?)]
   [open (path? . c-> . db?)]
   [close (db? . c-> . void?)]
   [exec (db? string? (vector? vector? . c-> . integer?) . c-> . void?)]
   [exec/ignore (db? string? . c-> . void?)]
   [insert (db? string? . c-> . integer?)]
   [select (db? string? . c-> . (listof vector?))]
   [prepare (db? string? . c-> . statement?)]
   [load-params ((statement?) (listof (union string? number? bytes?)) . ->* . (void?))]
   [step (statement? . c-> . (union (vectorof (union string? number? false/c bytes?)) false/c))]
   [run ((statement?) (listof (union string? number? bytes?)) . ->* . (void?))]
   [reset (statement? . c-> . void?)]
   [finalize (statement? . c-> . void?)]
   [errmsg (db? . c-> . string?)]
   [changes-count (db? . c-> . integer?)]
   [total-changes-count (db? . c-> . integer?)]
   [step* (statement? . c-> . (listof (vectorof (union string? number? false/c bytes?))))]
   [with-transaction* (db? (symbols 'none 'deferred 'immediate 'exclusive)  (any/c . c-> . any/c) . c-> . any/c)])
  
  (provide with-transaction/lock
           with-transaction
           (struct exn:sqlite ())
           statement?
           db?)
  
  ; Library Helpers
  (define (list->equal-sublists 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)))))))
  
  ;; cvector->list-of-vector : cvector natural natural -> (list-of vector)
  ;;
  ;; Convert a cvector holding a matrix of values with the
  ;; given number of rows and columns to a list of vectors
  (define (cvector->list-of-vector rows columns cvector)
    (define (column->vector r)
      (let ((vec (make-vector columns)))
        (let loop ((c 0))
          (if (= c columns)
              vec
              (begin
                (vector-set!
                 vec
                 c
                 (cvector-ref cvector (+ (* r columns) c)))
                (loop (add1 c)))))))
    ;; sqlite3_get_table is slightly inconsistent.  Normally
    ;; there will be one more row than reported (see the
    ;; SQLite 3 documentation) except if the select
    ;; statement returns no results, in which case there
    ;; will be no columns and rows.  Hence we check for this
    ;; here.
    (if (zero? columns)
        null
        (let loop ((r 0))
          (if (= r rows)
              null
              (cons
               (column->vector r)
               (loop (add1 r)))))))
  
  ;; cvector->vector : cvector -> vector
  (define (cvector->vector cvec)
    (let ((vec (make-vector (cvector-length cvec))))
      (let loop ((i (cvector-length cvec)))
        (if (zero? i)
            vec
            (begin
              (vector-set! vec (sub1 i) (cvector-ref cvec (sub1 i)))
              (loop (sub1 i)))))))
  
  (define (wrap-finalizer o f)
    (register-finalizer o f)
    o)
  
  ;; handle-status : (U db #f) integer -> integer
  ;;
  ;; Returns the status code if no error occurred, otherwise
  ;; raises an exception with an appropriate message.
  (define (handle-status db s)
    (if (or (= s SQLITE_OK)
            (= s SQLITE_ROW)
            (= s SQLITE_DONE))
        s
        (raise (make-exn:sqlite
                (string->immutable-string
                 (format "SQLite Error: ~a"
                         (lookup-status-message db s)))
                (current-continuation-marks)))))
  
  ;; lookup-status-message : (U db #f) integer -> string
  (define (lookup-status-message db s)
    (if (and (eq? s SQLITE_ERROR) db)
        (errmsg db)
        (cdr (assoc s
                    `([,SQLITE_ERROR . "Generic error, perhaps call errmsg?"]
                      [,SQLITE_INTERNAL . "An internal logic error in SQLite"]
                      [,SQLITE_PERM . "Access permission denied"]
                      [,SQLITE_ABORT . "Callback routine requested an abort"]
                      [,SQLITE_BUSY . "The database file is locked"]
                      [,SQLITE_LOCKED . "table in the database is locked"]
                      [,SQLITE_NOMEM . "A malloc() failed"]
                      [,SQLITE_READONLY . "Attempt to write a readonly database"]
                      [,SQLITE_INTERRUPT . "Operation terminated by sqlite3_interrupt()"]
                      [,SQLITE_IOERR . "Some kind of disk I/O error occurred"]
                      [,SQLITE_CORRUPT . "The database disk image is malformed"]
                      [,SQLITE_NOTFOUND . "(Internal Only) Table or record not found"]
                      [,SQLITE_FULL . "Insertion failed because database is full"]
                      [,SQLITE_CANTOPEN . "Unable to open the database file"]
                      [,SQLITE_PROTOCOL . "Database lock protocol error"]
                      [,SQLITE_EMPTY . "Database is empty"]
                      [,SQLITE_SCHEMA . "The database schema changed"]
                      [,SQLITE_TOOBIG . "Too much data for one row of a table"]
                      [,SQLITE_CONSTRAINT . "Abort due to contraint violation"]
                      [,SQLITE_MISMATCH . "Data type mismatch"]
                      [,SQLITE_MISUSE . "Library used incorrectly"]
                      [,SQLITE_NOLFS . "Uses OS features not supported on host"]
                      [,SQLITE_AUTH . "Authorization denied"]
                      [,SQLITE_FORMAT . "Auxiliary database format error"]
                      [,SQLITE_RANGE . "2nd parameter to sqlite3_bind out of range"]
                      [,SQLITE_NOTADB . "File opened that is not a database file"])))))
  
  ; Methods
  (define (open db-path)
    (let ([r (wrap-finalizer (make-db (malloc _sqlite3_ptr_ptr)
                                      (malloc _string_ptr)
                                      (malloc _pointer))
                             close)]
          [db-path (if (relative-path? db-path)
                       (build-path (current-directory) db-path)
                       db-path)])
      (when (handle-status r (sqlite3_open db-path (db-_db_ptr r)))
        r)))
  
  (define (close db)
    (let ([o-_db_ptr (db-_db_ptr db)])
      (set-db-_db_ptr! db #f)
      (set-db-_errMsg_ptr! db #f)
      (set-db-_callback_ptr! db #f)
      (when o-_db_ptr
        (handle-status db (sqlite3_close (db-handle (make-db o-_db_ptr #f #f)))))
      (void)))
  
  (define (insert db sql)
    (exec/ignore db sql)
    (sqlite3_last_insert_rowid (db-handle db)))
  
  (define (exec db sql callback)
    (let ([exec-callback
           (lambda (arg_ptr column-count_int column-values_ptr column-names_ptr)
             (callback
              (cvector->vector
               (make-cvector* column-names_ptr _string column-count_int))
              (cvector->vector
               (make-cvector* column-values_ptr _string column-count_int))))])
      (handle-status
       db
       (sqlite3_exec (db-handle db)
                     sql
                     (contract
                      (cpointer? integer? cpointer? cpointer? . c-> . integer?)
                      exec-callback
                      'positive 'negative)
                     (db-_callback_ptr db)
                     (db-_errMsg_ptr db)))
      (void)))
  (define (exec/ignore db sql)
    (exec db sql (lambda (c v) 0)))
  
  (define (select 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)])
      (when (handle-status
             db
             (sqlite3_get_table (db-handle db)
                                sql
                                result_ptr_ptr
                                row-count_ptr
                                column-count_ptr
                                (db-_errMsg_ptr db)))
        (cvector->list-of-vector
         (add1 (ptr-ref row-count_ptr _int))
         (ptr-ref column-count_ptr _int)
         (make-cvector* (ptr-ref result_ptr_ptr _string_array)
                        _string 
                        (* (+ (ptr-ref row-count_ptr _int) 1)
                           (ptr-ref column-count_ptr _int)))))))
  
  (define (prepare db sql)
    (let ([stmt (wrap-finalizer (make-statement (malloc _sqlite3_stmt_ptr_ptr))
                                finalize)])
      (when (handle-status
             db
             (sqlite3_prepare (db-handle db)
                              sql
                              (string-length sql)
                              (statement-_stmt_ptr stmt)
                              (db-_errMsg_ptr db)))
        (if  (zero? (ptr-ref (statement-_stmt_ptr stmt) _int))
             ;; the pointer is null; SQLite didn't raise an
             ;; error but should have!
             (handle-status db SQLITE_ERROR)
             stmt))))
  
  (define (load-params stmt . params)
    (let* ((handle (statement-handle stmt))
           (parameter-count (sqlite3_bind_parameter_count handle)))
      (when (not (= (length params) parameter-count))
        (raise-mismatch-error
         'load-params
         (format "Given ~a params when statement requires ~a params" (length params) parameter-count)
         params))
      (begin
        (reset stmt)
        (let loop ((i 1) (params params))
          (if (null? params)
              (void)
              (begin
                (let* ([param (car params)])
                  (handle-status
                   #f
                   (cond
                     [(integer? param)
                      (sqlite3_bind_int64 handle i param)]
                     [(number? param)
                      (sqlite3_bind_double handle i param)]
                     [(string? param)
                      (sqlite3_bind_text handle i param)]
                     [(bytes? param)
                      (sqlite3_bind_blob handle i param)]
                     [else
                      (sqlite3_bind_null handle i)])))
                (loop (add1 i) (cdr params))))))))
  
  (define (step stmt)
    (let ([s (handle-status
              #f
              (sqlite3_step (statement-handle stmt)))])
      (cond
        [(= s SQLITE_ROW)
         (let* ((cols (sqlite3_column_count (statement-handle stmt)))
                (vec (make-vector cols))
                (handle (statement-handle stmt)))
           (let loop ((i 0))
             (if (= i cols)
                 vec
                 (begin
                   (vector-set!
                    vec
                    i
                    (match (sqlite3_column_decltype handle i)
                      ["NULL" #f]
                      ["INTEGER" (sqlite3_column_int64 handle i)]
                      ["FLOAT" (sqlite3_column_double handle i)]
                      [(or #f "STRING" "TEXT")
                       (sqlite3_column_text handle i)]
                      ["BLOB" (sqlite3_column_blob handle i)]))
                   (loop (add1 i))))))]
        [(= s SQLITE_DONE)
         #f])))
  
  (define (run stmt . params)
    (begin (apply load-params stmt params)
           (handle-status #f (sqlite3_step (statement-handle stmt)))
           (void)))
  
  (define (reset stmt)
    (handle-status #f (sqlite3_reset (statement-handle stmt)))
    (void))
  
  (define (finalize stmt)
    (let ([o-_stmt_ptr (statement-_stmt_ptr stmt)])
      (set-statement-_stmt_ptr! stmt #f)
      (when o-_stmt_ptr
        (handle-status #f (sqlite3_finalize (statement-handle (make-statement o-_stmt_ptr)))))
      (void)))
  
  (define (lock-type->string lock-type)
    (case lock-type
      [(none) ""]
      [(deferred) "DEFERRED"]
      [(immediate) "IMMEDIATE"]
      [(exclusive) "EXCLUSIVE"]))
  
  ;; with-transaction* : db symbol (ec -> 'a) -> 'a
  (define (with-transaction* db lock-type body-f)
    (let ((end #f))
      (dynamic-wind
       (lambda ()
         (set! end (lambda ()
                     (exec/ignore db "ROLLBACK TRANSACTION")))
         (exec/ignore db
                      (format "BEGIN ~a TRANSACTION"
                              (lock-type->string lock-type))))
       (lambda ()
         (let/ec fail
           (begin0
             (body-f fail)
             (set! end
                   (lambda ()
                     (exec/ignore db "COMMIT TRANSACTION"))))))
       (lambda ()
         (end)))))
  
  (define-syntax with-transaction/lock
    (syntax-rules ()
      [(_ (db lock-type fail) body ...)
       (with-transaction* db 'lock-type (lambda (fail) body ...))]))
  (define-syntax with-transaction
    (syntax-rules ()
      [(_ (db fail) body ...)
       (with-transaction/lock (db none fail) body ...)]))
  
  (define (errmsg db)
    (sqlite3_errmsg (db-handle db)))
  (define (changes-count db)
    (sqlite3_changes (db-handle db)))
  (define (total-changes-count db)
    (sqlite3_total_changes (db-handle db)))
  
  ; User Helpers
  (define (step* stmt)
    (let loop ([r (list)])
      (let ([c (step stmt)])
        (if (not c)
            (reverse r)
            (loop (cons c r)))))))