(module sql-oo mzscheme
  (require (lib "class.ss")
           (lib "list.ss")
           (lib "unitsig.ss")
           (all-except (lib "13.ss" "srfi") string-upcase string-titlecase string-downcase)
           (prefix sqlite: (planet "sqlite.ss" ("jaymccarthy" "sqlite.plt" 3))))
  (provide (all-defined))
  
  ; Other helpers
  (define (string/not-suffix s)
    (string-drop-right s 1))
  
  ; SQL helpers
  (define (sql:step/return-first db sql)
    (lambda args
      (let ([db:stmt (sqlite:prepare db sql)])
        (apply sqlite:load-params db:stmt args)
        (let ([r (sqlite:step db:stmt)])
          (sqlite:finalize db:stmt)
          (if r
              (vector-ref r 0)
              #f)))))
  (define (sql:run db sql)
    (lambda args
      (let ([db:stmt (sqlite:prepare db sql)])
        (apply sqlite:run db:stmt args)
        (sqlite:finalize db:stmt))))
  
  ; Basic DB operations
  (define (object-type db _path)
    ((sql:step/return-first db "SELECT type FROM object WHERE path = ?") _path))
  
  ; DB Object
  (define sql-oo<%> (interface () get-db init-sql init-db object type->class))
  (define sql-oo%
    (class* object% (sql-oo<%>)
      (init-field db-path)
      (field [db #f])
      
      (define/public (get-db)
        db)
      
      (define/pubment (init-sql)
        (append
         `("CREATE TABLE object ( path STRING UNIQUE, type STRING )")
         (inner `() init-sql)))
      (define/public (init-db really?)
        (when (eq? really? 'really)
          (when db
            (sqlite:close db))
          (when (file-exists? db-path)
            (delete-file db-path))
          (set! db (sqlite:open db-path))
          (when db
            (for-each
             (lambda (sql)
               (sqlite:exec/ignore db sql))
             (init-sql)))))
      
      (define/pubment (type->class type)
        (inner #f type->class type))
      
      (define cache (make-hash-table 'equal))
      (define (get-object class% db type path)
        (let ([key (string-append type ":" path)])
          (hash-table-get cache key
                          (lambda ()
                            (let ([o (make-object class% db path)])
                              (hash-table-put! cache key o)
                              o)))))
      
      (define/public object
        (case-lambda
          [(path)          
           (let* ([the-type (object-type db path)]
                  [class% (type->class the-type)])
             (if class%
                 (get-object class% db the-type path)
                 #f))]
          [(path type)
           (let ([the-type (object-type db path)])
             (if (or (equal? the-type type)
                     (equal? the-type #f))
                 (let ([class% (type->class type)])
                   (if class%
                       (get-object class% db type path)
                       #f))
                 #f))]))
      
      (when (not (file-exists? db-path))
        (init-db 'really))
      (if (not db)
          (set! db (sqlite:open db-path)))
      (super-new)))
    
  ; Mixin
  (define (db-class->mixin-maker _type _init-sql)
    (lambda (_class)
      (mixin (sql-oo<%>) (sql-oo<%>)    
        (define/augment (init-sql)
          (append _init-sql
                  (inner `() init-sql)))
        
        (define/augment (type->class type)
          (if (equal? type _type)
              _class
              (inner #f type->class type)))
        
        (super-new))))
  
  ; Unit
  (define-signature db-addon^ (<%> % mixin-maker))
  (define (db-class-unit->mixin _unit)
    (define-values/invoke-unit/sig db-addon^ _unit)
    (mixin-maker %))
  
  ; DB-ify classes
  (define db-object<%> (interface () path type))
  (define db-object%
    (class* object% (db-object<%>)
      (init-field db _path)
      
      (define/public (path)
        _path)
      (define/public (type)
        ((sql:step/return-first db "SELECT type FROM object WHERE path = ?") _path))
      
      (super-new)))
  
  (define-syntax (db-class@ stx)
    (syntax-case stx ()
      [(_ sql_table_name (field ...))
       (with-syntax ([(field! ...) (datum->syntax-object 
                                    (syntax (field ...))
                                    (map (lambda (s) (string->symbol (string-append (symbol->string s) "!")))
                                         (syntax-object->datum (syntax (field ...)))))])
         (syntax
          (unit/sig db-addon^ (import)
                (define <%> (interface (db-object<%>)
                                   field ...
                                   field! ...))
                (define %
                  (class* db-object% (<%>)
                    (inherit-field db _path)
                    (define cache (make-hash-table))
                    
                    (define/public (field)
                      (hash-table-get cache
                                      'field
                                      (lambda ()
                                        (let ([r
                                               ((sql:step/return-first db (string-append "SELECT " (symbol->string 'field) 
                                                                                         " FROM " sql_table_name " WHERE path = ?"))
                                                _path)])
                                          (hash-table-put! cache 'field r)
                                          r))))
                    ...
                    (define/public (field! new)
                      (hash-table-put! cache 'field new)
                      ((sql:run db (string-append "UPDATE " sql_table_name " SET " 
                                                  (string/not-suffix (symbol->string 'field!)) " = ? WHERE path = ?"))
                       new _path))
                    ...
                    
                    ; Automatically create object if it does not exist
                    (super-new)
                    (when (equal? (object-type db _path) #f)
                      (sqlite:with-transaction (db fail)
                                               ((sql:run db "INSERT INTO object VALUES ( ?, ? )") _path sql_table_name)
                                               ((sql:run db (string-append "INSERT INTO " sql_table_name " VALUES ( ?, " 
                                                                           (string/not-suffix
                                                                            (apply string-append
                                                                                   (map (lambda (f) "\"\",")
                                                                                        (list 'field ...))))
                                                                           " ) ")) _path)))))
                (define mixin-maker
                  (db-class->mixin-maker
                   sql_table_name
                   (list
                    (string-append
                     "CREATE TABLE " sql_table_name " ( path STRING UNIQUE, "
                     (string/not-suffix
                      (apply string-append
                             (map (lambda (f) (string-append " " (symbol->string f) " STRING,"))
                                  (list 'field ...))))
                     " ) ")))))))]))
  
  ; Mixin helpers
  (define (apply-mixins b . m)
    (foldl (lambda (mixin base) (mixin base))
           b m))
  (define (apply-units b . u)
    (apply apply-mixins b
           (map db-class-unit->mixin u))))