(defpackage :webutils.simple-serialized-classes (:use :cl) (:nicknames :ssc)
            (:export :register-instance :delete-instance
                     :serialize-instance :deserialize-for-key
                     :deserialize-for-file
                     :find-instance-by-key :load-store-for-class
                     :serialize-file-name-for-key :key-of-instance
                     :class-name-of-instance
                     :define-simple-serialized-class
                     :register-key :shallow-copy-instance
                     :note-registered-instance :note-deleted-instance
                     :simple-serialized-class :store-of-class
                     :slot-to-accessor :class-has-slot-p))
(in-package :webutils.simple-serialized-classes)
(webutils::export-all :webutils.simple-serialized-classes)

(defgeneric register-instance (instance &key no-serialize))
(defgeneric delete-instance (instance))
(defgeneric serialize-instance (instance))
(defgeneric deserialize-for-file (file class))
(defgeneric deserialize-for-key (key class))
(defgeneric find-instance-by-key (key class &key find-by-loading))
(defgeneric load-store-for-class (class))
(defgeneric serialize-file-name-for-key (key class))
(defgeneric key-of-instance (instance))
(defgeneric class-name-of-instance (instance))
(defgeneric register-key (key class))
(defgeneric shallow-copy-instance (instance))
(defgeneric slot-to-accessor (slot class))
(defgeneric class-has-slot-p (slot class))

(defgeneric note-registered-instance (instance))
(defgeneric note-deleted-instance (instance))

(defmethod note-registered-instance (instance))

(defmethod note-deleted-instance (instance))

(defclass simple-serialized-class () ())

;; This method is provided to the user for use when deserializing an object
(defmethod register-key (key class)
  nil)

;; This default method handles the case where there are objects not of
;; the serializable type on that type's store list.
(defmethod key-of-instance (instance)
  nil)

(defvar *class-store-places* nil)

(defmacro store-of-class (class)
  (or (cdr (assoc class *class-store-places*))
      (error "No store found yet for class ~A!" class)))

(defmethod print-object :around ((object simple-serialized-class) stream)
  (when (find-package "SSC-TEMP")
    (delete-package "SSC-TEMP"))
  (let ((normal-printed
         (with-output-to-string (s)
           (with-standard-io-syntax
             (let ((*print-readably* nil))
               (call-next-method object s)))))
        (temp-package (make-package "SSC-TEMP")))
    (unwind-protect
         (let ((*package* temp-package))
           (with-standard-io-syntax
             (let ((*print-circle* t))
               (format stream "#.(#| ~A |# ~S ~S '~S ~S ~S)"
                       normal-printed
                       'find-instance-by-key
                       (key-of-instance object)
                       (class-name-of-instance object)
                       :find-by-loading t))))
      (delete-package temp-package))))

