#lang scheme/base

(require (prefix-in sqlite: (planet jaymccarthy/sqlite:4))
         (prefix-in log: (planet synx/log))
         (planet synx/util/unwind-protect)
         (prefix-in finalize: (planet synx/util/finalize))
         
         scheme/class
         scheme/contract)

(define statement%
  (class object%
    (init-field get-context sql)
    
    (define statement #f)
    (define (get-statement)
      (or statement 
          (begin
            (set! statement (sqlite:prepare (get-context) sql))
            statement)))
    
    (super-new)
    
    (define/public (load . params)
      (apply sqlite:load-params (get-statement) params))
    
    (define/public (finalize)
      (when statement
        (when (sqlite:open-statement? statement)
          (sqlite:finalize statement))
        (set! statement #f)))
    
    (define (reset)
      (sqlite:reset (get-statement)))
    
    (define/public (with-resetting params thunk)
      (dynamic-wind
       (λ () 
         (reset)
         (when (not (null? params))
           (apply sqlite:load-params (get-statement) params)))
       thunk
       reset))
    
    (define/public (for-each proc . params)
      (with-resetting 
       params
       (λ ()
         (let loop ()
           (let ([row (sqlite:step statement)])
             (when row
               (apply proc (vector->list row))
               (loop)))))))

    (define/public (fold proc init . params)
      (with-resetting
       params
       (λ ()
         (let loop ([result init])
           (let ([row (sqlite:step statement)])
             (if row
                 (loop (proc row result))
                 result))))))
    
    (define/public (once . params)
      (with-resetting
       params
       (λ () (sqlite:step statement))))
      
    (define/public (map proc)
      (begin0
        (reverse
         (fold (λ (row result) (cons (apply proc (vector->list row)) result)) null))))))

(define (hash-for-each-value h proc)
  (let loop ((i (hash-iterate-first h)))
    (when i
      (proc (hash-iterate-value h i))
      (loop (hash-iterate-next h i)))))

(define connection%
  (class object%
    (init-field (path ':memory:))
    (super-new)
    (define context #f)
    (when (string? path)
      (set! path (string->path path)))
    (define (get-context)
      (or context
          (begin
            (set! context (sqlite:open path))
            context)))
    
    (define statements (make-immutable-hash null))
        
    (define/public (clear)
      (when context
        (hash-for-each-value
         statements
         (λ (statement) 
           (send statement finalize)))
        (sqlite:close context)
        (set! statements (make-immutable-hash null))
        (set! context #f)))
      
    ; because no hash for weak values...
    (define/public (prepare sql)
      (define (new-statement)
        (let ((stmt (make-object statement% get-context sql)))
          (set! statements (hash-set statements sql stmt))
          stmt))
      (hash-ref statements sql new-statement))
    
    (define transaction-level 0)
    
    (define (adjust-transaction type direction)
      (cond
        ((and (eq? type 'begin) (= transaction-level 0))
         (send (prepare "BEGIN") once))
        ((= transaction-level 1)
         (send (prepare (if (eq? type 'rollback) "ROLLBACK" "END")) once)))
      (set! transaction-level (+ transaction-level direction)))
    
    (define/public (with-transaction body)
      (adjust-transaction 'begin 1)
      (call-with-exception-handler
       (λ (e) 
         (adjust-transaction 'rollback -1)
         e)
       body)
      (adjust-transaction 'end -1))
    
    (define (do-clear (myself #f))
      (clear))
    
    (finalize:register this do-clear)
    
    (define/public (with-clearing body)
      (rewind-protect
       body
       do-clear))
      
    
    (define/public (changes-count)
      (sqlite:changes-count context))
    
    (define/public (last-insert)
      (sqlite:last-insert-rowid context))
    
    (define/public (map proc sql . params)
      (let ([stmt (prepare sql)])
        (send/apply stmt load params)
        (send stmt map proc)))
    
    (define/public (for-each proc sql . params)
      (let ([stmt (prepare sql)])
        (send/apply stmt load params)
        (send stmt for-each proc)))
    
    (define/public (fold proc init sql . params)
      (let ([stmt (prepare sql)])
        (send/apply stmt load params)
        (send stmt fold proc init)))
    
    (define/public (once sql . params)
      (let ([stmt (prepare sql)])
        (send/apply stmt once params)))
    
    ; etc...
    ))

(define-syntax-rule (with-transaction c body ...)
  (send c with-transaction (λ () body ...)))

(define-syntax-rule (with-resetting stmt body ...)
  (send stmt with-resetting null (λ () body ...)))

(define-syntax-rule (with-clearing c body ...)
  (send c with-clearing (λ () body ...)))

;(provide connection% (rename-out (sqlite:with-transaction with-transaction)))
(provide connection% with-transaction with-resetting with-clearing)

(define (test (path ':memory:))
  (define c (new connection% (path path)))
  (send c clear)
  (with-clearing 
   c
   (send c once "CREATE TABLE IF NOT EXISTS foo (id INTEGER PRIMARY KEY, bar TEXT)"))
  (send (send c prepare "INSERT INTO foo (bar) VALUES (?)") once "42")
  (send (send c prepare "SELECT id,bar FROM foo") fold cons null))