;;;; sqlite3-tinyclos.scm {{{
;;;; Provides a bridge between persistent storage in SQLite3 tables and
;;;; TinyCLOS objects.

(define-extension sqlite3-tinyclos
  (export
    <sqlite3:stored-object-class>
    <sqlite3:stored-object>
    initialize
    sqlite3:db
    sqlite3:table
    sqlite3:pk
    sqlite3:pk/select
    sqlite3:pk/update
    sqlite3:pk/where
    sqlite3:fields
    sqlite3:set-pk!
    sqlite3:in-store?
    sqlite3:create-in-store!
    sqlite3:remove-from-store!
    sqlite3:get-stored-property
    sqlite3:set-stored-property!
    sqlite3:field-name->getter-symbol
    sqlite3:field-name->setter-symbol
    sqlite3:define-stored-object-class))

(require-extension
  (srfi 1) (srfi 13) (srfi 26) lolevel extras tinyclos sqlite3)
;;;; }}}

;;; metaclass for database object classes {{{
(define-class <sqlite3:stored-object-class> (<class>)
  (db table pk fields))

;; initialize an instance {{{
(define-method (initialize (self <sqlite3:stored-object-class>) initargs)
  (call-next-method)
  (initialize-slots self initargs)
  (let ((fields (sqlite3:map-row
		  (lambda (cid name type not-null? default-value pk?)
		    (cons (not (zero? pk?)) name))
		  (sqlite3:db self)
		  (sprintf "PRAGMA table_info(~A);" (sqlite3:table self)))))
    (slot-set! self 'pk
      (filter-map (lambda (f) (and (car f) (cdr f))) fields))
    (slot-set! self 'fields
      (filter-map (lambda (f) (and (not (car f)) (cdr f))) fields))))
;; }}}

;; get database handle {{{
(define-generic sqlite3:db)
(define-method (sqlite3:db (self <sqlite3:stored-object-class>))
  (slot-ref self 'db))
;; }}}

;; get database table name {{{
(define-generic sqlite3:table)
(define-method (sqlite3:table (self <sqlite3:stored-object-class>))
  (slot-ref self 'table))
;; }}}

;; get database table primary key {{{
(define-generic sqlite3:pk)
(define-method (sqlite3:pk (self <sqlite3:stored-object-class>))
  (slot-ref self 'pk))

(define-generic sqlite3:pk/select)
(define-method (sqlite3:pk/select (self <sqlite3:stored-object-class>))
  (string-intersperse (sqlite3:pk self) ", "))

(define-generic sqlite3:pk/update)
(define-method (sqlite3:pk/update (self <sqlite3:stored-object-class>))
  (string-intersperse
    (map (cut string-append <> " = ?") (sqlite3:pk self)) ", "))

(define-generic sqlite3:pk/where)
(define-method (sqlite3:pk/where (self <sqlite3:stored-object-class>))
  (string-intersperse
    (map (cut string-append <> " = ?") (sqlite3:pk self)) " AND "))
;; }}}

;; get database table fields {{{
(define-generic sqlite3:fields)
(define-method (sqlite3:fields (self <sqlite3:stored-object-class>))
  (slot-ref self 'fields))
;; }}}
;;; }}}

;;; base class for database objects {{{
(define-class <sqlite3:stored-object> (<object>)
  (pk))

;; initialize an instance {{{
(define-method (initialize (self <sqlite3:stored-object>) initargs)
  (call-next-method)
  (if (and (pair? initargs) (symbol? (car initargs)))
    (initialize-slots self initargs)
    (slot-set! self 'pk initargs))
  (unless (sqlite3:in-store? self)
    (sqlite3:create-in-store! self)))
;; }}}

;; get primary key data {{{
(define-method (sqlite3:pk (self <sqlite3:stored-object>))
  (slot-ref self 'pk))
;; }}}

;; set primary key data {{{
(define-generic sqlite3:set-pk!)
(define-method (sqlite3:set-pk! (self <sqlite3:stored-object>) . new-pk)
  (apply sqlite3:exec
    (sqlite3:db self)
    (sprintf "UPDATE ~A SET ~A WHERE ~A;"
      (sqlite3:table self)
      (sqlite3:pk/update self)
      (sqlite3:pk/where self))
    (append new-pk (sqlite3:pk self)))
  (slot-set! self 'pk new-pk))
;; }}}

;; get database, table, primary key and field information from class {{{
(define-method (sqlite3:db (self <sqlite3:stored-object>))
  (sqlite3:db (class-of self)))

(define-method (sqlite3:table (self <sqlite3:stored-object>))
  (sqlite3:table (class-of self)))

(define-method (sqlite3:pk/select (self <sqlite3:stored-object>))
  (sqlite3:pk/select (class-of self)))

(define-method (sqlite3:pk/update (self <sqlite3:stored-object>))
  (sqlite3:pk/update (class-of self)))

(define-method (sqlite3:pk/where (self <sqlite3:stored-object>))
  (sqlite3:pk/where (class-of self)))

(define-method (sqlite3:fields (self <sqlite3:stored-object>))
  (sqlite3:fields (class-of self)))
;; }}}

;; check for existence of the stored representation {{{
(define-generic sqlite3:in-store?)
(define-method (sqlite3:in-store? (self <sqlite3:stored-object>))
  (not (zero? (apply sqlite3:first-result
		(sqlite3:db self)
		(sprintf "SELECT count(*) FROM ~A WHERE ~A;"
		  (sqlite3:table self) (sqlite3:pk/where self))
		(sqlite3:pk self)))))
;; }}}

;; create stored representation if it does not exist already {{{
(define-generic sqlite3:create-in-store!)
(define-method (sqlite3:create-in-store! (self <sqlite3:stored-object>))
  (not (zero? (apply sqlite3:update
		(sqlite3:db self)
		(sprintf "INSERT OR IGNORE INTO ~A(~A) VALUES(~A);"
		  (sqlite3:table self) (sqlite3:pk/select self)
		  (string-intersperse
		    (make-list (length (sqlite3:pk self)) "?") ", "))
		(sqlite3:pk self)))))
;; }}}

;; remove stored representation of the object {{{
(define-generic sqlite3:remove-from-store!)
(define-method (sqlite3:remove-from-store! (self <sqlite3:stored-object>))
  (not (zero? (apply sqlite3:update
		(sqlite3:db self)
		(sprintf "DELETE FROM ~A WHERE ~A;"
		  (sqlite3:table self)
		  (sqlite3:pk/where self))
		(sqlite3:pk self)))))
;; }}}

;; get a stored property {{{
(define-generic sqlite3:get-stored-property)
(define-method (sqlite3:get-stored-property
		 (self <sqlite3:stored-object>) (prop <string>))
  (apply sqlite3:first-result
    (sqlite3:db self)
    (sprintf "SELECT ~A FROM ~A WHERE ~A;"
      prop (sqlite3:table self) (sqlite3:pk/where self))
    (slot-ref self 'pk)))
;; }}}

;; set a stored property {{{
(define-generic sqlite3:set-stored-property!)
(define-method (sqlite3:set-stored-property!
		 (self <sqlite3:stored-object>) (prop <string>) value)
  (apply sqlite3:exec
    (sqlite3:db self)
    (sprintf "UPDATE ~A SET ~A = ? WHERE ~A;"
      (sqlite3:table self) prop (sqlite3:pk/where self))
    value
    (sqlite3:pk self)))
;; }}}
;;; }}}

;;; create a new database object class {{{
(define (sqlite3:field-name->getter-symbol name #!optional (prefix "")) ;; {{{
  (let ((name (string-translate name #\_ #\-)))
    (string->symbol
      (string-append
	prefix
	(if (string-prefix? "is-" name)
	  (string-append (substring name 3) "?")
	  name))))) ;; }}}

(define (sqlite3:field-name->setter-symbol name #!optional (prefix "")) ;; {{{
  (let ((name (string-translate name #\_ #\-)))
    (string->symbol
      (string-append
	prefix
	"set-"
	(if (string-prefix? "is-" name)
	  (substring name 3)
	  name)
	"!")))) ;; }}}

(define (sqlite3:define-stored-object-class db table . key-params)
  (let* ((key-pairs (map
		      (lambda (l)
			(cons (car l) (cadr l)))
		      (chop key-params 2)))
	 (prefix (->string (alist-ref prefix: key-pairs eq? "")))
	 (name/string (->string
			(alist-ref
			  name: key-pairs eq?
			  (string-append
			    prefix (string-trim-right table #\s)))))
	 (name (string->symbol name/string))
	 (symbol/string (->string
			  (alist-ref
			    symbol: key-pairs eq?
			    (string-append "<" name/string ">"))))
	 (symbol (string->symbol symbol/string))
	 (supers (alist-ref supers: key-pairs eq? '()))
	 (slots (alist-ref slots: key-pairs eq? '()))
	 (class (make <sqlite3:stored-object-class>
		  'name name
		  'direct-supers (append supers (list <sqlite3:stored-object>))
		  'direct-slots slots
		  'db db
		  'table table)))
    (for-each
      (lambda (name)
	(let* ((getter-sym (sqlite3:field-name->getter-symbol name prefix))
	       (getter (if (global-bound? getter-sym)
			 (global-ref getter-sym)
			 (let ((getter (make-generic
					 (symbol->string getter-sym))))
			   (global-set! getter-sym getter)
			   getter))))
	  (add-method getter
	    (make-method (list class)
	      (if (string-prefix? "is_" name)
		(lambda (call-next-method self)
		  (let ((flag? (sqlite3:get-stored-property self name)))
		    (and flag? (not (zero? flag?)))))
		(lambda (call-next-method self)
		  (sqlite3:get-stored-property self name))))))
	(let* ((setter-sym (sqlite3:field-name->setter-symbol name prefix))
	       (setter (if (global-bound? setter-sym)
			 (global-ref setter-sym)
			 (let ((setter (make-generic
					 (symbol->string setter-sym))))
			   (global-set! setter-sym setter)
			   setter))))
	  (add-method setter
	    (if (string-prefix? "is_" name)
	      (make-method (list class <boolean>)
		(lambda (call-next-method self flag?)
		  (sqlite3:set-stored-property! self name (if flag? 1 0))))
	      (make-method (list class <top>)
		(lambda (call-next-method self value)
		  (sqlite3:set-stored-property! self name value)))))))
      (sqlite3:fields class))
    (global-set! symbol class)))
;;; }}}

;;;; vim:set shiftwidth=2 softtabstop=2 foldmethod=marker: ;;;;