(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? (list? list? . c-> . integer?) . c-> . void?)]
   [exec/ignore (db? string? . c-> . void?)]
   [select (db? string? . c-> . (listof list?))]
   [prepare (db? string? . c-> . statement?)]
   [load-params ((statement?) (listof (union string? number? bytes?)) . ->* . (void?))]
   [step (statement? . c-> . (union (listof (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 (listof (union string? number? false/c bytes?))))])
  (provide transaction/lock
           transaction)
  
  ; 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)))))))
  
  (define (wrap-finalizer o f)
    (register-finalizer o f)
    o)
  
  (define (handle-status 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 s)))
                                (current-continuation-marks)))))
  
  (define (lookup-status-message s)
    (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)])
      (when (handle-status (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 (sqlite3_close (db-handle (make-db o-_db_ptr #f #f)))))
      (void)))
  
  (define (exec 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))))])
      (handle-status
       (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 (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 (prepare db sql)
    (let ([stmt (wrap-finalizer (make-statement (malloc _sqlite3_stmt_ptr_ptr))
                                finalize)])
      (when (handle-status 
             (sqlite3_prepare (db-handle db)
                              sql
                              (string-length sql)
                              (statement-_stmt_ptr stmt)
                              (db-_errMsg_ptr db)))
        stmt)))
  (define (load-params stmt . params)
    (begin (reset stmt)
           (for-each
            (lambda (i)
              (let* ([param (list-ref params i)]
                     [pi (+ i 1)]
                     [ctype (sqlite3_column_decltype (statement-handle stmt) pi)]
                     [itype (cond 
                              [(integer? param) "INTEGER"]
                              [(number? param) "FLOAT"]
                              [(string? param) "TEXT"]
                              [(bytes? param) "BLOB"]
                              [else "NULL"])])
                (handle-status
                 (match (or ctype itype)
                   ["NULL" (sqlite3_bind_null (statement-handle stmt) pi)]
                   ["INTEGER" (sqlite3_bind_int (statement-handle stmt) pi param)]
                   ["FLOAT" (sqlite3_bind_double (statement-handle stmt) pi param)]
                   [(or "STRING" "TEXT") (sqlite3_bind_text (statement-handle stmt) pi param)]
                   ["BLOB" (sqlite3_bind_blob (statement-handle stmt) pi param)]))))
            (build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity))))
  (define (step stmt)
    (let ([s (handle-status (sqlite3_step (statement-handle stmt)))])
      (cond
        [(= s SQLITE_ROW)
         (map (lambda (i) 
                (match (sqlite3_column_decltype (statement-handle stmt) i)
                  ["NULL" #f]
                  ["INTEGER" (sqlite3_column_int (statement-handle stmt) i)]
                  ["FLOAT" (sqlite3_column_double (statement-handle stmt) i)]
                  [(or #f "STRING" "TEXT") (sqlite3_column_text (statement-handle stmt) i)]
                  ["BLOB" (sqlite3_column_blob (statement-handle stmt) i)]))
              (build-list (sqlite3_bind_parameter_count (statement-handle stmt)) identity))]
        [(= s SQLITE_DONE)
         #f])))
  (define (run stmt . params)
    (begin (apply load-params stmt params)
           (handle-status (sqlite3_step (statement-handle stmt)))
           (void)))
  (define (reset stmt)
    (handle-status (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 (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"]))
  (define (transaction/lock0 db lock-type body-f)
    (let ([end (lambda () (exec/ignore db "ROLLBACK TRANSACTION"))])
      (exec/ignore db (format "BEGIN ~a TRANSACTION" (lock-type->string lock-type)))
      (let/ec fail
        (body-f fail)
        (set! end (lambda () (exec/ignore db "COMMIT TRANSACTION"))))
      (end)))
  (define-syntax transaction/lock
    (syntax-rules ()
      [(_ db lock-type fail body ...)
       (transaction/lock0 db 'lock-type (lambda (fail) body ...))]))
  (define-syntax transaction
    (syntax-rules ()
      [(_ db fail body ...)
       (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)))))))