(defun conanicalize-to-readable-form (object)
  (if (typep object 'string)
      (map 'string
           #'(lambda (char)
               (if (typep char 'base-char)
                   char
                   #\?)) object)
      object))

(defmacro define-simple-serialized-class (class-name (&rest superclasses) (&rest all-slots)
                                          &rest all-keys)
  (let* ((key-slot-name (or (second (assoc :key-slot all-keys))
                            (error "Key slot not supplied!")))
         (path-name (gensym))
         (store (or (second (assoc :store all-keys))
                    (error "Store name not supplied!")))
         (store-directory (or (second (assoc :store-directory all-keys))
                              (error "Store directory not supplied!")))
         (managed-slots (cdr (assoc :managed-slots all-keys)))
         (all-slot-names (set-difference (mapcar #'car all-slots) managed-slots)))
    (push (cons class-name store) *class-store-places*)
    `(progn
       (defvar ,path-name (merge-pathnames ,store-directory))
       (defclass ,class-name (simple-serialized-class ,@superclasses)
         (,@all-slots)
         ,@(remove-if (lambda (e)
                        (member e '(:store :store-directory :key-slot :managed-slots)))
                      all-keys :key #'car))
       (defmethod class-name-of-instance ((instance ,class-name))
         ',class-name)
       (defmethod key-of-instance ((instance ,class-name))
         (slot-value instance ',key-slot-name))
       (defmethod class-has-slot-p (slot (class (eql ',class-name)))
         (member slot '(,@(loop for slot in all-slots collect (car slot)))))
       (defmethod slot-to-accessor (slot (class (eql ',class-name)))
         (ecase slot
           ,@(loop for slot in all-slots
                for accessor = (getf (cdr slot) :accessor)
                when accessor
                collect `(,(car slot) ',accessor))))
       (defmethod register-instance ((instance ,class-name) &key no-serialize)
         (when (find-instance-by-key (key-of-instance instance) ',class-name)
           (error "An instance of ~A with key ~A has already been defined!"
                  ',class-name (key-of-instance instance)))
         (push instance ,store)
         (unless no-serialize
           (serialize-instance instance))
         (note-registered-instance instance)
         instance)
       (defmethod delete-instance ((instance ,class-name))
         (setf ,store (delete (key-of-instance instance) ,store :key #'key-of-instance
                              :test #'equal))
         (rename-file (serialize-file-name-for-key (key-of-instance instance) ',class-name)
                      (merge-pathnames (make-pathname :type "disabled")
                                       (serialize-file-name-for-key (key-of-instance instance) ',class-name)))
         (note-deleted-instance instance))
       (defmethod serialize-instance ((instance ,class-name))
         (ensure-directories-exist (serialize-file-name-for-key (key-of-instance instance) ',class-name))
         (with-open-file (file (serialize-file-name-for-key (key-of-instance instance) ',class-name)
                               :direction :output :if-exists :supersede)
           (with-standard-io-syntax
             (let ((*package* ,(symbol-package class-name))
                   (*print-circle* t))
               (write
                (list ',class-name
                      ,@(loop for slot in all-slot-names
                           collect `',slot
                           collect `(conanicalize-to-readable-form (slot-value instance ',slot))))
                :stream file)))))
       (defmethod serialize-file-name-for-key (key (class (eql ',class-name)))
         (declare (special ,path-name))
         (merge-pathnames (make-pathname :name (if (stringp key)
                                                   key
                                                   (if (numberp key)
                                                       (princ-to-string key)
                                                       (princ-to-string (sxhash key))))
                                         :type "ssc")
                          ,path-name))
       (defmethod deserialize-for-file (filename (class (eql ',class-name)))
         (with-open-file (file filename
                               :direction :input)
           (let* ((*package* ,(symbol-package class-name))
                  (list (read file)))
             (assert (eql (car list) ',class-name))
             (let ((instance (make-instance ',class-name)))
               ,@(loop for slot in all-slot-names
                    collect `(setf (slot-value instance ',slot)
                                   (getf (cdr list) ',slot)))
               (unless (find-instance-by-key (key-of-instance instance) class)
                 (register-key (key-of-instance instance) class)
                 (register-instance instance :no-serialize t))))))
       (defmethod deserialize-for-key (key (class (eql ',class-name)))
         (deserialize-for-file (serialize-file-name-for-key key ',class-name) class))
       (defmethod find-instance-by-key (key (class (eql ',class-name)) &key find-by-loading)
         (let ((result (find key ,store :test #'equalp :key #'key-of-instance))) 
           (when (and (not result) find-by-loading)
             (deserialize-for-key key class)
             (setf result (find-instance-by-key key class)))
           result))
       (defmethod load-store-for-class ((class (eql ',class-name)))
         (declare (special ,path-name))
         (ensure-directories-exist ,path-name)
         (let ((path (make-pathname :name :wild :type "ssc" :defaults ,path-name)))
           (loop for file in (directory path)
              do (deserialize-for-file file class))))
       (defmethod shallow-copy-instance ((instance ,class-name))
         (let ((new (allocate-instance (find-class ',class-name))))
           ,@(loop for slot in all-slots
                collect `(setf (slot-value new ',(car slot))
                               (slot-value instance ',(car slot))))
           new))
       (find-class ',class-name))))
