;;; workgroups-commands --- main commands

;;; Commentary:

;;; Code:

(require 'cl-lib)

(eval-when-compile

  (require 'ido)

  (require 'iswitchb))

(require 'ring)

(require 'workgroups-variables)

(require 'workgroups-utils-basic)

(require 'workgroups-pickel)

(require 'workgroups-functions)

;;; workgroup switching commands

(defun wg-switch-to-workgroup (workgroup &optional noerror)

  "Switch to WORKGROUP."

  (interactive (list (wg-read-workgroup-name)))

  (if (wg-current-workgroup t)

      (wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb (and (boundp 'ecb-minor-mode)

                                                                     ecb-minor-mode)))

  (let ((workgroup (wg-get-workgroup-create workgroup))

        (current (wg-current-workgroup t)))

    (when (and (eq workgroup current) (not noerror))

      (error "Already on: %s" (wg-workgroup-name current)))

    (when current (push current wg-deactivation-list))

    (unwind-protect

        (progn

          ;; Before switching - turn off ECB

          ;; https://github.com/pashinin/workgroups2/issues/34

          (if (and (boundp 'ecb-minor-mode)

                   ecb-minor-mode

                   (equal ecb-frame (selected-frame)))

              (let ((ecb-split-edit-window-after-start 'before-deactivation))

                (ecb-deactivate)))

          (wg-restore-workgroup workgroup)

          (wg-set-previous-workgroup current)

          (wg-set-current-workgroup workgroup)

          ;; Save "last-workgroup" to the session params

          (if (and (wg-current-session t)

                   (wg-current-workgroup t))

              (wg-set-session-parameter (wg-current-session t)

                                        'last-workgroup

                                        (wg-workgroup-name (wg-current-workgroup))))

          ;; If a workgroup had ECB - turn it on

          (if (and (boundp 'ecb-minor-mode)

                   (not ecb-minor-mode)

                   (wg-workgroup-parameter (wg-current-workgroup t) 'ecb nil))

              (let ((ecb-split-edit-window-after-start 'before-deactivation))

                (ecb-activate)))

          (run-hooks 'wg-switch-to-workgroup-hook)

          (wg-fontified-message

            (:cmd "Switched: ")

            (wg-workgroup-name (wg-current-workgroup t))

            ))

      (when current (pop wg-deactivation-list)))))

(defun wg-switch-to-workgroup-other-frame (workgroup &optional n)

  "Switch to WORKGROUP in the frame N places cyclically from `selected-frame'.

Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."

  (interactive (list (wg-read-workgroup-name) current-prefix-arg))

  (with-selected-frame (wg-cyclic-nth-from-frame (or n 1))

    (wg-switch-to-workgroup workgroup)))

(defun wg-switch-to-workgroup-at-index (index)

  "Switch to the workgroup at INDEX in `wg-workgroup-list'."

  (interactive (list (or current-prefix-arg (wg-read-workgroup-index))))

  (let ((wl (wg-workgroup-list-or-error)))

    (wg-switch-to-workgroup

     (or (nth index wl) (error "There are only %d workgroups" (length wl))))))

(cl-macrolet

    ((define-range-of-switch-to-workgroup-at-index (num)

       `(progn

          ,@(wg-docar (i (wg-range 0 num))

              `(defun ,(intern (format "wg-switch-to-workgroup-at-index-%d" i)) ()

                 ,(format "Switch to the workgroup at index %d." i)

                 (interactive)

                 (wg-switch-to-workgroup-at-index ,i))))))

  (define-range-of-switch-to-workgroup-at-index 10))

(defun wg-switch-to-cyclic-nth-from-workgroup (workgroup n)

  "Switch N workgroups cyclically from WORKGROUP in `wg-workgroup-list.'"

  (let ((workgroup-list (wg-workgroup-list-or-error))

        (workgroup (wg-get-workgroup workgroup t)))

    (wg-switch-to-workgroup

     (cond ((not workgroup) (car workgroup-list))

           ((= 1 (length workgroup-list)) (error "There's only one workgroup"))

           (t (wg-cyclic-nth-from-workgroup workgroup n))))))

(defun wg-switch-to-workgroup-left (&optional workgroup n)

  "Switch to the workgroup (- N) places from WORKGROUP in `wg-workgroup-list'.

Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."

  (interactive (list nil current-prefix-arg))

  (wg-switch-to-cyclic-nth-from-workgroup workgroup (- (or n 1))))

(defun wg-switch-to-workgroup-right (&optional workgroup n)

  "Switch to the workgroup N places from WORKGROUP in `wg-workgroup-list'.

Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."

  (interactive (list nil current-prefix-arg))

  (wg-switch-to-cyclic-nth-from-workgroup workgroup (or n 1)))

(defun wg-switch-to-workgroup-left-other-frame (&optional n)

  "Like `wg-switch-to-workgroup-left', but operates on the next frame."

  (interactive "p")

  (with-selected-frame (wg-cyclic-nth-from-frame (or n 1))

    (call-interactively 'wg-switch-to-workgroup-left)))

(defun wg-switch-to-workgroup-right-other-frame (&optional n)

  "Like `wg-switch-to-workgroup-right', but operates on the next frame."

  (interactive "p")

  (with-selected-frame (wg-cyclic-nth-from-frame (or n -1))

    (call-interactively 'wg-switch-to-workgroup-right)))

(defun wg-switch-to-previous-workgroup ()

  "Switch to the previous workgroup."

  (interactive)

  (wg-switch-to-workgroup (wg-previous-workgroup)))

;;; workgroup creation commands

(defun wg-create-workgroup (name &optional blank)

  "Create and add a workgroup named NAME.

Optional argument BLANK non-nil (set interactively with a prefix

arg) means use a blank, one window window-config.  Otherwise use

the current window-configuration.  Keep in mind that even though

the current window-config may be used, other parameters of the

current workgroup are not copied to the created workgroup.  For

that, use `wg-clone-workgroup'."

  (interactive (list (wg-read-new-workgroup-name) current-prefix-arg))

  (wg-switch-to-workgroup (wg-make-and-add-workgroup name blank))

  (wg-fontified-message

    (:cmd "Created: ")

    (:cur name) "  "

    (wg-workgroup-list-display)))

(defun wg-clone-workgroup (workgroup name)

  "Create and add a clone of WORKGROUP named NAME.

Keep in mind that only WORKGROUP's top-level alist structure is

copied, so destructive operations on the keys or values of

WORKGROUP will be reflected in the clone, and vice-versa.  Be

safe -- don't mutate them."

  (interactive (list nil (wg-read-new-workgroup-name)))

  (let* ((workgroup (wg-get-workgroup workgroup))

         (clone (wg-copy-workgroup workgroup)))

    (setf (wg-workgroup-name clone) name

          (wg-workgroup-uid clone) (wg-generate-uid))

    (when (wg-check-and-add-workgroup clone)

      (wg-flag-workgroup-modified clone))

    (wg-set-workgroup-working-wconfig

     clone (wg-workgroup-working-wconfig workgroup))

    (wg-switch-to-workgroup clone)

    (wg-fontified-message

      (:cmd "Cloned: ")

      (:cur (wg-workgroup-name workgroup))

      (:msg " to ")

      (:cur name) "  "

      (wg-workgroup-list-display))))

;;; workgroup killing commands

(defun wg-wconfig-kill-ring ()

  "Return `wg-wconfig-kill-ring', creating it first if necessary."

  (or wg-wconfig-kill-ring

      (setq wg-wconfig-kill-ring (make-ring wg-wconfig-kill-ring-max))))

(defun wg-add-to-wconfig-kill-ring (wconfig)

  "Add WCONFIG to `wg-wconfig-kill-ring'."

  (ring-insert (wg-wconfig-kill-ring) wconfig))

(defun wg-kill-workgroup (&optional workgroup)

  "Kill WORKGROUP, saving its working-wconfig to the kill ring."

  (interactive)

  (let* ((workgroup (wg-get-workgroup workgroup))

         (to (or (wg-previous-workgroup t)

                 (wg-cyclic-nth-from-workgroup workgroup))))

    (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))

    (wg-delete-workgroup workgroup)

    (if (eq workgroup to) (wg-restore-wconfig (wg-make-blank-wconfig))

      (wg-switch-to-workgroup to))

    (wg-fontified-message

      (:cmd "Killed: ")

      (:cur (wg-workgroup-name workgroup)) "  "

      (wg-workgroup-list-display))))

(defun wg-kill-ring-save-base-wconfig (&optional workgroup)

  "Save WORKGROUP's base wconfig to the kill ring."

  (interactive)

  (let ((workgroup (wg-get-workgroup workgroup)))

    (wg-add-to-wconfig-kill-ring (wg-workgroup-base-wconfig workgroup))

    (wg-fontified-message

      (:cmd "Saved: ")

      (:cur (wg-workgroup-name workgroup))

      (:cur "'s ")

      (:msg "base wconfig to the kill ring"))))

(defun wg-kill-ring-save-working-wconfig (&optional workgroup)

  "Save WORKGROUP's working-wconfig to `wg-wconfig-kill-ring'."

  (interactive)

  (let ((workgroup (wg-get-workgroup workgroup)))

    (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))

    (wg-fontified-message

      (:cmd "Saved: ")

      (:cur (wg-workgroup-name workgroup))

      (:cur "'s ")

      (:msg "working-wconfig to the kill ring"))))

(defun wg-yank-wconfig ()

  "Restore a wconfig from `wg-wconfig-kill-ring'.

Successive yanks restore wconfigs sequentially from the kill

ring, starting at the front."

  (interactive)

  (when (zerop (ring-length (wg-wconfig-kill-ring)))

    (error "The kill-ring is empty"))

  (let ((pos (if (not (eq real-last-command 'wg-yank-wconfig)) 0

               (1+ (or (get 'wg-yank-wconfig :position) 0)))))

    (put 'wg-yank-wconfig :position pos)

    (wg-restore-wconfig-undoably (ring-ref (wg-wconfig-kill-ring) pos))

    (wg-fontified-message

      (:cmd "Yanked: ")

      (:msg (format "%S" pos)) "  "

      (wg-workgroup-list-display))))

(defun wg-kill-workgroup-and-buffers (&optional workgroup)

  "Kill WORKGROUP and the buffers in its working-wconfig."

  (interactive)

  (let* ((workgroup (wg-get-workgroup workgroup))

         (bufs (save-window-excursion

                 (wg-restore-workgroup workgroup)

                 (mapcar #'window-buffer (window-list)))))

    (wg-kill-workgroup workgroup)

    (mapc #'kill-buffer bufs)

    (wg-fontified-message

      (:cmd "Killed: ")

      (:cur (wg-workgroup-name workgroup))

      (:msg " and its buffers ") "\n"

      (wg-workgroup-list-display))))

    (wg-bury-buffer buffer)))

(defun wg-associate-buffer-with-workgroup (&optional workgroup buffer weak)

  "Associate BUFFER with WORKGROUP.

WEAK non-nil means weakly associate BUFFER."

  (interactive (list nil nil current-prefix-arg))

  (let* ((workgroup (wg-get-workgroup workgroup))

         (buffer (or buffer (current-buffer)))

         (bname (buffer-name buffer))

         (wgname (wg-workgroup-name workgroup)))

    (if (wg-workgroup-associate-bufobj workgroup buffer weak)

        (wg-message "%s-associated %S with %s"

                    (if weak "Weakly" "Strongly") bname wgname)

      (wg-message "%S is already associated with %s" bname wgname))))

(defun wg-associate-visible-buffers-with-workgroup (&optional workgroup weak)

  "Associate all buffers visible in `selected-frame' with WORKGROUP.

WEAK non-nil means weakly associate them.  Otherwise strongly

associate them."

  (interactive (list nil current-prefix-arg))

  (let ((workgroup (wg-get-workgroup workgroup))

        (buffers (mapcar 'window-buffer (window-list))))

    (dolist (buffer buffers)

      (wg-workgroup-associate-bufobj workgroup buffer weak))

    (wg-fontified-message

      (:cmd (format "%s associated: " (if weak "Weakly" "Strongly")))

      (wg-buffer-list-display buffers))))

(defun wg-dissociate-buffer-from-workgroup (&optional workgroup buffer)

  "Dissociate BUFFER from WORKGROUP."

  (interactive (list nil nil))

  (let ((workgroup (wg-get-workgroup workgroup))

        (buffer (or buffer (current-buffer))))

    (wg-message

     (if (wg-workgroup-dissociate-bufobj workgroup buffer)

         "Dissociated %S from %s" "%S isn't associated with %s")

     (wg-buffer-name buffer)

     (wg-workgroup-name workgroup))))

(defun wg-restore-workgroup-associated-buffers (&optional workgroup)

  "Restore all the buffers associated with WORKGROUP that can be restored."

  (interactive)

  (let* ((workgroup (wg-get-workgroup workgroup))

         (restored-buffers (wg-restore-workgroup-associated-buffers-internal

                            workgroup)))

    (wg-fontified-message

      (:cmd "Restored: ")

      (wg-buffer-list-display restored-buffers))))

(defun wg-cycle-buffer-association-type ()

  "Cycle the current buffer's association type in the current workgroup.

See `wg-workgroup-cycle-bufobj-association-type' for details."

  (interactive)

  (let* ((workgroup (wg-current-workgroup))

         (buffer (current-buffer))

         (type (wg-workgroup-cycle-bufobj-association-type workgroup buffer)))

    (force-mode-line-update)

    (wg-fontified-message

      (:cur (buffer-name buffer))

      (:cmd (cl-case type

              (strong " strongly associated with ")

              (weak " weakly associated with ")

              (otherwise " unassociated with ")))

      (:cur (wg-workgroup-name workgroup)))))

(defun wg-dissociate-weakly-associated-buffers (&optional workgroup)

  "Dissociate from the current workgroup all weakly associated buffers."

  (interactive)

  (let ((workgroup (wg-get-workgroup workgroup)))

    (wg-workgroup-dissociate-weakly-associated-buffers workgroup)

    (wg-fontified-message

      (:cmd "Remaining buffers: ")

      (wg-buffer-list-display (wg-workgroup-associated-buffers workgroup)))))

;;; window-tree commands

;;

;; TODO: These are half-hearted.  Clean them up; allow specification of the

;; window-tree depth at which to operate; add complex window creation commands;

;; and add window splitting, deletion and locking commands.

(defun wg-transpose-window-internal (workgroup offset)

  "Move `selected-window' by OFFSET in its wlist."

  (wg-restore-wconfig-undoably

   (wg-wconfig-move-window

    (wg-workgroup-working-wconfig

     (wg-get-workgroup workgroup))

    offset)))

(defun wg-backward-transpose-window (&optional workgroup offset)

  "Move `selected-window' backward by OFFSET in its wlist."

  (interactive (list nil current-prefix-arg))

  (wg-transpose-window-internal workgroup (or offset -1)))

(defun wg-transpose-window (&optional workgroup offset)

  "Move `selected-window' forward by OFFSET in its wlist."

  (interactive (list nil current-prefix-arg))

  (wg-transpose-window-internal workgroup (or offset 1)))

(defun wg-reverse-frame-horizontally (&optional workgroup)

  "Reverse the order of all horizontally split wtrees."

  (interactive)

  (wg-restore-wconfig-undoably

   (wg-reverse-wconfig

    (wg-workgroup-working-wconfig

     (wg-get-workgroup workgroup)))))

(defun wg-reverse-frame-vertically (&optional workgroup)

  "Reverse the order of all vertically split wtrees."

  (interactive)

  (wg-restore-wconfig-undoably

   (wg-reverse-wconfig

    (wg-workgroup-working-wconfig

     (wg-get-workgroup workgroup))

    t)))

(defun wg-reverse-frame-horizontally-and-vertically (&optional workgroup)

  "Reverse the order of all wtrees."

  (interactive)

  (wg-restore-wconfig-undoably

   (wg-reverse-wconfig

    (wg-workgroup-working-wconfig

     (wg-get-workgroup workgroup))

    'both)))

(defun wg-toggle-window-dedicated-p ()

  "Toggle `window-dedicated-p' in `selected-window'."

  (interactive)

  (set-window-dedicated-p nil (not (window-dedicated-p)))

  (force-mode-line-update t)

  (wg-fontified-message

    (:cmd "Window:")

    (:cur (concat (unless (window-dedicated-p) " not") " dedicated"))))

;;; misc commands

(defun wg-rename-workgroup (workgroup newname)

  "Rename WORKGROUP to NEWNAME."

  (interactive (list nil (wg-read-new-workgroup-name "New name: ")))

  (let* ((workgroup (wg-get-workgroup workgroup))

         (oldname (wg-workgroup-name workgroup)))

    (setf (wg-workgroup-name workgroup) newname)

    (wg-flag-workgroup-modified workgroup)

    (wg-fontified-message

      (:cmd "Renamed: ")

      (:cur oldname)

      (:msg " to ")

      (:cur (wg-workgroup-name workgroup)))))

(defun wg-reset (&optional force)

  "Reset Workgroups.

Resets all frame parameters, buffer-local vars, the current

Workgroups session object, etc."

  (interactive "P")

  (unless (or force wg-no-confirm-on-destructive-operation

              (y-or-n-p "Really reset Workgroups? "))

    (error "Canceled"))

  (wg-reset-internal)

  (wg-fontified-message

    (:cmd "Reset: ")

    (:msg "Workgroups")))

;;; file commands

(defun wg-read-session-save-file-name ()

  "Read and return a new session filename."

  (read-file-name "Save session as: "))

(defun wg-write-session-file (filename &optional confirm)

  "Write the current session into file FILENAME.

This makes the session visit that file, and marks it as not modified.

If optional second arg CONFIRM is non-nil, this function asks for

confirmation before overwriting an existing file.  Interactively,

confirmation is required unless you supply a prefix argument.

Think of it as `write-file' for Workgroups sessions."

  (interactive (list (wg-read-session-save-file-name)

                     (not current-prefix-arg)))

  (when (and confirm (file-exists-p filename))

    (unless (y-or-n-p (format "File `%s' exists; overwrite? " filename))

      (error "Cancelled")))

  (unless (file-writable-p filename)

    (error "File %s can't be written to" filename))

  (wg-perform-session-maintenance)

  (setf (wg-session-file-name (wg-current-session)) filename)

  (setf (wg-session-version (wg-current-session)) wg-version)

  (wg-write-sexp-to-file

   (wg-pickel-all-session-parameters (wg-current-session))

   filename)

  (wg-mark-everything-unmodified)

  (wg-fontified-message (:cmd "Wrote: ") (:file filename)))

(defun wg-determine-session-save-file-name ()

  "Return the filename in which to save the session."

  (or (wg-session-file-name (wg-current-session))

      (and wg-use-default-session-file wg-default-session-file)))

(defun wg-save-session (&optional force)

  "Save the current Workgroups session if it's been modified.

Think of it as `save-buffer' for Workgroups sessions.  Optional

argument FORCE non-nil, or interactively with a prefix arg, save

the session regardless of whether it's been modified."

  (interactive "P")

  (if (and (not (wg-modified-p)) (not force))

      (wg-message "(The session is unmodified)")

    (wg-write-session-file

     (or (wg-determine-session-save-file-name)

         (wg-read-session-save-file-name)))))

(defun wg-query-and-save-if-modified ()

  "Query for save when `wg-modified-p'."

  (or (not (wg-modified-p))

      (when (y-or-n-p "Save modified workgroups? ")

        (wg-save-session))))

(defun wg-save-session-on-exit (behavior)

  "Perform session-saving operations based on BEHAVIOR."

  (cl-case behavior

    (ask (wg-query-and-save-if-modified))

    (save

     (if (wg-determine-session-save-file-name)

         (wg-save-session)

       (wg-query-and-save-if-modified)))))

(defun wg-find-session-file (filename)

  "Load a session visiting FILENAME, creating one if none already exists."

  (interactive "FFind session file: ")

  (cond ((file-exists-p filename)

         (let ((session (wg-read-sexp-from-file filename)))

           (unless (wg-session-p session)

             (error "%S is not a Workgroups session file." filename))

           (setf (wg-session-file-name session) filename)

           (wg-reset-internal (wg-unpickel-session-parameters session)))

         (wg-awhen (and wg-switch-to-first-workgroup-on-find-session-file

                        (wg-workgroup-list))

           (if (and wg-open-this-wg

                    (member wg-open-this-wg (wg-workgroup-names)))

               (wg-switch-to-workgroup wg-open-this-wg)

             (if (and wg-load-last-workgroup

                      (member (wg-session-parameter (wg-current-session t) 'last-workgroup)

                              (wg-workgroup-names)))

                 (wg-switch-to-workgroup

                  (wg-session-parameter (wg-current-session t) 'last-workgroup))

               (wg-switch-to-workgroup (car it)))

             ))

         (wg-fontified-message (:cmd "Loaded: ") (:file filename)))

        (t

         (wg-query-and-save-if-modified)

         (wg-reset-internal (wg-make-session :file-name filename))

         (wg-fontified-message

           (:cmd "(New Workgroups session file)")))))

(defun wg-find-file-in-new-workgroup (filename)

  "Create a new blank workgroup and find file FILENAME in it."

  (interactive "FFind file in new workgroup: ")

  (wg-create-workgroup (file-name-nondirectory filename) t)

  (find-file filename))

(defun wg-find-file-read-only-in-new-workgroup (filename)

  "Create a new workgroup and find file FILENAME read-only in it."

  (interactive "FFind file read only in new workgroup: ")

  (wg-create-workgroup (file-name-nondirectory filename) t)

  (find-file-read-only filename))

(defun wg-dired-in-new-workgroup (dirname &optional switches)

  "Create a workgroup and open DIRNAME in dired with SWITCHES."

  (interactive (list (read-directory-name "Dired (directory): ")

                     current-prefix-arg))

  (wg-create-workgroup dirname)

  (dired dirname switches))

;;; toggle commands

(defun wg-toggle-and-message (symbol)

  "Toggle SYMBOL's truthiness and message the new value."

  (wg-fontified-message

    (:cmd (format "%s: " symbol))

    (:msg (format "%s" (wg-toggle symbol)))))

(defun wg-toggle-buffer-list-filtration ()

  "Toggle `wg-buffer-list-filtration-on'."

  (interactive)

  (wg-toggle-and-message 'wg-buffer-list-filtration-on))

(defun wg-toggle-mode-line-display ()

  "Toggle `wg-mode-line-display-on'."

  (interactive)

  (wg-toggle-and-message 'wg-mode-line-display-on))

;;; echo commands

(defun wg-echo-current-workgroup ()

  "Display the name of the current workgroup in the echo area."

  (interactive)

  (wg-fontified-message

    (:cmd "Current: ")

    (:cur (wg-workgroup-name (wg-current-workgroup)))))

(defun wg-echo-all-workgroups ()

  "Display the names of all workgroups in the echo area."

  (interactive)

  (wg-fontified-message

    (:cmd "Workgroups: ")

    (wg-workgroup-list-display)))

(defun wg-echo-time ()

  "Echo the current time.  Optionally includes `battery' info."

  (interactive)

  (wg-message ;; Pass through format to escape the % in `battery'

   "%s" (wg-fontify

          (:cmd "Current time: ")

          (:msg (format-time-string wg-time-format))

          (when (and wg-display-battery (fboundp 'battery))

            (wg-fontify "\n" (:cmd "Battery: ") (:msg (battery)))))))

(defun wg-echo-version ()

  "Echo Workgroups' current version number."

  (interactive)

  (wg-fontified-message

    (:cmd "Workgroups version: ")

    (:msg wg-version)))

(defun wg-echo-last-message ()

  "Echo the last message Workgroups sent to the echo area.

The string is passed through a format arg to escape %'s."

  (interactive)

  (message "%s" wg-last-message))

;;; help commands

(defun wg-help ()

  "Just call `apropos-command' on \"^wg-\".

There used to be a bunch of help-buffer construction stuff here,

including a `wg-help' variable that basically duplicated every

command's docstring;  But why, when there's `apropos-command'?"

  (interactive)

  (apropos-command "^wg-"))

(require 'workgroups-commands-minibuffer)

(provide 'workgroups-commands)

;;; workgroups-pickel.el --- Elisp object serdes used by Workgroups

;;

;; Copyright (C) 2010, 2011 tlh

;;

;; Author: tlh <thunkout at gmail dot com>

;; Keywords: serialization deserialization serdes

;; Homepage: https://github.com/tlh/workgroups.el

;; Version   1.0.0

;; This program is free software; you can redistribute it and/or modify

;; it under the terms of the GNU General Public License as published by

;; the Free Software Foundation; either version 2 of the License, or (at

;; your option) any later version.

;; 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

  '(integer

    float

    symbol

    string

    cons

    vector

    hash-table

    buffer

    ;;window-configuration

    ;;frame

    ;;window

    ;;process

    )

  "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)

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

    ;;(window-configuration   . wg-pickel-window-configuration-serializer)

    (buffer     . wg-pickel-buffer-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)

    (h . wg-pickel-deserialize-hash-table)

    (b . wg-pickel-deserialize-buffer))

  "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

            (format "Can't pickel objects of type: %S" (type-of obj))))

  (cl-typecase obj

    (cons

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

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

    (vector

     (cl-map nil 'wg-pickelable-or-error obj))

    (hash-table

     (wg-dohash (key value obj)

       (wg-pickelable-or-error key)

       (wg-pickelable-or-error value)))))

(defun wg-pickelable-p (obj)

  (condition-case err

      (progn (wg-pickelable-or-error obj) t)

    (wg-pickel-unpickelable-type-error nil)))

(defun wg-pickel-p (obj)

  "Return t when OBJ is a pickel, nil otherwise."

  (and (consp obj) (eq (car obj) wg-pickel-identifier)))

;; accessor functions

(defun wg-pickel-object-serializer (obj)

  "Return the object serializer for the `type-of' OBJ."

  (or (wg-aget wg-pickel-object-serializers (type-of obj))

      (error "Invalid type: %S" (type-of obj))))

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

  "Return the link serializer for the `type-of' OBJ."

  (wg-aget wg-pickel-link-serializers (type-of obj)))

(defun wg-pickel-object-deserializer (key)

  "Return the object deserializer for type key KEY, or error."

  (or (wg-aget wg-pickel-object-deserializers key)

      (error "Invalid object deserializer key: %S" key)))

(defun wg-pickel-link-deserializer (key)

  "Return the link deserializer for type key KEY, or error."

  (or (wg-aget wg-pickel-link-deserializers key)

      (error "Invalid link deserializer key: %S" key)))

;;; bindings

(defun wg-pickel-make-bindings-table (obj)

  "Return a table binding unique subobjects of OBJ to ids."

  (let ((binds (make-hash-table :test 'eq))

        (id -1))

    (cl-labels

     ((inner (obj)

           (unless (gethash obj binds)

              (puthash obj (cl-incf id) binds)

              (cl-case (type-of obj)

                (cons

                 (inner (car obj))

                 (inner (cdr obj)))

                (vector

                 (dotimes (idx (length obj))

                   (inner (aref obj idx))))

                (hash-table

                 (wg-dohash (key val obj)

                   (inner key)

                   (inner val)))))))

      (inner obj)

      binds)))

;;; object serialization

(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-window-configuration-serializer (wc)

  "Return Window configuration WC's serialization."

  (list 'wc

        1))

(defun wg-pickel-buffer-serializer (buffer)

  "Return BUFFER's UID in workgroups buffer list."

  (list 'b (wg-add-buffer-to-buf-list buffer)))

(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

            (nconc (list 'v

                         (gethash vector binds)

                         i

                         (gethash (aref vector i) binds))

                   result)))))