(in-package :odb)

(defvar *db*)
(defvar *print-id* t)
(defvar *make-proxy* nil)
(defvar *reify* nil)
(defvar *touch* nil)
(defvar *default-transaction*)
(defvar *transaction* nil)
(defvar *princ-object* t)
(defconstant +inline-count+ 16)

(defclass object-database ()
  ((home :accessor home :initarg :home)
   (current-id :accessor current-id :initform nil)
   (objects :accessor objects :initarg :objects)
   (btrees :accessor btrees :initarg :btrees)
   (read-lock :accessor read-lock :initarg :read-lock)
   (update-lock :accessor update-lock :initarg :update-lock)))

(defclass transaction ()
  ((cached-objects :accessor cached-objects)
   (dirty-objects :accessor dirty-objects :initform '())
   (deleted-objects :accessor deleted-objects :initform '())))

(defclass id-mixin ()
  ((id :accessor id :initarg :id :initform nil)))

(defclass proxy (id-mixin)
  ())

(defclass persistent-object (id-mixin)
  ())

(defclass node (persistent-object)
  ())

(defclass database ()
  ((handle :accessor handle :initarg :handle :initform 0)))

(defclass caching-database (database)
  ())

(defmacro with-object-database ((&optional (partial-home #p"db/")) &body body)
  (with-unique-names (home objects btrees)
    `(let* ((,home (merge-pathnames ,partial-home site:+data-directory+))
	    (*db-directory* ,home))
       (with-database (,objects "objects" 'integer)
	 (with-database (,btrees "btrees" 't)
	   (let* ((*db*
		   (make-instance
		    'object-database
		    :home ,home
		    :objects (make-instance 'caching-database :handle ,objects)
		    :btrees (make-instance 'database :handle ,btrees)))
		  (*default-transaction* (make-instance 'transaction))
		  (*transaction* *default-transaction*)
		  (*reify* t))
	     (with-lock ((read-lock *db*) :shared)
	       ,@body)))))))

(defmethod initialize-instance :after ((db object-database) &key home)
  (setf (read-lock db) (make-lock (merge-pathnames "read" home))
	(update-lock db) (make-lock (merge-pathnames "update" home))))

(defun get-next-object-id (db)
  (if (current-id db)
      (incf (current-id db))
      (let ((cursor (db-cursor (handle (objects db)))))
	(unwind-protect
	     (setf (current-id db)
		   (if (db-cursor-move cursor +db-last+)
		       (1+ (parse-integer *db-key*))
		       0))
	  (db-cursor-close cursor)))))

(defun %get (db key)
  (db-get (handle db)
	  (let ((*print-id* :bare))
	    (prin1-to-string key))))

(defun %put (db key value &optional (print-id t))
  (db-put (handle db)
	  (let ((*print-id* :bare))
	    (prin1-to-string key))
	  (let ((*print-id* print-id))
	    (prin1-to-string value))))

(defun %delete (db key)
  (db-delete (handle db)
	     (let ((*print-id* :bare))
	       (prin1-to-string key))))

(defun datum->object (&optional (datum *db-value*))
  (string-to-object (copy-seq datum)))

(defun commit (&optional (transaction *transaction*))
  (let ((lock (read-lock *db*)))
    (with-lock (lock nil)
      (with-lock (lock :exclusive)
	(loop for object in (dirty-objects transaction)
	      unless (id object)
	      do (setf (id object) (get-next-object-id *db*)))
	(loop for object in (dirty-objects transaction)
	      do (commit-object object))
	(loop for id in (deleted-objects transaction)
	      do (%delete (objects *db*) id))
	(db-sync (handle (objects *db*)))
	(db-sync (handle (btrees *db*))))))
  (reload-cached-objects)
  (setf (dirty-objects transaction) '()
	(deleted-objects transaction) '()))

(defmethod commit-object ((object persistent-object))
  (%put (objects *db*) (id object) object nil))

(defun rollback (&optional (transaction *transaction*))
  (setf (dirty-objects transaction) '()
	(deleted-objects transaction) '()))

(defmethod initialize-instance :after ((transaction transaction) &key cached-objects)
  (setf (cached-objects transaction)
	(cond (cached-objects cached-objects)
	      (*transaction* (cached-objects *transaction*))
	      (t (make-hash-table)))))

(defun reload-cached-objects (&optional (transaction *transaction*))
  (loop for node being the hash-values of (cached-objects transaction)
        when (typep node 'node)
        do (change-class node 'proxy)
        and do (reify node)))

(defun execute-transaction (fn)
  (if (eq *transaction* *default-transaction*)
      (let* ((*transaction* (make-instance 'transaction))
	     (lock (read-lock *db*))
	     (*touch* t))
	(with-lock (lock nil)
	  (with-lock ((update-lock *db*) :exclusive)
	    (with-lock (lock :shared)
	      (multiple-value-prog1
		  (progn
		    (reload-cached-objects)
		    (funcall fn))
		(commit))))))
      ;; Use existing transaction.
      (funcall fn)))

(defmacro with-transaction ((&key) &body body)
  `(execute-transaction (lambda () ,@body)))

(defmethod get-value ((db caching-database) key)
  (let* ((cached-objects (cached-objects *transaction*))
	 (object (gethash key cached-objects)))
    (cond (object (values (reify object) t))
	  ((%get db key) (values (setf (gethash key cached-objects) (datum->object)) t)))))

(defmethod get-value ((db database) key)
  (when (%get db key)
    (values (reify (datum->object)) t)))

(defmethod initialize-instance :after ((object persistent-object) &key &allow-other-keys)
  (touch object))

(defun touch (object)
  (prog1 object
    (when *touch*
      (pushnew object (dirty-objects *transaction*)))))

(defmethod reify ((object t))
  object)

(defmethod reify ((cons cons))
  (let ((car (car cons))
	(cdr (cdr cons)))
    (setf (car cons) (reify car)
	  (cdr cons) (reify cdr))
    ;; Simply 'evaporate' parts of the tree that contain
    ;; proxy objects that aren't reified.
    (cond ((and (typep car 'proxy)
		(eq (car cons) nil)
		(listp (cdr cons)))
	   (cdr cons))
	  ((and (typep cdr 'proxy)
		(eq (cdr cons) nil)
		(listp (car cons)))
	   (car cons))
	  (t
	   cons))))

(defmethod reify ((object proxy))
  (when (and (%get (objects *db*) (id object))
	     (>= (length *db-value*) 5))
    (whereas ((value (copy-seq *db-value*))
	      (start (1+ (position #\( value))))
      (with-input-from-string (stream value :start start)
	(let ((*package* site:+package+)
	      (*touch* nil)
	      (*make-proxy* t))
	  (whereas ((class-name (read stream nil nil))
		    (initargs (read-delimited-list #\) stream)))
	    (change-class object class-name)
	    (apply #'initialize-instance object initargs)
	    object))))))

(defmethod slot-value-using-class :around (class (node node) slot)
  (let ((*touch* nil)
	(value (call-next-method)))
    (if (and *reify* (sometree (lambda (x) (typep x 'proxy)) value))
	(setf (slot-value-using-class class node slot) (reify value))
	value)))

(defmethod (setf slot-value-using-class) :after (new-value class (node node) slot)
  (declare (ignore new-value class slot))
  (touch node))

(defmethod princ-object ((object t) stream)
  (let ((*princ-object* nil))
    (princ object stream)))

(defmethod print-object ((object id-mixin) stream)
  (when (and (not *print-escape*) *princ-object*)
    (princ-object object stream)
    (return-from print-object))
  (let (id)
    (if (and *print-id* (slot-boundp object 'id) (setf id (id object)))
	(format stream "~:[#i~;~]~d" (eq *print-id* :bare) id)
	(call-next-method))))

(defmethod print-object ((object standard-object) stream)
  (when (and (not *print-escape*) *princ-object*)
    (princ-object object stream)
    (return-from print-object))
  (let ((class (class-of object))
        (*package* site:+package+))
    (format stream "#S(~s" (class-name class))
    (dolist (slot (class-slots class))
      (let ((name (slot-definition-name slot))
	    (initargs (slot-definition-initargs slot))
	    (*print-id* t)
	    (*reify* nil))
	(when (and initargs (slot-boundp object name))
	  (let ((value (slot-value object name))
		(initfunction (slot-definition-initfunction slot)))
	    (unless (and initfunction (equal value (funcall initfunction)))
	      (format stream " ~s ~s" (first initargs) value))))))
    (write-char #\) stream)))

(defun read-object (stream char arg)
  (declare (ignore char arg))
  (let ((*package* site:+package+)
        (*make-proxy* t)
        (*touch* nil))
    (apply #'make-instance (read stream))))

(defun read-object-by-id (stream char arg)
  (declare (ignore char arg))
  (let ((id (read stream)))
    (if *make-proxy*
	(let ((cached-objects (cached-objects *transaction*)))
	  (or (gethash id cached-objects)
	      (setf (gethash id cached-objects)
		    (make-instance 'proxy :id id))))
        (values
	 (get-value (objects *db*) id)))))

(set-dispatch-macro-character #\# #\s 'read-object)
(set-dispatch-macro-character #\# #\S 'read-object)
(set-dispatch-macro-character #\# #\i 'read-object-by-id)
(set-dispatch-macro-character #\# #\I 'read-object-by-id)

(defmethod compare-objects ((a id-mixin) (b id-mixin))
  (compare (id a) (id b)))

(defmethod compare-objects ((a integer) (b id-mixin))
  (compare a (id b)))

(defmethod compare-objects ((a id-mixin) (b integer))
  (compare (id a) b))