diff --git a/.gitignore b/.gitignore index 44c9d71bbeea28693936676f7936eac732fec87e..8dccd094202602c989a887fc7ab0392cd857673d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,7 @@ *.elc TAGS +/dash.el +/s.el +/f.el +/anaphora.el +/deps diff --git a/.travis.yml b/.travis.yml index 998659398955a7107e3c30fff22ff1a630de1532..235ac3831f8d26c61a087115605d2bcaa27b059c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,19 +4,37 @@ env: global: - CURL=curl -fsSkL --retry 9 --retry-delay 9 matrix: - - EMACS=emacs24 - - EMACS=emacs-snapshot - + - EMACS=emacs23 GUI=1 + - EMACS=emacs24 GUI=1 + - EMACS=emacs-snapshot GUI=1 +# - EMACS=emacs-snapshot GUI=0 +#matrix: +# allow_failures: +# - env: EMACS=emacs-snapshot before_install: - sudo add-apt-repository -y ppa:cassou/emacs - sudo apt-get update -qq - sudo apt-get install -qq $EMACS + - "export DISPLAY=:99.0" + - "sh -e /etc/init.d/xvfb start" install: + - make deps + - if [ "$EMACS" = "emacs23" ]; then + $CURL https://raw.githubusercontent.com/ohler/ert/fb3c278d/lisp/emacs-lisp/ert.el -o ert.el; + $CURL http://elpa.gnu.org/packages/cl-lib-0.5.el -o cl-lib.el; + fi - if [ "$EMACS" = "emacs24" ]; then sudo apt-get install -qq emacs24-el; fi - if [ "$EMACS" = "emacs-snapshot" ]; then sudo apt-get install -qq emacs-snapshot-el emacs-snapshot-gtk; fi + script: - $EMACS --version && make test EMACS=${EMACS} \ No newline at end of file + - $EMACS --version + - if [ "$GUI" = "1" ]; then make testgui EMACS=${EMACS}; fi; + - if [ "$GUI" = "0" ]; then make test EMACS=${EMACS}; fi; + - ls -la /tmp + +notifications: + email: false \ No newline at end of file diff --git a/Makefile b/Makefile index 778cfb3c4b5adcc773e16a1ac1caf6a3e40367de..3b710b8deacb7cd0ff1cf8a06e8fd0383a607a65 100644 --- a/Makefile +++ b/Makefile @@ -1,11 +1,13 @@ # -*- Makefile -*- -EMACS = emacs - +EMACS ?= emacs TEST_DIR = src TRAVIS_FILE = .travis.yml - -# Compile with noninteractive and relatively clean environment. +EFLAGS ?= -L ../cl-lib -L src -L . -L tests -L deps +BATCH = $(EMACS) $(EFLAGS) -batch -Q +NOBATCH = $(EMACS) --debug-init $(EFLAGS) -Q +NOBATCHE = $(NOBATCH) -eval +BATCHE = $(BATCH) -eval BATCHFLAGS = -batch -q --no-site-file FLAGS = -L src -batch -l workgroups2.el --eval "(ido-mode t)" FLAGSWG = -L src -batch -l workgroups2.el --eval "(ido-mode t)" --eval "(workgroups-mode 1)" @@ -14,24 +16,34 @@ WGCMD = ${EMACS} $(FLAGSWG) --debug-init --eval clean: find . -name '*.elc' -delete -test: clean -# just load all files - ${EMACS} -L src $(BATCHFLAGS) -f batch-byte-compile $(TEST_DIR)/*.el - -# wg-mode-line-string - ${EMACS} -L src -batch -l workgroups-modeline.el --eval '(message (wg-mode-line-string))' - -# desktop-save-mode - ${EMACS} $(FLAGS) --eval "(desktop-save-mode 1)" --eval "(workgroups-mode 1)" - -# WGs list length - ${EMACS} $(FLAGSWG) --eval "(message (number-to-string (length (wg-workgroup-list))))" - -# show WG name - ${EMACS} $(FLAGSWG) --eval "(message (wg-workgroup-name (wg-current-workgroup)))" - -# save session - ${WGCMD} "(wg-save-session)" - -test-ido: - emacs -Q -L src -l cl.el -l ido.el -l workgroups2.el --eval "(ido-mode t)" --eval "(workgroups-mode 1)" +.PHONY: deps +deps: + mkdir -p deps; + if [ ! -f deps/f.el ]; then curl https://raw.githubusercontent.com/rejeep/f.el/master/f.el -o deps/f.el; fi; + if [ ! -f deps/s.el ]; then curl https://raw.githubusercontent.com/magnars/s.el/master/s.el -o deps/s.el; fi; + if [ ! -f deps/dash.el ]; then curl https://raw.githubusercontent.com/magnars/dash.el/master/dash.el -o deps/dash.el; fi; + if [ ! -f deps/anaphora.el ]; then curl https://raw.githubusercontent.com/rolandwalker/anaphora/master/anaphora.el -o deps/anaphora.el; fi; + if [ ! -f deps/magit.el ]; then curl https://raw.githubusercontent.com/magit/magit/master/magit.el -o deps/magit.el; fi; + if [ ! -f deps/git-commit-mode.el ]; then curl https://raw.githubusercontent.com/magit/git-modes/master/git-commit-mode.el -o deps/git-commit-mode.el; fi; + if [ ! -f deps/git-rebase-mode.el ]; then curl https://raw.githubusercontent.com/magit/git-modes/master/git-rebase-mode.el -o deps/git-rebase-mode.el; fi; + if [ ! -f deps/magit-key-mode.el ]; then curl https://raw.githubusercontent.com/magit/magit/master/magit-key-mode.el -o deps/magit-key-mode.el; fi; + + +.PHONY: test +test: $(ELCS) + @$(BATCHE) "(progn\ + (require 'cl) \ + (require 'ert) \ + (put 'flet 'byte-obsolete-info nil))" \ + -l tests/ert-my-utils.el -l tests/workgroups2-tests.el -f ert-run-tests-batch-and-exit + + +.PHONY: testgui +testgui: $(ELCS) + @$(NOBATCHE) "(progn\ + (require 'cl) \ + (require 'ert) \ + (put 'flet 'byte-obsolete-info nil))" \ + -l tests/ert-my-utils.el -l tests/workgroups2-tests.el -f my-ert-run-tests + if [ -f /tmp/wg-tests.log ]; then cat /tmp/wg-tests.log; exit 1; fi; + if [ -f /tmp/wg-tests-ok.log ]; then cat /tmp/wg-tests-ok.log; fi; diff --git a/README.md b/README.md index ac5a31ae049706f9d1ce669b974ecf0143964525..dff9b4292cb7c70d4101c6840e601b3094adf012 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,8 @@ -# Workgroups for Emacs +[![License](https://img.shields.io/badge/license-GPL_3-green.svg?dummy)](https://github.com/pashinin/workgroups2) [![Build Status](https://travis-ci.org/pashinin/workgroups2.png?branch=master)](https://travis-ci.org/pashinin/workgroups2) +[![Gittip](http://img.shields.io/gittip/pashinin.png)](https://www.gittip.com/pashinin) -## What is it? +# Workgroups for Emacs Workgroups is a session manager for Emacs. @@ -16,9 +17,11 @@ Fork it, [add more special buffers support](https://github.com/pashinin/workgrou Just install "workgroups2" from Melpa and activate it with - (require 'workgroups2) - ;; Change some settings - (workgroups-mode 1) ; put this one at the bottom of .emacs +```elisp +(require 'workgroups2) +;; Change some settings +(workgroups-mode 1) ; put this one at the bottom of .emacs +``` ## Use @@ -38,45 +41,77 @@ By default prefix is: "C-c z" (To change it - see settings below) If you want to change some settings - here is an example: - (require 'workgroups2) - ;; Your settings here +```elisp +(require 'workgroups2) +;; Your settings here - ;; autoload/autosave: - ;;(setq wg-session-load-on-start nil) +;;(setq wg-session-load-on-start t) ; default: (not (daemonp)) - ;; Change prefix key (before activating WG) - (setq wg-prefix-key (kbd "C-c z")) +;; Change prefix key (before activating WG) +(setq wg-prefix-key (kbd "C-c z")) - ;; Change workgroups session file - (setq wg-session-file "~/.emacs.d/.emacs_workgroups") +;; Change workgroups session file +(setq wg-session-file "~/.emacs.d/.emacs_workgroups") - ;; Set your own keyboard shortcuts to reload/save/switch WG: - (global-set-key (kbd "") 'wg-reload-session) - (global-set-key (kbd "C-S-") 'wg-save-session) - (global-set-key (kbd "s-z") 'wg-switch-to-workgroup) - (global-set-key (kbd "s-/") 'wg-switch-to-previous-workgroup) +;; Set your own keyboard shortcuts to reload/save/switch WGs: +;; "s" == "Super" or "Win"-key, "S" == Shift, "C" == Control +(global-set-key (kbd "") 'wg-reload-session) +(global-set-key (kbd "C-S-") 'wg-save-session) +(global-set-key (kbd "s-z") 'wg-switch-to-workgroup) +(global-set-key (kbd "s-/") 'wg-switch-to-previous-workgroup) - (workgroups-mode 1) ; put this one at the bottom of .emacs +(workgroups-mode 1) ; put this one at the bottom of .emacs +``` +## More options -## Help +You can use `M-x customize-group` `workgroups` to see all variables and +faces to change. + +```elisp +;; What to do on Emacs exit / workgroups-mode exit? +(setq wg-emacs-exit-save-behavior 'save) ; Options: 'save 'ask nil +(setq wg-workgroups-mode-exit-save-behavior 'save) ; Options: 'save 'ask nil -Type ` ?` (Eval `(wg-help)`) for more help. +;; Mode Line changes +;; Display workgroups in Mode Line? +(setq wg-mode-line-display-on t) ; Default: (not (featurep 'powerline)) +(setq wg-flag-modified t) ; Display modified flags as well +(setq wg-mode-line-decor-left-brace "[" + wg-mode-line-decor-right-brace "]" ; how to surround it + wg-mode-line-decor-divider ":") +``` -This will bring up a help buffer listing all the commands and their bindings. +### Hooks -See the customization section in the source for details, or use: +Hooks' names can tell when they are executed + +```elisp +workgroups-mode-hook ; when `workgroups-mode' is turned on +workgroups-mode-exit-hook ; `workgroups-mode' is turned off +wg-before-switch-to-workgroup-hook +wg-after-switch-to-workgroup-hook +``` + +## Help - M-x customize-group RET workgroups RET +For you: +1. ` ?` or `(wg-help)` - help buffer listing all the commands + and their bindings. +2. `M-x customize-group RET workgroups RET` - all customization options -## Original Workgroups +For me: -There is a package on Melpa called "workgroups". -This extension is based on experimental branch of the [original repo](http://github.com/tlh/workgroups.el). +1. **Reporting a bug** - give me full `(backtrace)` of what + happened and how you did it. +2. **Requesting a major-mode support** - write how you *install*, + *configure* and *run* yours. +3. Make pull-requests +4. Ask questions (if you don't know how to hack it). Personally I + found the code *very* complex at first -So great respect to the author. But it has not been updated for more -than 2 years and experimental branch was not released. ## License -Workgroups for Emacs is released under the GPL. +GPL. This extension is based on experimental branch of the +[original repo](http://github.com/tlh/workgroups.el). diff --git a/src/workgroups-advice.el b/src/workgroups-advice.el deleted file mode 100644 index 5ad48ae9b05bf5d157a9c977f52c3afcf55d9603..0000000000000000000000000000000000000000 --- a/src/workgroups-advice.el +++ /dev/null @@ -1,155 +0,0 @@ -;;; workgroups-advice --- change some functions behaviour -;;; Commentary: -;;; Code: - -(require 'workgroups-utils-basic) -(require 'workgroups-session) - - -;; `wg-pre-window-configuration-change-hook' implementation advice -(cl-macrolet ((define-p-w-c-c-h-advice - (fn) - `(defadvice ,fn (before wg-pre-window-configuration-change-hook) - "Call `wg-update-working-wconfig-hook' before this -function to save up-to-date undo information before the -window-configuration changes." - (run-hooks 'wg-pre-window-configuration-change-hook)))) - (define-p-w-c-c-h-advice split-window) - (define-p-w-c-c-h-advice enlarge-window) - (define-p-w-c-c-h-advice delete-window) - (define-p-w-c-c-h-advice delete-other-windows) - (define-p-w-c-c-h-advice delete-windows-on) - (define-p-w-c-c-h-advice switch-to-buffer) - (define-p-w-c-c-h-advice set-window-buffer)) - - -;; `save-buffers-kill-emacs' advice - -(defadvice save-buffers-kill-emacs (around wg-freeze-wconfig) - "`save-buffers-kill-emacs' calls `list-processes' when active -processes exist, screwing up the window config right before -Workgroups saves it. This advice freezes `wg-current-wconfig' in -its correct state, prior to any window-config changes caused by -`s-b-k-e'." - (wg-with-current-wconfig nil (wg-frame-to-wconfig) - ad-do-it)) - - -;; `select-frame' advice - -(defadvice select-frame (before wg-update-current-workgroup-working-wconfig) - "Update `selected-frame's current workgroup's working-wconfig. -Before selecting a new frame." - (when wg-update-current-workgroup-working-wconfig-on-select-frame - (wg-update-current-workgroup-working-wconfig))) - - -;; enable all advice - -(defun wg-enable-all-advice () - "Enable and activate all of Workgroups' advice." - - ;; From advice.el: - ;; - ;; (defmacro ad-define-subr-args (subr arglist) - ;; `(put ,subr 'ad-subr-arglist (list ,arglist))) - - ;; switch-to-buffer - ;; (ad-define-subr-args 'switch-to-buffer '(buffer-or-name &optional norecord)) - (ad-enable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook) - (ad-activate 'switch-to-buffer) - - ;; set-window-buffer - ;; (ad-define-subr-args 'set-window-buffer '(window buffer-or-name &optional keep-margins)) - (ad-enable-advice - 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook) - (ad-activate 'set-window-buffer) - - ;; split-window - (ad-enable-advice - 'split-window 'before 'wg-pre-window-configuration-change-hook) - (ad-activate 'split-window) - - ;; enlarge-window - (ad-enable-advice - 'enlarge-window 'before 'wg-pre-window-configuration-change-hook) - (ad-activate 'enlarge-window) - - ;; delete-window - (ad-enable-advice - 'delete-window 'before 'wg-pre-window-configuration-change-hook) - (ad-activate 'delete-window) - - ;; delete-other-windows - (ad-enable-advice - 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook) - (ad-activate 'delete-other-windows) - - ;; delete-windows-on - (ad-enable-advice - 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook) - (ad-activate 'delete-windows-on) - - ;; save-buffers-kill-emacs - (ad-enable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig) - (ad-activate 'save-buffers-kill-emacs) - - ;; select-frame - ;;(ad-enable-advice 'select-frame 'before - ;; 'wg-update-current-workgroup-working-wconfig) - ;;(ad-activate 'select-frame) - ) - - -;; disable all advice -;; (wg-disable-all-advice) -(defun wg-disable-all-advice () - "Disable and deactivate all of Workgroups' advice." - - ;; switch-to-buffer - (ad-disable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook) - (ad-deactivate 'switch-to-buffer) - - ;; set-window-buffer - (ad-disable-advice - 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook) - (ad-deactivate 'set-window-buffer) - - ;; split-window - (ad-disable-advice - 'split-window 'before 'wg-pre-window-configuration-change-hook) - (ad-deactivate 'split-window) - - ;; enlarge-window - (ad-disable-advice - 'enlarge-window 'before 'wg-pre-window-configuration-change-hook) - (ad-deactivate 'enlarge-window) - - ;; delete-window - (ad-disable-advice - 'delete-window 'before 'wg-pre-window-configuration-change-hook) - (ad-deactivate 'delete-window) - - ;; delete-other-windows - (ad-disable-advice - 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook) - (ad-deactivate 'delete-other-windows) - - ;; delete-windows-on - (ad-disable-advice - 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook) - (ad-deactivate 'delete-windows-on) - - ;; save-buffers-kill-emacs - (ad-disable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig) - (ad-deactivate 'save-buffers-kill-emacs) - - ;; select-frame - ;;(ad-disable-advice 'select-frame 'before - ;; 'wg-update-current-workgroup-working-wconfig) - ;;(ad-deactivate 'select-frame) - - ) - -(provide 'workgroups-advice) -;;; workgroups-advice.el ends here diff --git a/src/workgroups-buf.el b/src/workgroups-buf.el deleted file mode 100644 index 4b7a8db3932d385fd92f24276b9cfdf2ece87adb..0000000000000000000000000000000000000000 --- a/src/workgroups-buf.el +++ /dev/null @@ -1,483 +0,0 @@ -;;; workgroups-buf.el --- BUFFER class -;;; Commentary: -;; -;; Workgroups Data Structures: -;; https://github.com/pashinin/workgroups2/wiki/Workgroups-data-structures -;; -;; -;; BUFFER is the most low level part Workgroups operates with (except -;; serializing Emacs objects functions). -;; -;; Different buffers we have: -;; - live buffers (just switch-to them) -;; - files/dirs (open them) -;; - special buffers (shells, unknown modes - write support for them) -;; -;; Another different types of "buffers": -;; - standard Emacs buffer (as you know it) -;; - Workgroups Buffer object (Elisp object, a representation of Emacs buffer) -;;; Code: - -(require 'workgroups-pickel) -(require 'workgroups-specialbufs) -(require 'workgroups-structs) - -;;; Variables - -(defvar wg-buffer-workgroup nil - "A workgroup in which this buffer most recently appeared. -Buffer-local.") -(make-variable-buffer-local 'wg-buffer-workgroup) - -(defcustom wg-default-buffer "*scratch*" - "Show this in case everything else fails. -When a buffer can't be restored, when creating a blank wg." - :type 'string - :group 'workgroups) - - -;;; Functions - -(defmacro wg-buf-list () - "Setf'able `wg-current-session' buf-list slot accessor." - `(wg-session-buf-list (wg-current-session))) - -(defun wg-restore-default-buffer () - "Switch to `wg-default-buffer'." - (switch-to-buffer wg-default-buffer t)) - -(defun wg-restore-existing-buffer (buf) - "Just switch to and return existing buffer." - (wg-awhen (wg-find-buf-in-buffer-list buf (buffer-list)) - (switch-to-buffer it t) - (wg-set-buffer-uid-or-error (wg-buf-uid buf)) - it)) - -(defun wg-restore-file-buffer (buf) - "Restore BUF by finding its file. Return the created buffer. -If BUF's file doesn't exist, call `wg-restore-default-buffer'" - (wg-when-let ((file-name (wg-buf-file-name buf))) - (when (or wg-restore-remote-buffers - (not (file-remote-p file-name))) - (cond ((file-exists-p file-name) - (find-file file-name) - (rename-buffer (wg-buf-name buf) t) - (wg-set-buffer-uid-or-error (wg-buf-uid buf)) - (when wg-restore-mark - (set-mark (wg-buf-mark buf)) - (deactivate-mark)) - (wg-deserialize-buffer-local-variables buf) - (current-buffer)) - (t - ;; try directory - (if (not (file-remote-p file-name)) - (if (file-directory-p (file-name-directory file-name)) - (progn - (dired (file-name-directory file-name)) - (current-buffer)) - (progn - (message "Attempt to restore nonexistent file: %S" file-name) - nil)) - nil) - ))))) - -(defun wg-restore-special-buffer (buf) - "Restore a buffer BUF with DESERIALIZER-FN." - (wg-when-let - ((special-data (wg-buf-special-data buf)) - (buffer (save-window-excursion - (condition-case err - (funcall (car special-data) buf) - (error (message "Error deserializing %S: %S" - (wg-buf-name buf) err) - nil))))) - (switch-to-buffer buffer t) - (wg-set-buffer-uid-or-error (wg-buf-uid buf)) - buffer)) - -(defun wg-restore-buffer (buf) - "Restore BUF and return it." - (or (wg-restore-existing-buffer buf) - (wg-restore-special-buffer buf) - (wg-restore-file-buffer buf) - (progn (wg-restore-default-buffer) nil))) - - -;;; buffer object utils - -(defun wg-buffer-uid (buffer-or-name) - "Return BUFFER-OR-NAME's buffer-local value of `wg-buffer-uid'." - (buffer-local-value 'wg-buffer-uid (wg-get-buffer buffer-or-name))) - -(defun wg-bufobj-uid (bufobj) - "Return BUFOBJ's uid." - (cl-etypecase bufobj - (buffer (wg-buffer-uid bufobj)) - (wg-buf (wg-buf-uid bufobj)) - (string (wg-bufobj-uid (wg-get-buffer bufobj))))) - -(defun wg-bufobj-name (bufobj) - "Return BUFOBJ's buffer name." - (cl-etypecase bufobj - (buffer (buffer-name bufobj)) - (wg-buf (wg-buf-name bufobj)) - (string (wg-buffer-name bufobj)))) - -(defun wg-bufobj-file-name (bufobj) - "Return BUFOBJ's filename." - (cl-etypecase bufobj - (buffer (buffer-file-name bufobj)) - (wg-buf (wg-buf-file-name bufobj)) - (string (wg-bufobj-file-name (wg-get-buffer bufobj))))) - -(defun wg-buf-major-mode (buf) - "Return BUF's `major-mode'. -It's stored in BUF's local-vars list, since it's a local variable." - (wg-aget (wg-buf-local-vars buf) 'major-mode)) - -(defun wg-buffer-major-mode (bufobj) - "Return BUFOBJ's `major-mode'. -It works with Emacs buffer, Workgroups buffer object and a simple string." - (cl-etypecase bufobj - (buffer (wg-buffer-major-mode bufobj)) - (wg-buf (wg-buf-major-mode bufobj)) - (string (wg-buffer-major-mode bufobj)))) - -;; `wg-equal-bufobjs' and `wg-find-bufobj' may need to be made a lot smarter -(defun wg-equal-bufobjs (bufobj1 bufobj2) - "Return t if BUFOBJ1 is \"equal\" to BUFOBJ2." - (let ((fname1 (wg-bufobj-file-name bufobj1)) - (fname2 (wg-bufobj-file-name bufobj2))) - (cond ((and fname1 fname2) (string= fname1 fname2)) - ((or fname1 fname2) nil) - ((string= (wg-bufobj-name bufobj1) (wg-bufobj-name bufobj2)) t)))) - -(defun wg-find-bufobj (bufobj bufobj-list) - "Find BUFOBJ in BUFOBJ-LIST, testing with `wg-equal-bufobjs'." - (cl-find bufobj bufobj-list :test 'wg-equal-bufobjs)) - -(defun wg-find-bufobj-by-uid (uid bufobj-list) - "Find the bufobj in BUFOBJ-LIST with uid UID." - (cl-find uid bufobj-list :test 'string= :key 'wg-bufobj-uid)) - -(defun wg-find-buf-in-buf-list (buf buf-list) - "Find BUF in BUF-LIST. -This is only here for completeness." - (cl-find buf buf-list)) - -(defun wg-find-buffer-in-buffer-list (buffer-or-name buffer-list) - "Find BUFFER-OR-NAME in BUFFER-LIST." - (cl-find (wg-get-buffer buffer-or-name) buffer-list :key 'wg-get-buffer)) - -(defun wg-find-buffer-in-buf-list (buffer-or-name buf-list) - "Find BUFFER-OR-NAME in BUF-LIST." - (wg-aif (wg-buffer-uid buffer-or-name) - (wg-find-bufobj-by-uid it buf-list) - (wg-find-bufobj buffer-or-name buf-list))) - -(defun wg-find-buf-in-buffer-list (buf buffer-list) - "Find BUF in BUFFER-LIST." - (or (wg-find-bufobj-by-uid (wg-buf-uid buf) buffer-list) - (wg-find-bufobj buf buffer-list))) - -(defun wg-find-buf-by-uid (uid) - "Find a buf in `wg-buf-list' by UID." - (wg-find-bufobj-by-uid uid (wg-buf-list))) - -(defun wg-set-buffer-uid-or-error (uid &optional buffer) - "Set BUFFER's buffer local value of `wg-buffer-uid' to UID. -If BUFFER already has a buffer local value of `wg-buffer-uid', -and it's not equal to UID, error." - (if wg-buffer-uid - ;;(if (string= wg-buffer-uid uid) uid - ;; (error "uids don't match %S and %S" uid wg-buffer-uid)) - (setq wg-buffer-uid uid))) - - -(defun wg-buffer-special-data (buffer) - "Return BUFFER's auxiliary serialization, or nil." - (cl-some (lambda (fn) (funcall fn buffer)) wg-special-buffer-serdes-functions)) - - -(defun wg-serialize-buffer-local-variables () - "Return an alist of buffer-local variable symbols and their values. -See `wg-buffer-local-variables-alist' for details." - (wg-docar (entry wg-buffer-local-variables-alist) - (wg-dbind (var ser des) entry - (when (local-variable-p var) - (cons var (if ser (funcall ser) (symbol-value var))))))) - -(defun wg-buffer-to-buf (buffer) - "Return the serialization (a wg-buf) of Emacs buffer BUFFER." - (with-current-buffer buffer - (wg-make-buf - :name (buffer-name) - :file-name (buffer-file-name) - :point (point) - :mark (mark) - :local-vars (wg-serialize-buffer-local-variables) - :special-data (wg-buffer-special-data buffer)))) - -(defun wg-add-buffer-to-buf-list (buffer) - "Make a buf from BUFFER, and add it to `wg-buf-list' if necessary. -If there isn't already a buf corresponding to BUFFER in -`wg-buf-list', make one and add it. Return BUFFER's uid -in either case." - (with-current-buffer buffer - (setq wg-buffer-uid - (wg-aif (wg-find-buffer-in-buf-list buffer (wg-buf-list)) - (wg-buf-uid it) - (let ((buf (wg-buffer-to-buf buffer))) - (push buf (wg-buf-list)) - (wg-buf-uid buf)))))) - -(defun wg-buffer-uid-or-add (buffer) - "Return BUFFER's uid. -If there isn't already a buf corresponding to BUFFER in -`wg-buf-list', make one and add it." - (or (wg-buffer-uid buffer) (wg-add-buffer-to-buf-list buffer))) - -(defun wg-bufobj-uid-or-add (bufobj) - "If BUFOBJ is a wg-buf, return its uid. -If BUFOBJ is a buffer or a buffer name, see `wg-buffer-uid-or-add'." - (cl-etypecase bufobj - (wg-buf (wg-buf-uid bufobj)) ;; possibly also add to `wg-buf-list' - (buffer (wg-buffer-uid-or-add bufobj)) - (string (wg-bufobj-uid-or-add (wg-get-buffer bufobj))))) - - -(defun wg-reset-buffer (buffer) - "Return BUFFER. -Currently only sets BUFFER's `wg-buffer-uid' to nil." - (with-current-buffer buffer (setq wg-buffer-uid nil))) - - - -;;; buffer-list-filter commands - -(defun wg-next-buffer-internal (buffer-list &optional prev noerror) - "Switch to the next buffer in Workgroups' filtered buffer list." - (when buffer-list - (let* ((cur (current-buffer)) - (next (or (wg-cyclic-nth-from-elt cur buffer-list (if prev -1 1)) - (car buffer-list)))) - (unless (eq cur next) - (switch-to-buffer next) - (unless prev (bury-buffer cur)) - next)))) - -(defun wg-next-buffer (&optional prev) - "Switch to the next buffer in Workgroups' filtered buffer list. -In the post-command message the current buffer is rotated to the -middle of the list to more easily see where `wg-previous-buffer' -will take you." - (interactive) - (let ((command (if prev 'previous-buffer 'next-buffer))) - (if (not (wg-filter-buffer-list-p)) - (call-interactively (wg-prior-mapping workgroups-mode command)) - (wg-with-buffer-list-filters command - (wg-awhen (wg-filtered-buffer-list) (wg-next-buffer-internal it prev)) - (wg-message (wg-buffer-command-display)))))) - -(defun wg-previous-buffer () - "Switch to the next buffer in Workgroups' filtered buffer list." - (interactive) - (wg-next-buffer t)) - -(defun wg-bury-buffer (&optional buffer-or-name) - "Remove BUFFER-OR-NAME from the current workgroup, bury it, -and switch to the next buffer in the buffer-list-filter." - (interactive (list (current-buffer))) - (if (not (wg-filter-buffer-list-p)) - (call-interactively (wg-prior-mapping workgroups-mode 'bury-buffer)) - (wg-with-buffer-list-filters 'bury-buffer - (wg-next-buffer-internal (wg-filtered-buffer-list)) - (bury-buffer buffer-or-name) - (wg-message (wg-buffer-command-display))))) - -(defun wg-banish-buffer (&optional buffer-or-name) - "Bury BUFFER-OR-NAME." - (interactive) - (let ((buffer (or buffer-or-name (current-buffer)))) - (wg-bury-buffer buffer))) - - -(defun wg-update-buffer-in-buf-list (&optional buffer) - "Update BUFFER's corresponding buf in `wg-buf-list'. -BUFFER nil defaults to `current-buffer'." - (let ((buffer (or buffer (current-buffer)))) - (wg-when-let ((uid (wg-buffer-uid buffer)) - (old-buf (wg-find-buf-by-uid uid)) - (new-buf (wg-buffer-to-buf buffer))) - (setf (wg-buf-uid new-buf) (wg-buf-uid old-buf)) - (wg-asetf (wg-buf-list) (cons new-buf (remove old-buf it)))))) - -(defun wg-update-buf-list (&optional buffer-list) - "Update all bufs in `wg-buf-list' corresponding to buffers in BUFFER-LIST." - (mapc 'wg-update-buffer-in-buf-list (or buffer-list (buffer-list)))) - - - - -(defun wg-buffer-list-display (buffer-list) - "Return the BUFFER-LIST display string." - (wg-display-internal - 'wg-buffer-display - (if wg-center-rotate-buffer-list-display - (wg-center-rotate-list buffer-list) buffer-list))) - -(defun wg-buffer-list-filter-display (&optional workgroup blf-id) - "Return a buffer-list-filter display string from WORKGROUP and BLF-ID." - (wg-fontify - "(" - (wg-workgroup-name (wg-get-workgroup workgroup)) - ":" - (wg-get-buffer-list-filter-val blf-id 'indicator) - ")")) - -(defun wg-buffer-list-filter-prompt (prompt &optional workgroup blf-id) - "Return a prompt string from PROMPT indicating WORKGROUP and BLF-ID." - (wg-fontify - prompt " " - (wg-buffer-list-filter-display workgroup blf-id) - ": ")) - -(defun wg-buffer-command-display (&optional buffer-list) - "Return the buffer command display string." - (concat - (wg-buffer-list-filter-display) ": " - (wg-buffer-list-display (or buffer-list (wg-filtered-buffer-list))))) - - -(defun wg-read-buffer (prompt &optional default require-match) - "Workgroups' version of `read-buffer'. -Read with PROMT DEFAULT REQUIRE-MATCH." - (if (not (wg-filter-buffer-list-p)) - (funcall (wg-read-buffer-function) prompt default require-match) - (wg-with-buffer-list-filters 'read-buffer - (funcall (wg-read-buffer-function) - (wg-buffer-list-filter-prompt - (wg-aif (string-match ": *$" prompt) - (substring prompt 0 it) prompt)) - default require-match)))) - - - -;;; filtered buffer-list construction - -(defun wg-get-buffer-list-filter-id-flexibly (blf-id) - "Return a buffer-list-filter-id one way or another." - (or blf-id wg-current-buffer-list-filter-id 'all)) - -(defun wg-get-buffer-list-filter-val (id key &optional noerror) - "Return ID's KEY's value in `wg-buffer-list-filter-definitions'. -Lots of possible errors here because -`wg-buffer-list-filter-definitions' can be modified by the user." - (let ((slot-num (cl-case key (symbol 0) (indicator 1) (constructor 2)))) - (if (not slot-num) - (unless noerror - (error "`%S' is not a valid buffer-list-filter definition slot" key)) - (let* ((id (wg-get-buffer-list-filter-id-flexibly id)) - (entry (assq id (wg-local-value - 'wg-buffer-list-filter-definitions)))) - (if (not entry) - (unless noerror - (error "`%S' is an undefined buffer-list-filter" id)) - (or (nth slot-num entry) - (unless noerror - (error "Slot `%S' is undefined in `%S's definition" - key id)))))))) - -(defun wg-filtered-buffer-list (&optional names workgroup bfl-id initial) - "Return a filtered buffer-list from NAMES, WORKGROUP, BLF-ID and INITIAL. -NAMES non-nil means return a list of buffer-names instead of buffer objects. -WORKGROUP non-nil should be any workgroup identifier accepted by -`wg-get-workgroup'. -BLF-ID non-nil should be the identifier of a defined buffer-list-filter. -It defaults to `wg-get-buffer-list-filter-val'. -INITIAL non-nil should be an initial buffer-list to filter. It defaults to -`wg-interesting-buffers'." - (let ((buffer-list (funcall (wg-get-buffer-list-filter-val - (wg-get-buffer-list-filter-id-flexibly bfl-id) - 'constructor) - (wg-get-workgroup workgroup) - (or initial (wg-interesting-buffers))))) - (if names (mapcar 'wg-buffer-name buffer-list) buffer-list))) - - -;; buffer-list filters - -(defun wg-buffer-list-filter-all (workgroup initial) - "Return all buffers in INITIAL." - initial) - -(defun wg-filter-buffer-list-by-regexp (regexp buffer-list) - "Return only those buffers in BUFFER-LIST with names matching REGEXP." - (cl-remove-if-not (lambda (bname) (string-match regexp bname)) - buffer-list :key 'buffer-name)) - -(defun wg-filter-buffer-list-by-root-dir (root-dir buffer-list) - "Return only those buffers in BUFFER-LIST visiting files undo ROOT-DIR." - (cl-remove-if-not (lambda (f) (when f (wg-file-under-root-path-p root-dir f))) - buffer-list :key 'buffer-file-name)) - -(defun wg-filter-buffer-list-by-major-mode (major-mode buffer-list) - "Return only those buffers in BUFFER-LIST in major-mode MAJOR-MODE." - (cl-remove-if-not (lambda (mm) (eq mm major-mode)) - buffer-list :key 'wg-buffer-major-mode)) - - -;; Example custom buffer-list-filters - -(defun wg-buffer-list-filter-irc (workgroup buffer-list) - "Return only those buffers in BUFFER-LIST with names starting in \"#\"." - (wg-filter-buffer-list-by-regexp "^#" buffer-list)) - -(defun wg-buffer-list-filter-home-dir (workgroup buffer-list) - "Return only those buffers in BUFFER-LIST visiting files under ~/." - (wg-filter-buffer-list-by-root-dir "~/" buffer-list)) - - - -;; buffer-list-filter context - -(defun wg-buffer-list-filter-order (command) - "Return WORKGROUP's buffer-list-filter order for COMMAND, or a default." - (let ((bfo (wg-local-value 'wg-buffer-list-filter-order-alist))) - (or (wg-aget bfo command) (wg-aget bfo 'default)))) - -(defmacro wg-prior-mapping (mode command) - "Return whatever COMMAND would call if MODE wasn't on." - `(or (let (,mode) (command-remapping ,command)) ,command)) - -(defun wg-filter-buffer-list-p () - "Return the current workgroup when buffer-list-filters are on." - (and workgroups-mode wg-buffer-list-filtration-on (wg-current-workgroup t))) - -(defmacro wg-with-buffer-list-filters (command &rest body) - "Create buffer-list filter context for COMMAND, and eval BODY. -Binds `wg-current-buffer-list-filter-id' in BODY." - (declare (indent 1)) - (wg-with-gensyms (order status) - `(let* ((wg-previous-minibuffer-contents nil) - (,order (wg-buffer-list-filter-order ,command))) - (catch 'wg-result - (while 'your-mom - (let* ((wg-current-buffer-list-filter-id (car ,order)) - (,status (catch 'wg-action (list 'done (progn ,@body))))) - (cl-case (car ,status) - (done (throw 'wg-result (cadr ,status))) - (next (setq ,order (wg-rotate-list ,order 1)) - (setq wg-previous-minibuffer-contents (cadr ,status))) - (prev (setq ,order (wg-rotate-list ,order -1)) - (setq wg-previous-minibuffer-contents - (cadr ,status)))))))))) - -(defun wg-toggle-buffer-list-filtration () - "Toggle `wg-buffer-list-filtration-on'." - (interactive) - (wg-toggle-and-message 'wg-buffer-list-filtration-on)) - - -(provide 'workgroups-buf) -;;; workgroups-buf.el ends here diff --git a/src/workgroups-faces.el b/src/workgroups-faces.el deleted file mode 100644 index 44225e1145211930b411f87ebe3d1f909e0d416f..0000000000000000000000000000000000000000 --- a/src/workgroups-faces.el +++ /dev/null @@ -1,198 +0,0 @@ -;;; workgroups-faces.el --- Colors -;;; Commentary: -;; display customization -;;; Code: - -(defcustom wg-use-faces t - "Non-nil means use faces in various messages." - :type 'boolean - :group 'workgroups) - -(defcustom wg-list-display-decor-left-brace "( " - "String displayed to the left of the list display." - :type 'string - :group 'workgroups) - -(defcustom wg-list-display-decor-right-brace " )" - "String displayed to the right of the list display." - :type 'string - :group 'workgroups) - -(defcustom wg-list-display-decor-divider " | " - "String displayed between elements of the list display." - :type 'string - :group 'workgroups) - -(defcustom wg-list-display-decor-current-left "-<{ " - "String displayed to the left of the current element of the list display." - :type 'string - :group 'workgroups) - -(defcustom wg-list-display-decor-current-right " }>-" - "String displayed to the right of the current element of the list display." - :type 'string - :group 'workgroups) - -(defcustom wg-list-display-decor-previous-left "< " - "String displayed to the left of the previous element of the list display." - :type 'string - :group 'workgroups) - -(defcustom wg-list-display-decor-previous-right " >" - "String displayed to the right of the previous element of the list display." - :type 'string - :group 'workgroups) - - -(defvar wg-face-abbrevs nil - "Assoc list mapping face abbreviations to face names.") - -(defmacro wg-defface (face key spec doc &rest args) - "`defface' wrapper adding a lookup key used by `wg-fontify'." - (declare (indent 2)) - `(progn - (cl-pushnew (cons ,key ',face) wg-face-abbrevs :test #'equal) - (defface ,face ,spec ,doc ,@args))) - -(wg-defface wg-current-workgroup-face :cur - '((t :inherit font-lock-constant-face :bold nil)) - "Face used for current elements in list displays." - :group 'workgroups) - -(wg-defface wg-previous-workgroup-face :prev - '((t :inherit font-lock-keyword-face :bold nil)) - "Face used for the name of the previous workgroup in the list display." - :group 'workgroups) - -(wg-defface wg-other-workgroup-face :other - '((t :inherit font-lock-string-face :bold nil)) - "Face used for the names of other workgroups in the list display." - :group 'workgroups) - -(wg-defface wg-command-face :cmd - '((t :inherit font-lock-function-name-face :bold nil)) - "Face used for command/operation strings." - :group 'workgroups) - -(wg-defface wg-divider-face :div - '((t :inherit font-lock-builtin-face :bold nil)) - "Face used for dividers." - :group 'workgroups) - -(wg-defface wg-brace-face :brace - '((t :inherit font-lock-builtin-face :bold nil)) - "Face used for left and right braces." - :group 'workgroups) - -(wg-defface wg-message-face :msg - '((t :inherit font-lock-string-face :bold nil)) - "Face used for messages." - :group 'workgroups) - -(wg-defface wg-mode-line-face :mode - '((t :inherit font-lock-doc-face :bold nil)) - "Face used for workgroup position and name in the mode-line display." - :group 'workgroups) - -(wg-defface wg-filename-face :file - '((t :inherit font-lock-keyword-face :bold nil)) - "Face used for filenames." - :group 'workgroups) - - -;;; fancy displays - -(defun wg-element-display (elt elt-string &optional current-elt-p previous-elt-p) - "Return display string for ELT." - (cond ((and current-elt-p (funcall current-elt-p elt)) - (wg-fontify (:cur (concat wg-list-display-decor-current-left - elt-string - wg-list-display-decor-current-right)))) - ((and previous-elt-p (funcall previous-elt-p elt)) - (wg-fontify (:prev (concat wg-list-display-decor-previous-left - elt-string - wg-list-display-decor-previous-right)))) - (t (wg-fontify (:other elt-string))))) - -(defun wg-workgroup-display (workgroup index) - "Return display string for WORKGROUP at INDEX." - (if (not workgroup) wg-nowg-string - (wg-element-display - workgroup - (format "%d: %s" index (wg-workgroup-name workgroup)) - 'wg-current-workgroup-p - 'wg-previous-workgroup-p))) - -(defun wg-buffer-display (buffer index) - "Return display string for BUFFER. INDEX is ignored." - (if (not buffer) "No buffers" - (wg-element-display - (wg-get-buffer buffer) - (format "%s" (wg-buffer-name buffer)) - 'wg-current-buffer-p))) - - -;; (defun wg-display-internal (elt-fn list) -;; "Return display string built by calling ELT-FN on each element of LIST." -;; (let ((div (wg-add-face :div wg-list-display-decor-divider)) -;; (i -1)) -;; (wg-fontify -;; (:brace wg-list-display-decor-left-brace) -;; (if (not list) (funcall elt-fn nil nil) -;; (wg-doconcat (elt list div) (funcall elt-fn elt (cl-incf i)))) -;; (:brace wg-list-display-decor-right-brace)))) - - - -;;; messaging - -(defun wg-message (format-string &rest args) - "Call `message' with FORMAT-STRING and ARGS. -Also save the msg to `wg-last-message'." - (setq wg-last-message (apply #'message format-string args))) - -(defmacro wg-fontified-message (&rest format) - "`wg-fontify' FORMAT and call `wg-message' on it." - (declare (indent defun)) - `(wg-message (wg-fontify ,@format))) - -(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-add-face (facekey string) - "Return a copy of STRING fontified according to FACEKEY. -FACEKEY must be a key in `wg-face-abbrevs'." - (let ((face (wg-aget wg-face-abbrevs facekey)) - (string (copy-sequence string))) - (unless face (error "No face with key %s" facekey)) - (if (not wg-use-faces) string - (put-text-property 0 (length string) 'face face string) - string))) - -(defmacro wg-fontify (&rest specs) - "A small fontification DSL. -The results of all SPECS are `concat'd together. -If a spec is a cons with a keyword car, apply `wg-add-face' to it. -Other conses get evaluated, and should produce a strings. -If a spec is a string it is used unmodified. -Anything else is formatted with %s to produce a string." - (declare (indent defun)) - `(concat - ,@(wg-docar (spec specs) - (cond ((and (consp spec) - (keywordp (car spec))) - `(wg-add-face ,@spec)) - ;;((listp spec) (cdr (eval spec))) - ;;((listp spec) - ;; ;;(prin1-to-string (nth 1 (eval spec))) - ;; ) - ((consp spec) spec) - ((stringp spec) spec) - (t `(format "%s" ,spec)))))) - -(provide 'workgroups-faces) -;;; workgroups-faces.el ends here diff --git a/src/workgroups-ido.el b/src/workgroups-ido.el deleted file mode 100644 index c5bda3c9764b853081582dc72e3e88f5eb5e1fe3..0000000000000000000000000000000000000000 --- a/src/workgroups-ido.el +++ /dev/null @@ -1,92 +0,0 @@ -;;; workgroups-ido --- ido and iswitchb compatibility -;;; Commentary: -;;; Code: - -(require 'workgroups-variables) -(require 'cl-lib) -(require 'ido) - -(defcustom wg-ido-entry-buffer-replacement-regexp "^ .*Minibuf.*$" - "Regexp matching the name of a buffer to replace `ido-entry-buffer'. -The regexp should match the name of a live buffer that will never -be a completion candidate under normal circumstances. You -probably don't want to change this. See -`wg-get-sneaky-ido-entry-buffer-replacement'." - :type 'regexp - :group 'workgroups) - - -(defun wg-read-buffer-mode () - "Return the buffer switching package (ido or iswitchb) to use, or nil." - (if (eq wg-current-buffer-list-filter-id 'fallback) 'fallback - (cl-case (let (workgroups-mode) (command-remapping 'switch-to-buffer)) - (ido-switch-buffer 'ido) - (otherwise 'fallback)))) - -(defun wg-read-buffer-function (&optional mode) - "Return MODE's or `wg-read-buffer-mode's `read-buffer' function." - (cl-case (or mode (wg-read-buffer-mode)) - (ido 'ido-read-buffer) - (fallback (lambda (prompt &optional default require-match) - (let (read-buffer-function) - (read-buffer prompt default require-match)))))) - -(defun wg-completing-read - (prompt choices &optional pred require-match initial-input history default) - "Do a completing read. The function called depends on what's on." - (cl-ecase (wg-read-buffer-mode) - (ido - (ido-completing-read prompt choices pred require-match - initial-input history default)) - (fallback - (completing-read prompt choices pred require-match - initial-input history default)))) - -(defun wg-get-sneaky-ido-entry-buffer-replacement (&optional regexp) - "Return a live buffer to replace `ido-entry-buffer'. -This is a workaround for an ido misfeature. IMHO, ido should -respect the value of `ido-temp-list' after -`ido-make-buffer-list-hook' has been run, since the user's -preference for the final value of `ido-temp-list', if any, has -been expressed in that hook. But ido conditionally rotates the -first match to the end after the hook has been run, based on the -value of `ido-entry-buffer'. So as a workaround, set -`ido-entry-buffer' to a buffer that will never be a completion -candidate under normal circumstances. See -`wg-ido-entry-buffer-replacement-regexp'." - (wg-get-first-buffer-matching-regexp - (or regexp wg-ido-entry-buffer-replacement-regexp))) - -(defun wg-adjust-buffer-list-default (buflist &optional default) - "Adjust BUFLIST based on DEFAULT. -DEFAULT is the default completion candidate, and defaults to -`wg-buffer-internal-default-buffer'. Non-nil, this gets placed -at the beginning of BUFLIST. Otherwise rotate BUFLIST." - (wg-aif (or default wg-buffer-internal-default-buffer) - (wg-move-elt it buflist 0) - (wg-rotate-list buflist))) - -(defun wg-finalize-buffer-list (buflist) - "Run `wg-buffer-list-finalization-hook' and return -`wg-temp-buffer-list'." - (let ((wg-temp-buffer-list buflist)) - (run-hooks 'wg-buffer-list-finalization-hook) - wg-temp-buffer-list)) - -(defun wg-set-buffer-list-symbol (symbol) - "Set SYMBOL to the filtered buffer-list." - (when (and wg-current-buffer-list-filter-id (boundp symbol)) - (set symbol - (wg-finalize-buffer-list - (wg-adjust-buffer-list-default - (wg-filtered-buffer-list t)))))) - -(defun wg-set-ido-buffer-list () - "Set `ido-temp-list' with `wg-set-buffer-list-symbol'. -Added to `ido-make-buffer-list-hook'." - (wg-set-buffer-list-symbol 'ido-temp-list) - (wg-when-boundp (ido-entry-buffer) - (setq ido-entry-buffer (wg-get-sneaky-ido-entry-buffer-replacement)))) - -(provide 'workgroups-ido) -;;; workgroups-ido.el ends here diff --git a/src/workgroups-keys.el b/src/workgroups-keys.el deleted file mode 100644 index 862e8ed3304f2cf0392ad7631b84956aed7f51fd..0000000000000000000000000000000000000000 --- a/src/workgroups-keys.el +++ /dev/null @@ -1,142 +0,0 @@ -;;; workgroups.keys.el --- Set default workgroups keys -;;; Commentary: -;; -;;; Code: - -(require 'workgroups-variables) -(require 'workgroups-utils-basic) - -(defcustom wg-prefix-key (kbd "C-c z") - "Workgroups' prefix key. -Setting this variable requires that `workgroups-mode' be turned -off and then on again to take effect." - :type 'string - :group 'workgroups) - -(defvar workgroups-mode-map nil - "Workgroups Mode's keymap.") - -(defvar wg-prefixed-map - (wg-fill-keymap - (make-sparse-keymap) - - ;; workgroups - (kbd "C-c") 'wg-create-workgroup - (kbd "c") 'wg-create-workgroup - (kbd "C") 'wg-clone-workgroup - (kbd "A") 'wg-rename-workgroup - (kbd "C-'") 'wg-switch-to-workgroup - (kbd "'") 'wg-switch-to-workgroup - (kbd "C-v") 'wg-switch-to-workgroup - (kbd "v") 'wg-switch-to-workgroup - - ;; session - (kbd "C-s") 'wg-save-session - (kbd "C-w") 'wg-save-session-as - (kbd "C-f") 'wg-open-session - - ;; killing and yanking - (kbd "C-k") 'wg-kill-workgroup - (kbd "k") 'wg-kill-workgroup - (kbd "M-W") 'wg-kill-ring-save-base-wconfig - (kbd "M-w") 'wg-kill-ring-save-working-wconfig - (kbd "C-y") 'wg-yank-wconfig - (kbd "y") 'wg-yank-wconfig - (kbd "M-k") 'wg-kill-workgroup-and-buffers - (kbd "K") 'wg-delete-other-workgroups - - - ;; workgroup switching - (kbd "M-v") 'wg-switch-to-workgroup-other-frame - (kbd "C-j") 'wg-switch-to-workgroup-at-index - (kbd "j") 'wg-switch-to-workgroup-at-index - (kbd "0") 'wg-switch-to-workgroup-at-index-0 - (kbd "1") 'wg-switch-to-workgroup-at-index-1 - (kbd "2") 'wg-switch-to-workgroup-at-index-2 - (kbd "3") 'wg-switch-to-workgroup-at-index-3 - (kbd "4") 'wg-switch-to-workgroup-at-index-4 - (kbd "5") 'wg-switch-to-workgroup-at-index-5 - (kbd "6") 'wg-switch-to-workgroup-at-index-6 - (kbd "7") 'wg-switch-to-workgroup-at-index-7 - (kbd "8") 'wg-switch-to-workgroup-at-index-8 - (kbd "9") 'wg-switch-to-workgroup-at-index-9 - (kbd "C-p") 'wg-switch-to-workgroup-left - (kbd "p") 'wg-switch-to-workgroup-left - (kbd "C-n") 'wg-switch-to-workgroup-right - (kbd "n") 'wg-switch-to-workgroup-right - (kbd "C-a") 'wg-switch-to-previous-workgroup - (kbd "a") 'wg-switch-to-previous-workgroup - - - ;; updating and reverting - ;; wconfig undo/redo - (kbd "C-r") 'wg-revert-workgroup - (kbd "r") 'wg-revert-workgroup - (kbd "C-S-r") 'wg-revert-all-workgroups - (kbd "R") 'wg-revert-all-workgroups - (kbd "") 'wg-undo-wconfig-change - (kbd "") 'wg-redo-wconfig-change - (kbd "[") 'wg-undo-wconfig-change - (kbd "]") 'wg-redo-wconfig-change - (kbd "{") 'wg-undo-once-all-workgroups - (kbd "}") 'wg-redo-once-all-workgroups - - - ;; wconfig save/restore - (kbd "C-d C-s") 'wg-save-wconfig - (kbd "C-d C-'") 'wg-restore-saved-wconfig - (kbd "C-d C-k") 'wg-kill-saved-wconfig - - - ;; buffer-list - (kbd "(") 'wg-next-buffer - (kbd ")") 'wg-previous-buffer - - - ;; workgroup movement - (kbd "C-x") 'wg-swap-workgroups - (kbd "C-,") 'wg-offset-workgroup-left - (kbd "C-.") 'wg-offset-workgroup-right - - - ;; window moving and frame reversal - (kbd "|") 'wg-reverse-frame-horizontally - (kbd "\\") 'wg-reverse-frame-vertically - (kbd "/") 'wg-reverse-frame-horizontally-and-vertically - - - ;; toggling - (kbd "C-t C-m") 'wg-toggle-mode-line-display - (kbd "C-t C-b") 'wg-toggle-buffer-list-filtration - (kbd "C-t C-d") 'wg-toggle-window-dedicated-p - - - ;; misc - (kbd "!") 'wg-reset - (kbd "?") 'wg-help - - ) - "The keymap that sits on `wg-prefix-key'.") - -(defun wg-make-workgroups-mode-map () - "Return Workgroups' minor-mode-map. -This map includes `wg-prefixed-map' on `wg-prefix-key', as well -as Workgroups' command remappings." - (let ((map (make-sparse-keymap))) - (define-key map wg-prefix-key - wg-prefixed-map) - ;;(cond ((eq wg-remap-bury-buffer 'banish) - ;; (define-key map [remap bury-buffer] - ;; 'wg-banish-buffer)) - ;; (wg-remap-bury-buffer - ;; (define-key map [remap bury-buffer] - ;; 'wg-bury-buffer))) - (when (and (fboundp 'winner-undo) - (fboundp 'winner-redo)) - (define-key map [remap winner-undo] 'wg-undo-wconfig-change) - (define-key map [remap winner-redo] 'wg-redo-wconfig-change)) - (setq workgroups-mode-map map))) - - -(provide 'workgroups-keys) -;;; workgroups-keys.el ends here diff --git a/src/workgroups-minibuffer.el b/src/workgroups-minibuffer.el deleted file mode 100644 index 238a1ac826c29ef5e3acc1fc5d137ea9b87a8a80..0000000000000000000000000000000000000000 --- a/src/workgroups-minibuffer.el +++ /dev/null @@ -1,64 +0,0 @@ -;;; wg-commands-minibuffer --- minibuffer commands -;;; Commentary: -;;; Code: - -(require 'workgroups-utils-basic) -(require 'workgroups-ido) -(require 'workgroups-buf) - -(defvar wg-just-exited-minibuffer nil - "Flag set by `minibuffer-exit-hook'. -To exempt from undoification those window-configuration changes -caused by exiting the minibuffer. This is ugly, but necessary. -It may seem like we could just null out -`wg-undoify-window-configuration-change' in -`minibuffer-exit-hook', but that also prevents undoification of -window configuration changes triggered by commands called with -`execute-extended-command' -- i.e. it's just too coarse.") - -(defcustom wg-no-confirm-on-destructive-operation nil - "Do not request confirmation before various destructive operations. -Like `wg-reset'." - :type 'boolean - :group 'workgroups) - -(defcustom wg-minibuffer-message-timeout 0.75 - "Bound to `minibuffer-message-timeout' when messaging while the -minibuffer is active." - :type 'float - :group 'workgroups) - - -;; -;; Functions -;; - -(defun wg-read-object (prompt test warning &optional initial-contents keymap - read hist default-value inherit-input-method) - "PROMPT for an object that satisfies TEST, -WARNING if necessary. ARGS are `read-from-minibuffer's args, -after PROMPT." - (cl-labels ((read () (read-from-minibuffer - prompt initial-contents keymap read hist - default-value inherit-input-method))) - (let ((obj (read))) - (when (and (equal obj "") default-value) (setq obj default-value)) - (while (not (funcall test obj)) - (message warning) - (sit-for wg-minibuffer-message-timeout) - (setq obj (read))) - obj))) - -(defun wg-minibuffer-inactive-p () - "Return t when `minibuffer-depth' is zero, nil otherwise." - (zerop (minibuffer-depth))) - - -(defun wg-barf-on-active-minibuffer () - "Throw an error when the minibuffer is active." - (when (not (wg-minibuffer-inactive-p)) - (error "Exit minibuffer to use workgroups functions!"))) - - -(provide 'workgroups-minibuffer) -;;; workgroups-minibuffer.el ends here diff --git a/src/workgroups-modeline.el b/src/workgroups-modeline.el deleted file mode 100644 index 4b403d7e4316869bb7938749f845e413e9661ec4..0000000000000000000000000000000000000000 --- a/src/workgroups-modeline.el +++ /dev/null @@ -1,158 +0,0 @@ -;;; workgroups-modeline.el --- All modeline modifications -;;; Commentary: -;;; Code: - -(require 'workgroups-keys) -(require 'workgroups-workgroup) - -(defcustom wg-mode-line-display-on t - "Toggles Workgroups' mode-line display." - :type 'boolean - :group 'workgroups - :set (lambda (sym val) - (custom-set-default sym val) - (force-mode-line-update))) - -(defcustom wg-mode-line-use-faces nil - "Non-nil means use faces in the mode-line display. -It can be tricky to choose faces that are visible in both active -and inactive mode-lines, so this feature defaults to off." - :type 'boolean - :group 'workgroups) - -(defcustom wg-mode-line-disable (featurep 'powerline) - "Do not do any modeline modifications. -There are problems with powerline." - :type 'boolean - :group 'workgroups) - -(defcustom wg-mode-line-only-name t - "Display only workgroup name in modeline without any flags." - :type 'boolean - :group 'workgroups) - -(defcustom wg-mode-line-decor-left-brace "(" - "String displayed at the left of the mode-line display." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-right-brace ")" - "String displayed at the right of the mode-line display." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-divider ":" - "String displayed between elements of the mode-line display." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-window-dedicated - #("#" 0 1 (help-echo "This window is dedicated to its buffer.")) - "Indicates that the window is dedicated to its buffer." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-window-undedicated - #("-" 0 1 (help-echo "This window is not dedicated to its buffer.")) - "Indicates that the window is not dedicated to its buffer." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-session-modified - #("*" 0 1 (help-echo "The session is modified")) - "Indicates that the session is modified." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-session-unmodified - #("-" 0 1 (help-echo "The session is unmodified")) - "Indicates that the session is unmodified." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-workgroup-modified - #("*" 0 1 (help-echo "The current workgroup is modified")) - "Indicates that the current workgroup is modified." - :type 'string - :group 'workgroups) - -(defcustom wg-mode-line-decor-workgroup-unmodified - #("-" 0 1 (help-echo "The current workgroup is unmodified")) - "Indicates that the current workgroup is unmodified." - :type 'string - :group 'workgroups) - - - -;;; mode-line - -(defun wg-mode-line-string () - "Return the string to be displayed in the mode-line." - (let ((wg (wg-current-workgroup t)) - (wg-use-faces wg-mode-line-use-faces)) - (cond (wg (wg-fontify " " - ;;(consp (cons :div wg-mode-line-decor-left-brace)) - ;;(keywordp (car (cons :div wg-mode-line-decor-left-brace))) - ;;(:div wg-mode-line-decor-left-brace) - (:brace wg-mode-line-decor-left-brace) - (:mode (wg-workgroup-name wg)) - (if (not wg-mode-line-only-name) - (concat - (wg-add-face :div wg-mode-line-decor-divider) - (wg-add-face :div wg-mode-line-decor-divider) - (if (window-dedicated-p) - wg-mode-line-decor-window-dedicated - wg-mode-line-decor-window-undedicated) - (wg-add-face :div wg-mode-line-decor-divider) - (if (wg-session-modified (wg-current-session)) - wg-mode-line-decor-session-modified - wg-mode-line-decor-session-unmodified) - (if (wg-workgroup-modified wg) - wg-mode-line-decor-workgroup-modified - wg-mode-line-decor-workgroup-unmodified))) - (:brace wg-mode-line-decor-right-brace))) - (t (if wg-display-nowg - (progn - (wg-fontify " " - (:brace wg-mode-line-decor-left-brace) - (:mode wg-nowg-string) - (:brace wg-mode-line-decor-right-brace))) - ""))))) - -(defun wg-change-modeline () - "Add Workgroups' mode-line format to `mode-line-format'." - (unless (or (assq 'wg-mode-line-display-on mode-line-format) - wg-mode-line-disable) - (let ((format '(wg-mode-line-display-on (:eval (wg-mode-line-string)))) - (pos (or (cl-position 'mode-line-position mode-line-format) 10))) - (set-default 'mode-line-format - (wg-insert-after format mode-line-format pos)) - (force-mode-line-update)))) - - -(defun wg-remove-mode-line-display () - "Remove Workgroups' mode-line format from `mode-line-format'." - (wg-awhen (assq 'wg-mode-line-display-on mode-line-format) - (set-default 'mode-line-format (remove it mode-line-format)) - (force-mode-line-update))) - - -(defun wg-toggle-mode-line-display () - "Toggle `wg-mode-line-display-on'." - (interactive) - (wg-toggle-and-message 'wg-mode-line-display-on)) - -(defun wg-add-workgroups-mode-minor-mode-entries () - "Add Workgroups' minor-mode entries. -Adds entries to `minor-mode-list', `minor-mode-alist' and -`minor-mode-map-alist'." - (cl-pushnew 'workgroups-mode minor-mode-list) - (cl-pushnew '(workgroups-mode wg-modeline-string) minor-mode-alist :test 'equal) - (setq minor-mode-map-alist - (cons (cons 'workgroups-mode (wg-make-workgroups-mode-map)) - (delete (assoc 'workgroups-mode minor-mode-map-alist) - minor-mode-map-alist)))) - - -(provide 'workgroups-modeline) -;;; workgroups-modeline.el ends here diff --git a/src/workgroups-pickel.el b/src/workgroups-pickel.el deleted file mode 100644 index 1032edef253f6d09c175f37e68f0f2907dff472a..0000000000000000000000000000000000000000 --- a/src/workgroups-pickel.el +++ /dev/null @@ -1,360 +0,0 @@ -;;; workgroups-pickel.el --- Elisp object serdes used by Workgroups -;;; Commentary: -;; -;; Workgroups allows you to serialize some objects, even such as buffers -;; (that are displayed as #). The only trick is to write -;; functions that extract enough information about an object and -;; functions that can recreate an object. -;; -;; Main functions are: `wg-pickel', `wg-pickel-to-string', `wg-pickel-to-file' -;; What objects are supported? See `wg-pickel-pickelable-types' -;; -;;; Code: - -(require 'cl-lib) -(require 'workgroups-utils-basic) - -(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 - marker - ;;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) - (buffer . wg-pickel-buffer-serializer) - (marker . wg-pickel-marker-serializer) - ;;(window-configuration . wg-pickel-window-configuration-serializer) - ) - "Alist mapping types to object 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) - (m . wg-pickel-deserialize-marker) - ;;(f . wg-pickel-deserialize-frame) - ) - "Alist mapping type keys to object deserialization 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-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))) - - - -;;; Objects - -;; symbol -;; (wg-unpickel (wg-pickel 123)) -;; (wg-unpickel (wg-pickel "table")) -;; (wg-unpickel (wg-pickel 'test)) -(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-deserialize-uninterned-symbol (name) - "Return a new uninterned symbol from NAME." - (make-symbol name)) - - -;; buffer -;; (wg-unpickel (wg-pickel (current-buffer))) -(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-deserialize-buffer (uid) - "Return a restored buffer from it's UID." - (save-window-excursion - (wg-restore-buffer (wg-find-buf-by-uid uid)))) - - -;; marker -;; (wg-unpickel (wg-pickel (point-marker))) -(defun wg-pickel-marker-serializer (marker) - "Return MARKERS's data." - (list 'm (list (marker-position marker) - (wg-add-buffer-to-buf-list (marker-buffer marker))))) -(defun wg-pickel-deserialize-marker (data) - "Return marker from it's data." - (let ((m (make-marker))) - (set-marker m (car data) (wg-pickel-deserialize-buffer (car (cdr data)))))) - - -;; cons - http://www.gnu.org/software/emacs/manual/html_node/eintr/cons.html -(defun wg-pickel-cons-serializer (cons) - "Return CONS's serialization." - (list 'c)) -(defun wg-pickel-deserialize-cons () - "Return a new cons cell initialized to nil." - (cons nil nil)) -(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-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)))) - - - -;; vector - http://www.gnu.org/software/emacs/manual/html_node/elisp/Vector-Functions.html -;; (wg-unpickel (wg-pickel (make-vector 9 'Z))) -;; -(defun wg-pickel-vector-serializer (vector) - "Return VECTOR's serialization." - (list 'v (length vector))) -(defun wg-pickel-deserialize-vector (length) - "Return a new vector of length LENGTH." - (make-vector length nil)) -(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))))) -(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))) - - -;; hash table - http://www.gnu.org/software/emacs/manual/html_node/elisp/Hash-Tables.html -(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-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-hash-table-link-serializer (table binds) - "Return the serialization of TABLE's links in BINDS." - (let (result) - (wg-dohash (key value table result) - (setq result - (nconc (list 'h - (gethash key binds) - (gethash value binds) - (gethash table binds)) - result))))) -(defun wg-pickel-hash-table-link-deserializer (key-id value-id table-id binds) - "Relink a hash-table with its keys and values in BINDS." - (puthash (gethash key-id binds) - (gethash value-id binds) - (gethash table-id binds))) - - - -;; TODO -(defun wg-pickel-window-configuration-serializer (wc) - "Return Window configuration WC's serialization." - (list 'wc 1)) - - - - - -(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))))) -(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)))) - - - -(defun wg-pickel-serialize-links (binds) - "Return a list of serializations of the links between objects in BINDS." - (let (result) - (wg-dohash (obj id binds result) - (wg-awhen (wg-pickel-link-serializer obj) - (setq result (nconc (funcall it obj binds) result)))))) -(defun wg-pickel-deserialize-links (serial-links binds) - "Return BINDS after relinking all its objects according to SERIAL-LINKS." - (wg-destructuring-dolist ((key arg1 arg2 arg3 . rest) serial-links binds) - (funcall (wg-pickel-link-deserializer key) arg1 arg2 arg3 binds))) - - - -;;; pickeling - -(defun wg-pickel (obj) - "Return the serialization of OBJ." - (wg-pickelable-or-error obj) - (let ((binds (wg-pickel-make-bindings-table obj))) - (list wg-pickel-identifier - (wg-pickel-serialize-objects binds) - (wg-pickel-serialize-links binds) - (gethash obj binds)))) - -(defun wg-pickel-to-string (obj) - "Serialize OBJ to a string and return the string." - (format "%S" (wg-pickel obj))) - -(defun wg-pickel-to-file (file obj) - "Serialize OBJ to FILE." - (wg-write-sexp-to-file (wg-pickel obj) file)) - - - -;;; unpickeling - -(defun wg-unpickel (pickel) - "Return the deserialization of PICKEL." - (unless (wg-pickel-p pickel) - (error "Attempt to unpickel a non-pickel.")) - (wg-dbind (id serial-objects serial-links result) pickel - (gethash - result - (wg-pickel-deserialize-links - serial-links - (wg-pickel-deserialize-objects serial-objects))))) - -(defun wg-unpickel-file (file) - "`unpickel' an object directly from FILE." - (wg-unpickel (wg-lisp-object-from-file file))) - -(defun wg-unpickel-string (str) - "`unpickel' and object directly from STR." - (wg-unpickel (read str))) - -(provide 'workgroups-pickel) -;;; workgroups-pickel.el ends here diff --git a/src/workgroups-session.el b/src/workgroups-session.el deleted file mode 100644 index 68c289a6d62dfb673959893ebe0305726d6e61c3..0000000000000000000000000000000000000000 --- a/src/workgroups-session.el +++ /dev/null @@ -1,349 +0,0 @@ -;;; workgroups-session.el --- Top level structure "session" -;;; Commentary: -;; Main function are: `wg-write-session-file' -;;; Code: - -(require 'workgroups-variables) -(require 'workgroups-workgroup) - - - -;; -;; Variables -;; - -(defcustom wg-session-load-on-start (not (daemonp)) - "Load a session file on Workgroups start. -But only if Emacs is not started as daemon. You don't want any -promts while Emacs is being started as daemon." - :type 'boolean - :group 'workgroups) -(defvaralias 'wg-use-default-session-file 'wg-session-load-on-start) - -(defcustom wg-session-file - "~/.emacs_workgroups" - "Default filename to be used to save workgroups." - :type 'file - :group 'workgroups) -(defvaralias 'wg-default-session-file 'wg-session-file) - -(defvar wg-deactivation-list nil - "A stack of workgroups that are currently being switched away from. -Used to avoid associating the old workgroup's buffers with the -new workgroup during a switch.") - -(defvar wg-incorrectly-restored-bufs nil - "FIXME: docstring this.") -;; TODO: check it on switching WG - -(defvar wg-record-incorrectly-restored-bufs nil - "FIXME: docstring this.") - -(defcustom wg-emacs-exit-save-behavior 'save - "Determines save behavior on Emacs exit. -Possible values: - -`ask' Ask the user whether to save if there are unsaved changes - -`save' Call `wg-save-session' when there are unsaved changes - -Anything else Exit Emacs without saving changes" - :type 'symbol - :group 'workgroups) - -(defcustom wg-workgroups-mode-exit-save-behavior 'save - "Determines save behavior on `workgroups-mode' exit. -Possible values: - -`ask' Ask the user whether to saveif there are unsaved changes - -`save' Call `wg-save-session' when there are unsaved changes - -Anything else Exit `workgroups-mode' without saving changes" - :type 'symbol - :group 'workgroups) - - - -;; -;; Function -;; - -(defun wg-session-uids-consistent-p () - "Return t if there are no duplicate bufs or buf uids in the wrong places. -nil otherwise." - (and (not (wg-dups-p (wg-buf-list) :key 'wg-buf-uid :test 'string=)) - (not (wg-dups-p (wg-workgroup-list) :key 'wg-workgroup-uid :test 'string=)))) - - -(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))) - )) - (if wg-control-frames - (wg-restore-frames)) - (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)"))))) -(defalias 'wg-open-session 'wg-find-session-file) - -(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 (read-file-name "Save session as: ") - (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) - (if wg-control-frames - (wg-save-frames)) - (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))) -(defalias 'wg-save-session-as 'wg-write-session-file) - -(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-session-load-on-start wg-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) - (read-file-name "Save session as: "))))) - -(defun wg-reset-internal (&optional session) - "Reset Workgroups, setting `wg-current-session' to SESSION. -Resets all frame parameters, buffer-local vars, current -Workgroups session object, etc. SESSION nil defaults to a new, -blank session object." - (mapc 'wg-reset-frame (frame-list)) - (mapc 'wg-reset-buffer (buffer-list)) - (setq wg-wconfig-kill-ring nil) - (setq wg-current-session (or session (wg-make-session)))) - - - -(defun wg-session-all-buf-uids (&optional session) - "Return a new list of all unique buf uids in SESSION. -SESSION nil defaults to `wg-current-session'." - (cl-reduce 'wg-string-list-union - (wg-session-workgroup-list (or session (wg-current-session))) - :key 'wg-workgroup-all-buf-uids)) - -(defun wg-buffer-list-all-uids (&optional buffer-list) - "Return a list of the uids of all buffers in BUFFER-LIST in -which `wg-buffer-uid' is locally bound. -BUFFER-LIST nil defaults to `buffer-list'." - (delq nil (mapcar 'wg-buffer-uid (or buffer-list (buffer-list))))) - -(defun wg-all-buf-uids (&optional session buffer-list) - "Return the union of `wg-session-all-buf-uids' and `wg-buffer-list-all-uids'." - (cl-union (wg-session-all-buf-uids session) - (wg-buffer-list-all-uids buffer-list) - :test 'string=)) - -(defun wg-gc-bufs () - "gc bufs from `wg-buf-list' that are no longer needed." - (let ((all-buf-uids (wg-all-buf-uids))) - (wg-asetf (wg-buf-list) - (cl-remove-if-not (lambda (uid) (member uid all-buf-uids)) it - :key 'wg-buf-uid)))) - - - -;; FIXME: Duplicate buf names probably shouldn't be allowed. An unrelated error -;; causes two *scratch* buffers to be present, triggering the "uids don't match" -;; error. Write something to remove bufs with duplicate names. - - -(defun wg-perform-session-maintenance () - "Perform various maintenance operations on the current Workgroups session." - (wg-update-current-workgroup-working-wconfig) - - ;; Update every workgroup's base wconfig with `wg-workgroup-update-base-wconfig' - (dolist (workgroup (wg-workgroup-list)) - (wg-awhen (wg-workgroup-selected-frame-wconfig workgroup) - (setf (wg-workgroup-base-wconfig workgroup) it - (wg-workgroup-selected-frame-wconfig workgroup) nil))) - - (wg-gc-bufs) - (wg-gc-buf-uids) - (wg-update-buf-list)) - - -;; session consistency testing - - -(defun wg-modified-p () - "Return t when the current session or any of its workgroups are modified." - (or (wg-session-modified (wg-current-session)) - (cl-some 'wg-workgroup-modified (wg-workgroup-list)))) - -(defun wg-mark-everything-unmodified () - "Mark the session and all workgroups as unmodified." - (setf (wg-session-modified (wg-current-session)) nil) - (dolist (workgroup (wg-workgroup-list)) - (setf (wg-workgroup-modified workgroup) nil))) - - -(defun wg-workgroup-names (&optional noerror) - "Return a list of workgroup names or scream unless NOERROR." - (mapcar 'wg-workgroup-name (wg-workgroup-list-or-error noerror))) - - -;;; session parameters - -(defun wg-session-parameter (session parameter &optional default) - "Return SESSION's value for PARAMETER. -If PARAMETER is not found, return DEFAULT which defaults to nil. -SESSION nil defaults to the current session." - (wg-aget (wg-session-parameters (or session (wg-current-session))) - parameter default)) - -(defun wg-set-session-parameter (session parameter value) - "Set SESSION's value of PARAMETER to VALUE. -SESSION nil means use the current session. -Return value." - (let ((session (or session (wg-current-session)))) - (wg-set-parameter (wg-session-parameters session) parameter value) - (setf (wg-session-modified session) t) - value)) - -(defun wg-remove-session-parameter (session parameter) - "Remove parameter PARAMETER from SESSION's parameters." - (let ((session (or session (wg-current-session)))) - (wg-asetf (wg-session-parameters session) (wg-aremove it parameter)) - (setf (wg-session-modified session) t))) - -(defun wg-session-local-value (variable &optional session) - "Return the value of VARIABLE in SESSION. -SESSION nil defaults to the current session. If VARIABLE does -not have a session-local binding in SESSION, the value is -resolved by Emacs." - (let* ((undefined (cl-gensym)) - (value (wg-session-parameter session variable undefined))) - (if (not (eq value undefined)) value - (symbol-value variable)))) - - -(defun wg-reset-frame (frame) - "Reset Workgroups' frame-parameters in FRAME to nil." - (set-frame-parameter frame 'wg-workgroup-state-table nil) - (set-frame-parameter frame 'wg-current-workgroup-uid nil) - (set-frame-parameter frame 'wg-previous-workgroup-uid nil)) - - - -(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-save-frames () - "Save opened frames as a session parameter. -Exclude `selected-frame' and daemon one (if any). -http://stackoverflow.com/questions/21151992/why-emacs-as-daemon-gives-1-more-frame-than-is-opened" - (interactive) - (let ((fl (frame-list))) - (mapc (lambda (frame) - (if (string-equal "initial_terminal" (terminal-name frame)) - (delete frame fl))) fl) - (setq fl (delete (selected-frame) fl)) - (if (wg-current-session t) - (wg-set-session-parameter (wg-current-session t) - 'frame-list - (mapcar 'wg-frame-to-wconfig fl))))) - - -(defun wg-reload-session () - "Reload current workgroups session." - (interactive) - (let ((file (or (wg-determine-session-save-file-name) - wg-session-file))) - (when (file-exists-p file) - (condition-case err - (wg-open-session wg-session-file) - (progn - (wg-create-first-wg) - (error (message "Error finding session-file: %s" err))))) - (wg-create-first-wg))) - -(defun wg-save-session-on-emacs-exit () - "Call `wg-save-session-on-exit' with `wg-emacs-exit-save-behavior'. -Added to `kill-emacs-query-functions'." - (wg-save-session-on-exit wg-emacs-exit-save-behavior) t) - -(defun wg-save-session-on-workgroups-mode-exit () - "Call `wg-save-session-on-exit' with `wg-workgroups-mode-exit-save-behavior'. -Called when `workgroups-mode' is turned off." - (wg-save-session-on-exit wg-workgroups-mode-exit-save-behavior) t) - - -(defun wg-pickel-all-session-parameters (session) - "Return a copy of SESSION after pickeling its -parameters and the parameters of all its workgroups." - (let ((copy (wg-copy-session session))) - (when (wg-session-parameters copy) - (wg-asetf (wg-session-parameters copy) (wg-pickel it))) - (wg-asetf (wg-session-workgroup-list copy) - (cl-mapcar 'wg-pickel-workgroup-parameters it)) - copy)) - -(defun wg-unpickel-session-parameters (session) - "Return a copy of SESSION after unpickeling its -parameters and the parameters of all its workgroups." - (let ((copy (wg-copy-session session))) - (when (wg-session-parameters copy) - (wg-asetf (wg-session-parameters copy) (wg-unpickel it))) - (wg-asetf (wg-session-workgroup-list copy) - (cl-mapcar 'wg-unpickel-workgroup-parameters it)) - copy)) - - -(provide 'workgroups-session) -;;; workgroups-session.el ends here diff --git a/src/workgroups-specialbufs.el b/src/workgroups-specialbufs.el deleted file mode 100644 index e836efa80ffcf3ffec2c8c0f8a8a0f425924c4d7..0000000000000000000000000000000000000000 --- a/src/workgroups-specialbufs.el +++ /dev/null @@ -1,528 +0,0 @@ -;;; workgroups-specialbufs --- special buffers serialization -;;; Commentary: -;; -;; TODO: -;; 1. Add more special buffers support (that you use) -;; 2. Improve existing -;; -;;; Code: - -(require 'workgroups-variables) - -(defcustom wg-special-buffer-serdes-functions - '(wg-serialize-comint-buffer - wg-serialize-speedbar-buffer) - "Functions providing serialization/deserialization for complex buffers. - -Use `wg-support' macro and this variable will be filled -automatically. - -An entry should be either a function symbol or a lambda, and should -accept a single Emacs buffer object as an argument. - -When a buffer is to be serialized, it is passed to each of these -functions in turn until one returns non-nil, or the list ends. A -return value of nil indicates that the function can't handle -buffers of that type. A non-nil return value indicates that it -can. The first non-nil return value becomes the buffer's special -serialization data. The return value should be a cons, with a -deserialization function (a function symbol or a lambda) as the car, -and any other serialization data as the cdr. - -When it comes time to deserialize the buffer, the deserialization -function (the car of the cons mentioned above) is passed the -wg-buf object, from which it should restore the buffer. The -special serialization data itself can be accessed -with (cdr (wg-buf-special-data )). The deserialization -function must return the restored Emacs buffer object. - -See the definitions of the functions in this list for examples of -how to write your own." - :type 'alist - :group 'workgroups) - -;; Dired -(wg-support 'dired-mode 'dired - `((deserialize . ,(lambda (buffer vars) - (if (or wg-restore-remote-buffers - (not (file-remote-p default-directory))) - ;; TODO: try to restore parent dir if not exist - (if (file-directory-p default-directory) - (dired default-directory))))))) - -;; Info-mode -(wg-support 'Info-mode 'info - `((save . (Info-current-file Info-current-node)) - (deserialize . ,(lambda (buffer vars) - (wg-aif vars - (if (fboundp 'Info-find-node) - (apply #'Info-find-node it)) - (info)))))) - -;; help-mode -;; Bug: https://github.com/pashinin/workgroups2/issues/29 -(if nil -(wg-support 'help-mode 'help-mode - `((save . (help-xref-stack-item help-xref-stack help-xref-forward-stack)) - (deserialize . ,(lambda (buffer vars) - (wg-dbind (item stack forward-stack) vars - (condition-case err - (apply (car item) (cdr item)) - (error (message "%s" err))) - (wg-awhen (get-buffer "*Help*") - (set-buffer it) - (wg-when-boundp (help-xref-stack help-xref-forward-stack) - (setq help-xref-stack stack - help-xref-forward-stack forward-stack)))))))) -) - -;; ielm -(wg-support 'inferior-emacs-lisp-mode 'ielm - `((deserialize . ,(lambda (buffer vars) (ielm))))) - -;; Magit status -(wg-support 'magit-status-mode 'magit - `((deserialize . ,(lambda (buffer vars) - (when (file-directory-p default-directory) - (magit-status default-directory)))))) - -;; Shell -(wg-support 'shell-mode 'shell - `((deserialize . ,(lambda (buffer vars) - (shell (wg-buf-name buffer)))))) - -;; org-agenda buffer -(defun wg-get-org-agenda-view-commands () - "Return commands to restore the state of Agenda buffer. -Can be restored using \"(eval commands)\"." - (interactive) - (when (boundp 'org-agenda-buffer-name) - (if (get-buffer org-agenda-buffer-name) - (with-current-buffer org-agenda-buffer-name - (let* ((p (or (and (looking-at "\\'") (1- (point))) (point))) - (series-redo-cmd (get-text-property p 'org-series-redo-cmd))) - (if series-redo-cmd - (get-text-property p 'org-series-redo-cmd) - (get-text-property p 'org-redo-cmd))))))) - -(defun wg-run-agenda-cmd (f) - "Run commands F in Agenda buffer. -You can get these commands using `wg-get-org-agenda-view-commands'." - (when (and (boundp 'org-agenda-buffer-name) - (fboundp 'org-current-line) - (fboundp 'org-goto-line)) - (if (get-buffer org-agenda-buffer-name) - (save-window-excursion - (with-current-buffer org-agenda-buffer-name - (let* ((line (org-current-line))) - (if f (eval f)) - (org-goto-line line))))))) - -(wg-support 'org-agenda-mode 'org-agenda - '((serialize . (lambda (buffer) - (wg-get-org-agenda-view-commands))) - (deserialize . (lambda (buffer vars) - (org-agenda-list) - (wg-awhen (get-buffer org-agenda-buffer-name) - (set-buffer it) - (wg-run-agenda-cmd vars)) - )))) - -;; eshell -(wg-support 'eshell-mode 'esh-mode - '((deserialize . (lambda (buffer vars) - (prog1 (eshell t) - (rename-buffer (wg-buf-name buffer) t)))))) - -;; term-mode -;; -;; This should work for `ansi-term's, too, as there doesn't seem to -;; be any difference between the two except how the name of the -;; buffer is generated. -;; -(wg-support 'term-mode 'term - `((serialize . ,(lambda (buffer) - (if (get-buffer-process buffer) - (wg-last1 (process-command (get-buffer-process buffer))) - "/bin/bash"))) - (deserialize . ,(lambda (buffer vars) - (cl-labels ((term-window-width () 80) - (window-height () 24)) - (prog1 (term vars) - (rename-buffer (wg-buf-name buffer) t))))))) - -;; Python -(wg-support 'inferior-python-mode 'python - `((save . (python-shell-interpreter python-shell-interpreter-args)) - (deserialize . ,(lambda (buffer vars) - (wg-dbind (pythoncmd pythonargs) vars - (save-window-excursion - (run-python (concat pythoncmd " " pythonargs))) - (wg-awhen (get-buffer (process-buffer (python-shell-get-or-create-process))) - (set-buffer it) - (switch-to-buffer (process-buffer (python-shell-get-or-create-process))) - (goto-char (point-max))) - ))))) - -;; Sage shell -(wg-support 'inferior-sage-mode 'sage-mode - `((deserialize . ,(lambda (buffer vars) - (save-window-excursion - (if (boundp' sage-command) - (run-sage t sage-command t))) - (if (boundp 'sage-buffer) - (wg-awhen (and - sage-buffer) - (set-buffer it) - (switch-to-buffer sage-buffer) - (goto-char (point-max)))))))) - -;; inferior-ess-mode (ess-inf.el) -;; R shell, M-x R -(wg-support 'inferior-ess-mode 'ess-inf - `((save . (inferior-ess-program)) - (deserialize . ,(lambda (buffer vars) - (wg-dbind (cmd) vars - (let ((ess-ask-about-transfile nil) - (ess-ask-for-ess-directory nil) - (ess-history-file nil)) - (R))))))) - -;; inferior-octave-mode -(wg-support 'inferior-octave-mode 'octave - `((deserialize . ,(lambda (buffer vars) - (prog1 (run-octave) - (rename-buffer (wg-buf-name buffer) t)))))) - -;; Prolog shell -(wg-support 'prolog-inferior-mode 'prolog - `((deserialize . ,(lambda (buffer vars) - (save-window-excursion - (run-prolog nil)) - (switch-to-buffer "*prolog*") - (goto-char (point-max)))))) - -;; ensime-inf -(wg-support 'ensime-inf-mode 'ensime - `((deserialize . ,(lambda (buffer vars) - (save-window-excursion - (ensime-inf-switch)) - (when (boundp 'ensime-inf-buffer-name) - (switch-to-buffer ensime-inf-buffer-name) - (goto-char (point-max))))))) - -;; compilation-mode -;; -;; I think it's not a good idea to compile a program just to switch -;; workgroups. So just restoring a buffer name. -(wg-support 'compilation-mode 'compile - `((serialize . ,(lambda (buffer) - (if (boundp' compilation-arguments) compilation-arguments))) - (deserialize . ,(lambda (buffer vars) - (save-window-excursion - (get-buffer-create (wg-buf-name buffer))) - (with-current-buffer (wg-buf-name buffer) - (when (boundp' compilation-arguments) - (make-local-variable 'compilation-arguments) - (setq compilation-arguments vars))) - (switch-to-buffer (wg-buf-name buffer)) - (goto-char (point-max)))))) - -;; grep-mode -;; see grep.el - `compilation-start' - it is just a compilation buffer -;; local variables: -;; `compilation-arguments' == (cmd mode nil nil) -(wg-support 'grep-mode 'grep - `((serialize . ,(lambda (buffer) - (if (boundp' compilation-arguments) compilation-arguments))) - (deserialize . ,(lambda (buffer vars) - (compilation-start (car vars) (nth 1 vars)) - (switch-to-buffer "*grep*"))))) - - -;; speedbar-mode -(defun wg-deserialize-speedbar-buffer (buf) - "Deserialize speedbar-buffer BUF." - (when (and (require 'speedbar nil 'noerror) - (require 'dframe nil 'noerror)) - (wg-dbind (this-function args) (wg-buf-special-data buf) - (let ((default-directory (car args)) - bufname) - (if (boundp 'sr-speedbar-buffer-name) - (setq bufname sr-speedbar-buffer-name) - (setq bufname "*SPEEDBAR*")) - (when (and (fboundp 'speedbar-mode) - (fboundp 'speedbar-reconfigure-keymaps) - (fboundp 'speedbar-update-contents) - (fboundp 'speedbar-set-timer)) - (with-no-warnings - (setq speedbar-buffer (get-buffer-create bufname)) - (setq speedbar-frame (selected-frame) - dframe-attached-frame (selected-frame) - speedbar-select-frame-method 'attached - speedbar-verbosity-level 0 - speedbar-last-selected-file nil) - (set-buffer speedbar-buffer) - (speedbar-mode) - (speedbar-reconfigure-keymaps) - (speedbar-update-contents) - (speedbar-set-timer 1) - (set-window-dedicated-p (get-buffer-window bufname) t) - (switch-to-buffer bufname))) - (current-buffer) - )))) - - -(defun wg-serialize-speedbar-buffer (buffer) - "Serialize speedbar BUFFER." - (with-current-buffer buffer - (if (fboundp 'speedbar-mode) - (when (eq major-mode 'speedbar-mode) - (list 'wg-deserialize-speedbar-buffer - (list default-directory) - ))))) - - -(defun wg-deserialize-slime-buffer (buf) - "Deserialize `slime' buffer BUF." - (when (require 'slime nil 'noerror) - (wg-dbind (this-function args) (wg-buf-special-data buf) - (let ((default-directory (car args)) - (arguments (nth 1 args))) - (when (and (fboundp 'slime-start*) - (fboundp 'slime-process)) - (save-window-excursion - (slime-start* arguments)) - (switch-to-buffer (process-buffer (slime-process))) - (current-buffer)))))) - -;; `comint-mode' (general mode for all shells) -;; -;; It may have different shells. So we need to determine which shell is -;; now in `comint-mode' and how to restore it. -;; -;; Just executing `comint-exec' may be not enough because we can miss -;; some hooks or any other stuff that is executed when you run a -;; specific shell. -(defun wg-serialize-comint-buffer (buffer) - "Serialize comint BUFFER." - (with-current-buffer buffer - (if (fboundp 'comint-mode) - (when (eq major-mode 'comint-mode) - ;; `slime-inferior-lisp-args' var is used when in `slime' - (when (and (boundp 'slime-inferior-lisp-args) - slime-inferior-lisp-args) - (list 'wg-deserialize-slime-buffer - (list default-directory slime-inferior-lisp-args) - )))))) - -;; inf-mongo -;; https://github.com/tobiassvn/inf-mongo -;; `mongo-command' - command used to start inferior mongo -(wg-support 'inf-mongo-mode 'inf-mongo - `((serialize . ,(lambda (buffer) - (if (boundp 'inf-mongo-command) inf-mongo-command))) - (deserialize . ,(lambda (buffer vars) - (save-window-excursion - (when (fboundp 'inf-mongo) - (inf-mongo vars))) - (when (get-buffer "*mongo*") - (switch-to-buffer "*mongo*") - (goto-char (point-max))))))) - -(defun wg-temporarily-rename-buffer-if-exists (buffer) - "Rename BUFFER if it exists." - (when (get-buffer buffer) - (with-current-buffer buffer - (rename-buffer "*wg--temp-buffer*" t)))) - -;; SML shell -;; Functions to serialize deserialize inferior sml buffer -;; `inf-sml-program' is the program run as inferior sml, is the -;; `inf-sml-args' are the extra parameters passed, `inf-sml-host' -;; is the host on which sml was running when serialized -(wg-support 'inferior-sml-mode 'sml-mode - `((serialize . ,(lambda (buffer) - (list (if (boundp 'sml-program-name) sml-program-name) - (if (boundp 'sml-default-arg) sml-default-arg) - (if (boundp 'sml-host-name) sml-host-name)))) - (deserialize . ,(lambda (buffer vars) - (wg-dbind (program args host) vars - (save-window-excursion - ;; If a inf-sml buffer already exists rename it temporarily - ;; otherwise `run-sml' will simply switch to the existing - ;; buffer, however we want to create a separate buffer with - ;; the serialized name - (let* ((inf-sml-buffer-name (concat "*" - (file-name-nondirectory program) - "*")) - (existing-sml-buf (wg-temporarily-rename-buffer-if-exists - inf-sml-buffer-name))) - (with-current-buffer (run-sml program args host) - ;; Rename the buffer - (rename-buffer (wg-buf-name buffer) t) - - ;; Now we can re-rename the previously renamed buffer - (when existing-sml-buf - (with-current-buffer existing-sml-buf - (rename-buffer inf-sml-buffer-name t)))))) - (switch-to-buffer (wg-buf-name buffer)) - (goto-char (point-max))))))) - -;; Geiser repls -;; http://www.nongnu.org/geiser/ -(wg-support 'geiser-repl-mode 'geiser - `((save . (geiser-impl--implementation)) - (deserialize . ,(lambda (buffer vars) - (save-window-excursion - (when (fboundp 'run-geiser) - (wg-dbind (impl) vars - (run-geiser impl) - (goto-char (point-max))))) - (switch-to-buffer (wg-buf-name buffer)))))) - -;; w3m-mode -(wg-support 'w3m-mode 'w3m - `((save . (w3m-current-url)) - (deserialize . ,(lambda (buffer vars) - (wg-dbind (url) vars - (w3m-goto-url url)))))) - -;; notmuch -(wg-support 'notmuch-hello-mode 'notmuch - `((deserialize . ,(lambda (buffer vars) (notmuch))))) - -;; Wanderlust modes: -;; WL - folders -;;(defun wg-deserialize-wl-folders-buffer (buf) -;; "" -;; (if (fboundp 'wl) -;; (wg-dbind (this-function) (wg-buf-special-data buf) -;; ;;(when (not (eq major-mode 'wl-folder-mode)) -;; (wl) -;; (goto-char (point-max)) -;; (current-buffer) -;; ))) -;; -;;(defun wg-serialize-wl-folders-buffer (buffer) -;; "" -;; (if (fboundp 'wl) -;; (with-current-buffer buffer -;; (when (eq major-mode 'wl-folder-mode) -;; (list 'wg-deserialize-wl-folders-buffer -;; ))))) - -;; WL - summary mode (list of mails) -;;(defun wg-deserialize-wl-summary-buffer (buf) -;; "" -;; (interactive) -;; (if (fboundp 'wl) -;; (wg-dbind (this-function param-list) (wg-buf-special-data buf) -;; (when (not (eq major-mode 'wl-summary-mode)) -;; (let ((fld-name (car param-list))) -;; ;;(switch-to-buffer "*scratch*") -;; ;;(wl) -;; ;;(wl-folder-jump-folder fld-name) -;; ;;(message fld-name) -;; ;;(goto-char (point-max)) -;; ;;(insert fld-name) -;; (current-buffer) -;; ))))) -;; -;;(defun wg-serialize-wl-summary-buffer (buffer) -;; "" -;; (if (fboundp 'wl) -;; (with-current-buffer buffer -;; (when (eq major-mode 'wl-summary-mode) -;; (list 'wg-deserialize-wl-summary-buffer -;; (wg-take-until-unreadable (list wl-summary-buffer-folder-name)) -;; ))))) -;; -;; -;;;; mime-view-mode -;; -;;(defun wg-deserialize-mime-view-buffer (buf) -;; "" -;; (wg-dbind (this-function) (wg-buf-special-data buf) -;; (when (not (eq major-mode 'mime-view-mode)) -;; ;;(wl-summary-enter-handler 3570) ; only in wl-summary-mode -;; ;;(wl-summary-enter-handler) ; only in wl-summary-mode -;; (current-buffer) -;; ))) -;; -;;(defun wg-serialize-mime-view-buffer (buffer) -;; "" -;; (with-current-buffer buffer -;; (when (eq major-mode 'mime-view-mode) -;; (list 'wg-deserialize-mime-view-buffer -;; )))) - - -;; emms-playlist-mode -;; -;; Help me on this one: -;; 1. How to start emms without any user interaction? -;; -;;(defun wg-deserialize-emms-buffer (buf) -;; "Deserialize emms-playlist buffer BUF." -;; (when (require 'emms-setup nil 'noerror) -;; (require 'emms-player-mplayer) -;; (emms-standard) -;; (emms-default-players) -;; (if (fboundp 'emms-playlist-mode) -;; (wg-dbind (this-function args) (wg-buf-special-data buf) -;; (let ((default-directory (car args))) -;; (save-window-excursion -;; ;;(emms) -;; (if (or (null emms-playlist-buffer) -;; (not (buffer-live-p emms-playlist-buffer))) -;; ;;(call-interactively 'emms-add-file) -;; (emms-source-directory "/usr/data/disk_3/Music/SORT/") -;; )) -;; ;; (emms) -;; ;;(with-current-buffer emms-playlist-buffer-name -;; ;;(emms-source-playlist-directory-tree "/usr/data/disk_3/Music/SORT/") -;; ;;(emms-source-directory "/usr/data/disk_3/Music/SORT") -;; ;;(switch-to-buffer emms-playlist-buffer-name) -;; (emms-playlist-mode-go) -;; (current-buffer) -;; ))))) -;; -;;(defun wg-serialize-emms-buffer (buffer) -;; "Serialize emms BUFFER." -;; (with-current-buffer buffer -;; (if (fboundp 'emms-playlist-mode) -;; (when (eq major-mode 'emms-playlist-mode) -;; (list 'wg-deserialize-emms-buffer -;; (wg-take-until-unreadable (list default-directory)) -;; ))))) - - -;;; buffer-local variable serdes - -(defun wg-serialize-buffer-mark-ring () - "Return a new list of the positions of the marks in `mark-ring'." - (mapcar 'marker-position mark-ring)) - -(defun wg-deserialize-buffer-mark-ring (positions) - "Set `mark-ring' to a new list of markers created from POSITIONS." - (setq mark-ring - (mapcar (lambda (pos) (set-marker (make-marker) pos)) - positions))) - -(defun wg-deserialize-buffer-major-mode (major-mode-symbol) - "Conditionally retore MAJOR-MODE-SYMBOL in `current-buffer'." - (and (fboundp major-mode-symbol) - (not (eq major-mode-symbol major-mode)) - (funcall major-mode-symbol))) - -(defun wg-deserialize-buffer-local-variables (buf) - "Restore BUF's buffer local variables in `current-buffer'." - (cl-loop for ((var . val) . rest) on (wg-buf-local-vars buf) - do (wg-awhen (assq var wg-buffer-local-variables-alist) - (wg-dbind (var ser des) it - (if des (funcall des val) - (set var val)))))) - -(provide 'workgroups-specialbufs) -;;; workgroups-specialbufs.el ends here diff --git a/src/workgroups-structs.el b/src/workgroups-structs.el deleted file mode 100644 index 319e62e5d3da6dbdd92b468a318d09a4db444b2d..0000000000000000000000000000000000000000 --- a/src/workgroups-structs.el +++ /dev/null @@ -1,77 +0,0 @@ -;;; workgroups-structs.el --- Define Elisp objects -;;; Commentary: -;;; Code: -(require 'workgroups-utils-basic) - -(wg-defstruct wg session - (uid (wg-generate-uid)) - (name) - (modified) - (parameters) - (file-name) - (version wg-version) - (workgroup-list) - (buf-list)) - -(wg-defstruct wg workgroup - (uid (wg-generate-uid)) - (name) - (modified) - (parameters) - (base-wconfig) - (selected-frame-wconfig) - (saved-wconfigs) - (strong-buf-uids) - (weak-buf-uids)) - -(wg-defstruct wg workgroup-state - (undo-pointer) - (undo-list)) - -(wg-defstruct wg wconfig - (uid (wg-generate-uid)) - (name) - (parameters) - (left) - (top) - (width) - (height) - (vertical-scroll-bars) - (scroll-bar-width) - (wtree)) - -(wg-defstruct wg wtree - (uid) - (dir) - (edges) - (wlist)) - -(wg-defstruct wg win - (uid) - (parameters) - (edges) - (point) - (start) - (hscroll) - (dedicated) - (selected) - (minibuffer-scroll) - (buf-uid)) - -(wg-defstruct wg buf - (uid (wg-generate-uid)) - (name) - (file-name) - (point) - (mark) - (local-vars) - (special-data) - ;; This may be used later: - (gc)) - -(defmacro wg-workgroup-list () - "Setf'able `wg-current-session' modified slot accessor." - `(wg-session-workgroup-list (wg-current-session))) - -(provide 'workgroups-structs) -;;; workgroups-structs.el ends here diff --git a/src/workgroups-utils-basic.el b/src/workgroups-utils-basic.el deleted file mode 100644 index 809d65c045ed1282e52ee0753459deec19cea470..0000000000000000000000000000000000000000 --- a/src/workgroups-utils-basic.el +++ /dev/null @@ -1,570 +0,0 @@ -;;; workgroups-utils.el --- Utilities used by Workgroups -;;; Commentary: -;; -;; A bunch of general purpose-ish utilities used by Workgroups. -;; -;;; Code: - -;;; utils used in macros - -(require 'cl-lib) -(require 'workgroups-faces) - -(defmacro wg-with-gensyms (syms &rest body) - "Bind all symbols in SYMS to `gensym's, and eval BODY." - (declare (indent 1)) - `(let (,@(mapcar (lambda (sym) `(,sym (cl-gensym))) syms)) ,@body)) - -(defmacro wg-dbind (args expr &rest body) - "Bind the variables in ARGS to the result of EXPR and execute BODY. -Abbreviation of `destructuring-bind'." - (declare (indent 2)) - `(cl-destructuring-bind ,args ,expr ,@body)) - -(defun wg-partition (list &optional n step) - "Take LIST, return a list of N length sublists, offset by STEP. -N defaults to 2, and STEP defaults to N. -Iterative to prevent stack overflow." - (let* ((n (or n 2)) (step (or step n)) acc) - (while list - (push (wg-take list n) acc) - (setq list (nthcdr step list))) - (nreverse acc))) - - - -;;; bindings - -(defmacro wg-if-let (cond-form then &rest else) - "Bind VAR to the return value of COND. If VAR is non-nil, do THEN. -Else do ELSE... - -\(fn ((VAR COND) THEN ELSE...)" - (declare (indent 2)) - `(let (,cond-form) - (if ,(car cond-form) ,then ,@else))) - -(defmacro wg-when-let (binds &rest body) - "Like `let*' but when all BINDS are non-nil - eval BODY." - (declare (indent 1)) - (wg-dbind (bind . binds) binds - (when (consp bind) - `(let (,bind) - (when ,(car bind) - ,(if (not binds) `(progn ,@body) - `(wg-when-let ,binds ,@body))))))) - -(defmacro wg-when-boundp (symbols &rest body) - "When all SYMBOLS are bound, `eval' BODY." - (declare (indent 1)) - `(when (and ,@(mapcar (lambda (sym) `(boundp ',sym)) symbols)) - ,@body)) - - - -;;; do-style wrappers - -(defmacro wg-docar (spec &rest body) - "do-style wrapper for `mapcar'. - -\(fn (VAR LIST) BODY...)" - (declare (indent 1)) - `(mapcar (lambda (,(car spec)) ,@body) ,(cadr spec))) - -(defmacro wg-dohash (spec &rest body) - "do-style wrapper for `maphash'. - -\(fn (KEY VALUE TABLE [RESULT]) BODY...)" - (declare (indent 1)) - (wg-dbind (key val table &optional result) spec - `(progn (maphash (lambda (,key ,val) ,@body) ,table) ,result))) - -(defmacro wg-doconcat (spec &rest body) - "do-style wrapper for `mapconcat'. - -\(fn (VAR SEQ [SEPARATOR]) BODY...)" - (declare (indent 1)) - (wg-dbind (elt seq &optional sep) spec - `(mapconcat (lambda (,elt) ,@body) ,seq (or ,sep "")))) - - - -;;; anaphora - -(defmacro wg-aif (test then &rest else) - "Anaphoric `if'." - (declare (indent 2)) - `(let ((it ,test)) (if it ,then ,@else))) - -(defmacro wg-awhen (test &rest body) - "Anaphoric `when'." - (declare (indent 1)) - `(wg-aif ,test (progn ,@body))) - -(defmacro wg-asetf (&rest places-and-values) - "Anaphoric `setf'." - `(progn ,@(mapcar (lambda (pv) `(let ((it ,(car pv))) (setf ,@pv))) - (wg-partition places-and-values 2)))) - - - -;;; other control structures - -(defmacro wg-destructuring-dolist (spec &rest body) - "Loop over a list. -Evaluate BODY, destructuring LIST into SPEC, then evaluate RESULT -to get a return value, defaulting to nil. The only hitch is that -spec must end in dotted style, collecting the rest of the list -into a var, like so: (a (b c) . rest) - -\(fn (SPEC LIST [RESULT]) BODY...)" - (declare (indent 1)) - (wg-dbind (loopspec list &optional result) spec - (let ((rest (cdr (last loopspec)))) - (wg-with-gensyms (list-sym) - `(let ((,list-sym ,list)) - (while ,list-sym - (wg-dbind ,loopspec ,list-sym - ,@body - (setq ,list-sym ,rest))) - ,result))))) - - -;;; numbers - -(defun wg-step-to (n m step) - "Increment or decrement N toward M by STEP. -Return M when the difference between N and M is less than STEP." - (cond ((= n m) n) - ((< n m) (min (+ n step) m)) - ((> n m) (max (- n step) m)))) - -(defun wg-within (num lo hi &optional hi-inclusive) - "Return t when NUM is within bounds LO and HI. -HI-INCLUSIVE non-nil means the HI bound is inclusive." - (and (>= num lo) (if hi-inclusive (<= num hi) (< num hi)))) - -(defun wg-int-to-b36-one-digit (i) - "Return a character in 0..9 or A..Z from I, and integer 0<=I<32. -Cribbed from `org-id-int-to-b36-one-digit'." - (cond ((not (wg-within i 0 36)) - (error "%s out of range" i)) - ((< i 10) (+ ?0 i)) - ((< i 36) (+ ?A i -10)))) - -(defun wg-b36-to-int-one-digit (i) - "Turn a character 0..9, A..Z, a..z into a number 0..61. -The input I may be a character, or a single-letter string. -Cribbed from `org-id-b36-to-int-one-digit'." - (and (stringp i) (setq i (string-to-char i))) - (cond ((and (>= i ?0) (<= i ?9)) (- i ?0)) - ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10)) - (t (error "Invalid b36 character")))) - -(defun wg-int-to-b36 (i &optional length) - "Return a base 36 string from I." - (let ((base 36) b36) - (cl-labels ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36) - (setq i (/ i base)))) - (add-digit) - (while (> i 0) (add-digit)) - (setq b36 (cl-map 'string 'identity b36)) - (if (not length) b36 - (concat (make-string (max 0 (- length (length b36))) ?0) b36))))) - -(defun wg-b36-to-int (str) - "Convert STR, a base-36 string, into the corresponding integer. -Cribbed from `org-id-b36-to-int'." - (let ((result 0)) - (mapc (lambda (i) - (setq result (+ (* result 36) - (wg-b36-to-int-one-digit i)))) - str) - result)) - - - -;;; lists - -(defmacro wg-removef-p (item seq-place &rest keys) - "If ITEM is a `member*' of SEQ-PLACE, remove it from SEQ-PLACE and return t. -Otherwise return nil. KEYS can be any keywords accepted by `remove*'." - `(> (length ,seq-place) - (length (setf ,seq-place (cl-remove ,item ,seq-place ,@keys))))) - -(defmacro wg-pushnew-p (item seq-place &rest keys) - "If ITEM is not a `member' of SEQ-PLACE, push it to SEQ-PLACE and return t. -Otherwise return nil. KEYS can be any keyword args accepted by `pushnew'." - `(< (length ,seq-place) - (length (cl-pushnew ,item ,seq-place ,@keys)))) - -(defun wg-last1 (list) - "Return the last element of LIST." - (car (last list))) - -(defun wg-take (list n) - "Return a list of the first N elts in LIST." - (butlast list (- (length list) n))) - -(defun wg-leave (list n) - "Return a list of the last N elts in LIST." - (nthcdr (- (length list) n) list)) - -(defun wg-rnth (n list) - "Return the Nth element of LIST, counting from the end." - (nth (- (length list) n 1) list)) - -(defun wg-take-until-fail (pred list) - "Take elements from LIST up to the first element on which PRED fails." - (let (taken) - (catch 'result - (dolist (elt list (nreverse taken)) - (if (funcall pred elt) (push elt taken) - (throw 'result (nreverse taken))))))) - -(defun wg-range (start end) - "Return a list of integers from START up to but not including END." - (let (accum) - (dotimes (i (- end start) (nreverse accum)) - (push (+ start i) accum)))) - -(defun wg-rotate-list (list &optional offset) - "Rotate LIST by OFFSET. Positive OFFSET rotates left, negative right." - (when list - (let ((split (mod (or offset 1) (length list)))) - (append (nthcdr split list) (wg-take list split))))) - -(defun wg-center-rotate-list (list) - "Rotate LIST so it's first elt is in the center. When LIST's -length is even, the first elt is left nearer the front." - (wg-rotate-list list (- (/ (1- (length list)) 2)))) - -(defun wg-insert-after (elt list index) - "Insert ELT into LIST after INDEX." - (let ((new-list (cl-copy-list list))) - (push elt (cdr (nthcdr index new-list))) - new-list)) - -(defun wg-insert-before (elt list index) - "Insert ELT into LIST before INDEX." - (if (zerop index) (cons elt list) - (wg-insert-after elt list (1- index)))) - -(defun wg-move-elt (elt list index &rest keys) - "Move ELT before INDEX in LIST. -KEYS is passed to `remove*'." - (wg-insert-before elt (apply 'cl-remove elt list keys) index)) - -(defun wg-cyclic-nth (list n) - "Return the Nth element of LIST, modded by the length of list." - (nth (mod n (length list)) list)) - -(defun wg-cyclic-offset-elt (elt list n) - "Cyclically offset ELT's position in LIST by N." - (wg-when-let ((pos (cl-position elt list))) - (wg-move-elt elt list (mod (+ n pos) (length list))))) - -(defun wg-cyclic-nth-from-elt (elt list n &rest keys) - "Return the elt in LIST N places cyclically from ELT. -If ELT is not present is LIST, return nil. -KEYS is passed to `position'." - (wg-when-let ((pos (apply 'cl-position elt list keys))) - (wg-cyclic-nth list (+ pos n)))) - -(defun wg-util-swap (elt1 elt2 list) - "Return a copy of LIST with ELT1 and ELT2 swapped. -Return nil when ELT1 and ELT2 aren't both present." - (wg-when-let ((p1 (cl-position elt1 list)) - (p2 (cl-position elt2 list))) - (wg-move-elt elt1 (wg-move-elt elt2 list p1) p2))) - -(defun wg-dups-p (list &rest keys) - "Return non-nil when LIST contains duplicate elements. - -Keywords supported: :test :key - -\(fn LIST [KEYWORD VALUE]...)" - (let ((test (or (plist-get keys :test) 'eq)) - (key (or (plist-get keys :key) 'identity))) - (cl-loop for (elt . rest) on list - for elt = (funcall key elt) - when (cl-find elt rest :test test :key key) return elt))) - -(defun wg-string-list-union (&optional list1 list2) - "Return the `union' of LIST1 and LIST2, using `string=' as the test. -This only exists to get rid of duplicate lambdas in a few reductions." - (cl-union list1 list2 :test 'string=)) - - - -;;; alists - -(defun wg-make-alist (&rest kvps) - "Return a new alist from KVPS." - (let (alist) - (while kvps - (push (cons (car kvps) (cadr kvps)) alist) - (setq kvps (cddr kvps))) - (nreverse alist))) - -(defun wg-aget (alist key &optional default) - "Return the value of KEY in ALIST. Uses `assq'. -If PARAM is not found, return DEFAULT which defaults to nil." - (wg-aif (assq key alist) (cdr it) default)) - -(defun wg-acopy (alist) - "Return a copy of ALIST's toplevel list structure." - (mapcar (lambda (kvp) (cons (car kvp) (cdr kvp))) alist)) - -(defun wg-aput (alist key value) - "Return a new alist from ALIST with KEY's value set to VALUE." - (let* ((found nil) - (new (wg-docar (kvp alist) - (if (not (eq key (car kvp))) kvp - (setq found (cons key value)))))) - (if found new (cons (cons key value) new)))) - -(defun wg-aremove (alist key) - "`remove' KEY's key-value-pair from ALIST." - (remove (assoc key alist) alist)) - - -;;; symbols and strings - -(defun wg-toggle (symbol) - "Toggle SYMBOL's truthiness." - (set symbol (not (symbol-value symbol)))) - -(defun wg-symcat (&rest symbols-and-strings) - "Return a new interned symbol by concatenating SYMBOLS-AND-STRINGS." - (intern (mapconcat (lambda (obj) (if (symbolp obj) (symbol-name obj) obj)) - symbols-and-strings ""))) - -(defun wg-make-string (times string &optional separator) - "Like `make-string', but includes a separator." - (mapconcat 'identity (make-list times string) (or separator ""))) - - - -;;; buffers - -(defun wg-get-buffer (buffer-or-name) - "Return BUFFER-OR-NAME's buffer, or error." - (or (get-buffer buffer-or-name) - (error "%S does not identify a buffer" buffer-or-name))) - -(defun wg-buffer-name (buffer-or-name) - "Return BUFFER-OR-NAME's `buffer-name', or error." - (buffer-name (wg-get-buffer buffer-or-name))) - -(defun wg-buffer-file-name (buffer-or-name) - "Return BUFFER-OR-NAME's `buffer-file-name', or error." - (buffer-file-name (wg-get-buffer buffer-or-name))) - -(defun wg-buffer-major-mode (buffer-or-name) - "Return BUFFER's major-mode." - (with-current-buffer buffer-or-name major-mode)) - -(defun wg-current-buffer-p (buffer-or-name) - "Return t if BUFFER-OR-NAME is the current buffer, nil otherwise." - (eq (wg-get-buffer buffer-or-name) (current-buffer))) - -(defmacro wg-buffer-local-setq (buffer var value) - "`setq' VAR to VALUE while BUFFER is current. -Note that this won't make VAR buffer-local if it isn't already." - `(with-current-buffer ,buffer (setq ,var ,value))) - -(defun wg-interesting-buffers () - "Return a list of only the interesting buffers in `buffer-list'." - (cl-remove-if (lambda (bname) (string-match "^ " bname)) - (buffer-list) :key 'buffer-name)) - -(defun wg-get-first-buffer-matching-regexp (regexp &optional buffer-list) - "Return the first buffer in BUFFER-LIST with a name matching REGEXP. -BUFFER-LIST should contain buffer objects and/or buffer names." - (cl-find regexp (or buffer-list (buffer-list)) - :test 'string-match :key 'wg-buffer-name)) - - - -;;; files - -(defun wg-write-sexp-to-file (sexp file) - "Write the printable representation of SEXP to FILE." - (with-temp-buffer - (let ((print-level nil) (print-length nil)) - (insert (format "%S" sexp))) - (write-file file))) - -(defun wg-read-sexp-from-file (file) - "Return a Lisp object from FILE." - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (read (current-buffer)))) -(defalias 'wg-lisp-object-from-file 'wg-read-sexp-from-file) - -(defun wg-file-under-root-path-p (root-path file-path) - "Return t when FILE-PATH is under ROOT-PATH, nil otherwise." - (string-match (concat "^" (regexp-quote (expand-file-name root-path))) - (expand-file-name file-path))) - - - -;;; frames - -(defun wg-cyclic-nth-from-frame (&optional n frame) - "Return the frame N places away from FRAME in `frame-list' cyclically. -N defaults to 1, and FRAME defaults to `selected-frame'." - (wg-cyclic-nth-from-elt - (or frame (selected-frame)) (frame-list) (or n 1))) - - - -;;; namespace-prefixed defstruct - -(defmacro wg-defstruct (prefix name-form &rest slot-defs) - "`defstruct' wrapper that namespace-prefixes all generated functions. -Note: this doesn't yet work with :conc-name, and possibly other -options." - (declare (indent 2)) - (let* ((name (if (consp name-form) (car name-form) name-form)) - (prefixed-name (wg-symcat prefix "-" name))) - (cl-labels ((rebind (opstr) - (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name))) - `((fset ',(wg-symcat prefix "-" opstr "-" name) - (symbol-function ',oldfnsym)) - (fmakunbound ',oldfnsym))))) - ;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not - ;; known to be defined"). We can accomplish this with `declare-function' - ;; too, but it annoyingly requires inclusion of the function's arglist, - ;; which gets ugly. - `(eval-and-compile - (cl-defstruct ,(if (symbolp name-form) prefixed-name - `(,prefixed-name ,@(cdr name-form))) - ,@slot-defs) - ,@(rebind "make") - ,@(rebind "copy") - ',prefixed-name)))) - -(defmacro wg-with-slots (obj slot-bindings &rest body) - "Bind OBJ's slot values to symbols in BINDS, then eval BODY. -The car of each element of SLOT-BINDINGS is the bound symbol, and -the cadr as the accessor function." - (declare (indent 2)) - (wg-with-gensyms (objsym) - `(let* ((,objsym ,obj) - ,@(wg-docar (slot slot-bindings) - `(,(car slot) (,(cadr slot) ,objsym)))) - ,@body))) - - - -;;; misc - - -(defun wg-fill-keymap (keymap &rest binds) - "Return KEYMAP after defining in it all keybindings in BINDS." - (while binds - (define-key keymap (car binds) (cadr binds)) - (setq binds (cddr binds))) - keymap) - -(defun wg-add-or-remove-hooks (remove &rest pairs) - "Add FUNCTION to or remove it from HOOK, depending on REMOVE." - (dolist (pair (wg-partition pairs 2)) - (funcall (if remove 'remove-hook 'add-hook) - (car pair) (cadr pair)))) - - - -(defmacro wg-set-parameter (place parameter value) - "Set PARAMETER to VALUE at PLACE. -This needs to be a macro to allow specification of a setf'able place." - (wg-with-gensyms (p v) - `(let ((,p ,parameter) (,v ,value)) - (wg-pickelable-or-error ,p) - (wg-pickelable-or-error ,v) - (setf ,place (wg-aput ,place ,p ,v)) - ,v))) - - -;;; uid utils - -(defun wg-time-to-b36 () - "Convert `current-time' into a b36 string." - (apply 'concat (wg-docar (time (current-time)) - (wg-int-to-b36 time 4)))) - -(defun wg-b36-to-time (b36) - "Parse the time in B36 string from UID." - (cl-loop for i from 0 to 8 by 4 - collect (wg-b36-to-int (cl-subseq b36 i (+ i 4))))) -(defalias 'wg-uid-to-time 'wg-b36-to-time) - -(defun wg-generate-uid (&optional prefix) - "Return a new uid, optionally prefixed by PREFIX." - (concat prefix (wg-time-to-b36) "-" (wg-int-to-b36 string-chars-consed))) - -(defun wg-uid-to-seconds (uid) - "Return the `float-time' parsed from UID with `wg-uid-to-time'." - (float-time (wg-uid-to-time uid))) - - -(defun wg-get-value (arg) - "Get a value of ARG if it exists." - (if (boundp `,arg) (eval arg))) - -(defmacro wg-support (mode pkg params) - "Macro to create (de)serialization functions for a buffer. -You need to save/restore a specific MODE which is loaded from a -package PKG. In PARAMS you give local variables to save and a -deserialization function." - `(let ((mode-str (symbol-name ,mode)) - (args ,params)) - - (eval `(defun ,(intern (format "wg-deserialize-%s-buffer" mode-str)) (buffer) - "DeSerialization function created with `wg-support'. -Gets saved variables and runs code to restore a BUFFER." - (when (require ',,pkg nil 'noerror) - (wg-dbind (this-function variables) (wg-buf-special-data buffer) - (let ((default-directory (car variables)) - (df (cdr (assoc 'deserialize ',,params))) - (user-vars (car (cdr variables)))) - (if df (funcall df buffer user-vars)) - (current-buffer) - ))))) - - (eval `(defun ,(intern (format "wg-serialize-%s-buffer" mode-str)) (buffer) - "Serialization function created with `wg-support'. -Saves some variables to restore a BUFFER later." - (when (get-buffer buffer) - (with-current-buffer buffer - (when (eq major-mode ',,mode) - (let ((sf (cdr (assoc 'serialize ',,params))) - (save (cdr (assoc 'save ',,params)))) - (list ',(intern (format "wg-deserialize-%s-buffer" mode-str)) - (list default-directory - (if sf (funcall sf buffer) - (if save (mapcar 'wg-get-value save))) - )))))))) - ;; Maybe change a docstring for functions - ;;(put (intern (format "wg-serialize-%s-buffer" (symbol-name mode))) - ;; 'function-documentation - ;; (format "A function created by `wg-support'.")) - - ;; Add function to `wg-special-buffer-serdes-functions' variable - (eval `(add-to-list 'wg-special-buffer-serdes-functions - ',(intern (format "wg-serialize-%s-buffer" mode-str)) t)) - )) - -(defvar wg-current-session nil "Current session object.") -(defun wg-current-session (&optional noerror) - "Return `wg-current-session' or scream unless NOERROR." - (or wg-current-session - (unless noerror - (error "No session is defined")))) - - -(provide 'workgroups-utils-basic) -;;; workgroups-utils-basic.el ends here diff --git a/src/workgroups-variables.el b/src/workgroups-variables.el deleted file mode 100644 index 0eedbc6f4ca311f5d7b49e62a6d0b2c3540d170c..0000000000000000000000000000000000000000 --- a/src/workgroups-variables.el +++ /dev/null @@ -1,427 +0,0 @@ -;;; workgroups-variables --- Workgroups vars and consts -;;; Commentary: -;;; Code: - -(defconst wg-version "1.1.1" "Current version of Workgroups.") - -;;; customization - -(defgroup workgroups nil - "Workgroups for Emacs -- Emacs session manager" - :group 'convenience) - -(defcustom workgroups-mode nil - "Non-nil if Workgroups mode is enabled." - :set 'custom-set-minor-mode - :initialize 'custom-initialize-default - :group 'workgroups - :type 'boolean) - -(defcustom wg-first-wg-name "First workgroup" - "Title of the first workgroup created." - :type 'string - :group 'workgroups) - -(defcustom wg-modeline-string " wg" - "Appears in modeline." - :type 'string - :group 'workgroups) - -(defcustom wg-load-last-workgroup t - "Load last active (not first) workgroup from all your workgroups if it exists." - :group 'workgroups - :type 'boolean) - -(defcustom wg-control-frames t - "Save/restore frames." - :group 'workgroups - :type 'boolean) - - -;; hooks - -(defcustom workgroups-mode-hook nil - "Hook run when `workgroups-mode' is turned on." - :type 'hook - :group 'workgroups) - -(defcustom workgroups-mode-exit-hook nil - "Hook run when `workgroups-mode' is turned off." - :type 'hook - :group 'workgroups) - -(defcustom wg-switch-to-workgroup-hook nil - "Hook run by `wg-switch-to-workgroup'." - :type 'hook - :group 'workgroups) - -(defcustom wg-buffer-list-finalization-hook nil - "Functions in this hook can modify `wg-temp-buffer-list' -arbitrarily, provided its final value is still a list of the -names of live buffer. Any final adjustments the user wishes to -make to the filtered buffer list before ido/iswitchb get ahold of -it should be made here." - :type 'hook - :group 'workgroups) - -(defcustom wg-pre-window-configuration-change-hook nil - "Hook run before any function that triggers -`window-configuration-change-hook'." - :type 'hook - :group 'workgroups) - - -(defcustom wg-open-this-wg nil - "Try to open this workgroup on start. -If nil - nothing happens." - :type 'string - :group 'workgroups) - -(defcustom wg-switch-to-first-workgroup-on-find-session-file t - "Non-nil means switch to the first workgroup in a session file -when it's found with `wg-find-session-file'." - :type 'boolean - :group 'workgroups) - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; FIXME: -;; -;; Only set `wg-workgroup-base-wconfig' on `wg-write-session-file' or -;; `delete-frame' and only with the most recently changed working-wconfig. -;; Then, since it's not overwritten on every call to -;; `wg-workgroup-working-wconfig', its restoration can be retried after manually -;; recreating buffers that couldn't be restored. So it takes over the -;; 'incorrect restoration' portion of the base wconfig's duty. All that leaves -;; to base wconfigs is that they're a saved wconfig the user felt was important. -;; So why not allow more of of them? A workgroup could stash an unlimited -;; number of wconfigs. -;; -;; TODO: -;; -;; * Write new commands for restoring stashed wconfigs -;; -;; * Add this message on improper restoration of `base-wconfig': -;; -;; "Unable to restore 'buf1', 'buf2'... Hit C-whatever to retry after -;; manually recreating these buffers." -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; workgroup restoration customization - -;; TODO: possibly add `buffer-file-coding-system', `text-scale-mode-amount' -(defcustom wg-buffer-local-variables-alist - `((major-mode nil wg-deserialize-buffer-major-mode) - (mark-ring wg-serialize-buffer-mark-ring wg-deserialize-buffer-mark-ring) - (left-fringe-width nil nil) - (right-fringe-width nil nil) - (fringes-outside-margins nil nil) - (left-margin-width nil nil) - (right-margin-width nil nil) - (vertical-scroll-bar nil nil)) - "Alist mapping buffer-local variable symbols to serdes functions. - -The `car' of each entry should be a buffer-local variable symbol. - -The `cadr' of the entry should be either nil or a function of no -arguments. If nil, the variable's value is used as-is, and -should have a readable printed representation. If a function, -`funcall'ing it should yield a serialization of the value of the -variable. - -The `caddr' of the entry should be either nil or a function of -one argument. If nil, the serialized value from above is -assigned to the variable as-is. It a function, `funcall'ing it -on the serialized value from above should do whatever is -necessary to properly restore the original value of the variable. -For example, in the case of `major-mode' it should funcall the -value (a major-mode function symbol) rather than just assigning -it to `major-mode'." - :type 'alist - :group 'workgroups) - - -(defcustom wg-nowg-string "No workgroups" - "Display this string if there are no workgroups and -`wg-display-nowg' is t." - :type 'string - :group 'workgroups) - -(defcustom wg-display-nowg nil - "Display something if there are no workgroups." - :type 'boolean - :group 'workgroups) - -;; What to restore: - -(defcustom wg-restore-remote-buffers t - "Restore buffers that get \"t\" with `file-remote-p'." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-frame-position t - "Non-nil means restore frame position on workgroup restore." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-scroll-bars t - "Non-nil means restore scroll-bar settings on workgroup restore." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-fringes t - "Non-nil means restore fringe settings on workgroup restore." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-margins t - "Non-nil means restore margin settings on workgroup restore." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-point t - "Non-nil means restore `point' on workgroup restore. -This is included mainly so point restoration can be suspended -during `wg-morph' -- you probably want this non-nil." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-point-max t - "Controls point restoration when point is at `point-max'. -If `point' is at `point-max' when a wconfig is created, put -`point' back at `point-max' when the wconfig is restored, even if -`point-max' has increased in the meantime. This is useful in, -say, irc buffers where `point-max' is constantly increasing." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-mark t - "Non-nil means restore mark data on workgroup restore." - :type 'boolean - :group 'workgroups) - -(defcustom wg-restore-window-dedicated-p t - "Non-nil means restore `window-dedicated-p' on workgroup restore." - :type 'boolean - :group 'workgroups) - -(defcustom wg-remember-frame-for-each-wg nil - "When switching workgroups - restore frame parameters for each workgroup. - -When nil - save/restore frame parameters to/from the first workgroup." - :type 'boolean - :group 'workgroups) - - -(defcustom wg-wconfig-undo-list-max 20 - "Number of past window configs to retain for undo." - :type 'integer - :group 'workgroups) - -(defcustom wg-wconfig-kill-ring-max 20 - "Maximum length of the `wg-wconfig-kill-ring'." - :type 'integer - :group 'workgroups) - - -;; buffer-list filtration customization - -(defcustom wg-buffer-list-filtration-on t - "Non-nil means Workgroups' buffer-list filtration feature is on. -Nil means ido and iswitchb behave normally. See -`wg-buffer-list-filter-definitions' for more info." - :type 'boolean - :group 'workgroups) - -(defcustom wg-buffer-list-filter-definitions - '((all "all" wg-buffer-list-filter-all) - (fallback "fallback" nil)) - "List of buffer list filter definitions. -Each entry should be a list containing an identifier symbol, a -prompt string, and a function form that's funcall'd to produce -the filtered buffer-list. - -The prompt string is displayed as part of the minibuffer prompt -when its filter is active. - -The function form should be either a function-symbol or a lambda, and -should take two arguments: a workgroup and a list of live Emacs -buffers. The function should return a new list of live buffers, -typically by filtering its second argument in some way. - -Default buffer-list-filters include: - -`all' All buffer names - -`fallback' A special case used to fallback to the - original (non-ido/iswitchb) Emacs command. - `fallback' isn't actually a buffer-list-filter - itself, but can be used in - `wg-buffer-list-filter-order-alist' just the - same. - -Becomes workgroup-local when set with `wg-set-workgroup-parameter'. -Becomes session-local when set with `wg-set-session-parameter'." - :type 'list - :group 'workgroups) - -(defcustom wg-buffer-list-filter-order-alist - '((default all fallback)) - "Alist defining the order in which filtered buffer-lists are presented. - -The car of each entry should be the symbol of the original Emacs -command (not the ido or iswitchb remappings) -- i.e. one of -`switch-to-buffer', `switch-to-buffer-other-window', -`switch-to-buffer-other-frame', `kill-buffer', `next-buffer', -`previous-buffer', `display-buffer', `insert-buffer', -`read-buffer', or the special symbol `default', which defines the -buffer-list-filter order for all commands not present in this -alist. - -The cdr of each entry should be a list of buffer-list-filter -identifiers defining the order in which filtered buffer-lists are -presented for the command. See -`wg-buffer-list-filter-definitions'. - -Becomes workgroup-local when set with `wg-set-workgroup-parameter'. -Becomes session-local when set with `wg-set-session-parameter'." - :type 'alist - :group 'workgroups) - -(defcustom wg-center-rotate-buffer-list-display nil - "Non-nil means rotate the buffer list display so that the -current buffer is in the center of the list. This can make it -easier to see the where `wg-previous-buffer' will take you, but -it doesn't look right if the buffer list display is long enough -to wrap in the miniwindow." - :type 'boolean - :group 'workgroups) - -(defcustom wg-remap-bury-buffer nil - "Non-nil means remap `bury-buffer'. -`banish' means remap `bury-buffer' to `wg-banish-buffer'. -`bury' or other non-nil means remap `bury-buffer' to -`wg-bury-buffer'. Otherwise, don't remap." - :type 'boolean - :group 'workgroups) - - -;;; vars - -(defvar wg-workgroups-mode-minor-mode-map-entry nil - "Workgroups' minor-mode-map entry.") - -(defvar wg-wconfig-kill-ring nil - "Ring of killed or kill-ring-saved wconfigs.") - -(defvar wg-last-message nil - "Holds the last message Workgroups sent to the echo area.") - -(defvar wg-buffer-uid nil - "Symbol for the current buffer's wg-buf's uid. -Every Workgroups buffer object (wg-buf) has a uid. When -Workgroups creates or encounters an Emacs buffer object -corresponding to a wg-buf, it tags it with the wg-buf's uid to -unambiguously pair the two.") -(make-variable-buffer-local 'wg-buffer-uid) - - -;; file and modified flag vars - -(defvar wg-flag-modified t - "Dynamically bound to nil around destructive operations to -temporarily disable flagging `modified'.") - - -;; undo vars - -(defvar wg-window-configuration-changed nil - "Flag set by `window-configuration-change-hook'.") - -(defvar wg-already-updated-working-wconfig nil - "Flag set by `wg-update-working-wconfig-hook'.") - -(defvar wg-undoify-window-configuration-change t - "Flag unset when changes to the window config shouldn't cause -workgroups' undo info to be updated.") - - - - -;; buffer-list-filter vars - -(defvar wg-current-workgroup nil - "Bound to the current workgroup in `wg-with-buffer-list-filters'.") - -;; (defvar wg-current-buffer-command nil -;; "Bound to the current buffer command in `wg-with-buffer-list-filters'.") - -(defvar wg-current-buffer-list-filter-id nil - "Bound to the current buffer-list-filter symbol in `wg-with-buffer-list-filters'.") - -(defvar wg-previous-minibuffer-contents nil - "Holds the previous minibuffer contents for re-insertion when -the buffer-list-filter is cycled.") - -(defvar wg-ido-method-translations - `((switch-to-buffer . selected-window) - (switch-to-buffer-other-window . other-window) - (switch-to-buffer-other-frame . other-frame) - (kill-buffer . kill) - (insert-buffer . insert) - (display-buffer . display)) - "Alist mapping buffer commands to ido buffer methods.") - -(defvar wg-buffer-internal-default-buffer nil - "Bound to `wg-buffer-internal's optional DEFAULT argument for -use by buffer list filtration hooks.") - -(defvar wg-temp-buffer-list nil - "Dynamically bound to the filtered buffer list in -`wg-finalize-buffer-list'. Functions in -`wg-buffer-list-finalization-hook' should modify this variable.") - - -;; wconfig restoration - -(defvar wg-window-min-width 2 - "Bound to `window-min-width' when restoring wtrees. ") - -(defvar wg-window-min-height 1 - "Bound to `window-min-height' when restoring wtrees.") - -(defvar wg-window-min-pad 2 - "Added to `wg-window-min-foo' to produce the actual minimum window size.") - -(defvar wg-actual-min-width (+ wg-window-min-width wg-window-min-pad) - "Actual minimum window width when creating windows.") - -(defvar wg-actual-min-height (+ wg-window-min-height wg-window-min-pad) - "Actual minimum window height when creating windows.") - -(defvar wg-min-edges `(0 0 ,wg-actual-min-width ,wg-actual-min-height) - "Smallest allowable edge list of windows created by Workgroups.") - -(defvar wg-null-edges '(0 0 0 0) - "Null edge list.") - -(defvar wg-window-tree-selected-window nil - "Used during wconfig restoration to hold the selected window.") - -(defvar wg-update-current-workgroup-working-wconfig-on-select-frame t - "Non-nil means update `selected-frame's current workgroup's -working wconfig before `select-frame' selects a new frame. -let-bind this to nil around forms in which you don't want this to -happen.") - -;; Remove after some time -(defalias 'wg-switch-to-buffer 'switch-to-buffer) - -(provide 'workgroups-variables) -;;; workgroups-variables.el ends here diff --git a/src/workgroups-wconfig.el b/src/workgroups-wconfig.el deleted file mode 100644 index 4609a5f3899a957b305db1f43a6a749311dda277..0000000000000000000000000000000000000000 --- a/src/workgroups-wconfig.el +++ /dev/null @@ -1,273 +0,0 @@ -;;; workgroups-wconfig.el --- WCONFIG -;;; Commentary: -;; This is a window-configuration, a buffer layout, whatever you call -;; it... This is actually what you want to be saved and restored. -;; (Well, technically it is (window-tree + some frame parameters)) -;;; Code: - -(require 'workgroups-wtree) - -(defun wg-frame-to-wconfig (&optional frame) - "Return the serialization (a wg-wconfig) of Emacs frame FRAME. -FRAME nil defaults to `selected-frame'." - (let* ((frame (or frame (selected-frame))) - (fullscrn (frame-parameter frame 'fullscreen))) - (wg-make-wconfig - :left (frame-parameter frame 'left) - :top (frame-parameter frame 'top) - :width (frame-parameter frame 'width) - :height (frame-parameter frame 'height) - :parameters `((fullscreen . ,fullscrn)) - :vertical-scroll-bars (frame-parameter frame 'vertical-scroll-bars) - :scroll-bar-width (frame-parameter frame 'scroll-bar-width) - :wtree (wg-window-tree-to-wtree (window-tree frame)) - ))) - -(defun wg-current-wconfig () - "Return the current wconfig. -If `wg-current-wconfig' is non-nil, return it. Otherwise return -`wg-frame-to-wconfig'." - (or (frame-parameter nil 'wg-current-wconfig) - (wg-frame-to-wconfig))) - -(defmacro wg-with-current-wconfig (frame wconfig &rest body) - "Eval BODY with WCONFIG current in FRAME. -FRAME nil defaults to `selected-frame'." - (declare (indent 2)) - (wg-with-gensyms (frame-sym old-value) - `(let* ((,frame-sym (or ,frame (selected-frame))) - (,old-value (frame-parameter ,frame-sym 'wg-current-wconfig))) - (unwind-protect - (progn - (set-frame-parameter ,frame-sym 'wg-current-wconfig ,wconfig) - ,@body) - (when (frame-live-p ,frame-sym) - (set-frame-parameter ,frame-sym 'wg-current-wconfig ,old-value)))))) - -(defun wg-make-blank-wconfig (&optional buffer) - "Return a new blank wconfig. -BUFFER or `wg-default-buffer' is visible in the only window." - (save-window-excursion - (delete-other-windows) - (switch-to-buffer (or buffer wg-default-buffer)) - (wg-frame-to-wconfig))) - -(defun wg-wconfig-move-window (wconfig offset) - "Offset `selected-window' OFFSET places in WCONFIG." - (wg-asetf (wg-wconfig-wtree wconfig) (wg-wtree-move-window it offset)) - wconfig) - - -;;; base wconfig updating - -(defun wg-update-working-wconfig-on-delete-frame (frame) - "Update FRAME's current workgroup's working-wconfig before -FRAME is deleted, so we don't lose its state." - (with-selected-frame frame - (wg-update-current-workgroup-working-wconfig))) - - -(defun wg-wconfig-buf-uids (wconfig) - "Return WCONFIG's wtree's `wg-wtree-buf-uids'." - (if (not (wg-wconfig-wtree wconfig)) - (error "WTREE is nil in `wg-wconfig-buf-uids'!")) - (wg-wtree-unique-buf-uids (wg-wconfig-wtree wconfig))) - - - - - -(defun wg-wconfig-restore-frame-position (wconfig &optional frame) - "Use WCONFIG to restore FRAME's position. -If frame is nil then `selected-frame'." - (wg-when-let ((left (wg-wconfig-left wconfig)) - (top (wg-wconfig-top wconfig))) - ;; Check that arguments are integers - ;; Problem: https://github.com/pashinin/workgroups2/issues/15 - (if (and (integerp left) - (integerp top)) - (set-frame-position frame left top)))) - -(defun wg-wconfig-restore-scroll-bars (wconfig) - "Restore `selected-frame's scroll-bar settings from WCONFIG." - (set-frame-parameter - nil 'vertical-scroll-bars (wg-wconfig-vertical-scroll-bars wconfig)) - (set-frame-parameter - nil 'scroll-bar-width (wg-wconfig-scroll-bar-width wconfig))) - -;;(defun wg-wconfig-restore-fullscreen (wconfig) -;; "Restore `selected-frame's fullscreen settings from WCONFIG." -;; (set-frame-parameter -;; nil 'fullscreen (wg-wconfig-parameters wconfig)) -;; ) - -(defun wg-scale-wconfigs-wtree (wconfig new-width new-height) - "Scale WCONFIG's wtree with NEW-WIDTH and NEW-HEIGHT. -Return a copy WCONFIG's wtree scaled with `wg-scale-wtree' by the -ratio or NEW-WIDTH to WCONFIG's width, and NEW-HEIGHT to -WCONFIG's height." - (wg-normalize-wtree - (wg-scale-wtree - (wg-wconfig-wtree wconfig) - (/ (float new-width) (wg-wconfig-width wconfig)) - (/ (float new-height) (wg-wconfig-height wconfig))))) -;; (wg-wconfig-width (wg-current-wconfig)) -;; (wg-wconfig-wtree (wg-current-wconfig)) - - -(defun wg-scale-wconfig-to-frame (wconfig) - "Scale WCONFIG buffers to fit current frame size. -Return a scaled copy of WCONFIG." - (interactive) - (wg-scale-wconfigs-wtree wconfig - (frame-parameter nil 'width) - (frame-parameter nil 'height))) -;; (wg-scale-wconfig-to-frame (wg-current-wconfig)) - -(defun wg-frame-resize-and-position (wconfig &optional frame) - "Apply WCONFIG's size and position to a FRAME." - (interactive) - (unless frame - (setq frame (selected-frame))) - (let* ((params (wg-wconfig-parameters wconfig)) - fullscreen) - (set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params) - (cdr (assoc 'fullscreen params)) - nil)) - (when (and wg-restore-frame-position - (not (frame-parameter frame 'fullscreen))) - (wg-wconfig-restore-frame-position wconfig frame)) - )) - -(defun wg-restore-frame-size-position (wconfig &optional fs) - "Smart-restore of frame size and position. - -Depending on `wg-remember-frame-for-each-wg' frame parameters may -be restored for each workgroup. - -If `wg-remember-frame-for-each-wg' is nil (by default) then -current frame parameters are saved/restored to/from first -workgroup. And frame parameters for all other workgroups are just -ignored. -" - (interactive) - (let* ((params (wg-wconfig-parameters wconfig)) - fullscreen) - ;; Frame maximized / fullscreen / none - (unless wg-remember-frame-for-each-wg - (setq params (wg-wconfig-parameters (wg-workgroup-working-wconfig (wg-first-workgroup))))) - (setq fullscreen (if (assoc 'fullscreen params) - (cdr (assoc 'fullscreen params)) - nil)) - (when (and fs - fullscreen - (or wg-remember-frame-for-each-wg - (null (wg-current-workgroup t)))) - (set-frame-parameter nil 'fullscreen fullscreen) - ;; I had bugs restoring maximized frame: - ;; Frame could be maximized but buffers are not scaled to fit it. - ;; - ;; Maybe because of `set-frame-parameter' takes some time to finish and is async. - ;; So I tried this and it helped - (sleep-for 0 100)) - - ;; Position - (when (and wg-restore-frame-position - wg-remember-frame-for-each-wg - (not (frame-parameter nil 'fullscreen))) - (wg-wconfig-restore-frame-position wconfig)) - )) - - -(defun wg-restore-frames () - "Try to recreate opened frames, take info from session's 'frame-list parameter." - (interactive) - (delete-other-frames) - (when (wg-current-session t) - (let ((fl (wg-session-parameter (wg-current-session t) 'frame-list nil)) - (frame (selected-frame))) - (mapc (lambda (wconfig) - (with-selected-frame (make-frame) - ;;(wg-frame-resize-and-position wconfig) - ;;(wg-restore-frame-size-position wconfig) - ;;(wg-wconfig-restore-frame-position wconfig) - (wg-restore-wconfig wconfig) - )) fl) - (select-frame-set-input-focus frame)))) - -;; FIXME: throw a specific error if the restoration was unsuccessful -(defun wg-restore-wconfig (wconfig &optional frame) - "Restore a workgroup configuration WCONFIG in a FRAME. -Runs each time you're switching workgroups." - (unless frame (setq frame (selected-frame))) - (let ((wg-record-incorrectly-restored-bufs t) - (wg-incorrectly-restored-bufs nil) - (params (wg-wconfig-parameters wconfig)) - fullscreen wtree) - (wg-barf-on-active-minibuffer) - (when wg-restore-scroll-bars - (wg-wconfig-restore-scroll-bars wconfig)) - - ;; Restore buffers - (wg-restore-window-tree - (wg-scale-wconfig-to-frame wconfig)) - - ;; Restore frame position - (when (and wg-restore-frame-position - (not (frame-parameter nil 'fullscreen)) - (null (wg-current-workgroup t))) - (wg-wconfig-restore-frame-position wconfig frame)) - - (when wg-incorrectly-restored-bufs - (message "Unable to restore these buffers: %S\ -If you want, restore them manually and try again." - (mapcar 'wg-buf-name wg-incorrectly-restored-bufs))))) - - -;;; saved wconfig commands - -(defun wg-save-wconfig () - "Save the current wconfig to the current workgroup's saved wconfigs." - (interactive) - (let* ((workgroup (wg-current-workgroup)) - (name (wg-read-saved-wconfig-name workgroup)) - (wconfig (wg-current-wconfig))) - (setf (wg-wconfig-name wconfig) name) - (wg-workgroup-save-wconfig workgroup wconfig) - (wg-fontified-message - (:cmd "Saved: ") - (:cur name)))) - -(defun wg-restore-saved-wconfig () - "Restore one of the current workgroup's saved wconfigs in `selected-frame'." - (interactive) - (let ((workgroup (wg-current-workgroup))) - (wg-restore-wconfig-undoably - (wg-workgroup-get-saved-wconfig - workgroup - (wg-completing-read - "Saved wconfig: " - (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup)) - nil t))))) - -(defun wg-kill-saved-wconfig () - "Kill one of the current workgroup's saved wconfigs. -Also add it to the wconfig kill-ring." - (interactive) - (let* ((workgroup (wg-current-workgroup)) - (wconfig (wg-read-saved-wconfig workgroup))) - (wg-workgroup-kill-saved-wconfig workgroup wconfig) - (wg-add-to-wconfig-kill-ring wconfig) - (wg-fontified-message - (:cmd "Deleted: ") - (:cur (wg-wconfig-name wconfig))))) - - -(defun wg-reverse-wconfig (wconfig &optional dir) - "Reverse WCONFIG's wtree's wlist in direction DIR." - (wg-asetf (wg-wconfig-wtree wconfig) (wg-reverse-wlist it dir)) - wconfig) - - -(provide 'workgroups-wconfig) -;;; workgroups-wconfig.el ends here diff --git a/src/workgroups-win.el b/src/workgroups-win.el deleted file mode 100644 index 288098e6f2ccf08a220fc6ab3edca6af07951f30..0000000000000000000000000000000000000000 --- a/src/workgroups-win.el +++ /dev/null @@ -1,199 +0,0 @@ -;;; workgroups-win.el --- Emacs WINDOW -;;; Commentary: -;; -;; Emacs Window has a Buffer in it (see workgroups-buf.el). Window also -;; has got a "history" of opened buffers and more parameters. -;; -;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Windows-and-Frames.html#Windows-and-Frames -;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Windows.html#Windows -;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Window-History.html -;; -;;; Code: - -(require 'workgroups-buf) - -(defun wg-min-size (dir) - "Return the minimum window size in split direction DIR." - (if dir wg-window-min-height wg-window-min-width)) - -(defun wg-actual-min-size (dir) - "Return the actual minimum window size in split direction DIR." - (if dir wg-actual-min-height wg-actual-min-width)) - -(defmacro wg-with-edges (w spec &rest body) - "Bind W's edge list to SPEC and eval BODY." - (declare (indent 2)) - `(wg-dbind ,spec (wg-w-edges ,w) ,@body)) - -(defmacro wg-with-bounds (wtree dir spec &rest body) - "Bind SPEC to W's bounds in DIR, and eval BODY. -\"bounds\" are a direction-independent way of dealing with edge lists." - (declare (indent 3)) - (wg-with-gensyms (dir-sym l1 t1 r1 b1) - (wg-dbind (ls1 hs1 lb1 hb1) spec - `(wg-with-edges ,wtree (,l1 ,t1 ,r1 ,b1) - (cond (,dir (let ((,ls1 ,l1) (,hs1 ,r1) (,lb1 ,t1) (,hb1 ,b1)) - ,@body)) - (t (let ((,ls1 ,t1) (,hs1 ,b1) (,lb1 ,l1) (,hb1 ,r1)) - ,@body))))))) - -(defun wg-set-bounds (w dir ls hs lb hb) - "Set W's edges in DIR with bounds LS HS LB and HB." - (wg-set-edges w (if dir (list ls lb hs hb) (list lb ls hb hs)))) - -(defun wg-step-edges (edges1 edges2 hstep vstep) - "Return W1's edges stepped once toward W2's by HSTEP and VSTEP." - (wg-dbind (l1 t1 r1 b1) edges1 - (wg-dbind (l2 t2 r2 b2) edges2 - (let ((left (wg-step-to l1 l2 hstep)) - (top (wg-step-to t1 t2 vstep))) - (list left top - (+ left (wg-step-to (- r1 l1) (- r2 l2) hstep)) - (+ top (wg-step-to (- b1 t1) (- b2 t2) vstep))))))) - -(defun wg-w-edge-operation (w edges op) - "Return a copy of W with its edges mapped against EDGES through OP." - (wg-set-edges w (cl-mapcar op (wg-w-edges w) edges))) - -(defun wg-first-win (w) - "Return the first actual window in W." - (if (wg-win-p w) w - (wg-first-win (car (wg-wtree-wlist w))))) - -(defun wg-last-win (w) - "Return the last actual window in W." - (if (wg-win-p w) w - (wg-last-win (wg-last1 (wg-wtree-wlist w))))) - -(defun wg-minify-win (w) - "Set W's edges to the smallest allowable." - (let* ((edges (wg-w-edges w)) - (left (car edges)) - (top (cadr edges))) - (wg-set-edges w (list left top - (+ left wg-actual-min-width) - (+ top wg-actual-min-height))))) - -(defun wg-minified-copy-of-last-win (w) - "Minify a copy of the last actual window in W." - (wg-minify-win (wg-copy-win (wg-last-win w)))) - -(defun wg-w-size (w &optional height) - "Return the width or height of W, calculated from its edge list." - (wg-with-edges w (l1 t1 r1 b1) - (if height (- b1 t1) (- r1 l1)))) - -(defun wg-adjust-w-size (w width-fn height-fn &optional new-left new-top) - "Adjust W's width and height with WIDTH-FN and HEIGHT-FN." - (wg-with-edges w (left top right bottom) - (let ((left (or new-left left)) (top (or new-top top))) - (wg-set-edges (wg-copy-w w) - (list left - top - (+ left (funcall width-fn (- right left))) - (+ top (funcall height-fn (- bottom top)))))))) - -(defun wg-scale-w-size (w width-scale height-scale) - "Scale W's size by WIDTH-SCALE and HEIGHT-SCALE." - (cl-labels - ((wscale (width) (truncate (* width width-scale))) - (hscale (height) (truncate (* height height-scale)))) - (wg-adjust-w-size w #'wscale #'hscale))) - - - -(defun wg-restore-window-positions (win &optional window) - "Restore various positions in WINDOW from their values in WIN." - (let ((window (or window (selected-window)))) - (wg-with-slots win - ((win-point wg-win-point) - (win-start wg-win-start) - (win-hscroll wg-win-hscroll)) - (set-window-start window win-start t) - (set-window-hscroll window win-hscroll) - (set-window-point - window - (cond ((not wg-restore-point) win-start) - ((eq win-point :max) (point-max)) - (t win-point))) - (when (>= win-start (point-max)) (recenter))))) - -(defun wg-restore-window (win) - "Restore WIN in `selected-window'." - (let ((selwin (selected-window)) - (buf (wg-find-buf-by-uid (wg-win-buf-uid win)))) - (if (not buf) - (wg-restore-default-buffer) - (when (wg-restore-buffer buf) - (wg-restore-window-positions win selwin) - (when wg-restore-window-dedicated-p - (set-window-dedicated-p selwin (wg-win-dedicated win))))) - (ignore-errors - (set-window-prev-buffers - selwin (wg-unpickel (wg-win-parameter win 'prev-buffers))) - (set-window-next-buffers - selwin (wg-unpickel (wg-win-parameter win 'next-buffers))) - ))) - - -(defun wg-window-point (ewin) - "Return `point' or :max. See `wg-restore-point-max'. -EWIN should be an Emacs window object." - (let ((p (window-point ewin))) - (if (and wg-restore-point-max (= p (point-max))) :max p))) - -(defun wg-win-parameter (win parameter &optional default) - "Return WIN's value for PARAMETER. -If PARAMETER is not found, return DEFAULT which defaults to nil. -SESSION nil defaults to the current session." - (wg-aget (wg-win-parameters win) parameter default)) - -(defun wg-set-win-parameter (win parameter value) - "Set WIN's value of PARAMETER to VALUE. -SESSION nil means use the current session. -Return value." - (wg-set-parameter (wg-win-parameters win) parameter value) - value) -;; (wg-win-parameters (wg-window-to-win (selected-window))) - -(defun wg-remove-win-parameter (win parameter) - "Remove parameter PARAMETER from WIN's parameters." - (wg-asetf (wg-win-parameters win) (wg-aremove it parameter))) - -;; (wg-window-to-win (selected-window)) -(defun wg-window-to-win (window) - "Return the serialization (a wg-win) of Emacs window WINDOW." - (let ((selected (eq window (selected-window))) - win) - (with-selected-window window - (setq win - (wg-make-win - :edges (window-edges window) - :point (wg-window-point window) - :start (window-start window) - :hscroll (window-hscroll window) - :selected selected - :minibuffer-scroll (eq window minibuffer-scroll-window) - :dedicated (window-dedicated-p window) - :buf-uid (wg-buffer-uid-or-add (window-buffer window)))) - ;; To solve: https://github.com/pashinin/workgroups2/issues/51 - ;; shouldn't ignore here - (ignore-errors - (wg-set-win-parameter - win 'next-buffers (wg-pickel (remove nil (cl-subseq (window-next-buffers window) 0 4)))) - (wg-set-win-parameter - win 'prev-buffers (wg-pickel (remove nil (cl-subseq (window-prev-buffers window) 0 4)))) - )) - win)) - -(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")))) - -(provide 'workgroups-win) -;;; workgroups-win.el ends here diff --git a/src/workgroups-workgroup.el b/src/workgroups-workgroup.el deleted file mode 100644 index ec860f0a750f04a2f548e4af26f651106547818b..0000000000000000000000000000000000000000 --- a/src/workgroups-workgroup.el +++ /dev/null @@ -1,956 +0,0 @@ -;;; workgroups-workgroup.el --- workgroup functions -;;; Commentary: -;;; Code: - -(require 'ring) -(require 'workgroups-wconfig) -(require 'workgroups-minibuffer) - -;; -;; Variables -;; - -(defcustom wg-confirm-on-get-workgroup-create nil - "Non-nil means request confirmation before creating a new -workgroup when `wg-get-workgroup-create' is called with a string -that doesn't name an existing workgroup." - :type 'boolean - :group 'workgroups) - -(defun wg-flag-workgroup-modified (workgroup) - "Set WORKGROUP's and the current session's modified flags." - (when wg-flag-modified - (setf (wg-workgroup-modified workgroup) t) - (setf (wg-session-modified (wg-current-session)) t))) - - -(defun wg-current-workgroup (&optional noerror frame) - "Return the current workgroup in FRAME, or error unless NOERROR." - (or wg-current-workgroup - (wg-aif (frame-parameter frame 'wg-current-workgroup-uid) - (wg-find-workgroup-by :uid it noerror) - (unless noerror (error "No current workgroup in this frame"))))) - -(defun wg-previous-workgroup (&optional noerror frame) - "Return the previous workgroup in FRAME, or error unless NOERROR." - (wg-aif (frame-parameter frame 'wg-previous-workgroup-uid) - (wg-find-workgroup-by :uid it noerror) - (unless noerror (error "No previous workgroup in this frame")))) - -(defun wg-set-current-workgroup (workgroup &optional frame) - "Set the current workgroup to WORKGROUP. -WORKGROUP should be a workgroup or nil." - (set-frame-parameter frame 'wg-current-workgroup-uid - (when workgroup (wg-workgroup-uid workgroup)))) - -(defun wg-set-previous-workgroup (workgroup &optional frame) - "Set the previous workgroup to WORKGROUP. -WORKGROUP should be a workgroup or nil." - (set-frame-parameter frame 'wg-previous-workgroup-uid - (when workgroup (wg-workgroup-uid workgroup)))) - -(defun wg-current-workgroup-p (workgroup &optional frame) - "Return t when WORKGROUP is the current workgroup, nil otherwise." - (wg-awhen (wg-current-workgroup t frame) - (eq workgroup it))) - -(defun wg-previous-workgroup-p (workgroup &optional frame) - "Return t when WORKGROUP is the previous workgroup, nil otherwise." - (wg-awhen (wg-previous-workgroup t frame) - (eq workgroup it))) - -(defmacro wg-with-current-workgroup (workgroup &rest body) - "Execute forms in BODY with WORKGROUP temporarily current. -WORKGROUP should be any workgroup identifier accepted by -`wg-get-workgroup'. The value returned is the last form -in BODY." - (declare (indent 1)) - `(let ((wg-current-workgroup (wg-get-workgroup ,workgroup))) - ,@body)) - -(defun wg-get-workgroup (obj &optional noerror) - "Return a workgroup from OBJ. -If OBJ is a workgroup, return it. -If OBJ is a string, return the workgroup named OBJ, or error unless NOERROR. -If OBJ is nil, return the current workgroup, or error unless NOERROR." - (cond ((wg-workgroup-p obj) obj) - ((stringp obj) (wg-find-workgroup-by :name obj noerror)) - ((null obj) (wg-current-workgroup noerror)) - (t (error "Can't get workgroup from type:: %S" (type-of obj))))) - - - -;;; workgroup parameters -;; -;; Quick test: -;; (wg-workgroup-parameters (wg-current-workgroup)) -;; (wg-set-workgroup-parameter (wg-current-workgroup) 'test1 t) -;; (wg-workgroup-parameter (wg-current-workgroup) 'test1) -(defun wg-workgroup-parameter (workgroup parameter &optional default) - "Return WORKGROUP's value for PARAMETER. -If PARAMETER is not found, return DEFAULT which defaults to nil. -WORKGROUP should be accepted by `wg-get-workgroup'." - (wg-aget (wg-workgroup-parameters (wg-get-workgroup workgroup)) - parameter default)) - -(defun wg-set-workgroup-parameter (workgroup parameter value) - "Set WORKGROUP's value of PARAMETER to VALUE. -WORKGROUP should be a value accepted by `wg-get-workgroup'. -Return VALUE." - (let ((workgroup (wg-get-workgroup workgroup))) - (wg-set-parameter (wg-workgroup-parameters workgroup) parameter value) - (wg-flag-workgroup-modified workgroup) - value)) - -(defun wg-remove-workgroup-parameter (workgroup parameter) - "Remove PARAMETER from WORKGROUP's parameters." - (let ((workgroup (wg-get-workgroup workgroup))) - (wg-flag-workgroup-modified workgroup) - (wg-asetf (wg-workgroup-parameters workgroup) (wg-aremove it parameter)))) - -(defun wg-workgroup-local-value (variable &optional workgroup) - "Return the value of VARIABLE in WORKGROUP. -WORKGROUP nil defaults to the current workgroup. If there is no -current workgroup, or if VARIABLE does not have a workgroup-local -binding in WORKGROUP, resolve VARIABLE with `wg-session-local-value'." - (let ((workgroup (wg-get-workgroup workgroup t))) - (if (not workgroup) (wg-session-local-value variable) - (let* ((undefined (cl-gensym)) - (value (wg-workgroup-parameter workgroup variable undefined))) - (if (not (eq value undefined)) value - (wg-session-local-value variable)))))) - -(defalias 'wg-local-value 'wg-workgroup-local-value) - - -;;; workgroup saved wconfigs - -(defun wg-workgroup-saved-wconfig-names (workgroup) - "Return a new list of the names of all WORKGROUP's saved wconfigs." - (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup))) - -(defun wg-workgroup-get-saved-wconfig (workgroup wconfig-or-name) - "Return the wconfig in WORKGROUP's saved wconfigs named WCONFIG-OR-NAME. -WCONFIG-OR-NAME must be either a string or a wconfig. If -WCONFIG-OR-NAME is a string and there is no saved wconfig with -that name, return nil. If WCONFIG-OR-NAME is a wconfig, and it -is a member of WORKGROUP's saved wconfigs, return is as given. -Otherwise return nil." - (let ((wconfigs (wg-workgroup-saved-wconfigs workgroup))) - (cl-etypecase wconfig-or-name - (wg-wconfig (car (memq wconfig-or-name wconfigs))) - (string (cl-find wconfig-or-name wconfigs - :key 'wg-wconfig-name - :test 'string=))))) - -(defun wg-workgroup-save-wconfig (workgroup wconfig) - "Add WCONFIG to WORKGROUP's saved wconfigs. WCONFIG must have -a name. If there's already a wconfig with the same name in -WORKGROUP's saved wconfigs, replace it." - (let ((name (wg-wconfig-name wconfig))) - (unless name (error "Attempt to save a nameless wconfig")) - (setf (wg-workgroup-modified workgroup) t) - (wg-asetf (wg-workgroup-saved-wconfigs workgroup) - (cons wconfig (cl-remove name it - :key 'wg-wconfig-name - :test 'string=))))) - -(defun wg-workgroup-kill-saved-wconfig (workgroup wconfig-or-name) - "Delete WCONFIG-OR-NAME from WORKGROUP's saved wconfigs. -WCONFIG-OR-NAME is resolved with `wg-workgroup-get-saved-wconfig'." - (wg-when-let ((wconfig (wg-workgroup-get-saved-wconfig - workgroup wconfig-or-name))) - (wg-asetf (wg-workgroup-saved-wconfigs workgroup) (remq wconfig it) - (wg-workgroup-modified workgroup) t))) - - - -(defun wg-workgroup-base-wconfig-buf-uids (workgroup) - "Return a new list of all unique buf uids in WORKGROUP's working wconfig." - (wg-wconfig-buf-uids (wg-workgroup-base-wconfig workgroup))) - -(defun wg-workgroup-saved-wconfigs-buf-uids (workgroup) - "Return a new list of all unique buf uids in WORKGROUP's base wconfig." - (cl-reduce 'wg-string-list-union - (wg-workgroup-saved-wconfigs workgroup) - :key 'wg-wconfig-buf-uids)) - -(defun wg-workgroup-all-wconfig-buf-uids (workgroup) - "Return a new list of all unique buf uids in WORKGROUP's wconfigs." - (cl-union (wg-workgroup-base-wconfig-buf-uids workgroup) - (wg-workgroup-saved-wconfigs-buf-uids workgroup) - :test 'string=)) - -(defun wg-workgroup-all-buf-uids (workgroup) - "Return a new list of all unique buf uids in WORKGROUP." - (cl-reduce 'wg-string-list-union - (list (wg-workgroup-base-wconfig-buf-uids workgroup) - (wg-workgroup-saved-wconfigs-buf-uids workgroup)))) - - - -;;; workgroup restoration - -(defun wg-restore-workgroup (workgroup) - "Restore WORKGROUP in `selected-frame'." - (let (wg-flag-modified) - (wg-restore-wconfig-undoably (wg-workgroup-working-wconfig workgroup) t))) - - -(defun wg-workgroup-list-or-error (&optional noerror) - "Return the value of `wg-current-session's :workgroup-list slot. -Or scream unless NOERROR." - (or (wg-workgroup-list) - (unless noerror - (error "No workgroups are defined")))) - -(defun wg-find-workgroup-by (slotkey value &optional noerror) - "Return the workgroup on which ACCESSOR returns VALUE or error." - (let ((accessor (cl-ecase slotkey - (:name 'wg-workgroup-name) - (:uid 'wg-workgroup-uid)))) - (or (cl-find value (wg-workgroup-list-or-error noerror) :test 'equal :key accessor) - (unless noerror - (error "No are no workgroups with a %S of %S" - accessor value))))) - -(defun wg-first-workgroup () - "Return a first workgroup." - (car (wg-workgroup-list-or-error))) - -(defun wg-cyclic-nth-from-workgroup (workgroup &optional n) - "Return the workgroup N places from WORKGROUP in `wg-workgroup-list'." - (wg-cyclic-nth-from-elt workgroup (wg-workgroup-list-or-error) (or n 1))) - - -(defun wg-read-workgroup-name (&optional require-match) - "Read a workgroup with `wg-completing-read'." - (wg-completing-read - "Workgroup: " (wg-workgroup-names) nil require-match nil nil - (wg-awhen (wg-current-workgroup t) (wg-workgroup-name it)))) - -(defun wg-new-default-workgroup-name () - "Return a new, unique, default workgroup name." - (let ((names (wg-workgroup-names t)) (index -1) result) - (while (not result) - (let ((new-name (format "wg%s" (cl-incf index)))) - (unless (member new-name names) - (setq result new-name)))) - result)) - -(defun wg-unique-workgroup-name-p (new-name) - "Return t if NEW-NAME is unique in `wg-workgroup-list', nil otherwise." - (cl-every (lambda (existing-name) (not (equal new-name existing-name))) - (wg-workgroup-names t))) - -(defun wg-read-new-workgroup-name (&optional prompt) - "Read a non-empty name string from the minibuffer." - (let ((default (wg-new-default-workgroup-name))) - (wg-read-object - (or prompt (format "Name (default: %S): " default)) - (lambda (new) (and (stringp new) - (not (equal new "")) - (wg-unique-workgroup-name-p new))) - "Please enter a unique, non-empty name" - nil nil nil nil default))) - -(defun wg-read-workgroup-index () - "Prompt for the index of a workgroup." - (let ((max (1- (length (wg-workgroup-list-or-error))))) - (wg-read-object - (format "%s\n\nEnter [0-%d]: " (wg-workgroup-list-display) max) - (lambda (obj) (and (integerp obj) (wg-within obj 0 max t))) - (format "Please enter an integer [%d-%d]" 0 max) - nil nil t))) - -(defun wg-read-saved-wconfig-name (workgroup &optional prompt require-match) - "Read the name of a saved wconfig, completing on the names of -WORKGROUP's saved wconfigs." - (wg-completing-read - (or prompt "Saved wconfig name: ") - (wg-workgroup-saved-wconfig-names workgroup) - nil require-match)) - -(defun wg-read-saved-wconfig (workgroup) - "Read the name of and return one of WORKGROUP's saved wconfigs." - (wg-workgroup-get-saved-wconfig - workgroup (wg-read-saved-wconfig-name workgroup nil t))) - - -;;; workgroup-list reorganization commands - -(defun wg-swap-workgroups () - "Swap the previous and current workgroups." - (interactive) - (wg-swap-workgroups-in-workgroup-list - (wg-current-workgroup) (wg-previous-workgroup)) - (wg-fontified-message - (:cmd "Swapped: ") - (wg-workgroup-list-display))) - -(defun wg-offset-workgroup-left (&optional workgroup n) - "Offset WORKGROUP leftward in `wg-workgroup-list' cyclically." - (interactive (list nil current-prefix-arg)) - (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n -1)) - (wg-fontified-message - (:cmd "Offset left: ") - (wg-workgroup-list-display))) - -(defun wg-offset-workgroup-right (&optional workgroup n) - "Offset WORKGROUP rightward in `wg-workgroup-list' cyclically." - (interactive (list nil current-prefix-arg)) - (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n 1)) - (wg-fontified-message - (:cmd "Offset right: ") - (wg-workgroup-list-display))) - - -;;; undo/redo commands - -(defun wg-undo-wconfig-change (&optional workgroup) - "Undo a change to the current workgroup's window-configuration." - (interactive) - (let* ((workgroup (wg-get-workgroup workgroup)) - (undid? (wg-workgroup-offset-position-in-undo-list workgroup 1))) - (wg-fontified-message - (:cmd "Undo") - (:cur (if undid? "" " No more undo info"))))) - -(defun wg-redo-wconfig-change (&optional workgroup) - "Redo a change to the current workgroup's window-configuration." - (interactive) - (let* ((workgroup (wg-get-workgroup workgroup)) - (redid? (wg-workgroup-offset-position-in-undo-list workgroup -1))) - (wg-fontified-message - (:cmd "Redo") - (:cur (if redid? "" " No more redo info"))))) - -(defun wg-undo-once-all-workgroups () - "Do what the name says. Useful for instance when you -accidentally call `wg-revert-all-workgroups' and want to return -all workgroups to their un-reverted state." - (interactive) - (mapc 'wg-undo-wconfig-change (wg-workgroup-list-or-error)) - (wg-message "Undid once on all workgroups.")) - -(defun wg-redo-once-all-workgroups () - "Do what the name says. Probably useless. Included for -symetry with `wg-undo-once-all-workgroups'." - (interactive) - (mapc 'wg-redo-wconfig-change (wg-workgroup-list-or-error)) - (wg-message "Redid once on all workgroups.")) - - - -;;; 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-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))) - - -;;; 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"))) - - -(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)))) - - -;;; 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 switching commands -(defun wg-switch-to-workgroup (workgroup &optional noerror) - "Switch to WORKGROUP. -NOERROR means fail silently." - (interactive (list (wg-read-workgroup-name))) - ;; Mark if ECB is active - (if (wg-current-workgroup t) - (wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb (and (boundp 'ecb-minor-mode) - ecb-minor-mode))) - ;;(wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config (ecb-current-window-configuration)) - ;; (type-of (ecb-current-window-configuration)) - ;; (type-of (car (ecb-current-window-configuration))) - ;; (type-of (car (nthcdr 3 (ecb-current-window-configuration)))) - ;; (wg-pickelable-or-error (ecb-current-window-configuration)) - ;;(ecb-current-window-configuration) - ;;) - - (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) - (boundp 'ecb-frame) - (fboundp 'ecb-deactivate) - 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) - (fboundp 'ecb-activate) - (wg-workgroup-parameter (wg-current-workgroup t) 'ecb nil)) - (let ((ecb-split-edit-window-after-start 'before-deactivation)) - (ecb-activate))) - ;;(ecb-last-window-config-before-deactivation - ;; (wg-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config nil))) - - (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-previous-workgroup () - "Switch to the previous workgroup." - (interactive) - (wg-switch-to-workgroup (wg-previous-workgroup))) - - - -;;; 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)))) - -(defun wg-delete-other-workgroups (&optional workgroup) - "Delete all workgroups but WORKGROUP." - (interactive) - (let ((workgroup (wg-get-workgroup workgroup))) - (unless (or wg-no-confirm-on-destructive-operation - (y-or-n-p "Really delete all other workgroups? ")) - (error "Cancelled")) - (dolist (w (wg-workgroup-list-or-error)) - (unless (eq w workgroup) - (wg-delete-workgroup w))) - (unless (wg-current-workgroup-p workgroup) - (wg-switch-to-workgroup workgroup)) - (wg-fontified-message - (:cmd "Deleted: ") - (:msg "All workgroups but ") - (:cur (wg-workgroup-name workgroup))))) - - - -;;; workgroup updating and reverting commands - -(defun wg-revert-workgroup (&optional workgroup) - "Restore WORKGROUP's window configuration to its state at the last save." - (interactive) - (let* ((workgroup (wg-get-workgroup workgroup)) - (base-wconfig (wg-workgroup-base-wconfig workgroup))) - (if (wg-current-workgroup-p workgroup) - (wg-restore-wconfig-undoably base-wconfig) - (wg-add-wconfig-to-undo-list workgroup base-wconfig)) - (wg-fontified-message - (:cmd "Reverted: ") - (:cur (wg-workgroup-name workgroup))))) - -(defun wg-revert-all-workgroups () - "Revert all workgroups to their base wconfigs. -Only workgroups' working-wconfigs in `selected-frame' are -reverted." - (interactive) - (mapc #'wg-revert-workgroup (wg-workgroup-list-or-error)) - (wg-fontified-message - (:cmd "Reverted: ") - (:msg "All"))) - - - -;;; workgroup working-wconfig and wconfig undo/redo - -(defun wg-workgroup-state-table (&optional frame) - "Return FRAME's workgroup table, creating it first if necessary." - (or (frame-parameter frame 'wg-workgroup-state-table) - (let ((wtree (make-hash-table :test 'equal))) - (set-frame-parameter frame 'wg-workgroup-state-table wtree) - wtree))) - -(defun wg-get-workgroup-state (workgroup &optional frame) - "Return WORKGROUP's state table in a FRAME." - (let ((uid (wg-workgroup-uid workgroup)) - (state-table (wg-workgroup-state-table frame))) - (or (gethash uid state-table) - (let ((wgs (wg-make-workgroup-state - :undo-pointer 0 - :undo-list - (list (or (wg-workgroup-selected-frame-wconfig workgroup) - (wg-workgroup-base-wconfig workgroup)))))) - (puthash uid wgs state-table) - wgs)))) - -(defmacro wg-with-undo (workgroup spec &rest body) - "Bind WORKGROUP's undo state to SPEC and eval BODY." - (declare (indent 2)) - (wg-dbind (state undo-pointer undo-list) spec - `(let* ((,state (wg-get-workgroup-state ,workgroup)) - (,undo-pointer (wg-workgroup-state-undo-pointer ,state)) - (,undo-list (wg-workgroup-state-undo-list ,state))) - ,@body))) - -(defun wg-flag-just-exited-minibuffer () - "Added to `minibuffer-exit-hook'." - (setq wg-just-exited-minibuffer t)) - -(defun wg-flag-window-configuration-changed () - "Set `wg-window-configuration-changed' to t. -But only if not the minibuffer was just exited. Added to -`window-configuration-change-hook'." - (if wg-just-exited-minibuffer - (setq wg-just-exited-minibuffer nil) - (setq wg-window-configuration-changed t))) - -(defun wg-unflag-undoify-window-configuration-change () - "Set `wg-undoify-window-configuration-change' to nil, exempting -from undoification any window-configuration changes caused by the -current command." - (setq wg-undoify-window-configuration-change nil)) - -(defun wg-set-workgroup-working-wconfig (workgroup wconfig) - "Set the working-wconfig of WORKGROUP to WCONFIG." - (wg-flag-workgroup-modified workgroup) - (setf (wg-workgroup-selected-frame-wconfig workgroup) wconfig) - (wg-with-undo workgroup (state undo-pointer undo-list) - (setcar (nthcdr undo-pointer undo-list) wconfig))) - -(defun wg-add-wconfig-to-undo-list (workgroup wconfig) - "Add WCONFIG to WORKGROUP's undo list, truncating its future if necessary." - (wg-with-undo workgroup (state undo-pointer undo-list) - (let ((undo-list (cons nil (nthcdr undo-pointer undo-list)))) - (wg-awhen (nthcdr wg-wconfig-undo-list-max undo-list) (setcdr it nil)) - (setf (wg-workgroup-state-undo-list state) undo-list)) - (setf (wg-workgroup-state-undo-pointer state) 0)) - (wg-set-workgroup-working-wconfig workgroup wconfig)) - -(defun wg-workgroup-working-wconfig (workgroup &optional noupdate) - "Return WORKGROUP's working-wconfig. -If WORKGROUP is the current workgroup in `selected-frame', and -NOUPDATE is nil, set its working wconfig in `selected-frame' to -`wg-current-wconfig' and return the updated wconfig. Otherwise -return WORKGROUP's current undo state." - (if (and (not noupdate) (wg-current-workgroup-p workgroup)) - (wg-set-workgroup-working-wconfig workgroup (wg-current-wconfig)) - (wg-with-undo workgroup (state undo-pointer undo-list) - (nth undo-pointer undo-list)))) - -(defun wg-update-current-workgroup-working-wconfig () - "Update `selected-frame's current workgroup's working-wconfig with `wg-current-wconfig'." - (wg-awhen (wg-current-workgroup t) - (wg-set-workgroup-working-wconfig it (wg-current-wconfig)))) - -(defun wg-restore-wconfig-undoably (wconfig &optional noundo) - "Restore WCONFIG in `selected-frame', saving undo information. -Skip undo when NOUNDO." - (when noundo (wg-unflag-undoify-window-configuration-change)) - (wg-update-current-workgroup-working-wconfig) - (wg-restore-wconfig wconfig)) - -(defun wg-workgroup-offset-position-in-undo-list (workgroup increment) - "Increment WORKGROUP's undo-pointer by INCREMENT. -Also restore the wconfig at the incremented undo-pointer if -WORKGROUP is current." - (wg-with-undo workgroup (state undo-pointer undo-list) - (let ((new-pointer (+ undo-pointer increment))) - (when (wg-within new-pointer 0 (length undo-list)) - (when (wg-current-workgroup-p workgroup) - (wg-restore-wconfig-undoably (nth new-pointer undo-list) t)) - (setf (wg-workgroup-state-undo-pointer state) new-pointer))))) - -(defun wg-undoify-window-configuration-change () - "Conditionally `wg-add-wconfig-to-undo-list'. -Added to `post-command-hook'." - (when (and - wg-window-configuration-changed ;; When the window config has changed, - wg-undoify-window-configuration-change ;; and undoification is still on for the current command - (wg-minibuffer-inactive-p)) ;; and the change didn't occur while the minibuffer is active, - (wg-when-let ((workgroup (wg-current-workgroup t))) ;; and there's a current workgroup, - ;; add the current wconfig to that workgroup's undo list: - (wg-add-wconfig-to-undo-list workgroup (wg-current-wconfig)))) - ;; Reset all flags no matter what: - (setq wg-window-configuration-changed nil - wg-undoify-window-configuration-change t - wg-already-updated-working-wconfig nil)) - -(defun wg-update-working-wconfig-hook () - "Used in before advice on all functions that trigger `window-configuration-change-hook'. -To save up to date undo info before the change." - (when (and (not wg-already-updated-working-wconfig) - (wg-minibuffer-inactive-p)) - (wg-update-current-workgroup-working-wconfig) - (setq wg-already-updated-working-wconfig t))) - - -(defun wg-workgroup-gc-buf-uids (workgroup) - "Remove buf uids from WORKGROUP that have no referent in `wg-buf-list'." - (wg-asetf (wg-workgroup-strong-buf-uids workgroup) - (cl-remove-if-not 'wg-find-buf-by-uid it) - (wg-workgroup-weak-buf-uids workgroup) - (cl-remove-if-not 'wg-find-buf-by-uid it))) - -(defun wg-gc-buf-uids () - "Remove from all workgroups those buf uids that have no referent in `wg-buf-list'." - (mapc 'wg-workgroup-gc-buf-uids (wg-workgroup-list))) - - - -(defun wg-display-internal (elt-fn list) - "Return display string built by calling ELT-FN on each element of LIST." - (let ((div (wg-add-face :div wg-list-display-decor-divider)) - (wwidth (window-width (minibuffer-window))) - (i -1) - (str)) - (setq str - (wg-fontify - (:brace wg-list-display-decor-left-brace) - (if (not list) (funcall elt-fn nil nil) - (wg-doconcat (elt list div) (funcall elt-fn elt (cl-incf i)))) - (:brace wg-list-display-decor-right-brace))) - ;; (subseq str 0 wwidth) - )) - -(defun wg-workgroup-list-display (&optional workgroup-list) - "Return the Workgroups list display string. -The string contains the names of all workgroups in `wg-workgroup-list', -decorated with faces, dividers and strings identifying the -current and previous workgroups." - (wg-display-internal 'wg-workgroup-display - (or workgroup-list (wg-workgroup-list)))) - -(defun wg-create-first-wg () - "Create a first workgroup if needed." - (if (and workgroups-mode - wg-session-load-on-start - (= (length (wg-workgroup-list)) 0)) - (wg-create-workgroup wg-first-wg-name))) - - -(defun wg-pickel-workgroup-parameters (workgroup) - "Return a copy of WORKGROUP after pickeling its parameters. -If WORKGROUP's parameters are non-nil, otherwise return -WORKGROUP." - (if (not (wg-workgroup-parameters workgroup)) workgroup - (let ((copy (wg-copy-workgroup workgroup))) - (wg-asetf (wg-workgroup-parameters copy) (wg-pickel it)) - copy))) - -(defun wg-unpickel-workgroup-parameters (workgroup) - "If WORKGROUP's parameters are non-nil, return a copy of -WORKGROUP after unpickeling its parameters. Otherwise return -WORKGROUP." - (if (not (wg-workgroup-parameters workgroup)) workgroup - (let ((copy (wg-copy-workgroup workgroup))) - (wg-asetf (wg-workgroup-parameters copy) (wg-unpickel it)) - copy))) - -;;; workgroup-list ops - -(defun wg-delete-workgroup (workgroup) - "Remove WORKGROUP from `wg-workgroup-list'. -Also delete all references to it by `wg-workgroup-state-table', -`wg-current-workgroup' and `wg-previous-workgroup'." - (dolist (frame (frame-list)) - (remhash (wg-workgroup-uid workgroup) (wg-workgroup-state-table frame)) - (when (wg-current-workgroup-p workgroup frame) - (wg-set-current-workgroup nil frame)) - (when (wg-previous-workgroup-p workgroup frame) - (wg-set-previous-workgroup nil frame))) - (setf (wg-workgroup-list) (remove workgroup (wg-workgroup-list-or-error))) - (setf (wg-session-modified (wg-current-session)) t) - workgroup) - -(defun wg-add-workgroup (workgroup &optional index) - "Add WORKGROUP to `wg-workgroup-list' at INDEX or the end. -If a workgroup with the same name exists, overwrite it." - (wg-awhen (wg-find-workgroup-by :name (wg-workgroup-name workgroup) t) - (unless index (setq index (cl-position it (wg-workgroup-list-or-error)))) - (wg-delete-workgroup it)) - (wg-asetf (wg-workgroup-list) - (wg-insert-before workgroup it (or index (length it)))) - (setf (wg-session-modified (wg-current-session)) t) - workgroup) - -(defun wg-check-and-add-workgroup (workgroup) - "Add WORKGROUP to `wg-workgroup-list'. -Ask to overwrite if a workgroup with the same name exists." - (let ((name (wg-workgroup-name workgroup)) - (uid (wg-workgroup-uid workgroup))) - (when (wg-find-workgroup-by :uid uid t) - (error "A workgroup with uid %S already exists" uid)) - (when (wg-find-workgroup-by :name name t) - (unless (or wg-no-confirm-on-destructive-operation - (y-or-n-p (format "%S exists. Overwrite? " name))) - (error "Cancelled")))) - (wg-add-workgroup workgroup)) - -(defun wg-make-and-add-workgroup (name &optional blank) - "Create a workgroup named NAME with current `window-tree'. -If BLANK - then just scratch buffer. -Add it with `wg-check-and-add-workgroup'." - (wg-check-and-add-workgroup - (wg-make-workgroup - :name name - :base-wconfig (if blank (wg-make-blank-wconfig) - (wg-current-wconfig))))) - -(defun wg-get-workgroup-create (workgroup) - "Return the workgroup specified by WORKGROUP, creating a new one if needed. -If `wg-get-workgroup' on WORKGROUP returns a workgroup, return it. -Otherwise, if WORKGROUP is a string, create a new workgroup with -that name and return it. Otherwise error." - (or (wg-get-workgroup workgroup t) - (if (stringp workgroup) - (when (or (not wg-confirm-on-get-workgroup-create) - (y-or-n-p (format "%S doesn't exist. Create it? " - workgroup))) - (wg-make-and-add-workgroup workgroup)) - ;; Call this again for its error message - (wg-get-workgroup workgroup)))) - -(defun wg-cyclic-offset-workgroup (workgroup n) - "Offset WORKGROUP's position in `wg-workgroup-list' by N." - (let ((workgroup-list (wg-workgroup-list-or-error))) - (unless (member workgroup workgroup-list) - (error "Workgroup isn't present in `wg-workgroup-list'.")) - (setf (wg-workgroup-list) (wg-cyclic-offset-elt workgroup workgroup-list n) - (wg-session-modified (wg-current-session)) t))) - -(defun wg-swap-workgroups-in-workgroup-list (workgroup1 workgroup2) - "Swap the positions of WORKGROUP1 and WORKGROUP2 in `wg-workgroup-list'." - (let ((workgroup-list (wg-workgroup-list-or-error))) - (when (eq workgroup1 workgroup2) - (error "Can't swap a workgroup with itself")) - (unless (and (memq workgroup1 workgroup-list) - (memq workgroup2 workgroup-list)) - (error "Both workgroups aren't present in `wg-workgroup-list'.")) - (setf (wg-workgroup-list) (wg-util-swap workgroup1 workgroup2 workgroup-list) - (wg-session-modified (wg-current-session)) t))) - - -(provide 'workgroups-workgroup) -;;; workgroups-workgroup.el ends here diff --git a/src/workgroups-wtree.el b/src/workgroups-wtree.el deleted file mode 100644 index 4392f1c2edee7f4b9e08f139baf01ed97c7ffc17..0000000000000000000000000000000000000000 --- a/src/workgroups-wtree.el +++ /dev/null @@ -1,204 +0,0 @@ -;;; workgroups-wtree.el --- window-tree "class" -;;; Commentary: -;; -;; `window-tree' - several opened windows, their sizes and position is -;; what you want to save. -;; -;;; Code: - -(require 'workgroups-win) - -(defun wg-w-edges (w) - "Return W's edge list." - (cl-etypecase w - (wg-win (wg-win-edges w)) - (wg-wtree (wg-wtree-edges w)))) - -(defun wg-copy-w (w) - "Return a copy of W. W should be a wg-win or a wg-wtree." - (cl-etypecase w - (wg-win (wg-copy-win w)) - (wg-wtree (wg-copy-wtree w)))) - -(defun wg-set-edges (w edges) - "Set W's edge list, and return W." - (cl-etypecase w - (wg-win (setf (wg-win-edges w) edges)) - (wg-wtree (setf (wg-wtree-edges w) edges))) - w) - - -(defun wg-equal-wtrees (w1 w2) - "Return t when W1 and W2 have equal structure." - (cond ((and (wg-win-p w1) (wg-win-p w2)) - (equal (wg-w-edges w1) (wg-w-edges w2))) - ((and (wg-wtree-p w1) (wg-wtree-p w2)) - (and (eq (wg-wtree-dir w1) (wg-wtree-dir w2)) - (equal (wg-wtree-edges w1) (wg-wtree-edges w2)) - (cl-every #'wg-equal-wtrees - (wg-wtree-wlist w1) - (wg-wtree-wlist w2)))))) - -(defun wg-normalize-wtree (wtree) - "Clean up and return a new wtree from WTREE. -Recalculate the edge lists of all subwins, and remove subwins -outside of WTREE's bounds. If there's only one element in the -new wlist, return it instead of a new wtree." - (if (wg-win-p wtree) wtree - (wg-with-slots wtree ((dir wg-wtree-dir) - (wlist wg-wtree-wlist)) - (wg-with-bounds wtree dir (ls1 hs1 lb1 hb1) - (let* ((min-size (wg-min-size dir)) - (max (- hb1 1 min-size)) - (lastw (wg-last1 wlist))) - (cl-labels - ((mapwl - (wl) - (wg-dbind (sw . rest) wl - (cons (wg-normalize-wtree - (wg-set-bounds - sw dir ls1 hs1 lb1 - (setq lb1 (if (eq sw lastw) hb1 - (let ((hb2 (+ lb1 (wg-w-size sw dir)))) - (if (>= hb2 max) hb1 hb2)))))) - (when (< lb1 max) (mapwl rest)))))) - (let ((new (mapwl wlist))) - (if (not (cdr new)) (car new) - (setf (wg-wtree-wlist wtree) new) - wtree)))))))) - -(defun wg-scale-wtree (wtree wscale hscale) - "Return a copy of WTREE with its dimensions scaled by WSCALE and HSCALE. -All WTREE's subwins are scaled as well." - (let ((scaled (wg-scale-w-size wtree wscale hscale))) - (if (wg-win-p wtree) scaled - (wg-asetf (wg-wtree-wlist scaled) - (wg-docar (sw it) (wg-scale-wtree sw wscale hscale))) - scaled))) - - -(defun wg-resize-frame-scale-wtree (wconfig) - "Set FRAME's size to WCONFIG's, returning a possibly scaled wtree. -If the frame size was set correctly, return WCONFIG's wtree -unchanged. If it wasn't, return a copy of WCONFIG's wtree scaled -with `wg-scale-wconfigs-wtree' to fit the frame as it exists." - (let ((frame (selected-frame))) - (wg-with-slots wconfig ((wcwidth wg-wconfig-width) - (wcheight wg-wconfig-height)) - (when window-system (set-frame-size frame wcwidth wcheight)) - (let ((fwidth (frame-parameter frame 'width)) - (fheight (frame-parameter frame 'height))) - (if (and (= wcwidth fwidth) (= wcheight fheight)) - (wg-wconfig-wtree wconfig) - (wg-scale-wconfigs-wtree wconfig fwidth fheight)))))) - - -(defun wg-wtree-buf-uids (wtree) - "Return a new list of the buf uids of all wins in WTREE." - (if (not wtree) - (error "WTREE is nil in `wg-wtree-buf-uids'!")) - (wg-flatten-wtree wtree 'wg-win-buf-uid)) - -(defun wg-wtree-unique-buf-uids (wtree) - "Return a list of the unique buf uids of all wins in WTREE." - (cl-remove-duplicates (wg-wtree-buf-uids wtree) :test 'string=)) - - - - -(defun wg-reset-window-tree () - "Delete all but one window in `selected-frame', and reset -various parameters of that window in preparation for restoring -a wtree." - (delete-other-windows) - (set-window-dedicated-p nil nil)) - -(defun wg-restore-window-tree-helper (w) - "Recursion helper for `wg-restore-window-tree'." - (if (wg-wtree-p w) - (cl-loop with dir = (wg-wtree-dir w) - for (win . rest) on (wg-wtree-wlist w) - do (when rest (split-window nil (wg-w-size win dir) (not dir))) - do (wg-restore-window-tree-helper win)) - (wg-restore-window w) - (when (wg-win-selected w) - (setq wg-window-tree-selected-window (selected-window))) - (when (wg-win-minibuffer-scroll w) - (setq minibuffer-scroll-window (selected-window))) - (other-window 1))) - -(defun wg-restore-window-tree (wtree) - "Restore WTREE in `selected-frame'." - (let ((window-min-width wg-window-min-width) - (window-min-height wg-window-min-height) - (wg-window-tree-selected-window nil)) - (wg-reset-window-tree) - (wg-restore-window-tree-helper wtree) - (wg-awhen wg-window-tree-selected-window (select-window it)))) - - -;; (wg-window-tree-to-wtree (window-tree)) -(defun wg-window-tree-to-wtree (window-tree) - "Return the serialization (a wg-wtree) of Emacs window tree WINDOW-TREE." - (wg-barf-on-active-minibuffer) - (cl-labels - ((inner (w) (if (windowp w) (wg-window-to-win w) - (wg-dbind (dir edges . wins) w - (wg-make-wtree - :dir dir - :edges edges - :wlist (mapcar #'inner wins)))))) - (let ((w (car window-tree))) - (when (and (windowp w) (window-minibuffer-p w)) - (error "Workgroups can't operate on minibuffer-only frames.")) - (inner w)))) - - -(defun wg-flatten-wtree (wtree &optional key) - "Return a new list by flattening WTREE. -KEY non returns returns a list of WTREE's wins. -KEY non-nil returns a list of the results of calling KEY on each win." - (cl-labels - ((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w)) - (cl-mapcan #'inner (wg-wtree-wlist w))))) - (inner wtree))) - -(defun wg-win-list (wtree) - "Construct and return a list of all wg-wins in WTREE." - (wg-flatten-wtree wtree)) - - -(defun wg-reverse-wlist (w &optional dir) - "Reverse W's wlist and those of all its sub-wtrees in direction DIR. -If DIR is nil, reverse WTREE horizontally. -If DIR is 'both, reverse WTREE both horizontally and vertically. -Otherwise, reverse WTREE vertically." - (cl-labels - ((inner (w) (if (wg-win-p w) w - (wg-with-slots w ((d1 wg-wtree-dir)) - (wg-make-wtree - :dir d1 - :edges (wg-wtree-edges w) - :wlist (let ((wl2 (mapcar #'inner (wg-wtree-wlist w)))) - (if (or (eq dir 'both) (eq dir d1)) - (nreverse wl2) - wl2))))))) - (wg-normalize-wtree (inner w)))) - -(defun wg-wtree-move-window (wtree offset) - "Offset `selected-window' OFFSET places in WTREE." - (cl-labels - ((inner (w) (if (wg-win-p w) w - (wg-with-slots w ((wlist wg-wtree-wlist)) - (wg-make-wtree - :dir (wg-wtree-dir w) - :edges (wg-wtree-edges w) - :wlist (wg-aif (cl-find t wlist :key 'wg-win-selected) - (wg-cyclic-offset-elt it wlist offset) - (mapcar #'inner wlist))))))) - (wg-normalize-wtree (inner wtree)))) - - - -(provide 'workgroups-wtree) -;;; workgroups-wtree.el ends here diff --git a/src/workgroups2.el b/src/workgroups2.el index 84596ff7808e60d3c29543d2757fbe8962abdbe6..3bf8e9e20791c5a6107e07bef726a4c0e0e8e892 100644 --- a/src/workgroups2.el +++ b/src/workgroups2.el @@ -1,4 +1,5 @@ ;;; workgroups2.el --- New workspaces for Emacs +;;; -*- coding: utf-8; lexical-binding: t -*- ;; ;; Copyright (C) 2013-2014 Sergey Pashinin ;; Copyright (C) 2010-2011 tlh @@ -6,7 +7,8 @@ ;; Author: Sergey Pashinin ;; Keywords: session management window-configuration persistence ;; Homepage: https://github.com/pashinin/workgroups2 -;; Package-Requires: ((cl-lib "0.4")) +;; Version: 1.2.0 +;; Package-Requires: ((cl-lib "0.4") (dash "2.8.0") (anaphora "1.0.0") (f "0.17")) ;; ;; 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 @@ -83,42 +85,4455 @@ ;; ;;; Code: -(require 'workgroups-pickel) -(require 'workgroups-faces) -(require 'workgroups-advice) -(require 'workgroups-modeline) -(require 'workgroups-keys) -(require 'workgroups-session) +(require 'cl-lib) +(require 'f) +(require 'dash) +(require 'ring) +(require 'anaphora) -(define-minor-mode workgroups-everywhere - "Use Workgroups' buffer list filters everywhere `read-buffer' is used." - :global t +(defconst wg-version "1.2.0" "Current version of Workgroups.") + +(defgroup workgroups nil + "Workgroups for Emacs -- Emacs session manager" + :group 'convenience) + +(defcustom wg-session-file "~/.emacs_workgroups" + "Default filename to be used to save workgroups." + :type 'file + :group 'workgroups) +(defvaralias 'wg-default-session-file 'wg-session-file) + +(defcustom wg-prefix-key (kbd "C-c z") + "Workgroups' prefix key. +Setting this variable requires that `workgroups-mode' be turned +off and then on again to take effect." + :type 'string + :group 'workgroups) + +(defvar workgroups-mode-map nil "Workgroups Mode's keymap.") + +(defvar wg-incorrectly-restored-bufs nil + "FIXME: docstring this.") +;; TODO: check it on switching WG + +(defvar wg-record-incorrectly-restored-bufs nil + "FIXME: docstring this.") + +(defvar wg-log-level 1 + "Use later. +0 means no messages at all (for tests)") + +(defcustom wg-emacs-exit-save-behavior 'save + "Determines save behavior on Emacs exit. + +`ask' Ask the user whether to save if there are unsaved changes +`save' Call `wg-save-session' when there are unsaved changes +Anything else Exit Emacs without saving changes" + :type 'symbol + :group 'workgroups) + +(defcustom wg-workgroups-mode-exit-save-behavior 'save + "Determines save behavior on `workgroups-mode' exit. + +`ask' Ask the user whether to saveif there are unsaved changes +`save' Call `wg-save-session' when there are unsaved changes +Anything else Exit `workgroups-mode' without saving changes" + :type 'symbol + :group 'workgroups) + +(defcustom wg-session-load-on-start (not (daemonp)) + "Load a session file on Workgroups start. +Don't do it with Emacs --daemon option." + :type 'boolean + :group 'workgroups) +(defvaralias 'wg-use-default-session-file 'wg-session-load-on-start) + +(defcustom workgroups-mode nil + "Non-nil if Workgroups mode is enabled." + :set 'custom-set-minor-mode + :initialize 'custom-initialize-default + :group 'workgroups + :type 'boolean) + +(defcustom wg-first-wg-name "First workgroup" + "Title of the first workgroup created." + :type 'string + :group 'workgroups) + +(defcustom wg-modeline-string " wg" + "Appears in modeline." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-display-on (not (featurep 'powerline)) + "Toggles Workgroups' mode-line display." + :type 'boolean + :group 'workgroups + :set (lambda (sym val) + (custom-set-default sym val) + (force-mode-line-update))) + +(defcustom wg-mode-line-use-faces nil + "Non-nil means use faces in the mode-line display. +It can be tricky to choose faces that are visible in both active +and inactive mode-lines, so this feature defaults to off." + :type 'boolean + :group 'workgroups) + +(defcustom wg-mode-line-decor-left-brace "(" + "String displayed at the left of the mode-line display." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-right-brace ")" + "String displayed at the right of the mode-line display." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-divider ":" + "String displayed between elements of the mode-line display." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-window-dedicated + #("#" 0 1 (help-echo "This window is dedicated to its buffer.")) + "Indicates that the window is dedicated to its buffer." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-window-undedicated + #("-" 0 1 (help-echo "This window is not dedicated to its buffer.")) + "Indicates that the window is not dedicated to its buffer." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-session-modified + #("*" 0 1 (help-echo "The session is modified")) + "Indicates that the session is modified." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-session-unmodified + #("-" 0 1 (help-echo "The session is unmodified")) + "Indicates that the session is unmodified." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-workgroup-modified + #("*" 0 1 (help-echo "The current workgroup is modified")) + "Indicates that the current workgroup is modified." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-workgroup-unmodified + #("-" 0 1 (help-echo "The current workgroup is unmodified")) + "Indicates that the current workgroup is unmodified." + :type 'string + :group 'workgroups) + +(defcustom wg-load-last-workgroup t + "Load last active (not first) workgroup from all your workgroups if it exists." + :group 'workgroups + :type 'boolean) + +(defcustom wg-control-frames t + "Save/restore frames." + :group 'workgroups + :type 'boolean) + +(defcustom workgroups-mode-hook nil + "Hook run when `workgroups-mode' is turned on." + :type 'hook + :group 'workgroups) + +(defcustom workgroups-mode-exit-hook nil + "Hook run when `workgroups-mode' is turned off." + :type 'hook + :group 'workgroups) + +(defcustom wg-before-switch-to-workgroup-hook nil + "Hook run by `wg-switch-to-workgroup'." + :type 'hook + :group 'workgroups) + +(defcustom wg-after-switch-to-workgroup-hook nil + "Hook run by `wg-switch-to-workgroup'." + :type 'hook + :group 'workgroups) +(define-obsolete-variable-alias 'wg-switch-to-workgroup-hook 'wg-after-switch-to-workgroup-hook) + +(defcustom wg-pre-window-configuration-change-hook nil + "Hook run before any function that triggers `window-configuration-change-hook'." + :type 'hook + :group 'workgroups) + +(defcustom wg-open-this-wg nil + "Try to open this workgroup on start. +If nil - nothing happens." + :type 'string + :group 'workgroups) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; FIXME: +;; +;; Only set `wg-workgroup-base-wconfig' on `wg-save-session-as' or +;; `delete-frame' and only with the most recently changed working-wconfig. +;; Then, since it's not overwritten on every call to +;; `wg-workgroup-working-wconfig', its restoration can be retried after manually +;; recreating buffers that couldn't be restored. So it takes over the +;; 'incorrect restoration' portion of the base wconfig's duty. All that leaves +;; to base wconfigs is that they're a saved wconfig the user felt was important. +;; So why not allow more of of them? A workgroup could stash an unlimited +;; number of wconfigs. +;; +;; TODO: +;; +;; * Write new commands for restoring stashed wconfigs +;; +;; * Add this message on improper restoration of `base-wconfig': +;; +;; "Unable to restore 'buf1', 'buf2'... Hit C-whatever to retry after +;; manually recreating these buffers." +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; TODO: possibly add `buffer-file-coding-system', `text-scale-mode-amount' +(defcustom wg-buffer-local-variables-alist + `((major-mode nil wg-deserialize-buffer-major-mode) + (mark-ring wg-serialize-buffer-mark-ring wg-deserialize-buffer-mark-ring) + (left-fringe-width nil nil) + (right-fringe-width nil nil) + (fringes-outside-margins nil nil) + (left-margin-width nil nil) + (right-margin-width nil nil) + (vertical-scroll-bar nil nil)) + "Alist mapping buffer-local variable symbols to serdes functions. + +The `car' of each entry should be a buffer-local variable symbol. + +The `cadr' of the entry should be either nil or a function of no +arguments. If nil, the variable's value is used as-is, and +should have a readable printed representation. If a function, +`funcall'ing it should yield a serialization of the value of the +variable. + +The `caddr' of the entry should be either nil or a function of +one argument. If nil, the serialized value from above is +assigned to the variable as-is. It a function, `funcall'ing it +on the serialized value from above should do whatever is +necessary to properly restore the original value of the variable. +For example, in the case of `major-mode' it should funcall the +value (a major-mode function symbol) rather than just assigning +it to `major-mode'." + :type 'alist + :group 'workgroups) + + +(defcustom wg-nowg-string "No workgroups" + "Display this string if there are no workgroups and +`wg-display-nowg' is t." + :type 'string + :group 'workgroups) + +(defcustom wg-display-nowg nil + "Display something if there are no workgroups." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-remote-buffers t + "Restore buffers that get \"t\" with `file-remote-p'." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-frame-position t + "Non-nil means restore frame position on workgroup restore." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-scroll-bars t + "Non-nil means restore scroll-bar settings on workgroup restore." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-fringes t + "Non-nil means restore fringe settings on workgroup restore." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-margins t + "Non-nil means restore margin settings on workgroup restore." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-point t + "Non-nil means restore `point' on workgroup restore. +This is included mainly so point restoration can be suspended +during `wg-morph' -- you probably want this non-nil." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-point-max t + "Controls point restoration when point is at `point-max'. +If `point' is at `point-max' when a wconfig is created, put +`point' back at `point-max' when the wconfig is restored, even if +`point-max' has increased in the meantime. This is useful in, +say, irc buffers where `point-max' is constantly increasing." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-mark t + "Non-nil means restore mark data on workgroup restore." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-window-dedicated-p t + "Non-nil means restore `window-dedicated-p' on workgroup restore." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remember-frame-for-each-wg nil + "When switching workgroups - restore frame parameters for each workgroup. + +When nil - save/restore frame parameters to/from the first workgroup." + :type 'boolean + :group 'workgroups) + + +(defcustom wg-wconfig-undo-list-max 20 + "Number of past window configs to retain for undo." + :type 'integer + :group 'workgroups) + +(defcustom wg-wconfig-kill-ring-max 20 + "Maximum length of the `wg-wconfig-kill-ring'." + :type 'integer + :group 'workgroups) + +(defvar wg-wconfig-kill-ring nil + "Ring of killed or kill-ring-saved wconfigs.") + +(defvar wg-buffer-uid nil + "Symbol for the current buffer's wg-buf's uid. +Every Workgroups buffer object (wg-buf) has a uid. When +Workgroups creates or encounters an Emacs buffer object +corresponding to a wg-buf, it tags it with the wg-buf's uid to +unambiguously pair the two.") +(make-variable-buffer-local 'wg-buffer-uid) + +(defcustom wg-flag-modified t + "Show \"modified\" flags in modeline." + :type 'boolean :group 'workgroups - (wg-awhen (get 'workgroups-everywhere 'read-buffer-fn) - (when (eq read-buffer-function 'wg-read-buffer) - (setq read-buffer-function it)) - (put 'workgroups-everywhere 'read-buffer-fn nil)) - (when workgroups-everywhere - (put 'workgroups-everywhere 'read-buffer-fn read-buffer-function) - (setq read-buffer-function 'wg-read-buffer))) + :set (lambda (sym val) + (custom-set-default sym val) + (force-mode-line-update))) + + + +(defvar wg-window-configuration-changed nil + "Flag set by `window-configuration-change-hook'.") + +(defvar wg-already-updated-working-wconfig nil + "Flag set by `wg-update-working-wconfig-hook'.") + +(defvar wg-undoify-window-configuration-change t + "Should windows undo info be updated or not. +When you change window configuration.") + +(defvar wg-current-workgroup nil "Bound to the current workgroup.") + +(defvar wg-window-min-width 2 + "Bound to `window-min-width' when restoring wtrees.") + +(defvar wg-window-min-height 1 + "Bound to `window-min-height' when restoring wtrees.") + +(defvar wg-window-min-pad 2 + "Added to `wg-window-min-foo' to produce the actual minimum window size.") + +(defvar wg-actual-min-width (+ wg-window-min-width wg-window-min-pad) + "Actual minimum window width when creating windows.") + +(defvar wg-actual-min-height (+ wg-window-min-height wg-window-min-pad) + "Actual minimum window height when creating windows.") + +(defvar wg-min-edges `(0 0 ,wg-actual-min-width ,wg-actual-min-height) + "Smallest allowable edge list of windows created by Workgroups.") + +(defvar wg-null-edges '(0 0 0 0) "Null edge list.") + +(defvar wg-window-tree-selected-window nil + "Used during wconfig restoration to hold the selected window.") + +(defvar wg-buffer-workgroup nil + "A workgroup in which this buffer most recently appeared. +Buffer-local.") +(make-variable-buffer-local 'wg-buffer-workgroup) + +(defcustom wg-default-buffer "*scratch*" + "Show this in case everything else fails. +When a buffer can't be restored, when creating a blank wg." + :type 'string + :group 'workgroups) + + +;; +;; Crazy stuff... +;; +(defcustom wg-associate-blacklist (list "*helm mini*" "*Messages*" "*scratch*" + "*helm action*") + "Do not autoassociate these buffers." + :type 'list + :group 'workgroups) + +(defconst wg-buffer-list-original (symbol-function 'buffer-list)) +(fset 'wg-buffer-list-emacs wg-buffer-list-original) + +(defun buffer-list (&optional frame) + "Redefinition of `buffer-list'. +Pass FRAME to it. +Remove file and dired buffers that are not associated with workgroup." + (let ((res (wg-buffer-list-emacs frame)) + (wg-buf-uids (wg-workgroup-associated-buf-uids))) + (--remove (and (or (buffer-file-name it) + (eq (buffer-local-value 'major-mode it) 'dired-mode)) + ;;(not (member b wg-buffers)) + (not (member (wg-buffer-uid-or-add it) wg-buf-uids))) + res))) + +(defconst wg-buffer-list-function (symbol-function 'buffer-list)) +(fset 'buffer-list wg-buffer-list-original) + +;; locate-dominating-file +(defcustom wg-mess-with-buffer-list nil + "Redefine `buffer-list' to show buffers for each workgroup. + +Crazy stuff that allows to reduce amount of code, gives new +features but is fucking unstable, so disabled by default" + :type 'boolean + :group 'workgroups + :set (lambda (sym val) + (custom-set-default sym val) + (if (and workgroups-mode val) + (fset 'buffer-list wg-buffer-list-function) + (fset 'buffer-list wg-buffer-list-original)))) +(fset 'buffer-list wg-buffer-list-original) + +(defcustom wg-use-faces t + "Non-nil means use faces in various messages." + :type 'boolean + :group 'workgroups) + +(defcustom wg-list-display-decor-left-brace "( " + "String displayed to the left of the list display." + :type 'string + :group 'workgroups) + +(defcustom wg-list-display-decor-right-brace " )" + "String displayed to the right of the list display." + :type 'string + :group 'workgroups) + +(defcustom wg-list-display-decor-divider " | " + "String displayed between elements of the list display." + :type 'string + :group 'workgroups) + +(defcustom wg-list-display-decor-current-left "-<{ " + "String displayed to the left of the current element of the list display." + :type 'string + :group 'workgroups) + +(defcustom wg-list-display-decor-current-right " }>-" + "String displayed to the right of the current element of the list display." + :type 'string + :group 'workgroups) + +(defcustom wg-list-display-decor-previous-left "< " + "String displayed to the left of the previous element of the list display." + :type 'string + :group 'workgroups) + +(defcustom wg-list-display-decor-previous-right " >" + "String displayed to the right of the previous element of the list display." + :type 'string + :group 'workgroups) + + +(defvar wg-face-abbrevs nil + "Assoc list mapping face abbreviations to face names.") + +(defmacro wg-defface (face key spec doc &rest args) + "`defface' wrapper adding a lookup key used by `wg-fontify'." + (declare (indent 2)) + `(progn + (cl-pushnew (cons ,key ',face) wg-face-abbrevs :test #'equal) + (defface ,face ,spec ,doc ,@args))) + +(wg-defface wg-current-workgroup-face :cur + '((t :inherit font-lock-constant-face :bold nil)) + "Face used for current elements in list displays." + :group 'workgroups) + +(wg-defface wg-previous-workgroup-face :prev + '((t :inherit font-lock-keyword-face :bold nil)) + "Face used for the name of the previous workgroup in the list display." + :group 'workgroups) + +(wg-defface wg-other-workgroup-face :other + '((t :inherit font-lock-string-face :bold nil)) + "Face used for the names of other workgroups in the list display." + :group 'workgroups) + +(wg-defface wg-command-face :cmd + '((t :inherit font-lock-function-name-face :bold nil)) + "Face used for command/operation strings." + :group 'workgroups) + +(wg-defface wg-divider-face :div + '((t :inherit font-lock-builtin-face :bold nil)) + "Face used for dividers." + :group 'workgroups) + +(wg-defface wg-brace-face :brace + '((t :inherit font-lock-builtin-face :bold nil)) + "Face used for left and right braces." + :group 'workgroups) + +(wg-defface wg-message-face :msg + '((t :inherit font-lock-string-face :bold nil)) + "Face used for messages." + :group 'workgroups) + +(wg-defface wg-mode-line-face :mode + '((t :inherit font-lock-doc-face :bold nil)) + "Face used for workgroup position and name in the mode-line display." + :group 'workgroups) + +(wg-defface wg-filename-face :file + '((t :inherit font-lock-keyword-face :bold nil)) + "Face used for filenames." + :group 'workgroups) + + +;;; fancy displays + +(defun wg-element-display (elt elt-string &optional current-elt-p previous-elt-p) + "Return display string for ELT." + (cond ((and current-elt-p (funcall current-elt-p elt)) + (wg-fontify (:cur (concat wg-list-display-decor-current-left + elt-string + wg-list-display-decor-current-right)))) + ((and previous-elt-p (funcall previous-elt-p elt)) + (wg-fontify (:prev (concat wg-list-display-decor-previous-left + elt-string + wg-list-display-decor-previous-right)))) + (t (wg-fontify (:other elt-string))))) + +(defun wg-workgroup-display (workgroup index) + "Return display string for WORKGROUP at INDEX." + (if (not workgroup) wg-nowg-string + (wg-element-display + workgroup + (format "%d: %s" index (wg-workgroup-name workgroup)) + 'wg-current-workgroup-p + 'wg-previous-workgroup-p))) + +(defun wg-buffer-display (buffer index) + "Return display string for BUFFER. INDEX is ignored." + (if (not buffer) "No buffers" + (wg-element-display + (wg-get-buffer buffer) + (format "%s" (wg-buffer-name buffer)) + 'wg-current-buffer-p))) + +(defun wg-message (format-string &rest args) + "Call `message' with FORMAT-STRING and ARGS." + (if (> wg-log-level 0) (apply #'message format-string args))) + +(defmacro wg-fontified-message (&rest format) + "`wg-fontify' FORMAT and call `wg-message' on it." + (declare (indent defun)) + `(wg-message (wg-fontify ,@format))) + +(defun wg-add-face (facekey string) + "Return a copy of STRING fontified according to FACEKEY. +FACEKEY must be a key in `wg-face-abbrevs'." + (let ((face (wg-aget wg-face-abbrevs facekey)) + (string (copy-sequence string))) + (unless face (error "No face with key %s" facekey)) + (if (not wg-use-faces) string + (put-text-property 0 (length string) 'face face string) + string))) + +(defmacro wg-fontify (&rest specs) + "A small fontification DSL. +The results of all SPECS are `concat'd together. +If a spec is a cons with a keyword car, apply `wg-add-face' to it. +Other conses get evaluated, and should produce a strings. +If a spec is a string it is used unmodified. +Anything else is formatted with %s to produce a string." + (declare (indent defun)) + `(concat + ,@(wg-docar (spec specs) + (cond ((and (consp spec) + (keywordp (car spec))) + `(wg-add-face ,@spec)) + ;;((listp spec) (cdr (eval spec))) + ;;((listp spec) + ;; ;;(prin1-to-string (nth 1 (eval spec))) + ;; ) + ((consp spec) spec) + ((stringp spec) spec) + (t `(format "%s" ,spec)))))) + +(defmacro wg-with-gensyms (syms &rest body) + "Bind all symbols in SYMS to `gensym's, and eval BODY." + (declare (indent 1)) + `(let (,@(mapcar (lambda (sym) `(,sym (cl-gensym))) syms)) ,@body)) + +(defmacro wg-dbind (args expr &rest body) + "Bind the variables in ARGS to the result of EXPR and execute BODY. +Abbreviation of `destructuring-bind'." + (declare (indent 2)) + `(cl-destructuring-bind ,args ,expr ,@body)) + +(defun wg-partition (list &optional n step) + "Take LIST, return a list of N length sublists, offset by STEP. +N defaults to 2, and STEP defaults to N. +Iterative to prevent stack overflow." + (let* ((n (or n 2)) (step (or step n)) acc) + (while list + (push (-take n list) acc) + (setq list (nthcdr step list))) + (nreverse acc))) + +(defmacro wg-when-boundp (symbols &rest body) + "When all SYMBOLS are bound, `eval' BODY." + (declare (indent 1)) + `(when (and ,@(mapcar (lambda (sym) `(boundp ',sym)) symbols)) + ,@body)) + +(defmacro wg-docar (spec &rest body) + "do-style wrapper for `mapcar'. + +\(fn (VAR LIST) BODY...)" + (declare (indent 1)) + `(mapcar (lambda (,(car spec)) ,@body) ,(cadr spec))) + +(defmacro wg-dohash (spec &rest body) + "do-style wrapper for `maphash'. + +\(fn (KEY VALUE TABLE [RESULT]) BODY...)" + (declare (indent 1)) + (wg-dbind (key val table &optional result) spec + `(progn (maphash (lambda (,key ,val) ,@body) ,table) ,result))) + +(defmacro wg-doconcat (spec &rest body) + "do-style wrapper for `mapconcat'. + +\(fn (VAR SEQ [SEPARATOR]) BODY...)" + (declare (indent 1)) + (wg-dbind (elt seq &optional sep) spec + `(mapconcat (lambda (,elt) ,@body) ,seq (or ,sep "")))) + +(defmacro wg-asetf (&rest places-and-values) + "Anaphoric `setf'." + `(progn ,@(mapcar (lambda (pv) `(let ((it ,(car pv))) (setf ,@pv))) + (wg-partition places-and-values 2)))) + +(defmacro wg-destructuring-dolist (spec &rest body) + "Loop over a list. +Evaluate BODY, destructuring LIST into SPEC, then evaluate RESULT +to get a return value, defaulting to nil. The only hitch is that +spec must end in dotted style, collecting the rest of the list +into a var, like so: (a (b c) . rest) + +\(fn (SPEC LIST [RESULT]) BODY...)" + (declare (indent 1)) + (wg-dbind (loopspec list &optional result) spec + (let ((rest (cdr (last loopspec)))) + (wg-with-gensyms (list-sym) + `(let ((,list-sym ,list)) + (while ,list-sym + (wg-dbind ,loopspec ,list-sym + ,@body + (setq ,list-sym ,rest))) + ,result))))) + + +;;; numbers + +(defun wg-step-to (n m step) + "Increment or decrement N toward M by STEP. +Return M when the difference between N and M is less than STEP." + (cond ((= n m) n) + ((< n m) (min (+ n step) m)) + ((> n m) (max (- n step) m)))) + +(defun wg-within (num lo hi &optional hi-inclusive) + "Return t when NUM is within bounds LO and HI. +HI-INCLUSIVE non-nil means the HI bound is inclusive." + (and (>= num lo) (if hi-inclusive (<= num hi) (< num hi)))) + +(defun wg-int-to-b36-one-digit (i) + "Return a character in 0..9 or A..Z from I, and integer 0<=I<32. +Cribbed from `org-id-int-to-b36-one-digit'." + (cond ((not (wg-within i 0 36)) + (error "%s out of range" i)) + ((< i 10) (+ ?0 i)) + ((< i 36) (+ ?A i -10)))) + +(defun wg-b36-to-int-one-digit (i) + "Turn a character 0..9, A..Z, a..z into a number 0..61. +The input I may be a character, or a single-letter string. +Cribbed from `org-id-b36-to-int-one-digit'." + (and (stringp i) (setq i (string-to-char i))) + (cond ((and (>= i ?0) (<= i ?9)) (- i ?0)) + ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10)) + (t (error "Invalid b36 character")))) + +(defun wg-int-to-b36 (i &optional length) + "Return a base 36 string from I." + (let ((base 36) b36) + (cl-labels ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36) + (setq i (/ i base)))) + (add-digit) + (while (> i 0) (add-digit)) + (setq b36 (cl-map 'string 'identity b36)) + (if (not length) b36 + (concat (make-string (max 0 (- length (length b36))) ?0) b36))))) + +(defun wg-b36-to-int (str) + "Convert STR, a base-36 string, into the corresponding integer. +Cribbed from `org-id-b36-to-int'." + (let ((result 0)) + (mapc (lambda (i) + (setq result (+ (* result 36) + (wg-b36-to-int-one-digit i)))) + str) + result)) + + + +;;; lists + +(defmacro wg-removef-p (item seq-place &rest keys) + "If ITEM is a `member*' of SEQ-PLACE, remove it from SEQ-PLACE and return t. +Otherwise return nil. KEYS can be any keywords accepted by `remove*'." + `(> (length ,seq-place) + (length (setf ,seq-place (cl-remove ,item ,seq-place ,@keys))))) + +(defmacro wg-pushnew-p (item seq-place &rest keys) + "If ITEM is not a `member' of SEQ-PLACE, push it to SEQ-PLACE and return t. +Otherwise return nil. KEYS can be any keyword args accepted by `pushnew'." + `(< (length ,seq-place) + (length (cl-pushnew ,item ,seq-place ,@keys)))) + +(defun wg-range (start end) + "Return a list of integers from START up to but not including END." + (let (accum) + (dotimes (i (- end start) (nreverse accum)) + (push (+ start i) accum)))) + +(defun wg-insert-before (elt list index) + "Insert ELT into LIST before INDEX." + (if (zerop index) (cons elt list) + (-insert-at index elt list))) + +(defun wg-move-elt (elt list index &rest keys) + "Move ELT before INDEX in LIST. +KEYS is passed to `remove*'." + (wg-insert-before elt (apply 'cl-remove elt list keys) index)) + +(defun wg-cyclic-nth (list n) + "Return the Nth element of LIST, modded by the length of list." + (nth (mod n (length list)) list)) + +(defun wg-cyclic-offset-elt (elt list n) + "Cyclically offset ELT's position in LIST by N." + (-when-let (pos (cl-position elt list)) + (wg-move-elt elt list (mod (+ n pos) (length list))))) + +(defun wg-cyclic-nth-from-elt (elt list n &rest keys) + "Return the elt in LIST N places cyclically from ELT. +If ELT is not present is LIST, return nil. +KEYS is passed to `position'." + (-when-let (pos (apply 'cl-position elt list keys)) + (wg-cyclic-nth list (+ pos n)))) + +(defun wg-util-swap (elt1 elt2 list) + "Return a copy of LIST with ELT1 and ELT2 swapped. +Return nil when ELT1 and ELT2 aren't both present." + (-when-let* ((p1 (cl-position elt1 list)) + (p2 (cl-position elt2 list))) + (wg-move-elt elt1 (wg-move-elt elt2 list p1) p2))) + +(defun wg-dups-p (list &rest keys) + "Return non-nil when LIST contains duplicate elements. + +Keywords supported: :test :key + +\(fn LIST [KEYWORD VALUE]...)" + (let ((test (or (plist-get keys :test) 'eq)) + (key (or (plist-get keys :key) 'identity))) + (cl-loop for (elt . rest) on list + for elt = (funcall key elt) + when (cl-find elt rest :test test :key key) return elt))) + +(defun wg-string-list-union (&optional list1 list2) + "Return the `union' of LIST1 and LIST2, using `string=' as the test. +This only exists to get rid of duplicate lambdas in a few reductions." + (cl-union list1 list2 :test 'string=)) + + + +;;; alists + +(defun wg-aget (alist key &optional default) + "Return the value of KEY in ALIST. Uses `assq'. +If PARAM is not found, return DEFAULT which defaults to nil." + (aif (assq key alist) (cdr it) default)) + +(defun wg-aput (alist key value) + "Return a new alist from ALIST with KEY's value set to VALUE." + (let* ((found nil) + (new (wg-docar (kvp alist) + (if (not (eq key (car kvp))) kvp + (setq found (cons key value)))))) + (if found new (cons (cons key value) new)))) + +(defun wg-aremove (alist key) + "`remove' KEY's key-value-pair from ALIST." + (remove (assoc key alist) alist)) + + +;;; symbols and strings + +(defun wg-toggle (symbol) + "Toggle SYMBOL's truthiness." + (set symbol (not (symbol-value symbol)))) + +(defun wg-get-buffer (buffer-or-name) + "Return BUFFER-OR-NAME's buffer, or error." + (or (get-buffer buffer-or-name) + (error "%S does not identify a buffer" buffer-or-name))) + +(defun wg-buffer-name (buffer-or-name) + "Return BUFFER-OR-NAME's `buffer-name', or error." + (buffer-name (wg-get-buffer buffer-or-name))) + +(defun wg-buffer-major-mode (buffer-or-name) + "Return BUFFER's major-mode." + (with-current-buffer buffer-or-name major-mode)) + +(defun wg-current-buffer-p (buffer-or-name) + "Return t if BUFFER-OR-NAME is the current buffer, nil otherwise." + (eq (wg-get-buffer buffer-or-name) (current-buffer))) + +(defun wg-symcat (&rest symbols-and-strings) + "Return a new interned symbol by concatenating SYMBOLS-AND-STRINGS." + (intern (mapconcat (lambda (obj) (if (symbolp obj) (symbol-name obj) obj)) + symbols-and-strings ""))) + +(defmacro wg-defstruct (prefix name-form &rest slot-defs) + "`defstruct' wrapper that namespace-prefixes all generated functions. +Note: this doesn't yet work with :conc-name, and possibly other +options." + (declare (indent 2)) + (let* ((name (if (consp name-form) (car name-form) name-form)) + (prefixed-name (wg-symcat prefix "-" name))) + (cl-labels ((rebind (opstr) + (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name))) + `((fset ',(wg-symcat prefix "-" opstr "-" name) + (symbol-function ',oldfnsym)) + (fmakunbound ',oldfnsym))))) + ;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not + ;; known to be defined"). We can accomplish this with `declare-function' + ;; too, but it annoyingly requires inclusion of the function's arglist, + ;; which gets ugly. + `(eval-and-compile + (cl-defstruct ,(if (symbolp name-form) prefixed-name + `(,prefixed-name ,@(cdr name-form))) + ,@slot-defs) + ,@(rebind "make") + ,@(rebind "copy") + ',prefixed-name)))) + +(wg-defstruct wg session + (uid (wg-generate-uid)) + (name) + (modified) + (parameters) + (file-name) + (version wg-version) + (workgroup-list) + (buf-list)) + +(wg-defstruct wg workgroup + (uid (wg-generate-uid)) + (name) + (modified) + (parameters) + (base-wconfig) + (selected-frame-wconfig) + (saved-wconfigs) + (strong-buf-uids) + (weak-buf-uids)) + +(wg-defstruct wg workgroup-state + (undo-pointer) + (undo-list)) + +(wg-defstruct wg wconfig + (uid (wg-generate-uid)) + (name) + (parameters) + (left) + (top) + (width) + (height) + (vertical-scroll-bars) + (scroll-bar-width) + (wtree)) + +(wg-defstruct wg wtree + (uid) + (dir) + (edges) + (wlist)) + +(wg-defstruct wg win + (uid) + (parameters) + (edges) + (point) + (start) + (hscroll) + (dedicated) + (selected) + (minibuffer-scroll) + (buf-uid)) + +(wg-defstruct wg buf + (uid (wg-generate-uid)) + (name) + (file-name) + (point) + (mark) + (local-vars) + (special-data) + ;; This may be used later: + (gc)) + + +(defmacro wg-with-slots (obj slot-bindings &rest body) + "Bind OBJ's slot values to symbols in BINDS, then eval BODY. +The car of each element of SLOT-BINDINGS is the bound symbol, and +the cadr as the accessor function." + (declare (indent 2)) + (wg-with-gensyms (objsym) + `(let* ((,objsym ,obj) + ,@(wg-docar (slot slot-bindings) + `(,(car slot) (,(cadr slot) ,objsym)))) + ,@body))) + +(defun wg-add-or-remove-hooks (remove &rest pairs) + "Add FUNCTION to or remove it from HOOK, depending on REMOVE." + (dolist (pair (wg-partition pairs 2)) + (funcall (if remove 'remove-hook 'add-hook) + (car pair) (cadr pair)))) + +(defmacro wg-set-parameter (place parameter value) + "Set PARAMETER to VALUE at PLACE. +This needs to be a macro to allow specification of a setf'able place." + (wg-with-gensyms (p v) + `(let ((,p ,parameter) (,v ,value)) + (wg-pickelable-or-error ,p) + (wg-pickelable-or-error ,v) + (setf ,place (wg-aput ,place ,p ,v)) + ,v))) + +(defun wg-time-to-b36 () + "Convert `current-time' into a b36 string." + (apply 'concat (wg-docar (time (current-time)) + (wg-int-to-b36 time 4)))) + +(defun wg-b36-to-time (b36) + "Parse the time in B36 string from UID." + (cl-loop for i from 0 to 8 by 4 + collect (wg-b36-to-int (cl-subseq b36 i (+ i 4))))) +(defalias 'wg-uid-to-time 'wg-b36-to-time) + +(defun wg-generate-uid (&optional prefix) + "Return a new uid, optionally prefixed by PREFIX." + (concat prefix (wg-time-to-b36) "-" (wg-int-to-b36 string-chars-consed))) + +(defun wg-uid-to-seconds (uid) + "Return the `float-time' parsed from UID with `wg-uid-to-time'." + (float-time (wg-uid-to-time uid))) + + +(defun wg-get-value (arg) + "Get a value of ARG if it exists." + (if (boundp `,arg) arg)) + +(defmacro wg-support (mode pkg params) + "Macro to create (de)serialization functions for a buffer. +You need to save/restore a specific MODE which is loaded from a +package PKG. In PARAMS you give local variables to save and a +deserialization function." + (declare (indent 2)) + `(let ((mode-str (symbol-name ,mode)) + (args ,params)) + + (eval `(defun ,(intern (format "wg-deserialize-%s-buffer" mode-str)) (buffer) + "DeSerialization function created with `wg-support'. +Gets saved variables and runs code to restore a BUFFER." + (when (require ',,pkg nil 'noerror) + (wg-dbind (this-function variables) (wg-buf-special-data buffer) + (let ((default-directory (car variables)) + (df (cdr (assoc 'deserialize ',,params))) + (user-vars (cadr variables))) + (if df + (funcall df buffer user-vars) + (get-buffer-create wg-default-buffer)) + ))))) + + (eval `(defun ,(intern (format "wg-serialize-%s-buffer" mode-str)) (buffer) + "Serialization function created with `wg-support'. +Saves some variables to restore a BUFFER later." + (when (get-buffer buffer) + (with-current-buffer buffer + (when (eq major-mode ',,mode) + (let ((sf (cdr (assoc 'serialize ',,params))) + (save (cdr (assoc 'save ',,params)))) + (list ',(intern (format "wg-deserialize-%s-buffer" mode-str)) + (list default-directory + (if sf + (funcall sf buffer) + (if save (mapcar 'wg-get-value save))) + )))))))) + ;; Maybe change a docstring for functions + ;;(put (intern (format "wg-serialize-%s-buffer" (symbol-name mode))) + ;; 'function-documentation + ;; (format "A function created by `wg-support'.")) + + ;; Add function to `wg-special-buffer-serdes-functions' variable + (eval `(add-to-list 'wg-special-buffer-serdes-functions + ',(intern (format "wg-serialize-%s-buffer" mode-str)) t)) + )) + +(defconst wg-font-lock-keywords + '(("(\\(wg-support\\|wg-support\\)[ \t]*" + (1 font-lock-keyword-face) + ;;(2 font-lock-keyword-face) + ))) +(font-lock-add-keywords 'emacs-lisp-mode wg-font-lock-keywords) + +(defvar wg-current-session nil "Current session object.") +(defun wg-current-session (&optional noerror) + "Return `wg-current-session' or error unless NOERROR." + (or wg-current-session + (unless noerror (error "No session is defined")))) + +;; locate-dominating-file +(defun wg-get-first-existing-dir (&optional dir) + "Test if DIR exists and return it. +If not - try to go to the parent dir and do the same." + (let* ((d (or dir default-directory))) + (if (file-directory-p d) d + (let* ((cur d) (parent (file-name-directory (directory-file-name cur)))) + (while (and (> (length cur) (length parent)) + (not (file-directory-p parent))) + (message "Test %s" parent) + (setq cur parent) + (setq parent (file-name-directory (directory-file-name cur)))) + parent)))) + + +(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 + marker + ;;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) + (buffer . wg-pickel-buffer-serializer) + (marker . wg-pickel-marker-serializer) + ;;(window-configuration . wg-pickel-window-configuration-serializer) + ) + "Alist mapping types to object 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) + (m . wg-pickel-deserialize-marker) + ;;(f . wg-pickel-deserialize-frame) + ) + "Alist mapping type keys to object deserialization 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-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))) + + + +;;; Objects +(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-deserialize-uninterned-symbol (name) + "Return a new uninterned symbol from NAME." + (make-symbol name)) + + +;; buffer +(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-deserialize-buffer (uid) + "Return a restored buffer from it's UID." + (wg-restore-buffer (wg-find-buf-by-uid uid))) + + +;; marker +(defun wg-pickel-marker-serializer (marker) + "Return MARKER's data." + (list 'm (list (marker-position marker) + (wg-add-buffer-to-buf-list (marker-buffer marker))))) +(defun wg-pickel-deserialize-marker (data) + "Return marker from it's DATA." + (let ((m (make-marker))) + (set-marker m (car data) (wg-pickel-deserialize-buffer (car (cdr data)))))) + + +;; cons - http://www.gnu.org/software/emacs/manual/html_node/eintr/cons.html +(defun wg-pickel-cons-serializer (cons) + "Return CONS's serialization." + (list 'c)) +(defun wg-pickel-deserialize-cons () + "Return a new cons cell initialized to nil." + (cons nil nil)) +(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-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)))) + + + +;; vector - http://www.gnu.org/software/emacs/manual/html_node/elisp/Vector-Functions.html +;; (wg-unpickel (wg-pickel (make-vector 9 'Z))) +;; +(defun wg-pickel-vector-serializer (vector) + "Return VECTOR's serialization." + (list 'v (length vector))) +(defun wg-pickel-deserialize-vector (length) + "Return a new vector of length LENGTH." + (make-vector length nil)) +(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))))) +(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))) + + +;; hash table - http://www.gnu.org/software/emacs/manual/html_node/elisp/Hash-Tables.html +(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-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-hash-table-link-serializer (table binds) + "Return the serialization of TABLE's links in BINDS." + (let (result) + (wg-dohash (key value table result) + (setq result + (nconc (list 'h + (gethash key binds) + (gethash value binds) + (gethash table binds)) + result))))) +(defun wg-pickel-hash-table-link-deserializer (key-id value-id table-id binds) + "Relink a hash-table with its keys and values in BINDS." + (puthash (gethash key-id binds) + (gethash value-id binds) + (gethash table-id binds))) + + +;; TODO +(defun wg-pickel-window-configuration-serializer (wc) + "Return Window configuration WC's serialization." + (list 'wc 1)) + + +(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))))) +(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)))) + + + +(defun wg-pickel-serialize-links (binds) + "Return a list of serializations of the links between objects in BINDS." + (let (result) + (wg-dohash (obj id binds result) + (awhen (wg-pickel-link-serializer obj) + (setq result (nconc (funcall it obj binds) result)))))) +(defun wg-pickel-deserialize-links (serial-links binds) + "Return BINDS after relinking all its objects according to SERIAL-LINKS." + (wg-destructuring-dolist ((key arg1 arg2 arg3 . rest) serial-links binds) + (funcall (wg-pickel-link-deserializer key) arg1 arg2 arg3 binds))) + +(defun wg-pickel (obj) + "Return the serialization of OBJ." + (wg-pickelable-or-error obj) + (let ((binds (wg-pickel-make-bindings-table obj))) + (list wg-pickel-identifier + (wg-pickel-serialize-objects binds) + (wg-pickel-serialize-links binds) + (gethash obj binds)))) + +(defun wg-pickel-to-string (obj) + "Serialize OBJ to a string and return the string." + (format "%S" (wg-pickel obj))) + +(defun wg-unpickel (pickel) + "Return the deserialization of PICKEL." + (unless (wg-pickel-p pickel) + (error "Attempt to unpickel a non-pickel.")) + (wg-dbind (id serial-objects serial-links result) pickel + (gethash + result + (wg-pickel-deserialize-links + serial-links + (wg-pickel-deserialize-objects serial-objects))))) + +;; `wg-pre-window-configuration-change-hook' implementation advice +(cl-macrolet ((define-p-w-c-c-h-advice + (fn) + `(defadvice ,fn (before wg-pre-window-configuration-change-hook) + "Call `wg-update-working-wconfig-hook' before this +function to save up-to-date undo information before the +window-configuration changes." + (run-hooks 'wg-pre-window-configuration-change-hook)))) + (define-p-w-c-c-h-advice split-window) + (define-p-w-c-c-h-advice enlarge-window) + (define-p-w-c-c-h-advice delete-window) + (define-p-w-c-c-h-advice delete-other-windows) + (define-p-w-c-c-h-advice delete-windows-on) + (define-p-w-c-c-h-advice switch-to-buffer) + (define-p-w-c-c-h-advice set-window-buffer)) + + +(defadvice save-buffers-kill-emacs (around wg-freeze-wconfig) + "`save-buffers-kill-emacs' calls `list-processes' when active +processes exist, screwing up the window config right before +Workgroups saves it. This advice freezes `wg-current-wconfig' in +its correct state, prior to any window-config changes caused by +`s-b-k-e'." + (wg-with-current-wconfig nil (wg-frame-to-wconfig) + ad-do-it)) + +(defadvice select-frame (before wg-update-current-workgroup-working-wconfig) + "Update `selected-frame's current workgroup's working-wconfig. +Before selecting a new frame." + (wg-update-current-workgroup-working-wconfig)) + +(defun wg-enable-all-advice () + "Enable and activate all of Workgroups' advice." + ;; switch-to-buffer + (ad-enable-advice 'switch-to-buffer 'after 'wg-auto-associate-buffer) + (ad-enable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook) + (ad-activate 'switch-to-buffer) + + ;; set-window-buffer + (ad-enable-advice 'set-window-buffer 'after 'wg-auto-associate-buffer) + (ad-enable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook) + (ad-activate 'set-window-buffer) + + ;; split-window + (ad-enable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook) + (ad-activate 'split-window) + + ;; enlarge-window + (ad-enable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook) + (ad-activate 'enlarge-window) + + ;; delete-window + (ad-enable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook) + (ad-activate 'delete-window) + + ;; delete-other-windows + (ad-enable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook) + (ad-activate 'delete-other-windows) + + ;; delete-windows-on + (ad-enable-advice 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook) + (ad-activate 'delete-windows-on) + + ;; save-buffers-kill-emacs + (ad-enable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig) + (ad-activate 'save-buffers-kill-emacs) + + ;; select-frame + ;;(ad-enable-advice 'select-frame 'before + ;; 'wg-update-current-workgroup-working-wconfig) + ;;(ad-activate 'select-frame) + ) + + +;; disable all advice +;; (wg-disable-all-advice) +(defun wg-disable-all-advice () + "Disable and deactivate all of Workgroups' advice." + ;; switch-to-buffer + (ad-disable-advice 'switch-to-buffer 'after 'wg-auto-associate-buffer) + (ad-disable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook) + (ad-deactivate 'switch-to-buffer) + + ;; set-window-buffer + (ad-disable-advice 'set-window-buffer 'after 'wg-auto-associate-buffer) + (ad-disable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook) + (ad-deactivate 'set-window-buffer) + + ;; split-window + (ad-disable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook) + (ad-deactivate 'split-window) + + ;; enlarge-window + (ad-disable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook) + (ad-deactivate 'enlarge-window) + + ;; delete-window + (ad-disable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook) + (ad-deactivate 'delete-window) + + ;; delete-other-windows + (ad-disable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook) + (ad-deactivate 'delete-other-windows) + + ;; delete-windows-on + (ad-disable-advice 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook) + (ad-deactivate 'delete-windows-on) + + ;; save-buffers-kill-emacs + (ad-disable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig) + (ad-deactivate 'save-buffers-kill-emacs) + + ;; select-frame + ;;(ad-disable-advice 'select-frame 'before + ;; 'wg-update-current-workgroup-working-wconfig) + ;;(ad-deactivate 'select-frame) + ) + + +;; buffer auto-association advice + +(defcustom wg-buffer-auto-association-on t + "Non-nil means buffer auto-association is on. +-nil means it's off. See `wg-buffer-auto-association'." + :type 'boolean + :group 'workgroups) + +(defcustom wg-buffer-auto-association 'weak + "Specifies the behavior for auto-associating buffers with workgroups. + +When a buffer is made visible in a window it can be automatically +associated with the current workgroup in the window's frame. +This setting determines whether and how that happens. + +Allowable values: + +`weak' - weakly associate the buffer with the workgroup +`strong' - strongly associate the buffer with the workgroup + +A function (a function-symbol or a lambda) - `funcall' the function to +determine whether and how to associate the buffer with the +workgroup. The function should accept two arguments -- the +buffer and the workgroup -- and should return one of the +allowable values for this variable. + +`nil' or any other value - don't associate the buffer with the +workgroup. + +Becomes workgroup-local when set with `wg-set-workgroup-parameter'. +Becomes session-local when set with `wg-set-session-parameter'." + :type 'sexp + :group 'workgroups) + +(defcustom wg-dissociate-buffer-on-kill-buffer t + "Non-nil means dissociate buffers killed with `kill-buffer'." + :type 'boolean + :group 'workgroups) + +(defun wg-auto-associate-buffer-helper (workgroup buffer assoc) + "Associate BUFFER with WORKGROUP based on ASSOC. +See `wg-buffer-auto-association' for allowable values of ASSOC." + (cond ((memq assoc '(weak strong)) + (wg-workgroup-associate-bufobj workgroup buffer (eq assoc 'weak))) + ((functionp assoc) + (wg-auto-associate-buffer-helper + workgroup buffer (funcall assoc workgroup buffer))) + (t nil))) + +(defun wg-auto-associate-buffer (buffer &optional frame) + "Conditionally associate BUFFER with the current workgroup in FRAME. +Frame defaults to `selected-frame'. See `wg-buffer-auto-association'." + (when wg-buffer-auto-association-on + (-when-let* ((wg (wg-current-workgroup t frame)) + (b (get-buffer buffer))) + (unless (or (wg-workgroup-bufobj-association-type wg buffer) + (member wg wg-deactivation-list) + (member (buffer-name b) wg-associate-blacklist) + (not (or (buffer-file-name b) + (eq (buffer-local-value 'major-mode b) 'dired-mode)))) + (wg-auto-associate-buffer-helper + wg buffer (wg-local-value 'wg-buffer-auto-association wg)))))) + +(defadvice switch-to-buffer (after wg-auto-associate-buffer) + "Automatically associate the buffer with the current workgroup." + (wg-auto-associate-buffer ad-return-value)) + +(defadvice set-window-buffer (after wg-auto-associate-buffer) + "Automatically associate the buffer with the current workgroup." + (wg-auto-associate-buffer + (ad-get-arg 1) + (window-frame (or (ad-get-arg 0) (selected-window))))) + +(defun wg-mode-line-string () + "Return the string to be displayed in the mode-line." + (let ((wg (wg-current-workgroup t)) + (wg-use-faces wg-mode-line-use-faces)) + (cond (wg (wg-fontify " " + (:brace wg-mode-line-decor-left-brace) + (:mode (wg-workgroup-name wg)) + (if wg-flag-modified + (concat + (wg-add-face :div wg-mode-line-decor-divider) + ;;(if (window-dedicated-p) + ;; wg-mode-line-decor-window-dedicated + ;; wg-mode-line-decor-window-undedicated) + ;;(wg-add-face :div wg-mode-line-decor-divider) + (if (wg-session-modified (wg-current-session)) + wg-mode-line-decor-session-modified + wg-mode-line-decor-session-unmodified) + (if (wg-workgroup-modified wg) + wg-mode-line-decor-workgroup-modified + wg-mode-line-decor-workgroup-unmodified))) + (:brace wg-mode-line-decor-right-brace))) + (t (if wg-display-nowg + (wg-fontify " " + (:brace wg-mode-line-decor-left-brace) + (:mode wg-nowg-string) + (:brace wg-mode-line-decor-right-brace)) + ""))))) + +(defun wg-change-modeline () + "Add Workgroups' mode-line format to `mode-line-format'." + (unless (assq 'wg-mode-line-display-on mode-line-format) + (let ((format '(wg-mode-line-display-on (:eval (wg-mode-line-string)))) + (pos (or (cl-position 'mode-line-position mode-line-format) 10))) + (set-default 'mode-line-format (-insert-at (1+ pos) format mode-line-format)) + (force-mode-line-update)))) + +(defun wg-remove-mode-line-display () + "Remove Workgroups' mode-line format from `mode-line-format'." + (awhen (assq 'wg-mode-line-display-on mode-line-format) + (set-default 'mode-line-format (remove it mode-line-format)) + (force-mode-line-update))) + +(defun wg-add-workgroups-mode-minor-mode-entries () + "Add Workgroups' minor-mode entries. +Adds entries to `minor-mode-list', `minor-mode-alist' and +`minor-mode-map-alist'." + (cl-pushnew 'workgroups-mode minor-mode-list) + (cl-pushnew '(workgroups-mode wg-modeline-string) minor-mode-alist :test 'equal) + (setq minor-mode-map-alist + (cons (cons 'workgroups-mode (wg-make-workgroups-mode-map)) + (delete (assoc 'workgroups-mode minor-mode-map-alist) + minor-mode-map-alist)))) + +(defun wg-fill-keymap (keymap &rest binds) + "Return KEYMAP after defining in it all keybindings in BINDS." + (while binds + (define-key keymap (car binds) (cadr binds)) + (setq binds (cddr binds))) + keymap) + +(defvar wg-prefixed-map + (wg-fill-keymap + (make-sparse-keymap) + + ;; workgroups + (kbd "C-c") 'wg-create-workgroup + (kbd "c") 'wg-create-workgroup + (kbd "C") 'wg-clone-workgroup + (kbd "A") 'wg-rename-workgroup + (kbd "C-'") 'wg-switch-to-workgroup + (kbd "'") 'wg-switch-to-workgroup + (kbd "C-v") 'wg-switch-to-workgroup + (kbd "v") 'wg-switch-to-workgroup + + ;; session + (kbd "C-s") 'wg-save-session + (kbd "C-w") 'wg-save-session-as + (kbd "C-f") 'wg-open-session + + ;; killing and yanking + (kbd "C-k") 'wg-kill-workgroup + (kbd "k") 'wg-kill-workgroup + (kbd "M-W") 'wg-kill-ring-save-base-wconfig + (kbd "M-w") 'wg-kill-ring-save-working-wconfig + (kbd "C-y") 'wg-yank-wconfig + (kbd "y") 'wg-yank-wconfig + (kbd "M-k") 'wg-kill-workgroup-and-buffers + (kbd "K") 'wg-delete-other-workgroups + + + ;; workgroup switching + (kbd "C-j") 'wg-switch-to-workgroup-at-index + (kbd "j") 'wg-switch-to-workgroup-at-index + (kbd "0") 'wg-switch-to-workgroup-at-index-0 + (kbd "1") 'wg-switch-to-workgroup-at-index-1 + (kbd "2") 'wg-switch-to-workgroup-at-index-2 + (kbd "3") 'wg-switch-to-workgroup-at-index-3 + (kbd "4") 'wg-switch-to-workgroup-at-index-4 + (kbd "5") 'wg-switch-to-workgroup-at-index-5 + (kbd "6") 'wg-switch-to-workgroup-at-index-6 + (kbd "7") 'wg-switch-to-workgroup-at-index-7 + (kbd "8") 'wg-switch-to-workgroup-at-index-8 + (kbd "9") 'wg-switch-to-workgroup-at-index-9 + (kbd "C-p") 'wg-switch-to-workgroup-left + (kbd "p") 'wg-switch-to-workgroup-left + (kbd "C-n") 'wg-switch-to-workgroup-right + (kbd "n") 'wg-switch-to-workgroup-right + (kbd "C-a") 'wg-switch-to-previous-workgroup + (kbd "a") 'wg-switch-to-previous-workgroup + + + ;; updating and reverting + ;; wconfig undo/redo + (kbd "C-r") 'wg-revert-workgroup + (kbd "r") 'wg-revert-workgroup + (kbd "C-S-r") 'wg-revert-all-workgroups + (kbd "R") 'wg-revert-all-workgroups + (kbd "") 'wg-undo-wconfig-change + (kbd "") 'wg-redo-wconfig-change + (kbd "[") 'wg-undo-wconfig-change + (kbd "]") 'wg-redo-wconfig-change + (kbd "{") 'wg-undo-once-all-workgroups + (kbd "}") 'wg-redo-once-all-workgroups + + + ;; wconfig save/restore + (kbd "C-d C-s") 'wg-save-wconfig + (kbd "C-d C-'") 'wg-restore-saved-wconfig + (kbd "C-d C-k") 'wg-kill-saved-wconfig + + + ;; workgroup movement + (kbd "C-x") 'wg-swap-workgroups + (kbd "C-,") 'wg-offset-workgroup-left + (kbd "C-.") 'wg-offset-workgroup-right + + + ;; window moving and frame reversal + (kbd "|") 'wg-reverse-frame-horizontally + (kbd "\\") 'wg-reverse-frame-vertically + (kbd "/") 'wg-reverse-frame-horizontally-and-vertically + + + ;; toggling + (kbd "C-t C-m") 'wg-toggle-mode-line-display + (kbd "C-t C-d") 'wg-toggle-window-dedicated-p + + + ;; misc + (kbd "!") 'wg-reset + (kbd "?") 'wg-help + + ) + "The keymap that sits on `wg-prefix-key'.") + +(defun wg-make-workgroups-mode-map () + "Return Workgroups' minor-mode-map. +This map includes `wg-prefixed-map' on `wg-prefix-key', as well +as Workgroups' command remappings." + (let ((map (make-sparse-keymap))) + (define-key map wg-prefix-key + wg-prefixed-map) + (when (and (fboundp 'winner-undo) + (fboundp 'winner-redo)) + (define-key map [remap winner-undo] 'wg-undo-wconfig-change) + (define-key map [remap winner-redo] 'wg-redo-wconfig-change)) + (setq workgroups-mode-map map))) + + +(defun wg-min-size (dir) + "Return the minimum window size in split direction DIR." + (if dir wg-window-min-height wg-window-min-width)) + +(defun wg-actual-min-size (dir) + "Return the actual minimum window size in split direction DIR." + (if dir wg-actual-min-height wg-actual-min-width)) + +(defmacro wg-with-edges (w spec &rest body) + "Bind W's edge list to SPEC and eval BODY." + (declare (indent 2)) + `(wg-dbind ,spec (wg-w-edges ,w) ,@body)) + +(defmacro wg-with-bounds (wtree dir spec &rest body) + "Bind SPEC to W's bounds in DIR, and eval BODY. +\"bounds\" are a direction-independent way of dealing with edge lists." + (declare (indent 3)) + (wg-with-gensyms (dir-sym l1 t1 r1 b1) + (wg-dbind (ls1 hs1 lb1 hb1) spec + `(wg-with-edges ,wtree (,l1 ,t1 ,r1 ,b1) + (cond (,dir (let ((,ls1 ,l1) (,hs1 ,r1) (,lb1 ,t1) (,hb1 ,b1)) + ,@body)) + (t (let ((,ls1 ,t1) (,hs1 ,b1) (,lb1 ,l1) (,hb1 ,r1)) + ,@body))))))) + +(defun wg-set-bounds (w dir ls hs lb hb) + "Set W's edges in DIR with bounds LS HS LB and HB." + (wg-set-edges w (if dir (list ls lb hs hb) (list lb ls hb hs)))) + +(defun wg-step-edges (edges1 edges2 hstep vstep) + "Return W1's edges stepped once toward W2's by HSTEP and VSTEP." + (wg-dbind (l1 t1 r1 b1) edges1 + (wg-dbind (l2 t2 r2 b2) edges2 + (let ((left (wg-step-to l1 l2 hstep)) + (top (wg-step-to t1 t2 vstep))) + (list left top + (+ left (wg-step-to (- r1 l1) (- r2 l2) hstep)) + (+ top (wg-step-to (- b1 t1) (- b2 t2) vstep))))))) + +(defun wg-w-edge-operation (w edges op) + "Return a copy of W with its edges mapped against EDGES through OP." + (wg-set-edges w (cl-mapcar op (wg-w-edges w) edges))) + +(defun wg-first-win (w) + "Return the first actual window in W." + (if (wg-win-p w) w + (wg-first-win (car (wg-wtree-wlist w))))) + +(defun wg-last-win (w) + "Return the last actual window in W." + (if (wg-win-p w) w + (wg-last-win (-last-item (wg-wtree-wlist w))))) + +(defun wg-minify-win (w) + "Set W's edges to the smallest allowable." + (let* ((edges (wg-w-edges w)) + (left (car edges)) + (top (cadr edges))) + (wg-set-edges w (list left top + (+ left wg-actual-min-width) + (+ top wg-actual-min-height))))) + +(defun wg-minified-copy-of-last-win (w) + "Minify a copy of the last actual window in W." + (wg-minify-win (wg-copy-win (wg-last-win w)))) + +(defun wg-w-size (w &optional height) + "Return the width or height of W, calculated from its edge list." + (wg-with-edges w (l1 t1 r1 b1) + (if height (- b1 t1) (- r1 l1)))) + +(defun wg-adjust-w-size (w width-fn height-fn &optional new-left new-top) + "Adjust W's width and height with WIDTH-FN and HEIGHT-FN." + (wg-with-edges w (left top right bottom) + (let ((left (or new-left left)) (top (or new-top top))) + (wg-set-edges (wg-copy-w w) + (list left + top + (+ left (funcall width-fn (- right left))) + (+ top (funcall height-fn (- bottom top)))))))) + +(defun wg-scale-w-size (w width-scale height-scale) + "Scale W's size by WIDTH-SCALE and HEIGHT-SCALE." + (cl-labels + ((wscale (width) (truncate (* width width-scale))) + (hscale (height) (truncate (* height height-scale)))) + (wg-adjust-w-size w #'wscale #'hscale))) + +(defun wg-restore-window (win) + "Restore WIN in `selected-window'." + (let ((selwin (selected-window)) + (buf (wg-find-buf-by-uid (wg-win-buf-uid win)))) + (if (not buf) + (wg-restore-default-buffer) + (when (wg-restore-buffer buf t) + + ;; Restore various positions in WINDOW from their values in WIN + ;; (wg-restore-window-positions win selwin) + (let ((window (or selwin (selected-window)))) + (wg-with-slots win + ((win-point wg-win-point) + (win-start wg-win-start) + (win-hscroll wg-win-hscroll)) + (set-window-start window win-start t) + (set-window-hscroll window win-hscroll) + (set-window-point + window + (cond ((not wg-restore-point) win-start) + ((eq win-point :max) (point-max)) + (t win-point))) + (when (>= win-start (point-max)) (recenter)))) + + (when wg-restore-window-dedicated-p + (set-window-dedicated-p selwin (wg-win-dedicated win))))) + (ignore-errors + (set-window-prev-buffers + selwin (wg-unpickel (wg-win-parameter win 'prev-buffers))) + (set-window-next-buffers + selwin (wg-unpickel (wg-win-parameter win 'next-buffers))) + ))) + + +(defun wg-window-point (ewin) + "Return `point' or :max. See `wg-restore-point-max'. +EWIN should be an Emacs window object." + (let ((p (window-point ewin))) + (if (and wg-restore-point-max (= p (point-max))) :max p))) + +(defun wg-win-parameter (win parameter &optional default) + "Return WIN's value for PARAMETER. +If PARAMETER is not found, return DEFAULT which defaults to nil. +SESSION nil defaults to the current session." + (wg-aget (wg-win-parameters win) parameter default)) + +(defun wg-set-win-parameter (win parameter value) + "Set WIN's value of PARAMETER to VALUE. +SESSION nil means use the current session. +Return value." + (wg-set-parameter (wg-win-parameters win) parameter value) + value) +;; (wg-win-parameters (wg-window-to-win (selected-window))) + +(defun wg-remove-win-parameter (win parameter) + "Remove parameter PARAMETER from WIN's parameters." + (wg-asetf (wg-win-parameters win) (wg-aremove it parameter))) + +(defun wg-window-to-win (&optional window) + "Return the serialization (a wg-win) of Emacs window WINDOW." + (let ((window (or window (selected-window))) + (selected (eq window (selected-window))) + win) + (with-selected-window window + (setq win + (wg-make-win + :edges (window-edges window) + :point (wg-window-point window) + :start (window-start window) + :hscroll (window-hscroll window) + :selected selected + :minibuffer-scroll (eq window minibuffer-scroll-window) + :dedicated (window-dedicated-p window) + :buf-uid (wg-buffer-uid-or-add (window-buffer window)))) + (unless (version< emacs-version "24") + ;; To solve: https://github.com/pashinin/workgroups2/issues/51 + ;; shouldn't ignore here + (ignore-errors + (wg-set-win-parameter + win 'next-buffers (wg-pickel (remove nil (cl-subseq (window-next-buffers window) 0 4)))) + (wg-set-win-parameter + win 'prev-buffers (wg-pickel (remove nil (cl-subseq (window-prev-buffers window) 0 4))))))) + win)) + +(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")))) + +(defun wg-w-edges (w) + "Return W's edge list." + (cl-etypecase w + (wg-win (wg-win-edges w)) + (wg-wtree (wg-wtree-edges w)))) + +(defun wg-copy-w (w) + "Return a copy of W. W should be a wg-win or a wg-wtree." + (cl-etypecase w + (wg-win (wg-copy-win w)) + (wg-wtree (wg-copy-wtree w)))) + +(defun wg-set-edges (w edges) + "Set W's EDGES list, and return W." + (cl-etypecase w + (wg-win (setf (wg-win-edges w) edges)) + (wg-wtree (setf (wg-wtree-edges w) edges))) + w) + +(defun wg-equal-wtrees (w1 w2) + "Return t when W1 and W2 have equal structure." + (cond ((and (wg-win-p w1) (wg-win-p w2)) + (equal (wg-w-edges w1) (wg-w-edges w2))) + ((and (wg-wtree-p w1) (wg-wtree-p w2)) + (and (eq (wg-wtree-dir w1) (wg-wtree-dir w2)) + (equal (wg-wtree-edges w1) (wg-wtree-edges w2)) + (cl-every #'wg-equal-wtrees + (wg-wtree-wlist w1) + (wg-wtree-wlist w2)))))) + +(defun wg-normalize-wtree (wtree) + "Clean up and return a new wtree from WTREE. +Recalculate the edge lists of all subwins, and remove subwins +outside of WTREE's bounds. If there's only one element in the +new wlist, return it instead of a new wtree." + (if (wg-win-p wtree) wtree + (wg-with-slots wtree ((dir wg-wtree-dir) + (wlist wg-wtree-wlist)) + (wg-with-bounds wtree dir (ls1 hs1 lb1 hb1) + (let* ((min-size (wg-min-size dir)) + (max (- hb1 1 min-size)) + (lastw (-last-item wlist))) + (cl-labels + ((mapwl + (wl) + (wg-dbind (sw . rest) wl + (cons (wg-normalize-wtree + (wg-set-bounds + sw dir ls1 hs1 lb1 + (setq lb1 (if (eq sw lastw) hb1 + (let ((hb2 (+ lb1 (wg-w-size sw dir)))) + (if (>= hb2 max) hb1 hb2)))))) + (when (< lb1 max) (mapwl rest)))))) + (let ((new (mapwl wlist))) + (if (not (cdr new)) (car new) + (setf (wg-wtree-wlist wtree) new) + wtree)))))))) + +(defun wg-scale-wtree (wtree wscale hscale) + "Return a copy of WTREE with its dimensions scaled by WSCALE and HSCALE. +All WTREE's subwins are scaled as well." + (let ((scaled (wg-scale-w-size wtree wscale hscale))) + (if (wg-win-p wtree) scaled + (wg-asetf (wg-wtree-wlist scaled) + (wg-docar (sw it) (wg-scale-wtree sw wscale hscale))) + scaled))) + + +(defun wg-resize-frame-scale-wtree (wconfig) + "Set FRAME's size to WCONFIG's, returning a possibly scaled wtree. +If the frame size was set correctly, return WCONFIG's wtree +unchanged. If it wasn't, return a copy of WCONFIG's wtree scaled +with `wg-scale-wconfigs-wtree' to fit the frame as it exists." + (let ((frame (selected-frame))) + (wg-with-slots wconfig ((wcwidth wg-wconfig-width) + (wcheight wg-wconfig-height)) + (when window-system (set-frame-size frame wcwidth wcheight)) + (let ((fwidth (frame-parameter frame 'width)) + (fheight (frame-parameter frame 'height))) + (if (and (= wcwidth fwidth) (= wcheight fheight)) + (wg-wconfig-wtree wconfig) + (wg-scale-wconfigs-wtree wconfig fwidth fheight)))))) + +(defun wg-wtree-buf-uids (wtree) + "Return a new list of the buf uids of all wins in WTREE." + (if (not wtree) + (error "WTREE is nil in `wg-wtree-buf-uids'!")) + (wg-flatten-wtree wtree 'wg-win-buf-uid)) + + +(defun wg-wtree-unique-buf-uids (wtree) + "Return a list of the unique buf uids of all wins in WTREE." + (cl-remove-duplicates (wg-wtree-buf-uids wtree) :test 'string=)) + + +(defun wg-reset-window-tree () + "Delete all but one window in `selected-frame', and reset +various parameters of that window in preparation for restoring +a wtree." + (delete-other-windows) + (set-window-dedicated-p nil nil)) + +(defun wg-restore-window-tree-helper (w) + "Recursion helper for `wg-restore-window-tree' W." + (if (wg-wtree-p w) + (cl-loop with dir = (wg-wtree-dir w) + for (win . rest) on (wg-wtree-wlist w) + do (when rest (split-window nil (wg-w-size win dir) (not dir))) + do (wg-restore-window-tree-helper win)) + (wg-restore-window w) + (when (wg-win-selected w) + (setq wg-window-tree-selected-window (selected-window))) + (when (wg-win-minibuffer-scroll w) + (setq minibuffer-scroll-window (selected-window))) + (other-window 1))) + +(defun wg-restore-window-tree (wtree) + "Restore WTREE in `selected-frame'." + (let ((window-min-width wg-window-min-width) + (window-min-height wg-window-min-height) + (wg-window-tree-selected-window nil)) + (wg-reset-window-tree) + (wg-restore-window-tree-helper wtree) + (awhen wg-window-tree-selected-window (select-window it)))) + +(defun wg-window-tree-to-wtree (&optional window-tree) + "Return the serialization (a wg-wtree) of Emacs window tree WINDOW-TREE." + (wg-barf-on-active-minibuffer) + (unless window-tree + (setq window-tree (window-tree))) + (cl-labels + ((inner (w) (if (windowp w) (wg-window-to-win w) + (wg-dbind (dir edges . wins) w + (wg-make-wtree + :dir dir + :edges edges + :wlist (mapcar #'inner wins)))))) + (let ((w (car window-tree))) + (when (and (windowp w) (window-minibuffer-p w)) + (error "Workgroups can't operate on minibuffer-only frames.")) + (inner w)))) + + +(defun wg-flatten-wtree (wtree &optional key) + "Return a new list by flattening WTREE. +KEY non returns returns a list of WTREE's wins. +KEY non-nil returns a list of the results of calling KEY on each win." + (cl-labels + ((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w)) + (cl-mapcan #'inner (wg-wtree-wlist w))))) + (inner wtree))) + +(defun wg-reverse-wlist (w &optional dir) + "Reverse W's wlist and those of all its sub-wtrees in direction DIR. +If DIR is nil, reverse WTREE horizontally. +If DIR is 'both, reverse WTREE both horizontally and vertically. +Otherwise, reverse WTREE vertically." + (cl-labels + ((inner (w) (if (wg-win-p w) w + (wg-with-slots w ((d1 wg-wtree-dir)) + (wg-make-wtree + :dir d1 + :edges (wg-wtree-edges w) + :wlist (let ((wl2 (mapcar #'inner (wg-wtree-wlist w)))) + (if (or (eq dir 'both) (eq dir d1)) + (nreverse wl2) + wl2))))))) + (wg-normalize-wtree (inner w)))) + +(defun wg-wtree-move-window (wtree offset) + "Offset `selected-window' OFFSET places in WTREE." + (cl-labels + ((inner (w) (if (wg-win-p w) w + (wg-with-slots w ((wlist wg-wtree-wlist)) + (wg-make-wtree + :dir (wg-wtree-dir w) + :edges (wg-wtree-edges w) + :wlist (aif (cl-find t wlist :key 'wg-win-selected) + (wg-cyclic-offset-elt it wlist offset) + (mapcar #'inner wlist))))))) + (wg-normalize-wtree (inner wtree)))) + +(defun wg-frame-to-wconfig (&optional frame) + "Return the serialization (a wg-wconfig) of Emacs frame FRAME. +FRAME nil defaults to `selected-frame'." + (let* ((frame (or frame (selected-frame))) + (fullscrn (frame-parameter frame 'fullscreen))) + (wg-make-wconfig + :left (frame-parameter frame 'left) + :top (frame-parameter frame 'top) + :width (frame-parameter frame 'width) + :height (frame-parameter frame 'height) + :parameters `((fullscreen . ,fullscrn)) + :vertical-scroll-bars (frame-parameter frame 'vertical-scroll-bars) + :scroll-bar-width (frame-parameter frame 'scroll-bar-width) + :wtree (wg-window-tree-to-wtree (window-tree frame)) + ))) + +(defun wg-current-wconfig () + "Return the current wconfig. +If `wg-current-wconfig' is non-nil, return it. Otherwise return +`wg-frame-to-wconfig'." + (or (frame-parameter nil 'wg-current-wconfig) + (wg-frame-to-wconfig))) + +(defmacro wg-with-current-wconfig (frame wconfig &rest body) + "Eval BODY with WCONFIG current in FRAME. +FRAME nil defaults to `selected-frame'." + (declare (indent 2)) + (wg-with-gensyms (frame-sym old-value) + `(let* ((,frame-sym (or ,frame (selected-frame))) + (,old-value (frame-parameter ,frame-sym 'wg-current-wconfig))) + (unwind-protect + (progn + (set-frame-parameter ,frame-sym 'wg-current-wconfig ,wconfig) + ,@body) + (when (frame-live-p ,frame-sym) + (set-frame-parameter ,frame-sym 'wg-current-wconfig ,old-value)))))) + +(defun wg-make-blank-wconfig (&optional buffer) + "Return a new blank wconfig. +BUFFER or `wg-default-buffer' is visible in the only window." + (save-window-excursion + (delete-other-windows) + (switch-to-buffer (or buffer wg-default-buffer)) + (wg-frame-to-wconfig))) + +(defun wg-wconfig-move-window (wconfig offset) + "Offset `selected-window' OFFSET places in WCONFIG." + (wg-asetf (wg-wconfig-wtree wconfig) (wg-wtree-move-window it offset)) + wconfig) + + +;;; base wconfig updating + +(defun wg-update-working-wconfig-on-delete-frame (frame) + "Update FRAME's current workgroup's working-wconfig before +FRAME is deleted, so we don't lose its state." + (wg-flag-session-modified) + (with-selected-frame frame + (wg-update-current-workgroup-working-wconfig))) + +(defun wg-update-working-wconfig-on-make-frame (frame) + "Update FRAME's current workgroup's working-wconfig before +FRAME is deleted, so we don't lose its state." + (if (> (length (frame-list)) 1) + (wg-flag-session-modified)) + ;;(with-selected-frame frame + ;; (wg-update-current-workgroup-working-wconfig)) + ) + +(defun wg-wconfig-buf-uids (wconfig) + "Return WCONFIG's wtree's `wg-wtree-buf-uids'." + (if (not (wg-wconfig-wtree wconfig)) + (error "WTREE is nil in `wg-wconfig-buf-uids'!")) + (wg-wtree-unique-buf-uids (wg-wconfig-wtree wconfig))) + + + + + +(defun wg-wconfig-restore-frame-position (wconfig &optional frame) + "Use WCONFIG to restore FRAME's position. +If frame is nil then `selected-frame'." + (-when-let* ((left (wg-wconfig-left wconfig)) + (top (wg-wconfig-top wconfig))) + ;; Check that arguments are integers + ;; Problem: https://github.com/pashinin/workgroups2/issues/15 + (if (and (integerp left) + (integerp top)) + (set-frame-position frame left top)))) + +(defun wg-wconfig-restore-scroll-bars (wconfig) + "Restore `selected-frame's scroll-bar settings from WCONFIG." + (set-frame-parameter + nil 'vertical-scroll-bars (wg-wconfig-vertical-scroll-bars wconfig)) + (set-frame-parameter + nil 'scroll-bar-width (wg-wconfig-scroll-bar-width wconfig))) + +;;(defun wg-wconfig-restore-fullscreen (wconfig) +;; "Restore `selected-frame's fullscreen settings from WCONFIG." +;; (set-frame-parameter +;; nil 'fullscreen (wg-wconfig-parameters wconfig)) +;; ) + +(defun wg-scale-wconfigs-wtree (wconfig new-width new-height) + "Scale WCONFIG's wtree with NEW-WIDTH and NEW-HEIGHT. +Return a copy WCONFIG's wtree scaled with `wg-scale-wtree' by the +ratio or NEW-WIDTH to WCONFIG's width, and NEW-HEIGHT to +WCONFIG's height." + (wg-normalize-wtree + (wg-scale-wtree + (wg-wconfig-wtree wconfig) + (/ (float new-width) (wg-wconfig-width wconfig)) + (/ (float new-height) (wg-wconfig-height wconfig))))) + +(defun wg-scale-wconfig-to-frame (wconfig) + "Scale WCONFIG buffers to fit current frame size. +Return a scaled copy of WCONFIG." + (interactive) + (wg-scale-wconfigs-wtree wconfig + (frame-parameter nil 'width) + (frame-parameter nil 'height))) + +(defun wg-frame-resize-and-position (wconfig &optional frame) + "Apply WCONFIG's size and position to a FRAME." + (interactive) + (unless frame (setq frame (selected-frame))) + (let* ((params (wg-wconfig-parameters wconfig)) + fullscreen) + (set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params) + (cdr (assoc 'fullscreen params)) + nil)) + (when (and wg-restore-frame-position + (not (frame-parameter frame 'fullscreen))) + (wg-wconfig-restore-frame-position wconfig frame)) + )) + +(defun wg-restore-frame-size-position (wconfig &optional fs) + "Smart-restore of frame size and position. + +Depending on `wg-remember-frame-for-each-wg' frame parameters may +be restored for each workgroup. + +If `wg-remember-frame-for-each-wg' is nil (by default) then +current frame parameters are saved/restored to/from first +workgroup. And frame parameters for all other workgroups are just +ignored. +" + (interactive) + (let* ((params (wg-wconfig-parameters wconfig)) + fullscreen) + ;; Frame maximized / fullscreen / none + (unless wg-remember-frame-for-each-wg + (setq params (wg-wconfig-parameters (wg-workgroup-working-wconfig (wg-first-workgroup))))) + (setq fullscreen (if (assoc 'fullscreen params) + (cdr (assoc 'fullscreen params)) + nil)) + (when (and fs + fullscreen + (or wg-remember-frame-for-each-wg + (null (wg-current-workgroup t)))) + (set-frame-parameter nil 'fullscreen fullscreen) + ;; I had bugs restoring maximized frame: + ;; Frame could be maximized but buffers are not scaled to fit it. + ;; + ;; Maybe because of `set-frame-parameter' takes some time to finish and is async. + ;; So I tried this and it helped + (sleep-for 0 100)) + + ;; Position + (when (and wg-restore-frame-position + wg-remember-frame-for-each-wg + (not (frame-parameter nil 'fullscreen))) + (wg-wconfig-restore-frame-position wconfig)) + )) + + +(defun wg-restore-frames () + "Try to recreate opened frames, take info from session's 'frame-list parameter." + (interactive) + (delete-other-frames) + (awhen (wg-current-session t) + (let ((fl (wg-session-parameter 'frame-list nil it)) + (frame (selected-frame))) + (mapc (lambda (wconfig) + (with-selected-frame (make-frame) + ;;(wg-frame-resize-and-position wconfig) + ;;(wg-restore-frame-size-position wconfig) + ;;(wg-wconfig-restore-frame-position wconfig) + (wg-restore-wconfig wconfig) + )) fl) + (select-frame-set-input-focus frame)))) + +;; FIXME: throw a specific error if the restoration was unsuccessful +(defun wg-restore-wconfig (wconfig &optional frame) + "Restore a workgroup configuration WCONFIG in a FRAME. +Runs each time you're switching workgroups." + (unless frame (setq frame (selected-frame))) + (let ((wg-record-incorrectly-restored-bufs t) + (wg-incorrectly-restored-bufs nil) + (params (wg-wconfig-parameters wconfig)) + fullscreen) + (wg-barf-on-active-minibuffer) + (when wg-restore-scroll-bars + (wg-wconfig-restore-scroll-bars wconfig)) + + (when (null (wg-current-workgroup t)) + (set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params) + (cdr (assoc 'fullscreen params)) + nil))) + + ;; Restore frame position + (when (and wg-restore-frame-position + (not (frame-parameter nil 'fullscreen)) + (null (wg-current-workgroup t))) + (wg-wconfig-restore-frame-position wconfig frame)) + + ;; Restore buffers + (wg-restore-window-tree (wg-scale-wconfig-to-frame wconfig)) + + (when wg-incorrectly-restored-bufs + (message "Unable to restore these buffers: %S\ +If you want, restore them manually and try again." + (mapcar 'wg-buf-name wg-incorrectly-restored-bufs))))) + + +;;; saved wconfig commands + +(defun wg-save-wconfig () + "Save the current wconfig to the current workgroup's saved wconfigs." + (interactive) + (let* ((workgroup (wg-current-workgroup)) + (name (wg-read-saved-wconfig-name workgroup)) + (wconfig (wg-current-wconfig))) + (setf (wg-wconfig-name wconfig) name) + (wg-workgroup-save-wconfig workgroup wconfig) + (wg-fontified-message + (:cmd "Saved: ") + (:cur name)))) + +(defun wg-restore-saved-wconfig () + "Restore one of the current workgroup's saved wconfigs in `selected-frame'." + (interactive) + (let ((workgroup (wg-current-workgroup))) + (wg-restore-wconfig-undoably + (wg-workgroup-get-saved-wconfig + workgroup + (ido-completing-read "Saved wconfig: " + (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup)) + nil t))))) + +(defun wg-kill-saved-wconfig () + "Kill one of the current workgroup's saved wconfigs. +Also add it to the wconfig kill-ring." + (interactive) + (let* ((workgroup (wg-current-workgroup)) + (wconfig (wg-read-saved-wconfig workgroup))) + (wg-workgroup-kill-saved-wconfig workgroup wconfig) + (wg-add-to-wconfig-kill-ring wconfig) + (wg-fontified-message + (:cmd "Deleted: ") + (:cur (wg-wconfig-name wconfig))))) + + +(defun wg-reverse-wconfig (wconfig &optional dir) + "Reverse WCONFIG's wtree's wlist in direction DIR." + (wg-asetf (wg-wconfig-wtree wconfig) (wg-reverse-wlist it dir)) + wconfig) + + +;; specialbufs +(defcustom wg-special-buffer-serdes-functions + '(wg-serialize-comint-buffer + ) + "Functions providing serialization/deserialization for complex buffers. + +Use `wg-support' macro and this variable will be filled +automatically. + +An entry should be either a function symbol or a lambda, and should +accept a single Emacs buffer object as an argument. + +When a buffer is to be serialized, it is passed to each of these +functions in turn until one returns non-nil, or the list ends. A +return value of nil indicates that the function can't handle +buffers of that type. A non-nil return value indicates that it +can. The first non-nil return value becomes the buffer's special +serialization data. The return value should be a cons, with a +deserialization function (a function symbol or a lambda) as the car, +and any other serialization data as the cdr. + +When it comes time to deserialize the buffer, the deserialization +function (the car of the cons mentioned above) is passed the +wg-buf object, from which it should restore the buffer. The +special serialization data itself can be accessed +with (cdr (wg-buf-special-data )). The deserialization +function must return the restored Emacs buffer object. + +See the definitions of the functions in this list for examples of +how to write your own." + :type 'alist + :group 'workgroups) + +;; Dired +(wg-support 'dired-mode 'dired + `((deserialize . ,(lambda (buffer vars) + (when (or wg-restore-remote-buffers + (not (file-remote-p default-directory))) + (let ((d (wg-get-first-existing-dir))) + (if (file-directory-p d) (dired d)))))))) + +;; `Info-mode' C-h i +(wg-support 'Info-mode 'info + `((save . (Info-current-file Info-current-node)) + (deserialize . ,(lambda (buffer vars) + ;;(with-current-buffer + ;; (get-buffer-create (wg-buf-name buffer)) + (aif vars + (if (fboundp 'Info-find-node) + (apply #'Info-find-node it)) + (info) + (get-buffer (wg-buf-name buffer))))))) + +;; `help-mode' +;; Bug: https://github.com/pashinin/workgroups2/issues/29 +;; bug in wg-get-value +(wg-support 'help-mode 'help-mode + `((save . (help-xref-stack-item help-xref-stack help-xref-forward-stack)) + (deserialize . ,(lambda (buffer vars) + (wg-dbind (item stack forward-stack) vars + (condition-case err + (apply (car item) (cdr item)) + (error (message "%s" err))) + (awhen (get-buffer "*Help*") + (set-buffer it) + (wg-when-boundp (help-xref-stack help-xref-forward-stack) + (setq help-xref-stack stack + help-xref-forward-stack forward-stack)))))))) + +;; ielm +(wg-support 'inferior-emacs-lisp-mode 'ielm + `((deserialize . ,(lambda (buffer vars) + (ielm) (get-buffer "*ielm*"))))) + +;; Magit status +(wg-support 'magit-status-mode 'magit + `((deserialize . ,(lambda (buffer vars) + (if (file-directory-p default-directory) + (magit-status default-directory) + (let ((d (wg-get-first-existing-dir))) + (if (file-directory-p d) (dired d)))))))) + +;; Shell +(wg-support 'shell-mode 'shell + `((deserialize . ,(lambda (buffer vars) + (shell (wg-buf-name buffer)))))) + +;; org-agenda buffer +(defun wg-get-org-agenda-view-commands () + "Return commands to restore the state of Agenda buffer. +Can be restored using \"(eval commands)\"." + (interactive) + (when (boundp 'org-agenda-buffer-name) + (if (get-buffer org-agenda-buffer-name) + (with-current-buffer org-agenda-buffer-name + (let* ((p (or (and (looking-at "\\'") (1- (point))) (point))) + (series-redo-cmd (get-text-property p 'org-series-redo-cmd))) + (if series-redo-cmd + (get-text-property p 'org-series-redo-cmd) + (get-text-property p 'org-redo-cmd))))))) + +(defun wg-run-agenda-cmd (f) + "Run commands F in Agenda buffer. +You can get these commands using `wg-get-org-agenda-view-commands'." + (when (and (boundp 'org-agenda-buffer-name) + (fboundp 'org-current-line) + (fboundp 'org-goto-line)) + (if (get-buffer org-agenda-buffer-name) + (save-window-excursion + (with-current-buffer org-agenda-buffer-name + (let* ((line (org-current-line))) + (if f (eval f)) + (org-goto-line line))))))) + +(wg-support 'org-agenda-mode 'org-agenda + '((serialize . (lambda (buffer) + (wg-get-org-agenda-view-commands))) + (deserialize . (lambda (buffer vars) + (org-agenda-list) + (awhen (get-buffer org-agenda-buffer-name) + (with-current-buffer it + (wg-run-agenda-cmd vars)) + it))))) + +;; eshell +(wg-support 'eshell-mode 'esh-mode + '((deserialize . (lambda (buffer vars) + (prog1 (eshell t) + (rename-buffer (wg-buf-name buffer) t)))))) + +;; term-mode +;; +;; This should work for `ansi-term's, too, as there doesn't seem to +;; be any difference between the two except how the name of the +;; buffer is generated. +;; +(wg-support 'term-mode 'term + `((serialize . ,(lambda (buffer) + (if (get-buffer-process buffer) + (-last-item (process-command (get-buffer-process buffer))) + "/bin/bash"))) + (deserialize . ,(lambda (buffer vars) + (cl-labels ((term-window-width () 80) + (window-height () 24)) + (prog1 (term vars) + (rename-buffer (wg-buf-name buffer) t))))))) + +;; `inferior-python-mode' +(wg-support 'inferior-python-mode 'python + `((save . (python-shell-interpreter python-shell-interpreter-args)) + (deserialize . ,(lambda (buffer vars) + (wg-dbind (pythoncmd pythonargs) vars + (run-python (concat pythoncmd " " pythonargs)) + (awhen (get-buffer (process-buffer + (python-shell-get-or-create-process))) + (with-current-buffer it (goto-char (point-max))) + it)))))) + + +;; Sage shell ;; +(wg-support 'inferior-sage-mode 'sage-mode + `((deserialize . ,(lambda (buffer vars) + (save-window-excursion + (if (boundp' sage-command) + (run-sage t sage-command t))) + (if (boundp 'sage-buffer) + (awhen sage-buffer + (set-buffer it) + (switch-to-buffer sage-buffer) + (goto-char (point-max)))))))) + +;; `inferior-ess-mode' M-x R +(wg-support 'inferior-ess-mode 'ess-inf + `((save . (inferior-ess-program)) + (deserialize . ,(lambda (buffer vars) + (wg-dbind (cmd) vars + (let ((ess-ask-about-transfile nil) + (ess-ask-for-ess-directory nil) + (ess-history-file nil)) + (R) + (get-buffer (wg-buf-name buffer)))))))) + +;; `inferior-octave-mode' +(wg-support 'inferior-octave-mode 'octave + `((deserialize . ,(lambda (buffer vars) + (prog1 (run-octave) + (rename-buffer (wg-buf-name buffer) t)))))) + +;; `prolog-inferior-mode' +(wg-support 'prolog-inferior-mode 'prolog + `((deserialize . ,(lambda (buffer vars) + (save-window-excursion + (run-prolog nil)) + (switch-to-buffer "*prolog*") + (goto-char (point-max)))))) + +;; `ensime-inf-mode' +(wg-support 'ensime-inf-mode 'ensime + `((deserialize . ,(lambda (buffer vars) + (save-window-excursion + (ensime-inf-switch)) + (when (boundp 'ensime-inf-buffer-name) + (switch-to-buffer ensime-inf-buffer-name) + (goto-char (point-max))))))) + +;; compilation-mode +;; +;; I think it's not a good idea to compile a program just to switch +;; workgroups. So just restoring a buffer name. +(wg-support 'compilation-mode 'compile + `((serialize . ,(lambda (buffer) + (if (boundp' compilation-arguments) compilation-arguments))) + (deserialize . ,(lambda (buffer vars) + (save-window-excursion + (get-buffer-create (wg-buf-name buffer))) + (with-current-buffer (wg-buf-name buffer) + (when (boundp' compilation-arguments) + (make-local-variable 'compilation-arguments) + (setq compilation-arguments vars))) + (switch-to-buffer (wg-buf-name buffer)) + (goto-char (point-max)))))) + +;; grep-mode +;; see grep.el - `compilation-start' - it is just a compilation buffer +;; local variables: +;; `compilation-arguments' == (cmd mode nil nil) +(wg-support 'grep-mode 'grep + `((serialize . ,(lambda (buffer) + (if (boundp' compilation-arguments) compilation-arguments))) + (deserialize . ,(lambda (buffer vars) + (compilation-start (car vars) (nth 1 vars)) + (switch-to-buffer "*grep*"))))) +;; `speedbar-mode' (has bugs) +;; only from sr-speedbar.el +;;(wg-support 'speedbar-mode 'sr-speedbar +;; `((deserialize . ,(lambda (buffer vars) +;; ;;(with-current-buffer (get-buffer-create "*SPEEDBAR*") +;; (with-no-warnings +;; (setq speedbar-buffer (get-buffer-create "*SPEEDBAR*")) +;; (setq speedbar-frame (selected-frame) +;; dframe-attached-frame (selected-frame) +;; speedbar-select-frame-method 'attached +;; speedbar-verbosity-level 0 +;; speedbar-last-selected-file nil) +;; (set-buffer speedbar-buffer) +;; (speedbar-mode) +;; (speedbar-reconfigure-keymaps) +;; (speedbar-update-contents) +;; (speedbar-set-timer 1) +;; (aif (get-buffer-window "*SPEEDBAR*") +;; (set-window-dedicated-p it t)) +;; (get-buffer-create "*SPEEDBAR*")))))) + + +(defun wg-deserialize-slime-buffer (buf) + "Deserialize `slime' buffer BUF." + (when (require 'slime nil 'noerror) + (wg-dbind (this-function args) (wg-buf-special-data buf) + (let ((default-directory (car args)) + (arguments (nth 1 args))) + (when (and (fboundp 'slime-start*) + (fboundp 'slime-process)) + (save-window-excursion + (slime-start* arguments)) + (switch-to-buffer (process-buffer (slime-process))) + (current-buffer)))))) + +;; `comint-mode' (general mode for all shells) +;; +;; It may have different shells. So we need to determine which shell is +;; now in `comint-mode' and how to restore it. +;; +;; Just executing `comint-exec' may be not enough because we can miss +;; some hooks or any other stuff that is executed when you run a +;; specific shell. +(defun wg-serialize-comint-buffer (buffer) + "Serialize comint BUFFER." + (with-current-buffer buffer + (if (fboundp 'comint-mode) + (when (eq major-mode 'comint-mode) + ;; `slime-inferior-lisp-args' var is used when in `slime' + (when (and (boundp 'slime-inferior-lisp-args) + slime-inferior-lisp-args) + (list 'wg-deserialize-slime-buffer + (list default-directory slime-inferior-lisp-args) + )))))) + +;; inf-mongo +;; https://github.com/tobiassvn/inf-mongo +;; `mongo-command' - command used to start inferior mongo +(wg-support 'inf-mongo-mode 'inf-mongo + `((serialize . ,(lambda (buffer) + (if (boundp 'inf-mongo-command) inf-mongo-command))) + (deserialize . ,(lambda (buffer vars) + (save-window-excursion + (when (fboundp 'inf-mongo) + (inf-mongo vars))) + (when (get-buffer "*mongo*") + (switch-to-buffer "*mongo*") + (goto-char (point-max))))))) + +(defun wg-temporarily-rename-buffer-if-exists (buffer) + "Rename BUFFER if it exists." + (when (get-buffer buffer) + (with-current-buffer buffer + (rename-buffer "*wg--temp-buffer*" t)))) + +;; SML shell +;; Functions to serialize deserialize inferior sml buffer +;; `inf-sml-program' is the program run as inferior sml, is the +;; `inf-sml-args' are the extra parameters passed, `inf-sml-host' +;; is the host on which sml was running when serialized +(wg-support 'inferior-sml-mode 'sml-mode + `((serialize . ,(lambda (buffer) + (list (if (boundp 'sml-program-name) sml-program-name) + (if (boundp 'sml-default-arg) sml-default-arg) + (if (boundp 'sml-host-name) sml-host-name)))) + (deserialize . ,(lambda (buffer vars) + (wg-dbind (program args host) vars + (save-window-excursion + ;; If a inf-sml buffer already exists rename it temporarily + ;; otherwise `run-sml' will simply switch to the existing + ;; buffer, however we want to create a separate buffer with + ;; the serialized name + (let* ((inf-sml-buffer-name (concat "*" + (file-name-nondirectory program) + "*")) + (existing-sml-buf (wg-temporarily-rename-buffer-if-exists + inf-sml-buffer-name))) + (with-current-buffer (run-sml program args host) + ;; Rename the buffer + (rename-buffer (wg-buf-name buffer) t) + + ;; Now we can re-rename the previously renamed buffer + (when existing-sml-buf + (with-current-buffer existing-sml-buf + (rename-buffer inf-sml-buffer-name t)))))) + (switch-to-buffer (wg-buf-name buffer)) + (goto-char (point-max))))))) + +;; Geiser repls +;; http://www.nongnu.org/geiser/ +(wg-support 'geiser-repl-mode 'geiser + `((save . (geiser-impl--implementation)) + (deserialize . ,(lambda (buffer vars) + (when (fboundp 'run-geiser) + (wg-dbind (impl) vars + (run-geiser impl) + (goto-char (point-max)))) + (switch-to-buffer (wg-buf-name buffer)))))) + +;; w3m-mode +(wg-support 'w3m-mode 'w3m + `((save . (w3m-current-url)) + (deserialize . ,(lambda (buffer vars) + (wg-dbind (url) vars + (w3m-goto-url url)))))) + +;; notmuch +(wg-support 'notmuch-hello-mode 'notmuch + `((deserialize . ,(lambda (buffer vars) + (notmuch) + (get-buffer (wg-buf-name buffer)))))) + +;; Wanderlust modes: +;; WL - folders +;;(defun wg-deserialize-wl-folders-buffer (buf) +;; "" +;; (if (fboundp 'wl) +;; (wg-dbind (this-function) (wg-buf-special-data buf) +;; ;;(when (not (eq major-mode 'wl-folder-mode)) +;; (wl) +;; (goto-char (point-max)) +;; (current-buffer) +;; ))) +;; +;;(defun wg-serialize-wl-folders-buffer (buffer) +;; "" +;; (if (fboundp 'wl) +;; (with-current-buffer buffer +;; (when (eq major-mode 'wl-folder-mode) +;; (list 'wg-deserialize-wl-folders-buffer +;; ))))) + +;; WL - summary mode (list of mails) +;;(defun wg-deserialize-wl-summary-buffer (buf) +;; "" +;; (interactive) +;; (if (fboundp 'wl) +;; (wg-dbind (this-function param-list) (wg-buf-special-data buf) +;; (when (not (eq major-mode 'wl-summary-mode)) +;; (let ((fld-name (car param-list))) +;; ;;(switch-to-buffer "*scratch*") +;; ;;(wl) +;; ;;(wl-folder-jump-folder fld-name) +;; ;;(message fld-name) +;; ;;(goto-char (point-max)) +;; ;;(insert fld-name) +;; (current-buffer) +;; ))))) +;; +;;(defun wg-serialize-wl-summary-buffer (buffer) +;; "" +;; (if (fboundp 'wl) +;; (with-current-buffer buffer +;; (when (eq major-mode 'wl-summary-mode) +;; (list 'wg-deserialize-wl-summary-buffer +;; (wg-take-until-unreadable (list wl-summary-buffer-folder-name)) +;; ))))) +;; +;; +;;;; mime-view-mode +;; +;;(defun wg-deserialize-mime-view-buffer (buf) +;; "" +;; (wg-dbind (this-function) (wg-buf-special-data buf) +;; (when (not (eq major-mode 'mime-view-mode)) +;; ;;(wl-summary-enter-handler 3570) ; only in wl-summary-mode +;; ;;(wl-summary-enter-handler) ; only in wl-summary-mode +;; (current-buffer) +;; ))) +;; +;;(defun wg-serialize-mime-view-buffer (buffer) +;; "" +;; (with-current-buffer buffer +;; (when (eq major-mode 'mime-view-mode) +;; (list 'wg-deserialize-mime-view-buffer +;; )))) + + +;; emms-playlist-mode +;; +;; Help me on this one: +;; 1. How to start emms without any user interaction? +;; +;;(defun wg-deserialize-emms-buffer (buf) +;; "Deserialize emms-playlist buffer BUF." +;; (when (require 'emms-setup nil 'noerror) +;; (require 'emms-player-mplayer) +;; (emms-standard) +;; (emms-default-players) +;; (if (fboundp 'emms-playlist-mode) +;; (wg-dbind (this-function args) (wg-buf-special-data buf) +;; (let ((default-directory (car args))) +;; (save-window-excursion +;; ;;(emms) +;; (if (or (null emms-playlist-buffer) +;; (not (buffer-live-p emms-playlist-buffer))) +;; ;;(call-interactively 'emms-add-file) +;; (emms-source-directory "/usr/data/disk_3/Music/SORT/") +;; )) +;; ;; (emms) +;; ;;(with-current-buffer emms-playlist-buffer-name +;; ;;(emms-source-playlist-directory-tree "/usr/data/disk_3/Music/SORT/") +;; ;;(emms-source-directory "/usr/data/disk_3/Music/SORT") +;; ;;(switch-to-buffer emms-playlist-buffer-name) +;; (emms-playlist-mode-go) +;; (current-buffer) +;; ))))) +;; +;;(defun wg-serialize-emms-buffer (buffer) +;; "Serialize emms BUFFER." +;; (with-current-buffer buffer +;; (if (fboundp 'emms-playlist-mode) +;; (when (eq major-mode 'emms-playlist-mode) +;; (list 'wg-deserialize-emms-buffer +;; (wg-take-until-unreadable (list default-directory)) +;; ))))) + + +;;; buffer-local variable serdes + +(defun wg-serialize-buffer-mark-ring () + "Return a new list of the positions of the marks in `mark-ring'." + (mapcar 'marker-position mark-ring)) + +(defun wg-deserialize-buffer-mark-ring (positions) + "Set `mark-ring' to a new list of markers created from POSITIONS." + (setq mark-ring + (mapcar (lambda (pos) (set-marker (make-marker) pos)) + positions))) + +(defun wg-deserialize-buffer-major-mode (major-mode-symbol) + "Conditionally retore MAJOR-MODE-SYMBOL in `current-buffer'." + (and (fboundp major-mode-symbol) + (not (eq major-mode-symbol major-mode)) + (funcall major-mode-symbol))) + +(defun wg-deserialize-buffer-local-variables (buf) + "Restore BUF's buffer local variables in `current-buffer'." + (cl-loop for ((var . val) . rest) on (wg-buf-local-vars buf) + do (awhen (assq var wg-buffer-local-variables-alist) + (wg-dbind (var ser des) it + (if des (funcall des val) + (set var val)))))) + +(defmacro wg-workgroup-list () + "Setf'able `wg-current-session' modified slot accessor." + `(wg-session-workgroup-list (wg-current-session))) + +(defmacro wg-buf-list () + "Setf'able `wg-current-session' buf-list slot accessor." + `(wg-session-buf-list (wg-current-session))) + +(defun wg-restore-default-buffer (&optional switch) + "Return `wg-default-buffer' and maybe SWITCH to it." + (if switch + (switch-to-buffer wg-default-buffer t) + (get-buffer-create wg-default-buffer))) + +(defun wg-restore-existing-buffer (buf &optional switch) + "Return existing buffer from BUF and maybe SWITCH to it." + (-when-let (b (wg-find-buf-in-buffer-list buf (wg-buffer-list-emacs))) + (if switch (switch-to-buffer b t)) + (with-current-buffer b + (wg-set-buffer-uid-or-error (wg-buf-uid buf)) + b))) + +(defun wg-restore-file-buffer (buf &optional switch) + "Restore BUF by finding its file and maybe SWITCH to it. +Return the created buffer. +If BUF's file doesn't exist, call `wg-restore-default-buffer'" + ;;(-when-let ((file-name (wg-buf-file-name buf))) + (let ((file-name (wg-buf-file-name buf))) + (when (and file-name + (or wg-restore-remote-buffers + (not (file-remote-p file-name)))) + (cond ((file-exists-p file-name) + ;; jit ignore errors + ;;(ignore-errors + (condition-case err + (let ((b (find-file-noselect file-name nil nil nil))) + (with-current-buffer b + (rename-buffer (wg-buf-name buf) t) + (wg-set-buffer-uid-or-error (wg-buf-uid buf)) + (when wg-restore-mark + (set-mark (wg-buf-mark buf)) + (deactivate-mark)) + (wg-deserialize-buffer-local-variables buf) + ) + (if switch (switch-to-buffer b)) + b) + (error + (message "Error while restoring a file %s:\n %s" file-name (error-message-string err)) + nil))) + (t + ;; try directory + (if (file-directory-p (file-name-directory file-name)) + (dired (file-name-directory file-name)) + (progn + (message "Attempt to restore nonexistent file: %S" file-name) + nil)) + ))))) + +(defun wg-restore-special-buffer (buf &optional switch) + "Restore a buffer BUF with DESERIALIZER-FN and maybe SWITCH to it." + (-when-let* + ((special-data (wg-buf-special-data buf)) + (buffer (save-window-excursion + (condition-case err + (funcall (car special-data) buf) + (error (message "Error deserializing %S: %S" (wg-buf-name buf) err) + nil))))) + (if switch (switch-to-buffer buffer t)) + (with-current-buffer buffer + (wg-set-buffer-uid-or-error (wg-buf-uid buf))) + buffer)) + +(defun wg-restore-buffer (buf &optional switch) + "Restore BUF, return it and maybe SWITCH to it." + (when buf + (fset 'buffer-list wg-buffer-list-original) + (prog1 + (or (wg-restore-existing-buffer buf switch) + (wg-restore-special-buffer buf switch) ;; non existent dired problem + (wg-restore-file-buffer buf switch) + (progn (wg-restore-default-buffer switch) nil)) + (if wg-mess-with-buffer-list + (fset 'buffer-list wg-buffer-list-function))))) + + + +;;; buffer object utils + +(defun wg-buffer-uid (buffer-or-name) + "Return BUFFER-OR-NAME's buffer-local value of `wg-buffer-uid'." + (buffer-local-value 'wg-buffer-uid (wg-get-buffer buffer-or-name))) + +(defun wg-bufobj-uid (bufobj) + "Return BUFOBJ's uid." + (cl-etypecase bufobj + (buffer (wg-buffer-uid bufobj)) + (wg-buf (wg-buf-uid bufobj)) + (string (wg-bufobj-uid (wg-get-buffer bufobj))))) + +(defun wg-bufobj-name (bufobj) + "Return BUFOBJ's buffer name." + (cl-etypecase bufobj + (buffer (buffer-name bufobj)) + (wg-buf (wg-buf-name bufobj)) + (string (wg-buffer-name bufobj)))) + +(defun wg-bufobj-file-name (bufobj) + "Return BUFOBJ's filename." + (cl-etypecase bufobj + (buffer (buffer-file-name bufobj)) + (wg-buf (wg-buf-file-name bufobj)) + (string (wg-bufobj-file-name (wg-get-buffer bufobj))))) + +(defun wg-buf-major-mode (buf) + "Return BUF's `major-mode'. +It's stored in BUF's local-vars list, since it's a local variable." + (wg-aget (wg-buf-local-vars buf) 'major-mode)) + +(defun wg-buffer-major-mode (bufobj) + "Return BUFOBJ's `major-mode'. +It works with Emacs buffer, Workgroups buffer object and a simple string." + (cl-etypecase bufobj + (buffer (wg-buffer-major-mode bufobj)) + (wg-buf (wg-buf-major-mode bufobj)) + (string (wg-buffer-major-mode bufobj)))) + +;; `wg-equal-bufobjs' and `wg-find-bufobj' may need to be made a lot smarter +(defun wg-equal-bufobjs (bufobj1 bufobj2) + "Return t if BUFOBJ1 is \"equal\" to BUFOBJ2." + (let ((fname1 (wg-bufobj-file-name bufobj1)) + (fname2 (wg-bufobj-file-name bufobj2))) + (cond ((and fname1 fname2) (string= fname1 fname2)) + ((or fname1 fname2) nil) + ((string= (wg-bufobj-name bufobj1) (wg-bufobj-name bufobj2)) t)))) + +(defun wg-find-bufobj (bufobj bufobj-list) + "Find BUFOBJ in BUFOBJ-LIST, testing with `wg-equal-bufobjs'." + (cl-find bufobj bufobj-list :test 'wg-equal-bufobjs)) + +(defun wg-find-bufobj-by-uid (uid bufobj-list) + "Find the bufobj in BUFOBJ-LIST with uid UID." + (cl-find uid bufobj-list :test 'string= :key 'wg-bufobj-uid)) + +(defun wg-find-buffer-in-buf-list (buffer-or-name buf-list) + "Find BUFFER-OR-NAME in BUF-LIST." + (aif (wg-buffer-uid buffer-or-name) + (wg-find-bufobj-by-uid it buf-list) + (wg-find-bufobj buffer-or-name buf-list))) + +(defun wg-find-buf-in-buffer-list (buf buffer-list) + "Find BUF in BUFFER-LIST." + (or (wg-find-bufobj-by-uid (wg-buf-uid buf) buffer-list) + (wg-find-bufobj buf buffer-list))) + +(defun wg-find-buf-by-uid (uid) + "Find a buf in `wg-buf-list' by UID." + (when uid + (wg-find-bufobj-by-uid uid (wg-buf-list)))) + +(defun wg-set-buffer-uid-or-error (uid &optional buffer) + "Change UID value of a BUFFER's local var `wg-buffer-uid'. +If BUFFER already has a buffer local value of `wg-buffer-uid', +and it's not equal to UID, error." + (if wg-buffer-uid + ;;(if (string= wg-buffer-uid uid) uid + ;; (error "uids don't match %S and %S" uid wg-buffer-uid)) + (setq wg-buffer-uid uid))) + + +(defun wg-buffer-special-data (buffer) + "Return BUFFER's auxiliary serialization, or nil." + (cl-some (lambda (fn) (funcall fn buffer)) wg-special-buffer-serdes-functions)) + + +(defun wg-serialize-buffer-local-variables () + "Return an alist of buffer-local variable symbols and their values. +See `wg-buffer-local-variables-alist' for details." + (wg-docar (entry wg-buffer-local-variables-alist) + (wg-dbind (var ser des) entry + (when (local-variable-p var) + (cons var (if ser (funcall ser) (symbol-value var))))))) + +(defun wg-buffer-to-buf (buffer) + "Return the serialization (a wg-buf) of Emacs buffer BUFFER." + (with-current-buffer buffer + (wg-make-buf + :name (buffer-name) + :file-name (buffer-file-name) + :point (point) + :mark (mark) + :local-vars (wg-serialize-buffer-local-variables) + :special-data (wg-buffer-special-data buffer)))) + +(defun wg-add-buffer-to-buf-list (buffer) + "Make a buf from BUFFER, and add it to `wg-buf-list' if necessary. +If there isn't already a buf corresponding to BUFFER in +`wg-buf-list', make one and add it. Return BUFFER's uid +in either case." + (when buffer + (with-current-buffer buffer + (setq wg-buffer-uid + (aif (wg-find-buffer-in-buf-list buffer (wg-buf-list)) + (wg-buf-uid it) + (let ((buf (wg-buffer-to-buf buffer))) + (push buf (wg-buf-list)) + (wg-buf-uid buf))))))) + +(defun wg-buffer-uid-or-add (buffer) + "Return BUFFER's uid. +If there isn't already a buf corresponding to BUFFER in +`wg-buf-list', make one and add it." + (or (wg-buffer-uid buffer) (wg-add-buffer-to-buf-list buffer))) + +(defun wg-bufobj-uid-or-add (bufobj) + "If BUFOBJ is a wg-buf, return its uid. +If BUFOBJ is a buffer or a buffer name, see `wg-buffer-uid-or-add'." + (cl-etypecase bufobj + (wg-buf (wg-buf-uid bufobj)) ;; possibly also add to `wg-buf-list' + (buffer (wg-buffer-uid-or-add bufobj)) + (string (wg-bufobj-uid-or-add (wg-get-buffer bufobj))))) + +(defun wg-reset-buffer (buffer) + "Return BUFFER. +Currently only sets BUFFER's `wg-buffer-uid' to nil." + (with-current-buffer buffer (setq wg-buffer-uid nil))) + +(defun wg-update-buffer-in-buf-list (&optional buffer) + "Update BUFFER's corresponding buf in `wg-buf-list'. +BUFFER nil defaults to `current-buffer'." + (let ((buffer (or buffer (current-buffer)))) + (-when-let* ((uid (wg-buffer-uid buffer)) + (old-buf (wg-find-buf-by-uid uid)) + (new-buf (wg-buffer-to-buf buffer))) + (setf (wg-buf-uid new-buf) (wg-buf-uid old-buf)) + (wg-asetf (wg-buf-list) (cons new-buf (remove old-buf it)))))) + +(defvar wg-just-exited-minibuffer nil + "Flag set by `minibuffer-exit-hook'. +To exempt from undoification those window-configuration changes +caused by exiting the minibuffer. This is ugly, but necessary. +It may seem like we could just null out +`wg-undoify-window-configuration-change' in +`minibuffer-exit-hook', but that also prevents undoification of +window configuration changes triggered by commands called with +`execute-extended-command' -- i.e. it's just too coarse.") + +(defcustom wg-no-confirm-on-destructive-operation nil + "Do not request confirmation before various destructive operations." + :type 'boolean + :group 'workgroups) + +(defcustom wg-minibuffer-message-timeout 0.75 + "Bound to `minibuffer-message-timeout' when messaging while the +minibuffer is active." + :type 'float + :group 'workgroups) + +(defun wg-read-object (prompt test warning &optional initial-contents keymap + read hist default-value inherit-input-method) + "PROMPT for an object that satisfies TEST. WARNING if necessary. +INITIAL-CONTENTS KEYMAP READ HIST DEFAULT-VALUE +INHERIT-INPUT-METHOD are `read-from-minibuffer's args." + (cl-labels ((read () (read-from-minibuffer + prompt initial-contents keymap read hist + default-value inherit-input-method))) + (let ((obj (read))) + (when (and (equal obj "") default-value) (setq obj default-value)) + (while (not (funcall test obj)) + (message warning) + (sit-for wg-minibuffer-message-timeout) + (setq obj (read))) + obj))) + +(defun wg-read-new-workgroup-name (&optional prompt) + "Read a non-empty name string from the minibuffer. +Print PROMPT" + (let ((default (wg-new-default-workgroup-name))) + (wg-read-object + (or prompt (format "Name (default: %S): " default)) + (lambda (new) (and (stringp new) + (not (equal new "")) + (wg-unique-workgroup-name-p new))) + "Please enter a unique, non-empty name" + nil nil nil nil default))) + +(defun wg-read-workgroup-index () + "Prompt for the index of a workgroup." + (let ((max (1- (length (wg-workgroup-list-or-error))))) + (wg-read-object + (format "%s\n\nEnter [0-%d]: " (wg-workgroup-list-display) max) + (lambda (obj) (and (integerp obj) (wg-within obj 0 max t))) + (format "Please enter an integer [%d-%d]" 0 max) + nil nil t))) + +(defun wg-minibuffer-inactive-p () + "Return t when `minibuffer-depth' is zero, nil otherwise." + (zerop (minibuffer-depth))) + +(defun wg-barf-on-active-minibuffer () + "Throw an error when the minibuffer is active." + (when (not (wg-minibuffer-inactive-p)) + (error "Exit minibuffer to use workgroups functions!"))) + +(defvar wg-deactivation-list nil + "A stack of workgroups that are currently being switched away from. +Used to avoid associating the old workgroup's buffers with the +new workgroup during a switch.") + +(defun wg-flag-session-modified (&optional session) + "Set SESSION's modified flag." + (when (and wg-flag-modified + (or session (wg-current-session t))) + (setf (wg-session-modified (or session (wg-current-session t))) t))) + +(defun wg-flag-workgroup-modified (&optional workgroup) + "Set WORKGROUP's and the current session's modified flags." + (unless workgroup + (setq workgroup (wg-get-workgroup nil t))) + (when (and wg-flag-modified workgroup) + (setf (wg-workgroup-modified workgroup) t) + (wg-flag-session-modified))) + +(defun wg-current-workgroup (&optional noerror frame) + "Return current workgroup in frame. +Error unless NOERROR, in FRAME if specified." + (or wg-current-workgroup + (aif (frame-parameter frame 'wg-current-workgroup-uid) + (wg-find-workgroup-by :uid it noerror) + (unless noerror (error "No current workgroup in this frame"))))) + +(defun wg-previous-workgroup (&optional noerror frame) + "Return the previous workgroup in FRAME, or error unless NOERROR." + (aif (frame-parameter frame 'wg-previous-workgroup-uid) + (wg-find-workgroup-by :uid it noerror) + (unless noerror (error "No previous workgroup in this frame")))) + +(defun wg-set-current-workgroup (workgroup &optional frame) + "Set the current workgroup to WORKGROUP in FRAME. +WORKGROUP should be a workgroup or nil." + (set-frame-parameter frame 'wg-current-workgroup-uid + (when workgroup (wg-workgroup-uid workgroup)))) + +(defun wg-set-previous-workgroup (workgroup &optional frame) + "Set the previous workgroup to WORKGROUP in FRAME. +WORKGROUP should be a workgroup or nil." + (set-frame-parameter frame 'wg-previous-workgroup-uid + (when workgroup (wg-workgroup-uid workgroup)))) + +(defun wg-current-workgroup-p (workgroup &optional frame) + "Return t when WORKGROUP is the current workgroup, nil otherwise." + (awhen (wg-current-workgroup t frame) + (eq workgroup it))) + +(defun wg-previous-workgroup-p (workgroup &optional frame) + "Return t when WORKGROUP is the previous workgroup, nil otherwise." + (awhen (wg-previous-workgroup t frame) + (eq workgroup it))) + +(defun wg-get-workgroup (obj &optional noerror) + "Return a workgroup from OBJ. +If OBJ is a workgroup, return it. +If OBJ is a string, return the workgroup named OBJ, or error unless NOERROR. +If OBJ is nil, return the current workgroup, or error unless NOERROR." + (cond ((wg-workgroup-p obj) obj) + ((stringp obj) (wg-find-workgroup-by :name obj noerror)) + ((null obj) (wg-current-workgroup noerror)) + (t (error "Can't get workgroup from type:: %S" (type-of obj))))) + + +;;; workgroup parameters +;; +;; Quick test: +;; (wg-workgroup-parameters (wg-current-workgroup)) +;; (wg-set-workgroup-parameter (wg-current-workgroup) 'test1 t) +;; (wg-workgroup-parameter (wg-current-workgroup) 'test1) +(defun wg-workgroup-parameter (workgroup parameter &optional default) + "Return WORKGROUP's value for PARAMETER. +If PARAMETER is not found, return DEFAULT which defaults to nil. +WORKGROUP should be accepted by `wg-get-workgroup'." + (wg-aget (wg-workgroup-parameters (wg-get-workgroup workgroup)) + parameter default)) + +(defun wg-set-workgroup-parameter (parameter value &optional workgroup) + "Set PARAMETER to VALUE in a WORKGROUP. +WORKGROUP should be a value accepted by `wg-get-workgroup'. +Return VALUE." + (-when-let (workgroup (wg-get-workgroup (or workgroup (wg-current-workgroup t)) t)) + (wg-set-parameter (wg-workgroup-parameters workgroup) parameter value) + (wg-flag-workgroup-modified workgroup) + value)) + +(defun wg-remove-workgroup-parameter (parameter &optional workgroup) + "Remove PARAMETER from WORKGROUP's parameters." + (-when-let (workgroup (wg-get-workgroup workgroup t)) + (wg-flag-workgroup-modified workgroup) + (wg-asetf (wg-workgroup-parameters workgroup) (wg-aremove it parameter)))) + +(defun wg-workgroup-local-value (variable &optional workgroup) + "Return the value of VARIABLE in WORKGROUP. +WORKGROUP nil defaults to the current workgroup. If there is no +current workgroup, or if VARIABLE does not have a workgroup-local +binding in WORKGROUP, resolve VARIABLE with `wg-session-local-value'." + (let ((workgroup (wg-get-workgroup workgroup t))) + (if (not workgroup) (wg-session-local-value variable) + (let* ((undefined (cl-gensym)) + (value (wg-workgroup-parameter workgroup variable undefined))) + (if (not (eq value undefined)) value + (wg-session-local-value variable)))))) +(defalias 'wg-local-value 'wg-workgroup-local-value) + + +(defun wg-workgroup-saved-wconfig-names (workgroup) + "Return a new list of the names of all WORKGROUP's saved wconfigs." + (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup))) + +(defun wg-workgroup-get-saved-wconfig (wconfig-or-name &optional workgroup) + "Return the wconfig by WCONFIG-OR-NAME from WORKGROUP's saved wconfigs. +WCONFIG-OR-NAME must be either a string or a wconfig. If +WCONFIG-OR-NAME is a string and there is no saved wconfig with +that name, return nil. If WCONFIG-OR-NAME is a wconfig, and it +is a member of WORKGROUP's saved wconfigs, return is as given. +Otherwise return nil." + (let ((wconfigs (wg-workgroup-saved-wconfigs (or workgroup (wg-current-workgroup))))) + (cl-etypecase wconfig-or-name + (wg-wconfig (car (memq wconfig-or-name wconfigs))) + (string (cl-find wconfig-or-name wconfigs + :key 'wg-wconfig-name + :test 'string=))))) + +(defun wg-workgroup-save-wconfig (wconfig &optional workgroup) + "Add WCONFIG to WORKGROUP's saved wconfigs. +WCONFIG must have a name. If there's already a wconfig with the +same name in WORKGROUP's saved wconfigs, replace it." + (let ((name (wg-wconfig-name wconfig))) + (unless name (error "Attempt to save a nameless wconfig")) + (setf (wg-workgroup-modified workgroup) t) + (wg-asetf (wg-workgroup-saved-wconfigs workgroup) + (cons wconfig (cl-remove name it + :key 'wg-wconfig-name + :test 'string=))))) + +(defun wg-workgroup-kill-saved-wconfig (workgroup wconfig-or-name) + "Delete WCONFIG-OR-NAME from WORKGROUP's saved wconfigs. +WCONFIG-OR-NAME is resolved with `wg-workgroup-get-saved-wconfig'." + (-when-let (wconfig (wg-workgroup-get-saved-wconfig + workgroup wconfig-or-name)) + (wg-asetf (wg-workgroup-saved-wconfigs workgroup) (remq wconfig it) + (wg-workgroup-modified workgroup) t))) + + + +(defun wg-workgroup-base-wconfig-buf-uids (workgroup) + "Return a new list of all unique buf uids in WORKGROUP's working wconfig." + (wg-wconfig-buf-uids (wg-workgroup-base-wconfig workgroup))) + +(defun wg-workgroup-saved-wconfigs-buf-uids (workgroup) + "Return a new list of all unique buf uids in WORKGROUP's base wconfig." + (cl-reduce 'wg-string-list-union + (wg-workgroup-saved-wconfigs workgroup) + :key 'wg-wconfig-buf-uids)) + +(defun wg-workgroup-all-wconfig-buf-uids (workgroup) + "Return a new list of all unique buf uids in WORKGROUP's wconfigs." + (cl-union (wg-workgroup-base-wconfig-buf-uids workgroup) + (wg-workgroup-saved-wconfigs-buf-uids workgroup) + :test 'string=)) + +(defun wg-workgroup-all-buf-uids (workgroup) + "Return a new list of all unique buf uids in WORKGROUP." + (cl-reduce 'wg-string-list-union + (list (wg-workgroup-base-wconfig-buf-uids workgroup) + (wg-workgroup-saved-wconfigs-buf-uids workgroup)))) + +(defun wg-restore-workgroup (workgroup) + "Restore WORKGROUP in `selected-frame'." + (let (wg-flag-modified) + (wg-restore-wconfig-undoably (wg-workgroup-working-wconfig workgroup) t))) + +(defun wg-workgroup-list-or-error (&optional noerror) + "Return the value of `wg-current-session's :workgroup-list slot. +Or scream unless NOERROR." + (or (wg-workgroup-list) + (unless noerror (error "No workgroups are defined")))) + +(defun wg-find-workgroup-by (slotkey value &optional noerror) + "Return the workgroup on which ACCESSOR returns VALUE or error." + (let ((accessor (cl-ecase slotkey + (:name 'wg-workgroup-name) + (:uid 'wg-workgroup-uid)))) + (or (cl-find value (wg-workgroup-list-or-error noerror) :test 'equal :key accessor) + (unless noerror + (error "No are no workgroups with a %S of %S" + accessor value))))) + +(defun wg-cyclic-nth-from-workgroup (workgroup &optional n) + "Return the workgroup N places from WORKGROUP in `wg-workgroup-list'." + (wg-cyclic-nth-from-elt workgroup (wg-workgroup-list-or-error) (or n 1))) + +(defun wg-workgroup-names (&optional noerror) + "Return a list of workgroup names or scream unless NOERROR." + (mapcar 'wg-workgroup-name (wg-workgroup-list-or-error noerror))) + +(defun wg-read-workgroup-name (&optional require-match) + "Read a workgroup name from `wg-workgroup-names'. +REQUIRE-MATCH to match." + (ido-completing-read "Workgroup: " (wg-workgroup-names) nil require-match nil nil + (awhen (wg-current-workgroup t) (wg-workgroup-name it)))) + +(defun wg-new-default-workgroup-name () + "Return a new, unique, default workgroup name." + (let ((names (wg-workgroup-names t)) (index -1) result) + (while (not result) + (let ((new-name (format "wg%s" (cl-incf index)))) + (unless (member new-name names) + (setq result new-name)))) + result)) + +(defun wg-unique-workgroup-name-p (new-name) + "Return t if NEW-NAME is unique in `wg-workgroup-list', nil otherwise." + (cl-every (lambda (existing-name) (not (equal new-name existing-name))) + (wg-workgroup-names t))) + +(defun wg-read-saved-wconfig-name (workgroup &optional prompt require-match) + "Read the name of a saved wconfig, completing on the names of +WORKGROUP's saved wconfigs." + (ido-completing-read (or prompt "Saved wconfig name: ") + (wg-workgroup-saved-wconfig-names workgroup) + nil require-match)) + +(defun wg-read-saved-wconfig (workgroup) + "Read the name of and return one of WORKGROUP's saved wconfigs." + (wg-workgroup-get-saved-wconfig + workgroup (wg-read-saved-wconfig-name workgroup nil t))) + + +;;; workgroup-list reorganization commands + +(defun wg-swap-workgroups () + "Swap the previous and current workgroups." + (interactive) + (wg-swap-workgroups-in-workgroup-list + (wg-current-workgroup) (wg-previous-workgroup)) + (wg-fontified-message + (:cmd "Swapped: ") + (wg-workgroup-list-display))) + +(defun wg-offset-workgroup-left (&optional workgroup n) + "Offset WORKGROUP leftward in `wg-workgroup-list' cyclically." + (interactive (list nil current-prefix-arg)) + (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n -1)) + (wg-fontified-message + (:cmd "Offset left: ") + (wg-workgroup-list-display))) + +(defun wg-offset-workgroup-right (&optional workgroup n) + "Offset WORKGROUP rightward in `wg-workgroup-list' cyclically." + (interactive (list nil current-prefix-arg)) + (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n 1)) + (wg-fontified-message + (:cmd "Offset right: ") + (wg-workgroup-list-display))) + + +;;; undo/redo commands + +(defun wg-undo-wconfig-change (&optional workgroup) + "Undo a change to the current workgroup's window-configuration." + (interactive) + (let* ((workgroup (wg-get-workgroup workgroup)) + (undid? (wg-workgroup-offset-position-in-undo-list workgroup 1))) + (wg-fontified-message + (:cmd "Undo") + (:cur (if undid? "" " No more undo info"))))) + +(defun wg-redo-wconfig-change (&optional workgroup) + "Redo a change to the current workgroup's window-configuration." + (interactive) + (let* ((workgroup (wg-get-workgroup workgroup)) + (redid? (wg-workgroup-offset-position-in-undo-list workgroup -1))) + (wg-fontified-message + (:cmd "Redo") + (:cur (if redid? "" " No more redo info"))))) + +(defun wg-undo-once-all-workgroups () + "Do what the name says. Useful for instance when you +accidentally call `wg-revert-all-workgroups' and want to return +all workgroups to their un-reverted state." + (interactive) + (mapc 'wg-undo-wconfig-change (wg-workgroup-list-or-error)) + (wg-message "Undid once on all workgroups.")) + +(defun wg-redo-once-all-workgroups () + "Do what the name says. Probably useless. Included for +symetry with `wg-undo-once-all-workgroups'." + (interactive) + (mapc 'wg-redo-wconfig-change (wg-workgroup-list-or-error)) + (wg-message "Redid once on all workgroups.")) + + + +;;; 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-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-rename-workgroup (newname &optional workgroup) + "Set NEWNAME to WORKGROUP's name." + (interactive (list nil (wg-read-new-workgroup-name "New name: "))) + (-when-let (workgroup (wg-get-workgroup workgroup)) + (let* ((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"))) + +(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-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)))) + +(defun wg-switch-to-workgroup (workgroup &optional noerror) + "Switch to WORKGROUP. +NOERROR means fail silently." + (interactive (list (wg-read-workgroup-name))) + (fset 'buffer-list wg-buffer-list-original) + (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 switch + (run-hooks 'wg-before-switch-to-workgroup-hook) + ;; Save info about some hard-to-work-with libraries + (let (wg-flag-modified) + (wg-set-workgroup-parameter 'ecb (and (boundp 'ecb-minor-mode) + ecb-minor-mode))) + ;;(wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config (ecb-current-window-configuration)) + ;; (type-of (ecb-current-window-configuration)) + ;; (type-of (car (ecb-current-window-configuration))) + ;; (type-of (car (nthcdr 3 (ecb-current-window-configuration)))) + ;; (wg-pickelable-or-error (ecb-current-window-configuration)) + ;;(ecb-current-window-configuration) + ;;) + + ;; Before switching - turn off ECB + ;; https://github.com/pashinin/workgroups2/issues/34 + (if (and (boundp 'ecb-minor-mode) + (boundp 'ecb-frame) + (fboundp 'ecb-deactivate) + ecb-minor-mode + (equal ecb-frame (selected-frame))) + (let ((ecb-split-edit-window-after-start 'before-deactivation)) + (ecb-deactivate))) + + ;; Switch + (wg-restore-workgroup workgroup) + (wg-set-previous-workgroup current) + (wg-set-current-workgroup workgroup) + + ;; After switch + ;; Save "last-workgroup" to the session params + (let (wg-flag-modified) + (awhen (wg-current-workgroup t) + (wg-set-session-parameter 'last-workgroup (wg-workgroup-name it))) + (awhen (wg-previous-workgroup t) + (wg-set-session-parameter 'prev-workgroup (wg-workgroup-name it)))) + + ;; If a workgroup had ECB - turn it on + (if (and (boundp 'ecb-minor-mode) + (not ecb-minor-mode) + (fboundp 'ecb-activate) + (wg-workgroup-parameter (wg-current-workgroup t) 'ecb nil)) + (let ((ecb-split-edit-window-after-start 'before-deactivation)) + (ecb-activate))) + ;;(ecb-last-window-config-before-deactivation + ;; (wg-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config nil))) + + ;; `sr-speedbar' + ;; if *SPEEDBAR* buffer is visible - set some variables + (let* ((buffers (mapcar 'window-buffer (window-list))) + (buffer-names (mapcar 'buffer-name buffers))) + (when (and (featurep 'sr-speedbar) + (member sr-speedbar-buffer-name buffer-names)) + (setq sr-speedbar-window (get-buffer-window sr-speedbar-buffer-name)))) + + ;; Finally + (if wg-mess-with-buffer-list + (fset 'buffer-list wg-buffer-list-function)) + (wg-fontified-message (:cmd "Switched: ") (wg-workgroup-name (wg-current-workgroup t))) + (run-hooks 'wg-after-switch-to-workgroup-hook)) + (when current (pop wg-deactivation-list))))) + +(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 WORKGROUP that is (- N) places away 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-previous-workgroup () + "Switch to the previous workgroup." + (interactive) + (wg-switch-to-workgroup (wg-previous-workgroup))) + +(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)))) + +(defun wg-delete-other-workgroups (&optional workgroup) + "Delete all workgroups but WORKGROUP." + (interactive) + (let ((workgroup (wg-get-workgroup workgroup))) + (unless (or wg-no-confirm-on-destructive-operation + (y-or-n-p "Really delete all other workgroups? ")) + (error "Cancelled")) + (dolist (w (wg-workgroup-list-or-error)) + (unless (eq w workgroup) + (wg-delete-workgroup w))) + (unless (wg-current-workgroup-p workgroup) + (wg-switch-to-workgroup workgroup)) + (wg-fontified-message + (:cmd "Deleted: ") + (:msg "All workgroups but ") + (:cur (wg-workgroup-name workgroup))))) + +(defun wg-revert-workgroup (&optional workgroup) + "Restore WORKGROUP's window configuration to its state at the last save." + (interactive) + (let* ((workgroup (wg-get-workgroup workgroup)) + (base-wconfig (wg-workgroup-base-wconfig workgroup))) + (if (wg-current-workgroup-p workgroup) + (wg-restore-wconfig-undoably base-wconfig) + (wg-add-wconfig-to-undo-list workgroup base-wconfig)) + (wg-fontified-message + (:cmd "Reverted: ") + (:cur (wg-workgroup-name workgroup))))) + +(defun wg-revert-all-workgroups () + "Revert all workgroups to their base wconfigs. +Only workgroups' working-wconfigs in `selected-frame' are +reverted." + (interactive) + (mapc #'wg-revert-workgroup (wg-workgroup-list-or-error)) + (wg-fontified-message + (:cmd "Reverted: ") + (:msg "All"))) + +(defun wg-workgroup-state-table (&optional frame) + "Return FRAME's workgroup table, creating it first if necessary." + (or (frame-parameter frame 'wg-workgroup-state-table) + (let ((wtree (make-hash-table :test 'equal))) + (set-frame-parameter frame 'wg-workgroup-state-table wtree) + wtree))) + +(defun wg-get-workgroup-state (workgroup &optional frame) + "Return WORKGROUP's state table in a FRAME." + (let ((uid (wg-workgroup-uid workgroup)) + (state-table (wg-workgroup-state-table frame))) + (or (gethash uid state-table) + (let ((wgs (wg-make-workgroup-state + :undo-pointer 0 + :undo-list + (list (or (wg-workgroup-selected-frame-wconfig workgroup) + (wg-workgroup-base-wconfig workgroup)))))) + (puthash uid wgs state-table) + wgs)))) + +(defmacro wg-with-undo (workgroup spec &rest body) + "Bind WORKGROUP's undo state to SPEC and eval BODY." + (declare (indent 2)) + (wg-dbind (state undo-pointer undo-list) spec + `(let* ((,state (wg-get-workgroup-state ,workgroup)) + (,undo-pointer (wg-workgroup-state-undo-pointer ,state)) + (,undo-list (wg-workgroup-state-undo-list ,state))) + ,@body))) + +(defun wg-flag-just-exited-minibuffer () + "Added to `minibuffer-exit-hook'." + (setq wg-just-exited-minibuffer t)) + +(defun wg-flag-window-configuration-changed () + "Set `wg-window-configuration-changed' to t. +But only if not the minibuffer was just exited. Added to +`window-configuration-change-hook'." + (if wg-just-exited-minibuffer + (setq wg-just-exited-minibuffer nil) + (progn + (wg-flag-workgroup-modified) + (setq wg-window-configuration-changed t)))) + +(defun wg-unflag-undoify-window-configuration-change () + "Set `wg-undoify-window-configuration-change' to nil, exempting +from undoification any window-configuration changes caused by the +current command." + (setq wg-undoify-window-configuration-change nil)) + +(defun wg-set-workgroup-working-wconfig (workgroup wconfig) + "Set the working-wconfig of WORKGROUP to WCONFIG." + (wg-flag-workgroup-modified workgroup) + (setf (wg-workgroup-selected-frame-wconfig workgroup) wconfig) + (wg-with-undo workgroup (state undo-pointer undo-list) + (setcar (nthcdr undo-pointer undo-list) wconfig))) + +(defun wg-add-wconfig-to-undo-list (workgroup wconfig) + "Add WCONFIG to WORKGROUP's undo list, truncating its future if necessary." + (wg-with-undo workgroup (state undo-pointer undo-list) + (let ((undo-list (cons nil (nthcdr undo-pointer undo-list)))) + (awhen (nthcdr wg-wconfig-undo-list-max undo-list) (setcdr it nil)) + (setf (wg-workgroup-state-undo-list state) undo-list)) + (setf (wg-workgroup-state-undo-pointer state) 0)) + (wg-set-workgroup-working-wconfig workgroup wconfig)) + +(defun wg-workgroup-working-wconfig (workgroup &optional noupdate) + "Return WORKGROUP's working-wconfig. +If WORKGROUP is the current workgroup in `selected-frame', and +NOUPDATE is nil, set its working wconfig in `selected-frame' to +`wg-current-wconfig' and return the updated wconfig. Otherwise +return WORKGROUP's current undo state." + (if (and (not noupdate) (wg-current-workgroup-p workgroup)) + (wg-set-workgroup-working-wconfig workgroup (wg-current-wconfig)) + (wg-with-undo workgroup (state undo-pointer undo-list) + (nth undo-pointer undo-list)))) + +(defun wg-update-current-workgroup-working-wconfig () + "Update `selected-frame's current workgroup's working-wconfig with `wg-current-wconfig'." + (awhen (wg-current-workgroup t) + (wg-set-workgroup-working-wconfig it (wg-current-wconfig)))) + +(defun wg-restore-wconfig-undoably (wconfig &optional noundo) + "Restore WCONFIG in `selected-frame', saving undo information. +Skip undo when NOUNDO." + (when noundo (wg-unflag-undoify-window-configuration-change)) + (wg-update-current-workgroup-working-wconfig) + (wg-restore-wconfig wconfig)) + +(defun wg-workgroup-offset-position-in-undo-list (workgroup increment) + "Increment WORKGROUP's undo-pointer by INCREMENT. +Also restore the wconfig at the incremented undo-pointer if +WORKGROUP is current." + (wg-with-undo workgroup (state undo-pointer undo-list) + (let ((new-pointer (+ undo-pointer increment))) + (when (wg-within new-pointer 0 (length undo-list)) + (when (wg-current-workgroup-p workgroup) + (wg-restore-wconfig-undoably (nth new-pointer undo-list) t)) + (setf (wg-workgroup-state-undo-pointer state) new-pointer))))) + +(defun wg-undoify-window-configuration-change () + "Conditionally `wg-add-wconfig-to-undo-list'. +Added to `post-command-hook'." + (when (and wg-window-configuration-changed ;; When the window config has changed, + wg-undoify-window-configuration-change ;; and undoification is still on for the current command + (wg-minibuffer-inactive-p)) ;; and the change didn't occur while the minibuffer is active, + (-when-let (workgroup (wg-current-workgroup t)) ;; and there's a current workgroup, + ;; add the current wconfig to that workgroup's undo list: + (wg-add-wconfig-to-undo-list workgroup (wg-current-wconfig)))) + ;; Reset all flags no matter what: + (setq wg-window-configuration-changed nil + wg-undoify-window-configuration-change t + wg-already-updated-working-wconfig nil)) + +(defun wg-update-working-wconfig-hook () + "Used in before advice on all functions that trigger `window-configuration-change-hook'. +To save up to date undo info before the change." + (when (and (not wg-already-updated-working-wconfig) + (wg-minibuffer-inactive-p)) + (wg-update-current-workgroup-working-wconfig) + (setq wg-already-updated-working-wconfig t))) + +(defun wg-workgroup-gc-buf-uids (workgroup) + "Remove buf uids from WORKGROUP that have no referent in `wg-buf-list'." + (wg-asetf (wg-workgroup-strong-buf-uids workgroup) + (cl-remove-if-not 'wg-find-buf-by-uid it) + (wg-workgroup-weak-buf-uids workgroup) + (cl-remove-if-not 'wg-find-buf-by-uid it))) + +(defun wg-display-internal (elt-fn list) + "Return display string built by calling ELT-FN on each element of LIST." + (let ((div (wg-add-face :div wg-list-display-decor-divider)) + (wwidth (window-width (minibuffer-window))) + (i -1) + (str)) + (setq str + (wg-fontify + (:brace wg-list-display-decor-left-brace) + (if (not list) (funcall elt-fn nil nil) + (wg-doconcat (elt list div) (funcall elt-fn elt (cl-incf i)))) + (:brace wg-list-display-decor-right-brace))) + ;; (subseq str 0 wwidth) + )) + +(defun wg-workgroup-list-display (&optional workgroup-list) + "Return the WORKGROUP-LIST display string. +The string contains the names of all workgroups in `wg-workgroup-list', +decorated with faces, dividers and strings identifying the +current and previous workgroups." + (wg-display-internal 'wg-workgroup-display + (or workgroup-list (wg-workgroup-list)))) + +(defun wg-create-first-wg () + "Create a first workgroup if needed." + (when (and workgroups-mode + wg-session-load-on-start + (= (length (wg-workgroup-list)) 0)) + (wg-create-workgroup wg-first-wg-name) + (wg-mark-everything-unmodified))) + +(defun wg-pickel-workgroup-parameters (workgroup) + "Return a copy of WORKGROUP after pickeling its parameters. +If WORKGROUP's parameters are non-nil, otherwise return +WORKGROUP." + (if (not (wg-workgroup-parameters workgroup)) workgroup + (let ((copy (wg-copy-workgroup workgroup))) + (wg-asetf (wg-workgroup-parameters copy) (wg-pickel it)) + copy))) + +(defun wg-unpickel-workgroup-parameters (workgroup) + "If WORKGROUP's parameters are non-nil, return a copy of +WORKGROUP after unpickeling its parameters. Otherwise return +WORKGROUP." + (if (not (wg-workgroup-parameters workgroup)) workgroup + (let ((copy (wg-copy-workgroup workgroup))) + (wg-asetf (wg-workgroup-parameters copy) (wg-unpickel it)) + copy))) + +(defun wg-delete-workgroup (workgroup) + "Remove WORKGROUP from `wg-workgroup-list'. +Also delete all references to it by `wg-workgroup-state-table', +`wg-current-workgroup' and `wg-previous-workgroup'." + (dolist (frame (frame-list)) + (remhash (wg-workgroup-uid workgroup) (wg-workgroup-state-table frame)) + (when (wg-current-workgroup-p workgroup frame) + (wg-set-current-workgroup nil frame)) + (when (wg-previous-workgroup-p workgroup frame) + (wg-set-previous-workgroup nil frame))) + (setf (wg-workgroup-list) (remove workgroup (wg-workgroup-list-or-error))) + (wg-flag-session-modified) + workgroup) + +(defun wg-add-workgroup (workgroup &optional index) + "Add WORKGROUP to `wg-workgroup-list' at INDEX or the end. +If a workgroup with the same name exists, overwrite it." + (awhen (wg-find-workgroup-by :name (wg-workgroup-name workgroup) t) + (unless index (setq index (cl-position it (wg-workgroup-list-or-error)))) + (wg-delete-workgroup it)) + (wg-asetf (wg-workgroup-list) + (wg-insert-before workgroup it (or index (length it)))) + (wg-flag-session-modified) + workgroup) + +(defun wg-check-and-add-workgroup (workgroup) + "Add WORKGROUP to `wg-workgroup-list'. +Ask to overwrite if a workgroup with the same name exists." + (let ((name (wg-workgroup-name workgroup)) + (uid (wg-workgroup-uid workgroup))) + (when (wg-find-workgroup-by :uid uid t) + (error "A workgroup with uid %S already exists" uid)) + (when (wg-find-workgroup-by :name name t) + (unless (or wg-no-confirm-on-destructive-operation + (y-or-n-p (format "%S exists. Overwrite? " name))) + (error "Cancelled")))) + (wg-add-workgroup workgroup)) + +(defun wg-make-and-add-workgroup (name &optional blank) + "Create a workgroup named NAME with current `window-tree'. +If BLANK - then just scratch buffer. +Add it with `wg-check-and-add-workgroup'." + (wg-check-and-add-workgroup + (wg-make-workgroup + :name name + :base-wconfig (if blank (wg-make-blank-wconfig) + (wg-current-wconfig))))) + +(defun wg-get-workgroup-create (workgroup) + "Return the workgroup specified by WORKGROUP, creating a new one if needed. +If `wg-get-workgroup' on WORKGROUP returns a workgroup, return it. +Otherwise, if WORKGROUP is a string, create a new workgroup with +that name and return it. Otherwise error." + (or (wg-get-workgroup workgroup t) + (if (stringp workgroup) + (wg-make-and-add-workgroup workgroup) + (wg-get-workgroup workgroup)))) ; Call this again for its error message + +(defun wg-cyclic-offset-workgroup (workgroup n) + "Offset WORKGROUP's position in `wg-workgroup-list' by N." + (let ((workgroup-list (wg-workgroup-list-or-error))) + (unless (member workgroup workgroup-list) + (error "Workgroup isn't present in `wg-workgroup-list'.")) + (setf (wg-workgroup-list) (wg-cyclic-offset-elt workgroup workgroup-list n) + (wg-session-modified (wg-current-session)) t))) + +(defun wg-swap-workgroups-in-workgroup-list (workgroup1 workgroup2) + "Swap the positions of WORKGROUP1 and WORKGROUP2 in `wg-workgroup-list'." + (let ((workgroup-list (wg-workgroup-list-or-error))) + (when (eq workgroup1 workgroup2) + (error "Can't swap a workgroup with itself")) + (unless (and (memq workgroup1 workgroup-list) + (memq workgroup2 workgroup-list)) + (error "Both workgroups aren't present in `wg-workgroup-list'.")) + (setf (wg-workgroup-list) (wg-util-swap workgroup1 workgroup2 workgroup-list) + (wg-session-modified (wg-current-session)) t))) + +(defun wg-session-uids-consistent-p () + "Return t if there are no duplicate bufs or buf uids in the wrong places. +nil otherwise." + (and (not (wg-dups-p (wg-buf-list) :key 'wg-buf-uid :test 'string=)) + (not (wg-dups-p (wg-workgroup-list) :key 'wg-workgroup-uid :test 'string=)))) + +(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) + ;; TODO: handle errors when reading object + (let ((session (read (f-read-text 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))) + + (if wg-control-frames (wg-restore-frames)) + + (awhen (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 'last-workgroup) (wg-workgroup-names))) + (wg-switch-to-workgroup (wg-session-parameter 'last-workgroup)) + (wg-switch-to-workgroup (car it)))) + (awhen (wg-session-parameter 'prev-workgroup) + (when (and (member it (wg-workgroup-names)) + (wg-get-workgroup it t)) + (wg-set-previous-workgroup (wg-get-workgroup it t))))) + (wg-fontified-message (:cmd "Loaded: ") (:file filename)) + (wg-mark-everything-unmodified)) + (t + (wg-query-and-save-if-modified) + (wg-reset-internal (wg-make-session :file-name filename)) + (wg-fontified-message (:cmd "(New Workgroups session file)"))))) +(defalias 'wg-open-session 'wg-find-session-file) + +(defun wg-write-sexp-to-file (sexp file) + "Write the printable representation of SEXP to FILE." + (with-temp-buffer + (let ((print-level nil) (print-length nil)) + (insert (format "%S" sexp))) + (write-file file))) + +;; FIXME: Duplicate buf names probably shouldn't be allowed. An unrelated error +;; causes two *scratch* buffers to be present, triggering the "uids don't match" +;; error. Write something to remove bufs with duplicate names. +(defun wg-perform-session-maintenance () + "Perform various maintenance operations on the current Workgroups session." + (wg-update-current-workgroup-working-wconfig) + + ;; Update every workgroup's base wconfig with `wg-workgroup-update-base-wconfig' + (dolist (workgroup (wg-workgroup-list)) + (awhen (wg-workgroup-selected-frame-wconfig workgroup) + (setf (wg-workgroup-base-wconfig workgroup) it + (wg-workgroup-selected-frame-wconfig workgroup) nil))) + + ;; Garbage collection + (let ((all-buf-uids (wg-all-buf-uids))) + (wg-asetf (wg-buf-list) + (cl-remove-if-not (lambda (uid) (member uid all-buf-uids)) it + :key 'wg-buf-uid))) + (mapc 'wg-workgroup-gc-buf-uids (wg-workgroup-list)) ; Remove buf uids that have no referent in `wg-buf-list' + (mapc 'wg-update-buffer-in-buf-list (wg-buffer-list-emacs))) + +(defun wg-save-session-as (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." + (interactive (list (read-file-name "Save session as: ") + (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) + + ;; Save opened frames as a session parameter "frame-list". + ;; Exclude `selected-frame' and daemon one (if any). + ;; http://stackoverflow.com/questions/21151992/why-emacs-as-daemon-gives-1-more-frame-than-is-opened + (if wg-control-frames + (let ((fl (frame-list))) + ;; TODO: remove using dash + (mapc (lambda (frame) + (if (string-equal "initial_terminal" (terminal-name frame)) + (delete frame fl))) fl) + (setq fl (delete (selected-frame) fl)) + (let (wg-flag-modified) + (wg-set-session-parameter 'frame-list (mapcar 'wg-frame-to-wconfig fl))))) + (wg-write-sexp-to-file (wg-pickel-all-session-parameters) filename) + (wg-fontified-message (:cmd "Wrote: ") (:file filename)) + (wg-mark-everything-unmodified)) +(defalias 'wg-write-session-file 'wg-save-session-as) + +(defun wg-get-session-file () + "Return the filename in which to save the session." + (or (aif (wg-current-session t) (wg-session-file-name it)) + wg-session-file)) +;;(read-file-name (format "Save session as [%s]: " wg-session-file)) + +(defun wg-save-session (&optional force) + "Save the current Workgroups session if it's been modified. +When FORCE - save 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-save-session-as (wg-get-session-file))) + +(defun wg-reset-internal (&optional session) + "Reset Workgroups, setting `wg-current-session' to SESSION. +Resets all frame parameters, buffer-local vars, current session +object, etc. SESSION nil defaults to a new, blank session." + (mapc 'wg-reset-frame (frame-list)) + (mapc 'wg-reset-buffer (wg-buffer-list-emacs)) + (setq wg-wconfig-kill-ring nil) + (setq wg-current-session (or session (wg-make-session)))) + +(defun wg-all-buf-uids (&optional session buffer-list) + "Return the union of all SESSION buf-uids and BUFFER-LIST uids." + (cl-union (cl-reduce 'wg-string-list-union ; (wg-session-all-buf-uids session) + (wg-session-workgroup-list (or session (wg-current-session))) + :key 'wg-workgroup-all-buf-uids) + ;; (wg-buffer-list-all-uids buffer-list) + (delq nil (mapcar 'wg-buffer-uid (or buffer-list (wg-buffer-list-emacs)))) + :test 'string=)) + +(defun wg-modified-p () + "Return t when the current session or any of its workgroups are modified." + (aif (wg-current-session t) + (or (wg-session-modified it) + (cl-some 'wg-workgroup-modified (wg-workgroup-list))))) + +(defun wg-mark-everything-unmodified () + "Mark the session and all workgroups as unmodified." + (let (wg-undoify-window-configuration-change) ; to skip WG's `post-command-hook' that marks "modified" again + (-when-let (session (wg-current-session t)) + (setf (wg-session-modified session) nil)) + (dolist (workgroup (wg-workgroup-list)) + (setf (wg-workgroup-modified workgroup) nil)))) + +(defun wg-session-parameter (parameter &optional default session) + "Return session's value for PARAMETER. +If PARAMETER is not found, return DEFAULT which defaults to nil. +SESSION nil defaults to the current session." + (wg-aget (wg-session-parameters (or session (wg-current-session))) + parameter default)) + +(defun wg-set-session-parameter (parameter value &optional session) + "Set PARAMETER to VALUE in SESSION. +SESSION nil means use the current session. Return value." + (-when-let (session (or session (wg-current-session t))) + (wg-set-parameter (wg-session-parameters session) parameter value) + (wg-flag-session-modified session) + value)) + +(defun wg-remove-session-parameter (parameter &optional session) + "Remove parameter PARAMETER from SESSION's parameters." + (let ((session (or session (wg-current-session)))) + (wg-asetf (wg-session-parameters session) (wg-aremove it parameter)) + (wg-flag-session-modified session))) + +(defun wg-session-local-value (variable &optional session) + "Return the value of VARIABLE in SESSION. +SESSION nil defaults to the current session. If VARIABLE does +not have a session-local binding in SESSION, the value is +resolved by Emacs." + (let* ((undefined (cl-gensym)) + (value (wg-session-parameter variable undefined session))) + (if (not (eq value undefined)) value + (symbol-value variable)))) + +(defun wg-reset-frame (frame) + "Reset Workgroups' `frame-parameters' in FRAME to nil." + (set-frame-parameter frame 'wg-workgroup-state-table nil) + (set-frame-parameter frame 'wg-current-workgroup-uid nil) + (set-frame-parameter frame 'wg-previous-workgroup-uid nil)) + +(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 (wg-save-session)))) + +(defun wg-reload-session () + "Reload current workgroups session." + (interactive) + (let* ((file (wg-get-session-file)) + (exists (file-exists-p file))) + (condition-case err + (wg-open-session file) + (progn + (wg-create-first-wg) + (message "Error loading session-file: %s" err)))) + ;; TODO: print what exactly happened + (wg-create-first-wg)) + +(defun wg-save-session-on-emacs-exit () + "Call `wg-save-session-on-exit' with `wg-emacs-exit-save-behavior'. +Added to `kill-emacs-query-functions'." + (wg-save-session-on-exit wg-emacs-exit-save-behavior) t) + +(defun wg-save-session-on-workgroups-mode-exit () + "Call `wg-save-session-on-exit' with `wg-workgroups-mode-exit-save-behavior'. +Called when `workgroups-mode' is turned off." + (wg-save-session-on-exit wg-workgroups-mode-exit-save-behavior) t) + +(defun wg-pickel-all-session-parameters (&optional session) + "Return a copy of SESSION after pickeling its parameters. +And the parameters of all its workgroups." + (let ((copy (wg-copy-session (or session (wg-current-session))))) + (when (wg-session-parameters copy) + (wg-asetf (wg-session-parameters copy) (wg-pickel it))) + (wg-asetf (wg-session-workgroup-list copy) + (cl-mapcar 'wg-pickel-workgroup-parameters it)) + copy)) + +(defun wg-unpickel-session-parameters (session) + "Return a copy of SESSION after unpickeling its parameters. +And the parameters of all its workgroups." + (let ((copy (wg-copy-session session))) + (when (wg-session-parameters copy) + (wg-asetf (wg-session-parameters copy) (wg-unpickel it))) + (wg-asetf (wg-session-workgroup-list copy) + (cl-mapcar 'wg-unpickel-workgroup-parameters it)) + copy)) + +(defvar wg-buffer-workgroup nil + "Associating each buffer with the workgroup. +In which it most recently appeared.") +(make-variable-buffer-local 'wg-buffer-workgroup) + +(defun wg-workgroup-associated-buf-uids (&optional workgroup) + "Return a new list containing all of WORKGROUP's associated buf uids." + (awhen (or workgroup (wg-current-workgroup t)) + (append (wg-workgroup-strong-buf-uids it) + (wg-workgroup-weak-buf-uids it)))) + +(defun wg-workgroup-associated-bufs (workgroup) + "Return a new list containing all of WORKGROUP's associated bufs." + (delete nil (mapcar 'wg-find-buf-by-uid + (wg-workgroup-associated-buf-uids workgroup)))) + +(defun wg-workgroup-associated-buffers (workgroup) + "Return a new list containing all of WORKGROUP's associated buffer objects." + (delete nil (mapcar 'wg-restore-buffer + (wg-workgroup-associated-bufs workgroup)))) + +(defun wg-workgroup-strongly-associate-bufobj (workgroup bufobj) + "Strongly associate BUFOBJ with WORKGROUP." + (let* ((uid (wg-bufobj-uid-or-add bufobj)) + (remp (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup) + :test 'string=)) + (addp (wg-pushnew-p uid (wg-workgroup-strong-buf-uids workgroup) + :test 'string=))) + (when (or remp addp) + (wg-flag-workgroup-modified workgroup) + bufobj))) + +(defun wg-workgroup-weakly-associate-bufobj (workgroup bufobj) + "Weakly associate BUFOBJ with WORKGROUP." + (let* ((uid (wg-bufobj-uid-or-add bufobj)) + (remp (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup) + :test 'string=)) + (addp (wg-pushnew-p uid (wg-workgroup-weak-buf-uids workgroup) + :test 'string=))) + (when (or remp addp) + (wg-flag-workgroup-modified workgroup) + bufobj))) + +(defun wg-workgroup-associate-bufobj (workgroup bufobj &optional weak) + "Associate BUFOBJ with WORKGROUP. +WEAK non-nil means weakly associate it. Otherwise strongly associate it." + (if weak (wg-workgroup-weakly-associate-bufobj workgroup bufobj) + (wg-workgroup-strongly-associate-bufobj workgroup bufobj))) + +(defun wg-workgroup-dissociate-bufobj (workgroup bufobj) + "Dissociate BUFOBJ from WORKGROUP." + (let* ((uid (wg-bufobj-uid-or-add bufobj)) + (rem1p (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup) + :test 'string=)) + (rem2p (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup) + :test 'string=))) + (when (or rem1p rem2p) + (wg-flag-workgroup-modified workgroup) + bufobj))) + +(defun wg-workgroup-dissociate-weakly-associated-buffers (workgroup) + "Dissociate from WORKGROUP all weakly associated buffers." + (when (wg-workgroup-weak-buf-uids workgroup) + (wg-flag-workgroup-modified workgroup) + (setf (wg-workgroup-weak-buf-uids workgroup) nil))) + +(defun wg-workgroup-dissociate-strongly-associated-buffers (workgroup) + "Dissociate from WORKGROUP all strongly associated buffers." + (when (wg-workgroup-strong-buf-uids workgroup) + (wg-flag-workgroup-modified workgroup) + (setf (wg-workgroup-strong-buf-uids workgroup) nil))) + +(defun wg-workgroup-dissociate-all-buffers (workgroup) + "Dissociate from WORKGROUP all its associated buffers." + (wg-workgroup-dissociate-weakly-associated-buffers workgroup) + (wg-workgroup-dissociate-strongly-associated-buffers workgroup)) + +(defun wg-auto-dissociate-buffer-hook () + "`kill-buffer-hook' that automatically dissociates buffers from workgroups." + (when wg-dissociate-buffer-on-kill-buffer + (awhen (wg-current-workgroup t) + (wg-workgroup-dissociate-bufobj it (current-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-display-internal 'wg-buffer-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-associate-buffers (workgroup window-or-emacs-window-tree) + "Associate the buffers visible in window elements of +WINDOW-OR-EMACS-WINDOW-TREE with the given WORKGROUP. +WINDOW-OR-EMACS-WINDOW-TREE must be either a window or a tree of +the form produced by `(car (window-tree))'." + (if (windowp window-or-emacs-window-tree) + (with-current-buffer (window-buffer window-or-emacs-window-tree) + (setq wg-buffer-workgroup workgroup)) + (dolist (w (cddr window-or-emacs-window-tree)) + (when w (wg-associate-buffers workgroup w))))) + +(defun wg-workgroup-bufobj-association-type (workgroup bufobj) + "Return BUFOBJ's association-type in WORKGROUP, or nil if unassociated." + (let ((uid (wg-bufobj-uid-or-add bufobj))) + (or (and (member uid (wg-workgroup-strong-buf-uids workgroup)) 'strong) + (and (member uid (wg-workgroup-weak-buf-uids workgroup)) 'weak)))) + +(defun wg-associate-frame-buffers () + "Associate visible buffers with the current workgroup. +Unless it is currently being deactivated." + (awhen (wg-current-workgroup :noerror) + (unless (member it wg-deactivation-list) + (wg-associate-buffers it (car (window-tree)))))) + (defun wg-add-or-remove-workgroups-hooks (remove) "Add or remove all of Workgroups' hooks, depending on REMOVE." (wg-add-or-remove-hooks remove 'kill-emacs-query-functions 'wg-save-session-on-emacs-exit 'delete-frame-hook 'wg-update-working-wconfig-on-delete-frame + 'after-make-frame-functions 'wg-update-working-wconfig-on-make-frame 'wg-pre-window-configuration-change-hook 'wg-update-working-wconfig-hook 'window-configuration-change-hook 'wg-flag-window-configuration-changed 'post-command-hook 'wg-undoify-window-configuration-change 'minibuffer-exit-hook 'wg-flag-just-exited-minibuffer - 'ido-make-buffer-list-hook 'wg-set-ido-buffer-list 'kill-buffer-hook 'wg-update-buffer-in-buf-list + 'kill-buffer-hook 'wg-auto-dissociate-buffer-hook + ;;'window-configuration-change-hook 'wg-associate-frame-buffers )) - +;;;###autoload (defun workgroups-mode (&optional arg) "Turn `workgroups-mode' on and off. ARG is nil - toggle @@ -130,7 +4545,6 @@ ARG is anything else, turn on `workgroups-mode'." (cond ((not arg) (not workgroups-mode)) ((integerp arg) (if (> arg 0) t nil)) (t))) - (let (delayed) (cond (workgroups-mode (if (boundp 'desktop-restore-frames) @@ -141,11 +4555,16 @@ ARG is anything else, turn on `workgroups-mode'." (wg-add-or-remove-workgroups-hooks nil) (wg-change-modeline) + ;; some sr-speedbar hooks can harm + (when (featurep 'sr-speedbar) + (ad-disable-advice 'delete-other-windows 'around 'sr-speedbar-delete-other-window-advice) + (ad-disable-advice 'delete-window 'before 'sr-speedbar-delete-window-advice)) + ;; Load session (when (and wg-session-load-on-start (file-exists-p wg-session-file)) (condition-case err - (wg-find-session-file wg-session-file) + (wg-open-session wg-session-file) (error (message "Error finding `wg-session-file': %s" err)))) (run-hooks 'workgroups-mode-hook)) (t @@ -156,10 +4575,10 @@ ARG is anything else, turn on `workgroups-mode'." (run-hooks 'workgroups-mode-exit-hook))) (wg-fontified-message (:cmd "Workgroups Mode: ") (:msg (if workgroups-mode "on" "off"))) - (if (not delayed) (wg-create-first-wg)) - workgroups-mode)) - + (wg-create-first-wg) + workgroups-mode) +;;;###autoload (defun wg-help () "Just call `apropos-command' on \"^wg-\". There used to be a bunch of help-buffer construction stuff here, @@ -168,5 +4587,8 @@ command's docstring; But why, when there's `apropos-command'?" (interactive) (apropos-command "^wg-")) +;; Remove after some time +(defalias 'wg-switch-to-buffer 'switch-to-buffer) + (provide 'workgroups2) ;;; workgroups2.el ends here diff --git a/tests/ert-my-utils.el b/tests/ert-my-utils.el new file mode 100644 index 0000000000000000000000000000000000000000..1c4a68a18dc7ebeccf9e433e0c12e7b42fc43678 --- /dev/null +++ b/tests/ert-my-utils.el @@ -0,0 +1,89 @@ +;;; ert-my-utils.el --- Changes to ERT tests +;;; Commentary: +;; +;; Hacks to output errors when testing GUI +;; +;;; Code: + +(require 'cl-lib) +(require 'f) +(require 'ert) + +(defun wg-tests-log (&optional ok) + "Try to log with status OK." + (with-current-buffer "*Messages*" + (let ((txt (buffer-substring (point-min) (point-max)))) + (if ok + (f-write-text txt 'utf-8 "/tmp/wg-tests-ok.log") + (f-write-text txt 'utf-8 "/tmp/wg-tests.log"))))) + +(defun ert--run-test-internal (test-execution-info) + "Low-level function to run a test according to TEST-EXECUTION-INFO. + +My version without `save-window-excursion'." + (setf (ert--test-execution-info-next-debugger test-execution-info) debugger + (ert--test-execution-info-ert-debug-on-error test-execution-info) + ert-debug-on-error) + (catch 'ert--pass + ;;(with-temp-buffer + ;;(save-window-excursion + (let ((debugger (lambda (&rest args) + (ert--run-test-debugger test-execution-info args))) + (debug-on-error t) + (debug-on-quit t) + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))) + ;;)) + (ert-pass)) + (setf (ert--test-execution-info-result test-execution-info) + (make-ert-test-passed)) + nil) + +(defun my-ert-run-tests () + "My variant of `ert-run-tests-batch-and-exit'. +To hack this: +http://stackoverflow.com/questions/25490989/how-should-i-run-emacs-ert-tests-when-i-need-gui-tests" + (unwind-protect + (let ((stats (ert-run-tests-batch))) + (if (zerop (ert-stats-completed-unexpected stats)) + (wg-tests-log t) + (wg-tests-log)) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 0)) + ) + (unwind-protect + (progn + (message "Error running tests") + (backtrace) + ;;(wg-tests-log) + ) + (kill-emacs 0) + ))) + +(defmacro wg-test-special (mode pkg &rest body) + "Test restoring MODE from PKG. +Create needed buffer by executing BODY. +Then tests will follow to save it and restore." + (declare (indent 2)) + `(let ((wg-log-level 0) + message-log-max) + ;; prepare + (delete-other-windows) + (switch-to-buffer wg-default-buffer) + + ;; create a buffer + (require ,pkg) + ,@body + (should (eq major-mode ,mode)) + (wg-save-session) + + ;; save and restore + (workgroups-mode 0) + (switch-to-buffer wg-default-buffer) + (workgroups-mode 1) + (should (eq major-mode ,mode)) + )) + +(provide 'ert-my-utils) +;;; ert-my-utils.el ends here diff --git a/tests/workgroups2-tests.el b/tests/workgroups2-tests.el new file mode 100644 index 0000000000000000000000000000000000000000..46b7e9e5e56456ca6db9d06a1fb3ad8845381bfc --- /dev/null +++ b/tests/workgroups2-tests.el @@ -0,0 +1,177 @@ +;;; workgroups2-tests.el --- Try something here +;;; Commentary: +;;; Code: + +(require 'cl-lib) +(require 'f) +(require 'workgroups2) + +;;(defmacro w-all-buf-uids (value) +;; "Test `wg-all-buf-uids'." +;; (declare (indent 2)) +;; `(progn +;; (defface ,face ,spec ,doc ,@args))) + +(ert-deftest 000-initial () + ;;(make-frame) + (if (file-exists-p "/tmp/wg-tests.log") + (delete-file "/tmp/wg-tests.log")) + (if (file-exists-p "/tmp/wg-test") + (delete-file "/tmp/wg-test")) + ;;(should-not (string-equal "initial_terminal" (terminal-name (selected-frame)))) + (should (boundp workgroups-mode)) + (should-not workgroups-mode) + (should wg-session-load-on-start)) + +(ert-deftest 010-activate () + ;;(if (file-exists-p "/tmp/wg-test") + ;; (delete-file "/tmp/wg-test")) + (setq wg-session-file "/tmp/wg-test") + ;;(setq wg-session-load-on-start nil) + (let (message-log-max) + (workgroups-mode 1)) + (should workgroups-mode) + (should (string= (wg-get-session-file) "/tmp/wg-test"))) + +(ert-deftest 020-modeline-string () + (should (string= (wg-mode-line-string) " (First workgroup:--)")) + (setq wg-mode-line-decor-left-brace "[" + wg-mode-line-decor-right-brace "]") + (should (string= (wg-mode-line-string) " [First workgroup:--]")) + (setq wg-flag-modified nil) + (should (string= (wg-mode-line-string) " [First workgroup]")) + (setq wg-flag-modified t) + ) + +(ert-deftest 030-wg-utils () + (should (= (length (wg-all-buf-uids)) 1)) + (should (wg-frame-to-wconfig)) + ) + +(ert-deftest 040-wg-still-active () + (should workgroups-mode)) + +(ert-deftest 050-modify () + (split-window-vertically) + (switch-to-buffer "*Messages*") + ;; Check 2 buffers + ;;(should-not (window-tree)) + ;;(should-not (wg-window-tree-to-wtree)) + ;;(should (= (length (wg-all-buf-uids)) 2)) + ;;(should-not (wg-current-workgroup)) + (unless (string-equal "initial_terminal" (terminal-name (selected-frame))) + (should (wg-session-modified (wg-current-session)))) + + ;; Rename + (wg-rename-workgroup "asd") + (should (string= (wg-mode-line-string) " [asd:**]")) + (wg-rename-workgroup "First workgroup") + (should (string= (wg-mode-line-string) " [First workgroup:**]")) + + ) + +(ert-deftest 055-structs () + (let* ((s (wg-current-session)) + (wgs (wg-session-workgroup-list s)) + (wg1 (car wgs)) + (bufs (wg-session-buf-list s))) + (should s) + ;;(should (wg-session-modified s)) + (should wgs) + (should (string= "First workgroup" (wg-workgroup-name wg1))) + (should bufs) + ) + ;;(should-not (wg-current-wconfig)) + + ;; wtree + (let ((wtree (wg-window-tree-to-wtree))) + (should wtree) + (should-not (boundp 'window-tree)) + ;;(should (string= (wg-wtree-dir wtree) "a")) + ;;(should-not (wg-wtree-wlist wtree)) + ) + ) + +(ert-deftest 100-wg-save () + (should (= (length (frame-list)) 1)) + (let (message-log-max) + (wg-save-session)) + (should-not (wg-session-modified (wg-current-session))) + (unless (string-equal "initial_terminal" (terminal-name (selected-frame))) + (unless (file-exists-p "/tmp/wg-test") + (error "WG session file wasn't created")))) + + +;; Test serialization functions + +(defmacro test-pickel (value) + "Test `wg-pickel' `wg-unpickel' on VALUE." + `(progn + (eq (wg-unpickel (wg-pickel ,value)) ,value))) + +(ert-deftest 110-wg-pickel () + (test-pickel 123) + (test-pickel "str") + (test-pickel 'symbol) + (test-pickel (current-buffer)) ; # + (test-pickel (point-marker)) ; # + (test-pickel (make-marker)) ; # + (test-pickel (list 'describe-variable 'help-xref-stack-item (get-buffer "*Help*"))) + ;; TODO: + ;;(test-pickel (current-window-configuration)) + ) + + +;; Special buffers + +(require 'python) +(ert-deftest 300-special-modes () + (wg-test-special 'dired-mode 'dired + (dired "/tmp")) + + (wg-test-special 'Info-mode 'info + (info)) + + (wg-test-special 'help-mode 'help-mode + (describe-variable 'help-xref-stack-item) + (switch-to-buffer "*Help*")) + + (wg-test-special 'magit-status-mode 'magit + (magit-status ".")) + + (wg-test-special 'shell-mode 'shell + (shell)) + + (wg-test-special 'term-mode 'term + (term "/bin/sh")) + + (unless (version< emacs-version "24") + (wg-test-special 'inferior-python-mode 'python + (run-python python-shell-interpreter) + (switch-to-buffer (process-buffer (python-shell-get-or-create-process))))) + + ;; TODO: handle errors + ) + +(ert-deftest 310-frames () + (should wg-control-frames) + (make-frame) + (make-frame) + (should (wg-modified-p)) + (should (= (length (frame-list)) 3)) + (should workgroups-mode) + (let (message-log-max) + (wg-save-session)) + (should-not (wg-session-modified (wg-current-session))) + (should (= (length (wg-session-parameter 'frame-list)) 2)) + (delete-other-frames) + (should (= (length (frame-list)) 1)) + (wg-reload-session) + ;;(should (= (length (wg-session-parameter 'frame-list)) 2)) + (should (= (length (frame-list)) 3)) + (delete-other-frames) + (let (message-log-max) + (wg-save-session))) + +(provide 'workgroups2-tests) +;;; workgroups2-tests.el ends here