;; This program is distributed in the hope that it will be useful, but

;; WITHOUT ANY WARRANTY; without even the implied warranty of

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

;; General Public License for more details.

;; You should have received a copy of the GNU General Public License

;; along with this program; if not, write to the Free Software

;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307

;; USA

;;; Commentary:

;;

;;; Code:

(require 'cl-lib)

(require 'workgroups-utils-basic)

;;; vars

(defvar wg-pickel-identifier '~pickel!~

  "Symbol identifying a stream as a pickel.")

(defvar wg-pickel-pickelable-types

  "Types pickel can serialize.")

(defvar wg-pickel-object-serializers

  '((integer    . identity)

    (float      . identity)

    (string     . identity)

    (symbol     . wg-pickel-symbol-serializer)

    (cons       . wg-pickel-cons-serializer)

    (vector     . wg-pickel-vector-serializer)

  "Alist mapping types to object serialization functions.")

(defvar wg-pickel-link-serializers

  '((cons       . wg-pickel-cons-link-serializer)

    (vector     . wg-pickel-vector-link-serializer)

    (hash-table . wg-pickel-hash-table-link-serializer))

  "Alist mapping types to link serialization functions.")

(defvar wg-pickel-object-deserializers

  '((s . wg-pickel-deserialize-uninterned-symbol)

    (c . wg-pickel-deserialize-cons)

    (v . wg-pickel-deserialize-vector)

  "Alist mapping type keys to object deserialization functions.")

(defvar wg-pickel-link-deserializers

  `((c . wg-pickel-cons-link-deserializer)

    (v . wg-pickel-vector-link-deserializer)

    (h . wg-pickel-hash-table-link-deserializer))

  "Alist mapping type keys to link deserialization functions.")

;;; errors and predicates

(put 'wg-pickel-unpickelable-type-error

     'error-conditions

     '(error wg-pickel-errors wg-pickel-unpickelable-type-error))

(put 'wg-pickel-unpickelable-type-error

     'error-message

     "Attemp to pickel unpickelable type")

(defun wg-pickelable-or-error (obj)

  "Error when OBJ isn't pickelable."

  (unless (memq (type-of obj) wg-pickel-pickelable-types)

    (signal 'wg-pickel-unpickelable-type-error

(defun wg-pickel-symbol-serializer (symbol)

  "Return SYMBOL's serialization."

  (cond ((eq symbol t) t)

        ((eq symbol nil) nil)

        ((intern-soft symbol) symbol)

        (t (list 's (symbol-name symbol)))))

(defun wg-pickel-cons-serializer (cons)

  "Return CONS's serialization."

  (list 'c))

(defun wg-pickel-vector-serializer (vector)

  "Return VECTOR's serialization."

  (list 'v (length vector)))

(defun wg-pickel-hash-table-serializer (table)

  "Return HASH-TABLE's serialization."

  (list 'h

        (hash-table-test table)

        (hash-table-size table)

        (hash-table-rehash-size table)

        (hash-table-rehash-threshold table)

        (hash-table-weakness table)))

(defun wg-pickel-serialize-objects (binds)

  "Return a list of serializations of the objects in BINDS."

  (let (result)

    (wg-dohash (obj id binds result)

      (setq result

            (nconc (list id (funcall (wg-pickel-object-serializer obj) obj))

                   result)))))

;;; link serialization

(defun wg-pickel-cons-link-serializer (cons binds)

  "Return the serialization of CONS's links in BINDS."

  (list 'c

        (gethash cons binds)

        (gethash (car cons) binds)

        (gethash (cdr cons) binds)))

(defun wg-pickel-vector-link-serializer (vector binds)

  "Return the serialization of VECTOR's links in BINDS."

  (let (result)

    (dotimes (i (length vector) result)

      (setq result

      (wg-awhen (wg-pickel-link-serializer obj)

        (setq result (nconc (funcall it obj binds) result))))))

;;; object deserialization

(defun wg-pickel-deserialize-uninterned-symbol (name)

  "Return a new uninterned symbol from NAME."

  (make-symbol name))

(defun wg-pickel-deserialize-cons ()

  "Return a new cons cell initialized to nil."

  (cons nil nil))

(defun wg-pickel-deserialize-vector (length)

  "Return a new vector of length LENGTH."

  (make-vector length nil))

(defun wg-pickel-deserialize-hash-table (test size rsize rthresh weakness)

  "Return a new hash-table with the specified properties."

  (make-hash-table :test test :size size :rehash-size rsize

                   :rehash-threshold rthresh :weakness weakness))

(defun wg-pickel-deserialize-objects (serial-objects)

  "Return a hash-table of objects deserialized from SERIAL-OBJECTS."

  (let ((binds (make-hash-table)))

    (wg-destructuring-dolist ((id obj . rest) serial-objects binds)

      (puthash id

               (if (atom obj) obj

                 (wg-dbind (key . data) obj

                   (apply (wg-pickel-object-deserializer key) data)))

               binds))))

;;; link deserialization

(defun wg-pickel-cons-link-deserializer (cons-id car-id cdr-id binds)

  "Relink a cons cell with its car and cdr in BINDS."

  (let ((cons (gethash cons-id binds)))

    (setcar cons (gethash car-id binds))

    (setcdr cons (gethash cdr-id binds))))

(defun wg-pickel-vector-link-deserializer (vector-id index value-id binds)

  "Relink a vector with its elements in BINDS."

  (aset (gethash vector-id binds) index (gethash value-id binds)))