diff --git a/README.md b/README.md new file mode 100644 index 0000000000000000000000000000000000000000..39433ac458033f542556cc261910c65d094c392d --- /dev/null +++ b/README.md @@ -0,0 +1,182 @@ +# Workgroups for Emacs +## What it does? + +- It saves all your opened buffers, their location and sizes on disk to restore later. +- You also can create several workspaces. + +Isn't it enough? + +## Usage + +### Getting Workgroups + +See [github repo](http://github.com/tlh/workgroups.el). + +- Put `workgroups` somewhere on your Emacs load path + + cd ~/.emacs.d/extensions + git clone git://github.com/pashinin/workgroups2 + git pull + +### Installing + +- Byte-compile it if you want. This isn't required, but it'll speed some + things up: + + C-u 0 M-x byte-recompile-directory ~/.emacs.d/extensions/workgroups2/ + +- Load a module: + + (add-to-list 'load-path "~/.emacs.d/extensions/workgroups2") + (require 'workgroups2) + +- and set some parameters: + + ;; Settings: + (setq wg-prefix-key (kbd "C-c z") + wg-no-confirm t + wg-file "~/.emacs_files/workgroups" + wg-use-faces nil + wg-morph-on nil ; animation off + wg-switch-on-load t) ; load first on start + (workgroups-mode 1) + + ;; Keyboard shortcuts + ;; Load workgroups: + (global-set-key (kbd "") (lambda () (interactive) + (wg-find-session-file wg-file))) + ;; Save workgroups: + (global-set-key (kbd "C-S-") 'wg-save-session) ; Ctrl-Shift-pause + ;; Switch: + (global-set-key (kbd "s-z") 'wg-switch-to-workgroup) + (global-set-key (kbd "s-/") 'wg-switch-to-previous-workgroup) + ;; s-z == super + z == Win + z + +# Configuration + +- Set your prefix key (or not). The prefix key for Workgroups' commands + defaults to `C-z`. You could set it to `C-c w` like this: + + (setq wg-prefix-key (kbd "C-c w")) + + Workgroups saves the prefix key's current definition when it's enabled, and + restores it when it's disabled, so you don't have to worry about stomping + keydefs if you want to try out different prefixes. + + Most commands are bound to both ` ` and ` C-` for + convenience. See the definition of `wg-map` in the source for a complete list + of bindings. + +- There are many other customization options. See the customization section in + the source for details, or use: + + M-x customize-group RET workgroups RET + + +## Usage + +- Turn on `workgroups-mode` either by issuing the command: + + M-x workgroups-mode RET + + or by evaluating this form, which can be added to your `.emacs` file: + + (workgroups-mode 1) + + You should see "wg" in the minor mode list on the mode-line. + +- To get started right away, hit ` ?` for a list of commands and their + bindings. + + +## Tutorial + +### Workgroup Creation + +To start off, add a few workgroups. Hit ` c` to issue the command +`wg-create-workgroup`, give it a name, hit `RET`, and a new workgroup is +created. Maybe split the screen a few times with `C-x 2` and `C-x 3`, and +switch to different buffers in some of the windows to make it unique. Repeat +this process a few times to create some different workgroups. + +Every workgroup must have a unique name. You can rename workgroups after +they've been created with ` A` (`wg-rename-workgroup`). + +### Saving and Loading + +Saving and loading was the original motivation for writing Workgroups. You can +save your workgroups to a file with ` C-s` (`wg-save-session`) +and you can load workgroups from a file with `(wg-find-session-file wg-file)`. + +Once you have a file of saved workgroups, it's convenient to load it on +Emacs startup. To do so you can add a line like this to your`.emacs`: + + (wg-find-session-file "~/.emacs_files/workgroups") + +So your final `.emacs` setup may look something like this: + + (add-to-list 'load-path "/path/to/workgroups.el") (require 'workgroups) + (setq wg-prefix-key (kbd "C-c a")) (workgroups-mode 1) (wg-load + "/path/to/saved/workgroups") + +The customization variable `wg-switch-on-load` controls whether to automatically +switch to the first workgroup in a file when the file is loaded. It defaults to +`t`, so when you add the above to your `.emacs` file, the first workgroup in the +file will automatically be switched to on Emacs startup. + + +### Killing and Yanking + +You can kill workgroups with ` k` (`wg-kill-workgroup`). Killing a +workgroup deletes it from the list of workgroups, and copies its working config +to the kill ring. You can yank killed wconfigs into the current frame with +` y` (`wg-yank-config`). If the last command was `wg-yank-config`, +calling it again will yank the *next* wconfig in the kill ring, and so on, much +like Emacs' own kill ring. + +You can save a wconfig to the kill ring without killing its workgroup with the +kill-ring-save commands. ` M-w` (`wg-kill-ring-save-working-config`) +saves the working config to the kill ring, and ` M-W` +(`wg-kill-ring-save-base-config`) saves the base config to the kill ring. + +` M-k` (`wg-kill-workgroup-and-buffers`) kills a workgroup, and all the +buffers visible in it, and ` K` (`wg-delete-other-workgroups`) deletes +all but the current workgroup. + + +### Cloning + +Cloning a workgroup creates a new workgroup under a different name with the a +copy of the current workgroup's base and working configs. ` C` +(`wg-clone-workgroup`) will clone the current workgroup. + + +### Offsetting and Swapping + +You can move a workgroup leftward or rightward in the workgroups list with +` ,` (`wg-offset-left`) and ` .` (`wg-offset-right`) +respectively. These commands work cyclically, so when you offset a workgroup +leftward or rightward when it's already on the far left or right of the list, it +will wrap around to the other side. + +` x` (`wg-swap-workgroups`) will swap the position in the workgroups +list of the previously selected workgroup with that of the current workgroup. + +### Help + +To bring up a help buffer listing all the commands and their bindings, hit +` ?` (`wg-help`). + +## Original Workgroups + +There is a package on Melpa called "workgroups". +This extension is based on experimental branch of the original repo: + +https://github.com/tlh/workgroups.el + +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 Windows (for Emacs) is released under the GPL. diff --git a/dflet.el b/dflet.el new file mode 100644 index 0000000000000000000000000000000000000000..dc22477fedb759259319084284394ea3390c0672 --- /dev/null +++ b/dflet.el @@ -0,0 +1,86 @@ +;;; dflet.el --- dynamically-scoped flet + +;; Copyright (C) 2012 Yann Hodique +;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. + +;; Author: Yann Hodique +;; Keywords: lisp + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This is bringing back the historical definition of `flet', in all its global +;; and dynamic splendor. + +;;; Code: + +(eval-when-compile + (require 'cl) + (require 'macroexp) + (require 'subr-compat)) + +;;; silence byte-compiler +(eval-when-compile + (if (version< emacs-version "24.3") + ;; sure it doesn't exist, but it won't be called anyway... + (autoload 'cl--compiling-file "cl") + (declare-function cl--compiling-file "cl" t t))) + +(if (version< emacs-version "24.3") + ;; before that version, flet was not marked as obsolete, so use it + (defalias 'dflet 'flet) + + ;; This should really have some way to shadow 'byte-compile properties, etc. + (defmacro dflet (bindings &rest body) + "Make temporary overriding function definitions. +This is an analogue of a dynamically scoped `let' that operates on the function +cell of FUNCs rather than their value cell. +If you want the Common-Lisp style of `flet', you should use `cl-flet'. +The FORMs are evaluated with the specified function definitions in place, +then the definitions are undone (the FUNCs go back to their previous +definitions, or lack thereof). + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug cl-flet)) + `(letf ,(mapcar + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) macroexpand-all-environment))) + (error "Use `labels', not `dflet', to rebind macro names")) + (let ((func `(cl-function + (lambda ,(cadr x) + (cl-block ,(car x) ,@(cddr x)))))) + (when (cl--compiling-file) + ;; Bug#411. It would be nice to fix this. + (and (get (car x) 'byte-compile) + (error "Byte-compiling a redefinition of `%s' \ +will not work - use `labels' instead" (symbol-name (car x)))) + ;; FIXME This affects the rest of the file, when it + ;; should be restricted to the flet body. + (and (boundp 'byte-compile-function-environment) + (push (cons (car x) (eval func)) + byte-compile-function-environment))) + (list `(symbol-function ',(car x)) func))) + bindings) + ,@body))) + +;;;###autoload +(autoload 'dflet "dflet") + +(provide 'dflet) +;;; dflet.el ends here diff --git a/subr-compat.el b/subr-compat.el new file mode 100644 index 0000000000000000000000000000000000000000..e63a7c9ed6a365dee2e8446a33a6275195a9d225 --- /dev/null +++ b/subr-compat.el @@ -0,0 +1,35 @@ +;;; subr-compat.el --- subr.el compatibility layer + +;; Copyright (C) 2012 Yann Hodique + +;; Author: Yann Hodique +;; Keywords: lisp + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Allow `declare-function' to be used in older Emacs versions. Even if that +;; means doing exactly nothing. + +;;; Code: + +(or (fboundp 'declare-function) + (defmacro declare-function (&rest args) + nil)) + +(provide 'subr-compat) +;;; subr-compat.el ends here diff --git a/workgroups-advice.el b/workgroups-advice.el new file mode 100644 index 0000000000000000000000000000000000000000..e2ecdfd3528697bd8b68cb13756392f6c818ca10 --- /dev/null +++ b/workgroups-advice.el @@ -0,0 +1,189 @@ +;;; advice + +;; buffer auto-association advice + +(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 + (wg-when-let ((wg (wg-current-workgroup t frame))) + (unless (wg-workgroup-bufobj-association-type wg buffer) + (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))))) + + +;; `wg-pre-window-configuration-change-hook' implementation advice + +(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 '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-define-subr-args 'set-window-buffer '(window buffer-or-name &optional keep-margins)) + (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 + +(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) + + ) + +(provide 'workgroups-advice) diff --git a/workgroups-commands-minibuffer.el b/workgroups-commands-minibuffer.el new file mode 100644 index 0000000000000000000000000000000000000000..9264742817e069d8d2cbefb6f5417acd3fb261d0 --- /dev/null +++ b/workgroups-commands-minibuffer.el @@ -0,0 +1,58 @@ +;;; wg-minibuffer-mode commands + +(defun wg-next-buffer-list-filter () + "Trigger a switch to the next buffer-list-filter." + (interactive) + (throw 'wg-action (list 'next (minibuffer-contents)))) + +(defun wg-previous-buffer-list-filter () + "Trigger a switch to the previous buffer-list-filter." + (interactive) + (throw 'wg-action (list 'prev (minibuffer-contents)))) + +(defun wg-backward-char-or-next-buffer-list-filter () + "Call `backward-char' unless `point' is right after the prompt, +in which case call `wg-next-buffer-list-filter'." + (interactive) + (if (> (point) (minibuffer-prompt-end)) (backward-char) + (wg-next-buffer-list-filter))) + +(defun wg-backward-char-or-previous-buffer-list-filter (&optional num) + "Call `backward-char' unless `point' is right after the prompt, +in which case call `wg-previous-buffer-list-filter'." + (interactive) + (if (> (point) (minibuffer-prompt-end)) (backward-char) + (wg-previous-buffer-list-filter))) + +(defun wg-dissociate-first-match () + "Dissociate the first match from current workgroup." + (interactive) + (wg-when-let + ((mode (wg-read-buffer-mode)) + (buffer (wg-current-match mode)) + (pos (position buffer (wg-filtered-buffer-list t) :test 'equal))) + (wg-workgroup-dissociate-bufobj (wg-current-workgroup) buffer) + (wg-set-current-matches + (wg-rotate-list (wg-filtered-buffer-list t) pos) mode))) + +(defun wg-associate-first-match () + "Associate the first match with or update it in the current workgroup." + (interactive) + (wg-when-let + ((mode (wg-read-buffer-mode)) + (buffer (wg-current-match mode)) + (pos (position buffer (wg-filtered-buffer-list t) :test 'equal))) + (wg-workgroup-associate-bufobj (wg-current-workgroup) buffer) + (wg-set-current-matches + (wg-rotate-list (wg-filtered-buffer-list t) pos) mode))) + +(defun wg-minibuffer-mode-dissociate-weakly-associated-buffers () + "Dissociate weakly associated buffers and update the current matches." + (interactive) + (wg-workgroup-dissociate-weakly-associated-buffers (wg-current-workgroup)) + (wg-set-current-matches + (let ((remaining (wg-filtered-buffer-list t))) + (remove-if-not (lambda (match) (member match remaining)) + (wg-current-matches))))) + +(provide 'workgroups-commands-minibuffer) diff --git a/workgroups-commands.el b/workgroups-commands.el new file mode 100644 index 0000000000000000000000000000000000000000..a6c796fd0c5fb5734c717f5c8dd2008cefa7e77a --- /dev/null +++ b/workgroups-commands.el @@ -0,0 +1,826 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; ;;; +;;; Commands ;;; +;;; ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;;; workgroup switching commands + +(defun wg-switch-to-workgroup (workgroup &optional noerror) + "Switch to WORKGROUP." + (interactive (list (wg-read-workgroup-name))) + (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 + (wg-restore-workgroup workgroup) + (wg-set-previous-workgroup current) + (wg-set-current-workgroup workgroup) + (run-hooks 'wg-switch-to-workgroup-hook) + (wg-fontified-message + (:cmd "Switched: ") + (wg-workgroup-name (wg-current-workgroup t)) + ;;(wg-workgroup-list-display) + )) + (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)))))) + +(macrolet + ((define-range-of-switch-to-workgroup-at-index (num) + `(progn + ,@(wg-docar (i (wg-range 0 num)) + `(defun ,(intern (format "wg-switch-to-workgroup-at-index-%d" i)) () + ,(format "Switch to the workgroup at index %d." i) + (interactive) + (wg-switch-to-workgroup-at-index ,i)))))) + (define-range-of-switch-to-workgroup-at-index 10)) + +(defun wg-switch-to-cyclic-nth-from-workgroup (workgroup n) + "Switch N workgroups cyclically from WORKGROUP in `wg-workgroup-list.'" + (let ((workgroup-list (wg-workgroup-list-or-error)) + (workgroup (wg-get-workgroup workgroup t))) + (wg-switch-to-workgroup + (cond ((not workgroup) (car workgroup-list)) + ((= 1 (length workgroup-list)) (error "There's only one workgroup")) + (t (wg-cyclic-nth-from-workgroup workgroup n)))))) + +(defun wg-switch-to-workgroup-left (&optional workgroup n) + "Switch to the workgroup (- N) places from WORKGROUP in `wg-workgroup-list'. +Use `current-prefix-arg' for N if non-nil. Otherwise N defaults to 1." + (interactive (list nil current-prefix-arg)) + (wg-switch-to-cyclic-nth-from-workgroup workgroup (- (or n 1)))) + +(defun wg-switch-to-workgroup-right (&optional workgroup n) + "Switch to the workgroup N places from WORKGROUP in `wg-workgroup-list'. +Use `current-prefix-arg' for N if non-nil. Otherwise N defaults to 1." + (interactive (list nil current-prefix-arg)) + (wg-switch-to-cyclic-nth-from-workgroup workgroup (or n 1))) + +(defun wg-switch-to-workgroup-left-other-frame (&optional n) + "Like `wg-switch-to-workgroup-left', but operates on the next frame." + (interactive "p") + (with-selected-frame (wg-cyclic-nth-from-frame (or n 1)) + (call-interactively 'wg-switch-to-workgroup-left))) + +(defun wg-switch-to-workgroup-right-other-frame (&optional n) + "Like `wg-switch-to-workgroup-right', but operates on the next frame." + (interactive "p") + (with-selected-frame (wg-cyclic-nth-from-frame (or n -1)) + (call-interactively 'wg-switch-to-workgroup-right))) + +(defun wg-switch-to-previous-workgroup () + "Switch to the previous workgroup." + (interactive) + (wg-switch-to-workgroup (wg-previous-workgroup))) + + + +;;; workgroup creation commands + +(defun wg-create-workgroup (name &optional blank) + "Create and add a workgroup named NAME. +Optional argument BLANK non-nil (set interactively with a prefix +arg) means use a blank, one window window-config. Otherwise use +the current window-configuration. Keep in mind that even though +the current window-config may be used, other parameters of the +current workgroup are not copied to the created workgroup. For +that, use `wg-clone-workgroup'." + (interactive (list (wg-read-new-workgroup-name) current-prefix-arg)) + (wg-switch-to-workgroup (wg-make-and-add-workgroup name blank)) + (wg-fontified-message + (:cmd "Created: ") + (:cur name) " " + (wg-workgroup-list-display))) + +(defun wg-clone-workgroup (workgroup name) + "Create and add a clone of WORKGROUP named NAME. +Keep in mind that only WORKGROUP's top-level alist structure is +copied, so destructive operations on the keys or values of +WORKGROUP will be reflected in the clone, and vice-versa. Be +safe -- don't mutate them." + (interactive (list nil (wg-read-new-workgroup-name))) + (let* ((workgroup (wg-get-workgroup workgroup)) + (clone (wg-copy-workgroup workgroup))) + (setf (wg-workgroup-name clone) name + (wg-workgroup-uid clone) (wg-generate-uid)) + (when (wg-check-and-add-workgroup clone) + (wg-flag-workgroup-modified clone)) + (wg-set-workgroup-working-wconfig + clone (wg-workgroup-working-wconfig workgroup)) + (wg-switch-to-workgroup clone) + (wg-fontified-message + (:cmd "Cloned: ") + (:cur (wg-workgroup-name workgroup)) + (:msg " to ") + (:cur name) " " + (wg-workgroup-list-display)))) + + + +;;; workgroup killing commands + +(defun wg-wconfig-kill-ring () + "Return `wg-wconfig-kill-ring', creating it first if necessary." + (or wg-wconfig-kill-ring + (setq wg-wconfig-kill-ring (make-ring wg-wconfig-kill-ring-max)))) + +(defun wg-add-to-wconfig-kill-ring (wconfig) + "Add WCONFIG to `wg-wconfig-kill-ring'." + (ring-insert (wg-wconfig-kill-ring) wconfig)) + +(defun wg-kill-workgroup (&optional workgroup) + "Kill WORKGROUP, saving its working-wconfig to the kill ring." + (interactive) + (let* ((workgroup (wg-get-workgroup workgroup)) + (to (or (wg-previous-workgroup t) + (wg-cyclic-nth-from-workgroup workgroup)))) + (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup)) + (wg-delete-workgroup workgroup) + (if (eq workgroup to) (wg-restore-wconfig (wg-make-blank-wconfig)) + (wg-switch-to-workgroup to)) + (wg-fontified-message + (:cmd "Killed: ") + (:cur (wg-workgroup-name workgroup)) " " + (wg-workgroup-list-display)))) + +(defun wg-kill-ring-save-base-wconfig (&optional workgroup) + "Save WORKGROUP's base wconfig to the kill ring." + (interactive) + (let ((workgroup (wg-get-workgroup workgroup))) + (wg-add-to-wconfig-kill-ring (wg-workgroup-base-wconfig workgroup)) + (wg-fontified-message + (:cmd "Saved: ") + (:cur (wg-workgroup-name workgroup)) + (:cur "'s ") + (:msg "base wconfig to the kill ring")))) + +(defun wg-kill-ring-save-working-wconfig (&optional workgroup) + "Save WORKGROUP's working-wconfig to `wg-wconfig-kill-ring'." + (interactive) + (let ((workgroup (wg-get-workgroup workgroup))) + (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup)) + (wg-fontified-message + (:cmd "Saved: ") + (:cur (wg-workgroup-name workgroup)) + (:cur "'s ") + (:msg "working-wconfig to the kill ring")))) + +(defun wg-yank-wconfig () + "Restore a wconfig from `wg-wconfig-kill-ring'. +Successive yanks restore wconfigs sequentially from the kill +ring, starting at the front." + (interactive) + (when (zerop (ring-length (wg-wconfig-kill-ring))) + (error "The kill-ring is empty")) + (let ((pos (if (not (eq real-last-command 'wg-yank-wconfig)) 0 + (1+ (or (get 'wg-yank-wconfig :position) 0))))) + (put 'wg-yank-wconfig :position pos) + (wg-restore-wconfig-undoably (ring-ref (wg-wconfig-kill-ring) pos)) + (wg-fontified-message + (:cmd "Yanked: ") + (:msg (format "%S" pos)) " " + (wg-workgroup-list-display)))) + +(defun wg-kill-workgroup-and-buffers (&optional workgroup) + "Kill WORKGROUP and the buffers in its working-wconfig." + (interactive) + (let* ((workgroup (wg-get-workgroup workgroup)) + (bufs (save-window-excursion + (wg-restore-workgroup workgroup) + (mapcar #'window-buffer (window-list))))) + (wg-kill-workgroup workgroup) + (mapc #'kill-buffer bufs) + (wg-fontified-message + (:cmd "Killed: ") + (:cur (wg-workgroup-name workgroup)) + (:msg " and its buffers ") "\n" + (wg-workgroup-list-display)))) + +(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"))) + + + +;;; 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))))) + + + +;;; 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: ") + (wg-undo-timeline-display workgroup) + (: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: ") + (wg-undo-timeline-display workgroup) + (: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.")) + + + +;;; buffer-list-filter commands + +(defun wg-switch-to-buffer () + "Workgroups' version of `switch-to-buffer'." + (interactive) + (wg-buffer-internal 'switch-to-buffer "Buffer")) + +(defun wg-switch-to-buffer-other-window () + "Workgroups' version of `switch-to-buffer-other-window'." + (interactive) + (wg-buffer-internal + 'switch-to-buffer-other-window "Switch to buffer in other window")) + +(defun wg-switch-to-buffer-other-frame () + "Workgroups' version of `switch-to-buffer-other-frame'." + (interactive) + (wg-buffer-internal + 'switch-to-buffer-other-frame "Switch to buffer in other frame")) + +(defun wg-kill-buffer () + "Workgroups' version of `kill-buffer'." + (interactive) + (wg-buffer-internal + 'kill-buffer "Kill buffer" (buffer-name (current-buffer)))) + +(defun wg-display-buffer () + "Workgroups' version of `display-buffer'." + (interactive) + (wg-buffer-internal 'display-buffer "Display buffer")) + +(defun wg-insert-buffer () + "Workgroups' version of `insert-buffer'." + (interactive) + (wg-buffer-internal 'insert-buffer "Insert buffer")) + +;; FIXME: If you C-h i for info, then wg-next-buffer, you occasionally don't +;; switch to the buffer you were on previously. +(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) + "Dissociate BUFFER-OR-NAME from the current workgroup, and bury it." + (interactive) + (let ((buffer (or buffer-or-name (current-buffer)))) + (wg-workgroup-dissociate-bufobj (wg-current-workgroup) buffer) + (wg-bury-buffer buffer))) + +(defun wg-associate-buffer-with-workgroup (&optional workgroup buffer weak) + "Associate BUFFER with WORKGROUP. +WEAK non-nil means weakly associate BUFFER." + (interactive (list nil nil current-prefix-arg)) + (let* ((workgroup (wg-get-workgroup workgroup)) + (buffer (or buffer (current-buffer))) + (bname (buffer-name buffer)) + (wgname (wg-workgroup-name workgroup))) + (if (wg-workgroup-associate-bufobj workgroup buffer weak) + (wg-message "%s-associated %S with %s" + (if weak "Weakly" "Strongly") bname wgname) + (wg-message "%S is already associated with %s" bname wgname)))) + +(defun wg-associate-visible-buffers-with-workgroup (&optional workgroup weak) + "Associate all buffers visible in `selected-frame' with WORKGROUP. +WEAK non-nil means weakly associate them. Otherwise strongly +associate them." + (interactive (list nil current-prefix-arg)) + (let ((workgroup (wg-get-workgroup workgroup)) + (buffers (mapcar 'window-buffer (window-list)))) + (dolist (buffer buffers) + (wg-workgroup-associate-bufobj workgroup buffer weak)) + (wg-fontified-message + (:cmd (format "%s associated: " (if weak "Weakly" "Strongly"))) + (wg-buffer-list-display buffers)))) + +(defun wg-dissociate-buffer-from-workgroup (&optional workgroup buffer) + "Dissociate BUFFER from WORKGROUP." + (interactive (list nil nil)) + (let ((workgroup (wg-get-workgroup workgroup)) + (buffer (or buffer (current-buffer)))) + (wg-message + (if (wg-workgroup-dissociate-bufobj workgroup buffer) + "Dissociated %S from %s" "%S isn't associated with %s") + (wg-buffer-name buffer) + (wg-workgroup-name workgroup)))) + +(defun wg-restore-workgroup-associated-buffers (&optional workgroup) + "Restore all the buffers associated with WORKGROUP that can be restored." + (interactive) + (let* ((workgroup (wg-get-workgroup workgroup)) + (restored-buffers (wg-restore-workgroup-associated-buffers-internal + workgroup))) + (wg-fontified-message + (:cmd "Restored: ") + (wg-buffer-list-display restored-buffers)))) + +(defun wg-cycle-buffer-association-type () + "Cycle the current buffer's association type in the current workgroup. +See `wg-workgroup-cycle-bufobj-association-type' for details." + (interactive) + (let* ((workgroup (wg-current-workgroup)) + (buffer (current-buffer)) + (type (wg-workgroup-cycle-bufobj-association-type workgroup buffer))) + (force-mode-line-update) + (wg-fontified-message + (:cur (buffer-name buffer)) + (:cmd (case type + (strong " strongly associated with ") + (weak " weakly associated with ") + (otherwise " unassociated with "))) + (:cur (wg-workgroup-name workgroup))))) + +(defun wg-dissociate-weakly-associated-buffers (&optional workgroup) + "Dissociate from the current workgroup all weakly associated buffers." + (interactive) + (let ((workgroup (wg-get-workgroup workgroup))) + (wg-workgroup-dissociate-weakly-associated-buffers workgroup) + (wg-fontified-message + (:cmd "Remaining buffers: ") + (wg-buffer-list-display (wg-workgroup-associated-buffers workgroup))))) + + + +;;; window-tree commands +;; +;; TODO: These are half-hearted. Clean them up; allow specification of the +;; window-tree depth at which to operate; add complex window creation commands; +;; and add window splitting, deletion and locking commands. + +(defun wg-transpose-window-internal (workgroup offset) + "Move `selected-window' by OFFSET in its wlist." + (wg-restore-wconfig-undoably + (wg-wconfig-move-window + (wg-workgroup-working-wconfig + (wg-get-workgroup workgroup)) + offset))) + +(defun wg-backward-transpose-window (&optional workgroup offset) + "Move `selected-window' backward by OFFSET in its wlist." + (interactive (list nil current-prefix-arg)) + (wg-transpose-window-internal workgroup (or offset -1))) + +(defun wg-transpose-window (&optional workgroup offset) + "Move `selected-window' forward by OFFSET in its wlist." + (interactive (list nil current-prefix-arg)) + (wg-transpose-window-internal workgroup (or offset 1))) + +(defun wg-reverse-frame-horizontally (&optional workgroup) + "Reverse the order of all horizontally split wtrees." + (interactive) + (wg-restore-wconfig-undoably + (wg-reverse-wconfig + (wg-workgroup-working-wconfig + (wg-get-workgroup workgroup))))) + +(defun wg-reverse-frame-vertically (&optional workgroup) + "Reverse the order of all vertically split wtrees." + (interactive) + (wg-restore-wconfig-undoably + (wg-reverse-wconfig + (wg-workgroup-working-wconfig + (wg-get-workgroup workgroup)) + t))) + +(defun wg-reverse-frame-horizontally-and-vertically (&optional workgroup) + "Reverse the order of all wtrees." + (interactive) + (wg-restore-wconfig-undoably + (wg-reverse-wconfig + (wg-workgroup-working-wconfig + (wg-get-workgroup workgroup)) + 'both))) + +(defun wg-toggle-window-dedicated-p () + "Toggle `window-dedicated-p' in `selected-window'." + (interactive) + (set-window-dedicated-p nil (not (window-dedicated-p))) + (force-mode-line-update t) + (wg-fontified-message + (:cmd "Window:") + (:cur (concat (unless (window-dedicated-p) " not") " dedicated")))) + + + +;;; misc commands + +(defun wg-rename-workgroup (workgroup newname) + "Rename WORKGROUP to NEWNAME." + (interactive (list nil (wg-read-new-workgroup-name "New name: "))) + (let* ((workgroup (wg-get-workgroup workgroup)) + (oldname (wg-workgroup-name workgroup))) + (setf (wg-workgroup-name workgroup) newname) + (wg-flag-workgroup-modified workgroup) + (wg-fontified-message + (:cmd "Renamed: ") + (:cur oldname) + (:msg " to ") + (:cur (wg-workgroup-name workgroup))))) + +(defun wg-reset (&optional force) + "Reset Workgroups. +Resets all frame parameters, buffer-local vars, the current +Workgroups session object, etc." + (interactive "P") + (unless (or force wg-no-confirm-on-destructive-operation + (y-or-n-p "Really reset Workgroups? ")) + (error "Canceled")) + (wg-reset-internal) + (wg-fontified-message + (:cmd "Reset: ") + (:msg "Workgroups"))) + + + +;;; file commands + +(defun wg-read-session-save-file-name () + "Read and return a new session filename." + (read-file-name "Save session as: ")) + +(defun wg-write-session-file (filename &optional confirm) + "Write the current session into file FILENAME. +This makes the session visit that file, and marks it as not modified. + +If optional second arg CONFIRM is non-nil, this function asks for +confirmation before overwriting an existing file. Interactively, +confirmation is required unless you supply a prefix argument. + +Think of it as `write-file' for Workgroups sessions." + (interactive (list (wg-read-session-save-file-name) + (not current-prefix-arg))) + (when (and confirm (file-exists-p filename)) + (unless (y-or-n-p (format "File `%s' exists; overwrite? " filename)) + (error "Cancelled"))) + (unless (file-writable-p filename) + (error "File %s can't be written to" filename)) + (wg-perform-session-maintenance) + (setf (wg-session-file-name (wg-current-session)) filename) + + ;;(wg-set-session-parameter nil wg-key-load-last-workgroup wg-load-last-workgroup) + ;;(wg-set-session-parameter nil wg-key-current-workgroup "wg-") + ;;(wg-session-parameter nil wg-key-current-workgroup) + ;;(wg-remove-session-parameter nil wg-key-current-workgroup) + ;;(if wg-load-last-workgroup + ;; (let ((curr-wg-name (wg-workgroup-name (wg-current-workgroup)))) + ;; (wg-set-session-parameter nil wg-key-current-workgroup curr-wg-name) + ;; )) + (wg-write-sexp-to-file + (wg-pickel-all-session-parameters (wg-current-session)) + filename) + (wg-mark-everything-unmodified) + (wg-fontified-message (:cmd "Wrote: ") (:file filename))) + +(defun wg-determine-session-save-file-name () + "Return the filename in which to save the session." + (or (wg-session-file-name (wg-current-session)) + (and wg-use-default-session-file wg-default-session-file))) + +(defun wg-save-session (&optional force) + "Save the current Workgroups session if it's been modified. +Think of it as `save-buffer' for Workgroups sessions. Optional +argument FORCE non-nil, or interactively with a prefix arg, save +the session regardless of whether it's been modified." + (interactive "P") + (if (and (not (wg-modified-p)) (not force)) + (wg-message "(The session is unmodified)") + (wg-write-session-file + (or (wg-determine-session-save-file-name) + (wg-read-session-save-file-name))))) + +(defun wg-query-and-save-if-modified () + "Query for save when `wg-modified-p'." + (or (not (wg-modified-p)) + (when (y-or-n-p "Save modified workgroups? ") + (wg-save-session)))) + +(defun wg-save-session-on-exit (behavior) + "Perform session-saving operations based on BEHAVIOR." + (case behavior + (ask (wg-query-and-save-if-modified)) + (save + (if (wg-determine-session-save-file-name) + (wg-save-session) + (wg-query-and-save-if-modified))))) + +(defun wg-find-session-file (filename) + "Load a session visiting FILENAME, creating one if none already exists." + (interactive "FFind session file: ") + (cond ((file-exists-p filename) + (let ((session (wg-read-sexp-from-file filename))) + (unless (wg-session-p session) + (error "%S is not a Workgroups session file." filename)) + (setf (wg-session-file-name session) filename) + (wg-reset-internal (wg-unpickel-session-parameters session)) + ;;(message (wg-session-parameter nil wg-key-current-workgroup)) + ;;(message "session") + ;;(sleep-for 3) + ) + (wg-awhen (and wg-switch-to-first-workgroup-on-find-session-file + (wg-workgroup-list)) + (wg-switch-to-workgroup (car it))) + (wg-fontified-message + (:cmd "Loaded: ") + (:file filename))) + (t + (wg-query-and-save-if-modified) + (wg-reset-internal (wg-make-session :file-name filename)) + (wg-fontified-message + (:cmd "(New Workgroups session file)")))) + + + ;;(wg-remove-session-parameter nil wg-key-current-workgroup) + ;;(if (wg-session-parameter nil wg-key-load-last-workgroup wg-load-last-workgroup) + ;; (let ((cur-wg (wg-session-parameter nil wg-key-current-workgroup))) + ;; (if cur-wg + ;; (wg-switch-to-workgroup (wg-get-workgroup cur-wg)) + ;; ))) + ) + +(defun wg-find-file-in-new-workgroup (filename) + "Create a new blank workgroup and find file FILENAME in it." + (interactive "FFind file in new workgroup: ") + (wg-create-workgroup (file-name-nondirectory filename) t) + (find-file filename)) + +(defun wg-find-file-read-only-in-new-workgroup (filename) + "Create a new workgroup and find file FILENAME read-only in it." + (interactive "FFind file read only in new workgroup: ") + (wg-create-workgroup (file-name-nondirectory filename) t) + (find-file-read-only filename)) + +(defun wg-dired-in-new-workgroup (dirname &optional switches) + "Create a workgroup and open DIRNAME in dired with SWITCHES." + (interactive (list (read-directory-name "Dired (directory): ") + current-prefix-arg)) + (wg-create-workgroup dirname) + (dired dirname switches)) + + + +;;; toggle commands + +(defun wg-toggle-and-message (symbol) + "Toggle SYMBOL's truthiness and message the new value." + (wg-fontified-message + (:cmd (format "%s: " symbol)) + (:msg (format "%s" (wg-toggle symbol))))) + +(defun wg-toggle-buffer-list-filtration () + "Toggle `wg-buffer-list-filtration-on'." + (interactive) + (wg-toggle-and-message 'wg-buffer-list-filtration-on)) + +(defun wg-toggle-mode-line-display () + "Toggle `wg-mode-line-display-on'." + (interactive) + (wg-toggle-and-message 'wg-mode-line-display-on)) + +(defun wg-toggle-morph () + "Toggle `wg-morph-on'." + (interactive) + (wg-toggle-and-message 'wg-morph-on)) + + + +;;; echo commands + +(defun wg-echo-current-workgroup () + "Display the name of the current workgroup in the echo area." + (interactive) + (wg-fontified-message + (:cmd "Current: ") + (:cur (wg-workgroup-name (wg-current-workgroup))))) + +(defun wg-echo-all-workgroups () + "Display the names of all workgroups in the echo area." + (interactive) + (wg-fontified-message + (:cmd "Workgroups: ") + (wg-workgroup-list-display))) + +(defun wg-echo-time () + "Echo the current time. Optionally includes `battery' info." + (interactive) + (wg-message ;; Pass through format to escape the % in `battery' + "%s" (wg-fontify + (:cmd "Current time: ") + (:msg (format-time-string wg-time-format)) + (when (and wg-display-battery (fboundp 'battery)) + (wg-fontify "\n" (:cmd "Battery: ") (:msg (battery))))))) + +(defun wg-echo-version () + "Echo Workgroups' current version number." + (interactive) + (wg-fontified-message + (:cmd "Workgroups version: ") + (:msg wg-version))) + +(defun wg-echo-last-message () + "Echo the last message Workgroups sent to the echo area. +The string is passed through a format arg to escape %'s." + (interactive) + (message "%s" wg-last-message)) + + + +;;; help commands + +(defun wg-help () + "Just call `apropos-command' on \"^wg-\". +There used to be a bunch of help-buffer construction stuff here, +including a `wg-help' variable that basically duplicated every +command's docstring; But why, when there's `apropos-command'?" + (interactive) + (apropos-command "^wg-")) + + +(require 'workgroups-commands-minibuffer) + +(provide 'workgroups-commands) diff --git a/workgroups-compat.el b/workgroups-compat.el new file mode 100644 index 0000000000000000000000000000000000000000..80359ebd8ba8488adba32773955bf29957596476 --- /dev/null +++ b/workgroups-compat.el @@ -0,0 +1,45 @@ +;; flet (Temporary redifinition) command caused a lot of warnings and is +;; obsolete +;; +;; So we need to define something new: + + +(defun wg--call-with-temporary-redefinitions (function + &rest function-names-and-overriding-functions) + (let* ((overrides (remove-if-not #'(lambda (fdef) + (fboundp (first fdef))) + function-names-and-overriding-functions)) + (definition-names (mapcar #'first overrides)) + (overriding-functions (mapcar #'second overrides)) + (saved-functions (mapcar #'symbol-function definition-names))) + ;; saving all definitions before overriding anything ensures FDEFINITION + ;; errors don't cause accidental permanent redefinitions. + ;; + ;;(labels ((set-fdefinitions (names functions) + (cl-labels ((set-fdefinitions (names functions) + (loop for name in names + for fn in functions + do (fset name fn)))) + (set-fdefinitions definition-names overriding-functions) + (unwind-protect (funcall function) + (set-fdefinitions definition-names saved-functions))))) + + +(defmacro wg--with-temporary-redefinitions (fdefinitions &rest body) + ;; "Temporarily (but globally) redefine each function in FDEFINITIONS. + ;; E.g.: (wg--with-temporary-redefinitions ((foo (x) ...) + ;; (bar (x) ...)) + ;; ;; code that eventually calls foo, bar of (setf foo) + ;; ...)" + `(wg--call-with-temporary-redefinitions + (lambda () ,@body) + ,@(mapcar #'(lambda (thingy) + `(list ',(first thingy) + (lambda ,@(rest thingy)))) + fdefinitions))) + +(put 'wg--with-temporary-redefinitions 'lisp-indent-function 1) +(put 'wg--with-temporary-redefinitions 'edebug-form-spec '((&rest (defun*)) cl-declarations body)) + + +(provide 'workgroups-compat) diff --git a/workgroups-functions.el b/workgroups-functions.el new file mode 100644 index 0000000000000000000000000000000000000000..89ed571ab32f47dd85379143f1c46b3727638d70 --- /dev/null +++ b/workgroups-functions.el @@ -0,0 +1,1854 @@ +;;; workgroups utils +(require 'dflet) +(require 'cl-macs) +(require 'workgroups-compat) + +(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." + (wg--with-temporary-redefinitions ((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))) + +(defvar wg-readable-types + '(integer float cons symbol vector string char-table bool-vector) + "List of types with readable printed representations.") + +(defun wg-is-readable-p (obj) + "Return non-nil if OBJ's printed representation is readable." + (memq (type-of obj) wg-readable-types)) + +(defun wg-take-until-unreadable (list) + "Return a new list of elements of LIST up to the first unreadable element." + (wg-take-until-fail 'wg-is-readable-p list)) + +(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-seq 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. +It 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)) + ((consp spec) spec) + ((stringp spec) spec) + (t `(format "%s" ,spec)))))) + +(defun wg-barf-on-active-minibuffer () + "Throw an error when the minibuffer is active." + (when (wg-minibuffer-active-p) + (error "Workgroup operations aren't permitted while the \ +minibuffer is active"))) + +(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 (&optional time) + "Convert `current-time' into a b36 string." + (apply 'concat (wg-docar (time (or time (current-time))) + (wg-int-to-b36 time 4)))) + +(defun wg-b36-to-time (b36) + "Parse the time from UID." + (loop for i from 0 to 8 by 4 + collect (wg-b36-to-int (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))) + + + +;;; structure types + +(wg-defstruct wg buf + (uid (wg-generate-uid)) + (name) + (file-name) + (point) + (mark) + (local-vars) + (special-data) + ;; This may be used later: + (gc)) + +(wg-defstruct wg win + (uid) + (parameters) + (edges) + (point) + (start) + (hscroll) + (dedicated) + (selected) + (minibuffer-scroll) + (buf-uid)) + +(wg-defstruct wg wtree + (uid) + (dir) + (edges) + (wlist)) + +(wg-defstruct wg wconfig + (uid (wg-generate-uid)) + (name) + (parameters) + (left) + (top) + (width) + (height) + (vertical-scroll-bars) + (scroll-bar-width) + (wtree)) + +(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 session + (uid (wg-generate-uid)) + (name) + (modified) + (parameters) + (file-name) + (version wg-version) + (workgroup-list) + (buf-list)) + +(wg-defstruct wg workgroup-state + (undo-pointer) + (undo-list)) + + + +;;; session ops + +(defun wg-current-session (&optional noerror) + "Return `wg-current-session', setting it first if necessary." + (or wg-current-session + (unless noerror + (error "No session is defined")))) + +(defmacro wg-buf-list () + "setf'able `wg-current-session' buf-list slot accessor." + `(wg-session-buf-list (wg-current-session))) + +(defmacro wg-workgroup-list () + "setf'able `wg-current-session' modified slot accessor." + `(wg-session-workgroup-list (wg-current-session))) + +(defun wg-workgroup-list-or-error (&optional noerror) + "Return the value of `wg-current-session's :workgroup-list slot." + (or (wg-workgroup-list) + (unless noerror + (error "No workgroups are defined")))) + +(defun wg-modified-p () + "Return t when the current session or any of its workgroups are modified." + (or (wg-session-modified (wg-current-session)) + (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." + (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 (gensym)) + (value (wg-session-parameter session variable undefined))) + (if (not (eq value undefined)) value + (symbol-value variable)))) + + + +;;; 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." + (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." + (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." + (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-bufobj-major-mode (bufobj) + "Return BUFOBJ's major-mode." + (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'." + (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." + (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." + (find buf buf-list)) + +(defun wg-find-buffer-in-buffer-list (buffer-or-name buffer-list) + "Find BUFFER-OR-NAME in BUFFER-LIST." + (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))) + + + + +;;; wconfig construction + +(defun wg-buffer-special-data (buffer) + "Return BUFFER's auxiliary serialization, or nil." + (some (lambda (fn) (funcall fn buffer)) wg-special-buffer-serdes-functions)) + +(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-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) + "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." + (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'." + (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))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Notes on buffer and window properties: +;; +;; fringes, margins and scroll-bars are properly properties of buffers, but +;; their settings can be forced ephemerally in a window with the set-window-foo +;; functions. +;; +;; window-point is a property of a buffer/window pair, but won't set properly +;; unless the buffer is current -- i.e. (set-window-buffer some-window +;; some-buffer) (set-window-point some-window 0)) won't set some-buffer's point +;; in some-window unless some-buffer is also current. +;; +;; window-start and window-hscroll are properties of buffer/window pairs. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun wg-window-to-win (window) + "Return the serialization (a wg-win) of Emacs window WINDOW." + (let ((selected (eq window (selected-window)))) + (with-selected-window window + (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)))))) + +(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) + ;;(wg--with-temporary-redefinitions + (dflet + ;;(letf + ((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-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)))) + (wg-make-wconfig + :left (frame-parameter frame 'left) + :top (frame-parameter frame 'top) + :width (frame-parameter frame 'width) + :height (frame-parameter frame 'height) + :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))) + + + + + +;;; win/wtree/wconfig utils + +(defun wg-w-edges (w) + "Return W's edge list." + (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." + (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." + (etypecase w + (wg-win (setf (wg-win-edges w) edges)) + (wg-wtree (setf (wg-wtree-edges w) edges))) + w) + +(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 (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 w (list left +;; top +;; (+ left (funcall width-fn (- right left))) +;; (+ top (funcall height-fn (- bottom top)))))))) + +(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." + ;;(wg--with-temporary-redefinitions + (dflet + ((wscale (width) (truncate (* width width-scale))) + (hscale (height) (truncate (* height height-scale)))) + (wg-adjust-w-size w #'wscale #'hscale))) + +(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)) + (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))) + ;;(wg--with-temporary-redefinitions + (dflet + ((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-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-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-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." + ;;(wg--with-temporary-redefinitions + (dflet + ((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." + ;;(wg--with-temporary-redefinitions + (dflet + ((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 (find t wlist :key 'wg-win-selected) + (wg-cyclic-offset-elt it wlist offset) + (mapcar #'inner wlist))))))) + (wg-normalize-wtree (inner wtree)))) + +(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) + +(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) + +(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." + ;;(wg--with-temporary-redefinitions + (dflet + ((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w)) + (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)) + + +(require 'workgroups-specialbufs) +(require 'workgroups-wconfig-restore) +(require 'workgroups-morph) + + +;;; workgroup utils + +(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-find-workgroup-by (slotkey value &optional noerror) + "Return the workgroup on which ACCESSOR returns VALUE or error." + (let ((accessor (ecase slotkey + (:name 'wg-workgroup-name) + (:uid 'wg-workgroup-uid)))) + (or (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-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 + +(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 ((value (wg-workgroup-parameter workgroup variable 'default))) +;; (if (not (eq value 'default)) value +;; (wg-session-local-value variable)))))) + +(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 (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 associated buffers + +(defun wg-workgroup-associated-buf-uids (workgroup) + "Return a new list containing all of WORKGROUP's associated buf uids." + (append (wg-workgroup-strong-buf-uids workgroup) + (wg-workgroup-weak-buf-uids workgroup))) + +(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 &optional initial names) + "Return a list of WORKGROUP's live associated buffers." + (let ((assoc-bufs (wg-workgroup-associated-bufs workgroup))) + (remove-if-not + (lambda (buffer) (wg-find-buffer-in-buf-list buffer assoc-bufs)) + (or initial (buffer-list))))) + +(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-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-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=))) + (wg-awhen (or rem1p rem2p) + (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-cycle-bufobj-association-type (workgroup bufobj) + "Cycle the BUFOBJ's association type in WORKGROUP. +If it's strongly associated with the workgroup, weakly associate it. +If it's weakly associated with the workgroup, dissociate it. +If it's unassociated with the workgroup, mark it as strongly associated." + (case (wg-workgroup-bufobj-association-type workgroup bufobj) + (strong (wg-workgroup-weakly-associate-bufobj workgroup bufobj) 'weak) + (weak (wg-workgroup-dissociate-bufobj workgroup bufobj) nil) + (otherwise (wg-workgroup-strongly-associate-bufobj workgroup bufobj) 'strong))) + +(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 + (wg-awhen (wg-current-workgroup t) + (wg-workgroup-dissociate-bufobj it (current-buffer))))) + + + +;;; 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 (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-buffer-list-filter-associated (workgroup initial) + "Return only those buffers associated with WORKGROUP." + (wg-workgroup-associated-buffers workgroup initial)) + +(defun wg-buffer-list-filter-unassociated (workgroup initial) + "Return only those buffer unassociated with WORKGROUP." + (let ((buffers (wg-workgroup-associated-buffers workgroup initial))) + (remove-if (lambda (buffer) (member buffer buffers)) initial))) + + +;; buffer-list filtration utils + +(defun wg-filter-buffer-list-by-regexp (regexp buffer-list) + "Return only those buffers in BUFFER-LIST with names matching REGEXP." + (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." + (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." + (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)) + +(defun wg-buffer-list-filter-elisp (workgroup buffer-list) + "Return only those buffers in BUFFER-LIST in `emacs-lisp-mode'." + (wg-filter-buffer-list-by-major-mode 'emacs-lisp-mode buffer-list)) + +(defun wg-buffer-list-filter-home-dir->elisp (workgroup buffer-list) + "Example of chaining buffer-list filters. +This returns all buffers under \"~/\" that are also in `emacs-lisp-mode'." + (wg-buffer-list-filter-elisp + nil (wg-buffer-list-filter-home-dir nil 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))))) + (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)))))))))) + + + +;;; 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 FRAME's WORKGROUP's state table." + (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 unless 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." + (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 + ;; When the window config has changed, + wg-window-configuration-changed + ;; and undoification is still on for the current command + wg-undoify-window-configuration-change + ;; and the change didn't occur while the minibuffer is active, + (wg-minibuffer-inactive-p)) + ;; and there's a current workgroup, + (wg-when-let ((workgroup (wg-current-workgroup t))) + ;; 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))) + + + +;;; base wconfig updating + +(defun wg-update-all-base-wconfigs () + "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)))) + +(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))) + + + +;;; 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))) + (etypecase wconfig-or-name + (wg-wconfig (car (memq wconfig-or-name wconfigs))) + (string (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 (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))) + + + + +;;; garbage collection + +;; update buf list + +(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)))) + + +;; gc buf uids + +(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) + (remove-if-not 'wg-find-buf-by-uid it) + (wg-workgroup-weak-buf-uids workgroup) + (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))) + + +;; gc bufs + +(defun wg-wtree-buf-uids (wtree) + "Return a new list of the buf uids of all wins in wtree." + (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." + (remove-duplicates (wg-wtree-buf-uids wtree) :test 'string=)) + +(defun wg-wconfig-buf-uids (wconfig) + "Return WCONFIG's wtree's `wg-wtree-buf-uids'." + (wg-wtree-unique-buf-uids (wg-wconfig-wtree wconfig))) + +(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." + (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." + (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." + (reduce 'wg-string-list-union + (list (wg-workgroup-base-wconfig-buf-uids workgroup) + (wg-workgroup-saved-wconfigs-buf-uids workgroup) + (wg-workgroup-associated-buf-uids workgroup)))) + +(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'." + (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'." + (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) + (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) + (wg-update-all-base-wconfigs) + (wg-gc-bufs) + (wg-gc-buf-uids) + (wg-update-buf-list)) + + +;; session consistency testing + +(defun wg-session-uids-consistent-p () + "Return t if there are no duplicate bufs or buf uids in the wrong places, +nil otherwise." + (and (every (lambda (wg) + (not (wg-dups-p (wg-workgroup-associated-buf-uids wg) + :test 'string=))) + (wg-workgroup-list)) + (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=)))) + + + +;;; workgroup restoration + +(defun wg-restore-workgroup-associated-buffers-internal (workgroup) + "Restore all the buffers associated with WORKGROUP that can be restored." + (save-window-excursion + (delete nil (mapcar 'wg-restore-buffer + (wg-workgroup-associated-bufs workgroup))))) + +(defun wg-restore-workgroup (workgroup) + "Restore WORKGROUP in `selected-frame'." + (when wg-restore-associated-buffers + (wg-restore-workgroup-associated-buffers-internal workgroup)) + (let (wg-flag-modified) + (wg-restore-wconfig-undoably + (wg-workgroup-working-wconfig workgroup) t))) + + + +;;; 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 (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 and 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))) + +(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))) + + + +;;; buffer association + +(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))'." + (wg-aif (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-associate-frame-buffers () + "Associate the buffers visible in the current frame with the +current workgroup (unless it is currently being deactivated)." + (wg-awhen (wg-current-workgroup :noerror) + (unless (member it wg-deactivation-list) + (wg-associate-buffers it (car (window-tree)))))) + +(defun wg-associate-all-frame-buffers () + "Associate all visible buffers with the current +workgroup (unless it is currently being deactivated)." + (mapcar 'wg-associate-frame-buffers (frame-list))) + +(defun wg-buffer-predicate (buffer) + "Return t iff the given BUFFER should be considered a candidate +for display by `other-buffer' in the current workgroup." + (or (not wg-associate-buffers) + (wg-awhen (wg-current-workgroup :noerror) + (with-current-buffer buffer + (eq wg-buffer-workgroup it))))) + +(defun wg-after-make-frame (frame) + (set-frame-parameter frame 'buffer-predicate + 'wg-buffer-predicate)) + +;;; mode-line + +(defun wg-mode-line-buffer-association-indicator (workgroup) + "Return a string indicating `current-buffer's association-type in WORKGROUP." + (case (wg-workgroup-bufobj-association-type workgroup (current-buffer)) + (strong wg-mode-line-decor-strongly-associated) + (weak wg-mode-line-decor-weakly-associated) + (otherwise wg-mode-line-decor-unassociated))) + +(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 " " + (:div wg-mode-line-decor-left-brace) + (:mode (wg-workgroup-name wg)) + (:div wg-mode-line-decor-divider) + (:mode (wg-mode-line-buffer-association-indicator wg)) + (:div wg-mode-line-decor-divider) + (:mode (if (window-dedicated-p) + wg-mode-line-decor-window-dedicated + wg-mode-line-decor-window-undedicated)) + (:div wg-mode-line-decor-divider) + (:mode (if (wg-session-modified (wg-current-session)) + wg-mode-line-decor-session-modified + wg-mode-line-decor-session-unmodified)) + (:mode (if (wg-workgroup-modified wg) + wg-mode-line-decor-workgroup-modified + wg-mode-line-decor-workgroup-unmodified)) + (:div wg-mode-line-decor-right-brace))) + (t (wg-fontify " " + (:div wg-mode-line-decor-left-brace) + (:mode "no workgroups") + (:div wg-mode-line-decor-right-brace)))))) + +(defun wg-add-mode-line-display () + "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 (position 'mode-line-position mode-line-format))) + (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))) + + + +;;; 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))) + + + +;;; fancy displays + +;; FIXME: add `wg-display-max-lines' to chop long display strings at max-line +;; and element-name boundaries + +(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) "No workgroups" + (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 (incf i)))) +;; (:brace wg-list-display-decor-right-brace)))) + +(defcustom wg-display-max-lines 1 + "FIXME: docstring this" + :type 'integer + :group 'workgroups) + + + +(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 (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)))) + +;; TODO: Possibly add scroll animation for the buffer list display during +;; `wg-next-buffer' and `wg-previous-buffer' +(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 + (:div "(") + (:msg (wg-workgroup-name (wg-get-workgroup workgroup))) + (:div ":") + (:msg (wg-get-buffer-list-filter-val blf-id 'indicator)) + (:div ")"))) + +(defun wg-buffer-list-filter-prompt (prompt &optional workgroup blf-id) + "Return a prompt string from PROMPT indicating WORKGROUP and BLF-ID." + (wg-fontify + (:cmd prompt) " " + (wg-buffer-list-filter-display workgroup blf-id) + (:msg ": "))) + +(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-timeline-display (position length) + "Return a timeline visualization string from POSITION and LENGTH." + (wg-fontify + (:div "-<{") + (:other (wg-make-string (- length position) "-" "=")) + (:cur "O") + (:other (wg-make-string (1+ position) "-" "=")) + (:div "}>-"))) + +(defun wg-undo-timeline-display (workgroup) + "Return WORKGROUP's undo timeline string." + (wg-with-undo workgroup (state undo-pointer undo-list) + (wg-timeline-display undo-pointer (length undo-list)))) + + + +(require 'workgroups-ido) + + +;;; minibuffer reading + +(defun wg-read-buffer (prompt &optional default require-match) + "Workgroups' version of `read-buffer'." + (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)))) + +;; TODO: Add minibuffer commands for killing, cloning, etc. +(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" (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." + (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))) + + + +;;; session resetting + +(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-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-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)))) + + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: +(provide 'workgroups-functions) diff --git a/workgroups-ido.el b/workgroups-ido.el new file mode 100644 index 0000000000000000000000000000000000000000..07c2a6cc821f8d2f51d12068f33267a4b7a52f21 --- /dev/null +++ b/workgroups-ido.el @@ -0,0 +1,156 @@ +;;; ido and iswitchb compatibility + +(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 + (case (let (workgroups-mode) (command-remapping 'switch-to-buffer)) + (ido-switch-buffer 'ido) + (iswitchb-buffer 'iswitchb) + (otherwise 'fallback)))) + +(defun wg-read-buffer-function (&optional mode) + "Return MODE's or `wg-read-buffer-mode's `read-buffer' function." + (case (or mode (wg-read-buffer-mode)) + (ido 'ido-read-buffer) + (iswitchb 'iswitchb-read-buffer) + (fallback (lambda (prompt &optional default require-match) + (let (read-buffer-function) + (read-buffer prompt default require-match)))))) + +;; TODO: clean this up +(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." + (ecase (wg-read-buffer-mode) + (ido + (ido-completing-read prompt choices pred require-match + initial-input history default)) + (iswitchb + (let* ((iswitchb-use-virtual-buffers nil) + (iswitchb-make-buflist-hook + (lambda () (setq iswitchb-temp-buflist choices)))) + (iswitchb-read-buffer prompt default require-match))) + (fallback + (completing-read prompt choices pred require-match + initial-input history default)))) + +(defun wg-current-matches (&optional read-buffer-mode) + "Return READ-BUFFER-MODE's current matches." + (ecase (or read-buffer-mode (wg-read-buffer-mode)) + (ido (wg-when-boundp (ido-cur-list) ido-cur-list)) + (iswitchb (wg-when-boundp (iswitchb-buflist) iswitchb-buflist)) + (fallback (list minibuffer-default)))) + +(defun wg-current-match (&optional read-buffer-mode) + "Return READ-BUFFER-MODE's current match." + (car (wg-current-matches read-buffer-mode))) + +(defun wg-set-current-matches (match-list &optional read-buffer-mode) + "Set READ-BUFFER-MODE's current matches, and flag a rescan." + (case (or read-buffer-mode (wg-read-buffer-mode)) + (ido + (wg-when-boundp (ido-cur-list) + (setq ido-cur-list match-list ido-rescan t))) + (iswitchb + (wg-when-boundp (iswitchb-buflist) + (setq iswitchb-buflist match-list iswitchb-rescan t))) + (fallback nil))) + +(defun wg-iswitchb-internal (method &optional prompt default init) + "This provides the buffer switching interface to +`iswitchb-read-buffer' (analogous to ido's `ido-buffer-internal') +that iswitchb *should* have had. A lot of this code is +duplicated from `iswitchb', so is similarly shitty." + (let ((iswitchb-method (if (memq method '(insert kill)) 'samewindow method)) + (iswitchb-invalid-regexp nil) + (buffer (iswitchb-read-buffer (or prompt "iswitch ") default nil init))) + (cond ((eq iswitchb-exit 'findfile) + (call-interactively 'find-file)) + (iswitchb-invalid-regexp + (message "Won't make invalid regexp named buffer")) + ((not buffer) nil) + ((not (wg-get-buffer buffer)) + (iswitchb-possible-new-buffer buffer)) + ((eq method 'insert) + (insert-buffer-substring buffer)) + ((eq method 'kill) + (kill-buffer buffer)) + (t (iswitchb-visit-buffer buffer))))) + +(defun wg-buffer-internal (command &optional prompt default) + "Buffer list filtration interface to the current remapping of COMMAND. +PROMPT non-nil specifies the prompt. +DEFAULT non-nil specifies the first completion candidate." + (if (not (wg-filter-buffer-list-p)) + (call-interactively (wg-prior-mapping workgroups-mode command)) + (wg-with-buffer-list-filters command + (let ((wg-buffer-internal-default-buffer default)) + (ecase (wg-read-buffer-mode) + (ido + (ido-buffer-internal + (wg-aget wg-ido-method-translations command) nil + (wg-buffer-list-filter-prompt prompt) + nil wg-previous-minibuffer-contents)) + (iswitchb + (wg-iswitchb-internal + (wg-aget wg-iswitchb-method-translations command) + (wg-buffer-list-filter-prompt prompt) + nil wg-previous-minibuffer-contents)) + (fallback + (let (read-buffer-function) + (call-interactively command)))) + (wg-message (wg-buffer-command-display)))))) + +(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)))) + +(defun wg-set-iswitchb-buffer-list () + "Set `iswitchb-temp-buflist' with `wg-set-buffer-list-symbol'. +Added to `iswitchb-make-buflist-hook'." + (wg-set-buffer-list-symbol 'iswitchb-temp-buflist)) + + +(provide 'workgroups-ido) diff --git a/workgroups-keys.el b/workgroups-keys.el new file mode 100644 index 0000000000000000000000000000000000000000..670bfd84a32b17631384b85a909d85c773393a74 --- /dev/null +++ b/workgroups-keys.el @@ -0,0 +1,209 @@ +;;; keymaps + +(defvar wg-prefixed-map + (wg-fill-keymap + (make-sparse-keymap) + + + ;; workgroup creation + + (kbd "C-c") 'wg-create-workgroup + (kbd "c") 'wg-create-workgroup + (kbd "C") 'wg-clone-workgroup + + + ;; 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 + + + ;; updating and reverting + + (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 + + + ;; workgroup switching + + (kbd "C-'") 'wg-switch-to-workgroup + (kbd "'") 'wg-switch-to-workgroup + (kbd "C-v") 'wg-switch-to-workgroup + (kbd "v") 'wg-switch-to-workgroup + (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 "M-p") 'wg-switch-to-workgroup-left-other-frame + (kbd "M-n") 'wg-switch-to-workgroup-right-other-frame + (kbd "C-a") 'wg-switch-to-previous-workgroup + (kbd "a") 'wg-switch-to-previous-workgroup + + + ;; wconfig undo/redo + + (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 + + ;; FIXME: come up with better keys for these: + (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-associate-buffer-with-workgroup + (kbd "~") 'wg-associate-visible-buffers-with-workgroup + (kbd "-") 'wg-dissociate-buffer-from-workgroup + (kbd "=") 'wg-cycle-buffer-association-type + (kbd "*") 'wg-restore-workgroup-associated-buffers + (kbd "_") 'wg-dissociate-weakly-associated-buffers + (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 + + + ;; file and buffer + + (kbd "C-s") 'wg-save-session + (kbd "C-w") 'wg-write-session-file + (kbd "C-f") 'wg-find-session-file + (kbd "F") 'wg-find-file-in-new-workgroup + (kbd "M-F") 'wg-find-file-read-only-in-new-workgroup + (kbd "d") 'wg-dired-in-new-workgroup + (kbd "C-b") 'wg-switch-to-buffer + (kbd "b") 'wg-switch-to-buffer + + + ;; window moving and frame reversal + + (kbd "<") 'wg-backward-transpose-window + (kbd ">") 'wg-transpose-window + (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-m") 'wg-toggle-morph + (kbd "C-t C-b") 'wg-toggle-buffer-list-filtration + (kbd "C-t C-d") 'wg-toggle-window-dedicated-p + + + ;; echoing + + (kbd "S-C-e") 'wg-echo-current-workgroup + (kbd "E") 'wg-echo-current-workgroup + (kbd "C-e") 'wg-echo-all-workgroups + (kbd "e") 'wg-echo-all-workgroups + ;; FIXME: possibly get rid of the time stuff + (kbd "T") 'wg-echo-time + (kbd "V") 'wg-echo-version + (kbd "C-m") 'wg-echo-last-message + (kbd "m") 'wg-echo-last-message + + + ;; misc + + (kbd "A") 'wg-rename-workgroup + (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 wg-remap-switch-to-buffer + (define-key map [remap switch-to-buffer] + 'wg-switch-to-buffer)) + (when wg-remap-switch-to-buffer-other-window + (define-key map [remap switch-to-buffer-other-window] + 'wg-switch-to-buffer-other-window)) + (when wg-remap-switch-to-buffer-other-frame + (define-key map [remap switch-to-buffer-other-frame] + 'wg-switch-to-buffer-other-frame)) + (when wg-remap-next-buffer + (define-key map [remap next-buffer] + 'wg-next-buffer)) + (when wg-remap-previous-buffer + (define-key map [remap previous-buffer] + 'wg-previous-buffer)) + (when wg-remap-kill-buffer + (define-key map [remap kill-buffer] + 'wg-kill-buffer)) + (when wg-remap-display-buffer + (define-key map [remap display-buffer] + 'wg-display-buffer)) + (when wg-remap-insert-buffer + (define-key map [remap insert-buffer] + 'wg-insert-buffer)) + (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))) + (setq workgroups-mode-map map))) + +(defvar wg-minibuffer-mode-map + (wg-fill-keymap + (make-sparse-keymap) + (kbd "C-b") 'wg-backward-char-or-next-buffer-list-filter + (kbd "C-c n") 'wg-next-buffer-list-filter + (kbd "C-c C-n") 'wg-next-buffer-list-filter + (kbd "C-S-b") 'wg-backward-char-or-previous-buffer-list-filter + (kbd "C-c p") 'wg-previous-buffer-list-filter + (kbd "C-c C-p") 'wg-previous-buffer-list-filter + (kbd "C-c a") 'wg-associate-first-match + (kbd "C-c C-a") 'wg-associate-first-match + (kbd "C-c d") 'wg-dissociate-first-match + (kbd "C-c C-d") 'wg-dissociate-first-match + (kbd "C-c _") 'wg-minibuffer-mode-dissociate-weakly-associated-buffers + ) + "`wg-minibuffer-mode's keymap.") + + +(provide 'workgroups-keys) diff --git a/workgroups-morph.el b/workgroups-morph.el new file mode 100644 index 0000000000000000000000000000000000000000..5099d4e150a5a94c838e2b0c0613a808f534fc8a --- /dev/null +++ b/workgroups-morph.el @@ -0,0 +1,133 @@ +;;; morph +;; +;; TODO: Add upward and left morphing. And once it's been added, add selection +;; of a random morph direction. +;; + +(defun wg-morph-p () + "Return t when it's ok to morph, nil otherwise." + (and after-init-time wg-morph-on)) + +(defun wg-morph-step-edges (w1 w2) + "Step W1's edges toward W2's by `wg-morph-hsteps' and `wg-morph-vsteps'." + (wg-step-edges (wg-w-edges w1) (wg-w-edges w2) + wg-morph-hsteps wg-morph-vsteps)) + +(defun wg-morph-determine-steps (gui-steps &optional term-steps) + (max 1 (if (and (not window-system) term-steps) term-steps gui-steps))) + +(defun wg-morph-match-wlist (wt1 wt2) + "Return a wlist by matching WT1's wlist to WT2's. +When wlist1's and wlist2's lengths are equal, return wlist1. +When wlist1 is shorter than wlist2, add a window at the front of wlist1. +When wlist1 is longer than wlist2, package up wlist1's excess windows +into a wtree, so it's the same length as wlist2." + (let* ((wl1 (wg-wtree-wlist wt1)) + (l1 (length wl1)) + (d1 (wg-wtree-dir wt1)) + (wl2 (wg-wtree-wlist wt2)) + (l2 (length wl2))) + (cond ((= l1 l2) wl1) + ((< l1 l2) + (cons (wg-minified-copy-of-last-win (wg-rnth (1+ l1) wl2)) + (if (< (wg-w-size (car wl1) d1) + (* 2 (wg-actual-min-size d1))) + wl1 + (cons (wg-w-edge-operation (car wl1) wg-min-edges #'-) + (cdr wl1))))) + ((> l1 l2) + (append (wg-take wl1 (1- l2)) + (list (wg-make-wtree + :dir d1 + :edges wg-null-edges + :wlist (nthcdr (1- l2) wl1)))))))) + +(defun wg-morph-win-to-win (w1 w2 &optional swap) + "Return a copy of W1 with its edges stepped once toward W2. +When SWAP is non-nil, return a copy of W2 instead." + (wg-set-edges (wg-copy-win (if swap w2 w1)) (wg-morph-step-edges w1 w2))) + +(defun wg-morph-win-to-wtree (win wtree) + "Return a new wtree with WIN's edges and WTREE's last two windows." + (wg-make-wtree + :dir (wg-wtree-dir wtree) + :edges (wg-morph-step-edges win wtree) + :wlist (let ((wg-morph-hsteps 2) (wg-morph-vsteps 2)) + (wg-docar (w (wg-leave (wg-wtree-wlist wtree) 2)) + (wg-morph-win-to-win (wg-minified-copy-of-last-win w) w))))) + +(defun wg-morph-wtree-to-win (wtree win &optional noswap) + "Grow the first window of WTREE and its subtrees one step toward WIN. +This eventually wipes WTREE's components, leaving only a window. +Swap WTREE's first actual window for WIN, unless NOSWAP is non-nil." + (if (wg-win-p wtree) (wg-morph-win-to-win wtree win (not noswap)) + (wg-make-wtree + :dir (wg-wtree-dir wtree) + :edges (wg-morph-step-edges wtree win) + :wlist (wg-dbind (fwin . wins) (wg-wtree-wlist wtree) + (cons (wg-morph-wtree-to-win fwin win noswap) + (wg-docar (sw wins) + (if (wg-win-p sw) sw + (wg-morph-wtree-to-win sw win t)))))))) + +(defun wg-morph-wtree-to-wtree (wt1 wt2) + "Return a new wtree morphed one step toward WT2 from WT1. +Mutually recursive with `wg-morph-dispatch' to traverse the +structures of WT1 and WT2 looking for discrepancies." + (let ((d1 (wg-wtree-dir wt1)) (d2 (wg-wtree-dir wt2))) + (wg-make-wtree + :dir d2 + :edges (wg-morph-step-edges wt1 wt2) + :wlist (if (not (eq (wg-wtree-dir wt1) (wg-wtree-dir wt2))) + (list (wg-minified-copy-of-last-win wt2) wt1) + (mapcar* #'wg-morph-dispatch + (wg-morph-match-wlist wt1 wt2) + (wg-wtree-wlist wt2)))))) + +(defun wg-morph-dispatch (w1 w2) + "Return a wtree morphed one step toward W2 from W1. +Dispatches on each possible combination of types." + (cond ((and (wg-win-p w1) (wg-win-p w2)) + (wg-morph-win-to-win w1 w2 t)) + ((and (wg-wtree-p w1) (wg-wtree-p w2)) + (wg-morph-wtree-to-wtree w1 w2)) + ((and (wg-win-p w1) (wg-wtree-p w2)) + (wg-morph-win-to-wtree w1 w2)) + ((and (wg-wtree-p w1) (wg-win-p w2)) + (wg-morph-wtree-to-win w1 w2)))) + +(defun wg-morph (to &optional from) + "Morph from wtree FROM to wtree TO. +Assumes both FROM and TO fit in `selected-frame'." + (let ((from (or from (wg-window-tree-to-wtree (window-tree)))) + (wg-morph-hsteps + (wg-morph-determine-steps wg-morph-hsteps wg-morph-terminal-hsteps)) + (wg-morph-vsteps + (wg-morph-determine-steps wg-morph-vsteps wg-morph-terminal-vsteps)) + (truncate-partial-width-windows wg-morph-truncate-partial-width-windows) + (wg-record-incorrectly-restored-bufs nil) + (wg-restore-scroll-bars nil) + (wg-restore-fringes nil) + (wg-restore-margins nil) + (wg-restore-point nil) + (wg-restore-mark nil) + (watchdog 0)) + (wg-until (wg-equal-wtrees from to) + (condition-case err + (if (> (incf watchdog) wg-morph-max-steps) + (error "`wg-morph-max-steps' exceeded") + (setq from (wg-normalize-wtree (wg-morph-dispatch from to))) + (wg-restore-window-tree from) + (redisplay)) + (error (wg-dbind (sym data) err + (unless (and (stringp data) + (string-match "too small" data)) + (signal sym data)))))) + to)) + + +(provide 'workgroups-morph) + + + + diff --git a/workgroups-pickel.el b/workgroups-pickel.el new file mode 100644 index 0000000000000000000000000000000000000000..2119c552a61387ea053b461b584af3f28b5fd705 --- /dev/null +++ b/workgroups-pickel.el @@ -0,0 +1,383 @@ +;;; workgroups-pickel.el --- Elisp object serdes used by Workgroups +;; +;; Copyright (C) 2010, 2011 tlh +;; +;; Author: tlh +;; Keywords: serialization deserialization serdes +;; Homepage: https://github.com/tlh/workgroups.el +;; Version 1.0.0 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +;; USA + +;;; Commentary: +;; +;;; Code: + +;;(require 'cl) +(require 'dflet) +(require 'workgroups-compat) +(require 'workgroups-utils-basic) + + +;;; vars + +(defvar wg-pickel-identifier '~pickel!~ + "Symbol identifying a stream as a pickel.") + +(defvar wg-pickel-pickelable-types + '(integer float symbol string cons vector hash-table) + "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)) + "Alist mapping types to object serialization functions.") + +(defvar wg-pickel-link-serializers + '((cons . wg-pickel-cons-link-serializer) + (vector . wg-pickel-vector-link-serializer) + (hash-table . wg-pickel-hash-table-link-serializer)) + "Alist mapping types to link serialization functions.") + +(defvar wg-pickel-object-deserializers + '((s . wg-pickel-deserialize-uninterned-symbol) + (c . wg-pickel-deserialize-cons) + (v . wg-pickel-deserialize-vector) + (h . wg-pickel-deserialize-hash-table)) + "Alist mapping type keys to object deserialization functions.") + +(defvar wg-pickel-link-deserializers + `((c . wg-pickel-cons-link-deserializer) + (v . wg-pickel-vector-link-deserializer) + (h . wg-pickel-hash-table-link-deserializer)) + "Alist mapping type keys to link deserialization functions.") + + + +;;; errors and predicates + +(put 'wg-pickel-unpickelable-type-error + 'error-conditions + '(error wg-pickel-errors wg-pickel-unpickelable-type-error)) + +(put 'wg-pickel-unpickelable-type-error + 'error-message + "Attemp to pickel unpickelable type") + +(defun wg-pickelable-or-error (obj) + "Error when OBJ isn't pickelable." + (unless (memq (type-of obj) wg-pickel-pickelable-types) + (signal 'wg-pickel-unpickelable-type-error + (format "Can't pickel objects of type: %S" (type-of obj)))) + (typecase obj + (cons + (wg-pickelable-or-error (car obj)) + (wg-pickelable-or-error (cdr obj))) + (vector + (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)) + ;;(flet + (dflet + ((inner (obj) + (unless (gethash obj binds) + (puthash obj (incf id) binds) + (case (type-of obj) + (cons + (inner (car obj)) + (inner (cdr obj))) + (vector + (dotimes (idx (length obj)) + (inner (aref obj idx)))) + (hash-table + (wg-dohash (key val obj) + (inner key) + (inner val))))))) + (inner obj) + binds))) + + + +;;; object serialization + +(defun wg-pickel-symbol-serializer (symbol) + "Return SYMBOL's serialization." + (cond ((eq symbol t) t) + ((eq symbol nil) nil) + ((intern-soft symbol) symbol) + (t (list 's (symbol-name symbol))))) + +(defun wg-pickel-cons-serializer (cons) + "Return CONS's serialization." + (list 'c)) + +(defun wg-pickel-vector-serializer (vector) + "Return VECTOR's serialization." + (list 'v (length vector))) + +(defun wg-pickel-hash-table-serializer (table) + "Return HASH-TABLE's serialization." + (list 'h + (hash-table-test table) + (hash-table-size table) + (hash-table-rehash-size table) + (hash-table-rehash-threshold table) + (hash-table-weakness table))) + +(defun wg-pickel-serialize-objects (binds) + "Return a list of serializations of the objects in BINDS." + (let (result) + (wg-dohash (obj id binds result) + (setq result + (nconc (list id (funcall (wg-pickel-object-serializer obj) obj)) + result))))) + + + +;;; link serialization + +(defun wg-pickel-cons-link-serializer (cons binds) + "Return the serialization of CONS's links in BINDS." + (list 'c + (gethash cons binds) + (gethash (car cons) binds) + (gethash (cdr cons) binds))) + +(defun wg-pickel-vector-link-serializer (vector binds) + "Return the serialization of VECTOR's links in BINDS." + (let (result) + (dotimes (i (length vector) result) + (setq result + (nconc (list 'v + (gethash vector binds) + i + (gethash (aref vector i) binds)) + result))))) + +(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-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)))))) + + + +;;; object deserialization + +(defun wg-pickel-deserialize-uninterned-symbol (name) + "Return a new uninterned symbol from NAME." + (make-symbol name)) + +(defun wg-pickel-deserialize-cons () + "Return a new cons cell initialized to nil." + (cons nil nil)) + +(defun wg-pickel-deserialize-vector (length) + "Return a new vector of length LENGTH." + (make-vector length nil)) + +(defun wg-pickel-deserialize-hash-table (test size rsize rthresh weakness) + "Return a new hash-table with the specified properties." + (make-hash-table :test test :size size :rehash-size rsize + :rehash-threshold rthresh :weakness weakness)) + +(defun wg-pickel-deserialize-objects (serial-objects) + "Return a hash-table of objects deserialized from SERIAL-OBJECTS." + (let ((binds (make-hash-table))) + (wg-destructuring-dolist ((id obj . rest) serial-objects binds) + (puthash id + (if (atom obj) obj + (wg-dbind (key . data) obj + (apply (wg-pickel-object-deserializer key) data))) + binds)))) + + + +;;; link deserialization + +(defun wg-pickel-cons-link-deserializer (cons-id car-id cdr-id binds) + "Relink a cons cell with its car and cdr in BINDS." + (let ((cons (gethash cons-id binds))) + (setcar cons (gethash car-id binds)) + (setcdr cons (gethash cdr-id binds)))) + +(defun wg-pickel-vector-link-deserializer (vector-id index value-id binds) + "Relink a vector with its elements in BINDS." + (aset (gethash vector-id binds) index (gethash value-id binds))) + +(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))) + +(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-read-sexp-from-file file))) + +(defun wg-unpickel-string (str) + "`unpickel' and object directly from STR." + (wg-unpickel (read str))) + + + + + +;;; parameter pickeling + +(defun wg-pickel-workgroup-parameters (workgroup) + "If WORKGROUP's parameters are non-nil, return a copy of +WORKGROUP after pickeling 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-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-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) + (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) + ;;(message "session") + ;;(sleep-for 3) + (wg-asetf (wg-session-parameters copy) (wg-unpickel it))) + (wg-asetf (wg-session-workgroup-list copy) + (mapcar 'wg-unpickel-workgroup-parameters it)) + copy)) + + +(provide 'workgroups-pickel) diff --git a/workgroups-specialbufs.el b/workgroups-specialbufs.el new file mode 100644 index 0000000000000000000000000000000000000000..4b73ccb34b7b3842765310da71913f1d0e103a3b --- /dev/null +++ b/workgroups-specialbufs.el @@ -0,0 +1,200 @@ +;;; special buffer serdes functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; TODO: Possibly add restore-special-data customization option +;; TODO: These could be a little more thorough +;; + +(require 'dflet) + +;; Info buffer serdes + +(defun wg-deserialize-Info-buffer (buf) + "Deserialize an Info buffer." + (require 'info) + (wg-aif (cdr (wg-buf-special-data buf)) + (apply #'Info-find-node it) + (info)) + (current-buffer)) + +(defun wg-serialize-Info-buffer (buffer) + "Serialize an Info buffer." + (with-current-buffer buffer + (when (eq major-mode 'Info-mode) + (wg-when-boundp (Info-current-file Info-current-node) + (list 'wg-deserialize-Info-buffer + Info-current-file + Info-current-node))))) + + +;; help buffer serdes + +(defun wg-deserialize-help-buffer (buf) + "Deserialize a help buffer. +See `wg-serialize-help-buffer'." + (require 'help-mode) + (wg-dbind (this-function item stack forward-stack) (wg-buf-special-data buf) + (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)) + (current-buffer)))) + +(defun wg-serialize-help-buffer (buffer) + "Serialize a help buffer. +Since `help-mode' is used by many buffers that aren't actually +*Help* buffers (e.g. *Process List*), we also check that +`help-xref-stack-item' has a local binding." + (with-current-buffer buffer + (when (and (eq major-mode 'help-mode) + (local-variable-p 'help-xref-stack-item) + (boundp 'help-xref-stack-item) + (boundp 'help-xref-stack) + (boundp 'help-xref-forward-stack)) + (list 'wg-deserialize-help-buffer + (wg-take-until-unreadable help-xref-stack-item) + (mapcar 'wg-take-until-unreadable help-xref-stack) + (mapcar 'wg-take-until-unreadable help-xref-forward-stack))))) + + +;; ielm buffer serdes + +(defun wg-deserialize-ielm-buffer (buf) + "Deserialize an `inferior-emacs-lisp-mode' buffer." + (ielm) + (current-buffer)) + +(defun wg-serialize-ielm-buffer (buffer) + "Serialize an `inferior-emacs-lisp-mode' buffer." + (with-current-buffer buffer + (when (eq major-mode 'inferior-emacs-lisp-mode) + (list 'wg-deserialize-ielm-buffer)))) + + +;; shell buffer serdes + +(defun wg-deserialize-shell-buffer (buf) + "Deserialize a `shell-mode' buffer." + (shell (wg-buf-name buf))) + +(defun wg-serialize-shell-buffer (buffer) + "Serialize a `shell-mode' buffer." + (with-current-buffer buffer + (when (eq major-mode 'shell-mode) + (list 'wg-deserialize-shell-buffer)))) + + +;; org-agenda buffer serdes + +(defun wg-get-org-agenda-view-commands () + "Get commands by which the current state of Agenda buffer can +be restored using \"(eval commands)\"." + (interactive) + (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\"." + (if (get-buffer org-agenda-buffer-name) + (save-window-excursion + (with-current-buffer org-agenda-buffer-name + (let* ((line (org-current-line)) + (series-redo-cmd (xdev/get-org-agenda-view-commands))) + (if f (eval f)) + (org-goto-line line)))))) + +(defun wg-deserialize-org-agenda-buffer (buf) + "Deserialize a `org-agenda-mode' buffer." + (org-agenda-list) + (wg-dbind (this-function item) (wg-buf-special-data buf) + (wg-awhen (get-buffer org-agenda-buffer-name) + (set-buffer it) + (wg-run-agenda-cmd item) + (current-buffer)))) + +(defun wg-serialize-org-agenda-buffer (buffer) + "Serialize a `org-agenda-mode' buffer." + (with-current-buffer buffer + (when (eq major-mode 'org-agenda-mode) + (list 'wg-deserialize-org-agenda-buffer + (wg-take-until-unreadable (wg-get-org-agenda-view-commands)) + )))) + + +;; eshell buffer serdes + +(defun wg-deserialize-eshell-buffer (buf) + "Deserialize an `eshell-mode' buffer." + (prog1 (eshell t) + (rename-buffer (wg-buf-name buf) t))) + +(defun wg-serialize-eshell-buffer (buffer) + "Serialize an `eshell-mode' buffer." + (with-current-buffer buffer + (when (eq major-mode 'eshell-mode) + (list 'wg-deserialize-eshell-buffer)))) + + +;; term and ansi-term buffer serdes + +(defun wg-deserialize-term-buffer (buf) + "Deserialize a `term-mode' buffer." + (require 'term) + ;; flet'ing these prevents scrunched up wrapping when restoring during morph + (dflet ((term-window-width () 80) + (window-height () 24)) + (prog1 (term (nth 1 (wg-buf-special-data buf))) + (rename-buffer (wg-buf-name buf) t)))) + +(defun wg-serialize-term-buffer (buffer) + "Serialize a `term-mode' buffer. +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." + (with-current-buffer buffer + (when (eq major-mode 'term-mode) + (wg-when-let ((process (get-buffer-process buffer))) + (list 'wg-deserialize-term-buffer + (wg-last1 (process-command process))))))) + + + + + + +;;; 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'." + (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) diff --git a/workgroups-utils-basic.el b/workgroups-utils-basic.el new file mode 100644 index 0000000000000000000000000000000000000000..89934d575e0497ce01598799a8431cbb3eb7e56d --- /dev/null +++ b/workgroups-utils-basic.el @@ -0,0 +1,573 @@ +;;; workgroups-utils.el --- Utilities used by Workgroups +;; +;; Copyright (C) 2010, 2011 tlh +;; +;; Author: tlh +;; Keywords: session management window-configuration persistence +;; Homepage: https://github.com/tlh/workgroups.el +;; Version 1.0.0 + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be +;; useful, but WITHOUT ANY WARRANTY; without even the implied +;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. See the GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, +;; MA 02111-1307 USA + +;;; Commentary: +;; +;; A bunch of general purpose-ish utilities used by Workgroups. +;; +;;; Code: + + +(eval-and-compile + (require 'cl)) + + +;;; utils used in macros + +(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 (gensym))) syms)) ,@body)) + +(defmacro wg-dbind (args expr &rest body) + "Abbreviation of `destructuring-bind'." + (declare (indent 2)) + `(destructuring-bind ,args ,expr ,@body)) + +(defun wg-partition (list &optional n step) + "Return list of N-length sublists of LIST, 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 only eval BODY when all BINDS are non-nil." + (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-acond (&rest clauses) + "Anaphoric `cond'." + (when clauses + (wg-dbind ((condition . body) . rest) clauses + `(wg-aif ,condition (progn ,@body) + (wg-acond ,@rest))))) + +(defmacro wg-aand (&rest args) + "Anaphoric `and'." + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(wg-aif ,(car args) (aand ,@(cdr args)))))) + +(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-until (test &rest body) + "`while' not." + (declare (indent 1)) + `(while (not ,test) ,@body)) + +(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))))) + + + +;;; boolean operators + +(defmacro wg-eager-or (&rest conditions) + "Evaluate all CONDITIONS. Return the first non-nil return value." + (let ((syms (mapcar (lambda (x) (gensym)) conditions))) + `(let ,(mapcar* 'list syms conditions) + (or ,@syms)))) + +(defmacro wg-eager-and (&rest conditions) + "Evaluate all conditions. If any return nil, return nil. +Otherwise return the return value of the last condition." + (let ((syms (mapcar (lambda (x) (gensym)) conditions))) + `(let ,(mapcar* 'list syms conditions) + (and ,@syms)))) + + + +;;; 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) + (flet ((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 (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 (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 (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 (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 '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 (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 '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 (position elt1 list)) + (p2 (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))) + (loop for (elt . rest) on list + for elt = (funcall key elt) + when (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." + (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)) + +(defmacro wg-abind (alist binds &rest body) + "Bind values in ALIST to symbols in BINDS, then eval BODY. +If an elt of BINDS is a symbol, use it as both the bound variable +and the key in ALIST. If it is a cons, use the car as the bound +variable, and the cadr as the key." + (declare (indent 2)) + (wg-with-gensyms (asym) + `(let* ((,asym ,alist) + ,@(wg-docar (bind binds) + (let ((c (consp bind))) + `(,(if c (car bind) bind) + (wg-aget ,asym ',(if c (cadr bind) bind)))))) + ,@body))) + + + +;;; hash-tables + +(defun wg-fill-hash-table (table &rest key-value-pairs) + "Fill TABLE with KEY-VALUE-PAIRS and return TABLE." + (while key-value-pairs + (puthash (car key-value-pairs) (cadr key-value-pairs) table) + (setq key-value-pairs (cddr key-value-pairs))) + table) + + + +;;; 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'." + (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." + (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) + "Read and return an sexp from FILE." + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (read (current-buffer)))) + +(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))) + (flet ((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 + (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-minibuffer-inactive-p () + "Return t when `minibuffer-depth' returns zero, nil otherwise." + (zerop (minibuffer-depth))) + +(defun wg-minibuffer-active-p () + "Return t when `minibuffer-depth' does not return zero, nil otherwise." + (not (wg-minibuffer-inactive-p))) + +(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)))) + + + +(provide 'workgroups-utils-basic) diff --git a/workgroups-variables.el b/workgroups-variables.el new file mode 100644 index 0000000000000000000000000000000000000000..70727a40bcfcc70a5655aa47f67373c46ae0b4e2 --- /dev/null +++ b/workgroups-variables.el @@ -0,0 +1,905 @@ +;;; consts + +(defconst wg-version "1.0.0" + "Current version of workgroups.") + +;;; customization + +(defgroup workgroups nil + "Workgroup for Windows -- Emacs session manager" + :group 'convenience + :version wg-version) + +(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-load-last-workgroup nil + "Load last active, not first, workgroup from all your workgroups." + :group 'workgroups + :type 'boolean) + +(defvar wg-key-current-workgroup "_current_workgroup") +(defvar wg-key-load-last-workgroup "_load-last-workgroup") + +;; keybinding customization + +(defcustom wg-prefix-key (kbd "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) + + +;; 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) + + +;; save and load customization + +(defcustom wg-use-default-session-file t + "Generally, non-nil means take care of saving and loading automatically, +and nil means leave it up to the user. + +FIXME: docstring this" + :type 'boolean + :group 'workgroups) + +(defcustom wg-default-session-file + (concat user-emacs-directory "default-workgroups-session") + "FIXME: nix or docstring this" + :type 'file + :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) + +(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) + + +;; minibuffer customization + +(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) + +(defcustom wg-no-confirm-on-destructive-operation nil + "Non-nil means don't 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) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 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-special-buffer-serdes-functions + '(wg-serialize-Info-buffer + wg-serialize-org-agenda-buffer + wg-serialize-help-buffer + wg-serialize-ielm-buffer + wg-serialize-shell-buffer + wg-serialize-eshell-buffer + wg-serialize-term-buffer + ) + "List of functions providing special buffer serialization/deserialization. +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) + +(defcustom wg-default-buffer "*scratch*" + "Buffer made visible a window when the window's actual buffer +can't be restored. Also used when a blank workgroup is created." + :type 'string + :group 'workgroups) + +(defcustom wg-restore-associated-buffers t + "Non-nil means restore all buffers associated with the +workgroup on workgroup restore." + :type 'boolean + :group 'workgroups) + +(defcustom wg-restore-frame-position nil + "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) + + +;; wconfig undo/redo customization + +(defcustom wg-wconfig-undo-list-max 20 + "Number of past window configs to retain for undo." + :type 'integer + :group 'workgroups) + + +;; wconfig kill-ring customization + +(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) + (associated "associated" wg-buffer-list-filter-associated) + (unassociated "unassociated" wg-buffer-list-filter-unassociated) + (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 + +`associated' Only the names of those live buffers that have + been associated with the current workgroup + +`unassociated' Only the names of those live buffers that are + unassociated with the current workgroup + +`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. + +A few example custom buffer-list filtration functions are +included, like `wg-buffer-list-filter-home-dir', +`wg-buffer-list-filter-irc' and `wg-buffer-list-filter-elisp'. +See their definitions for more info on how they're defined, and +the utilities they're built on. + +Here's an example of how to add an `elisp' buffer-list-filter +definition to `wg-buffer-list-filter-definitions' using the +example function `wg-buffer-list-filter-elisp': + +(add-to-list + 'wg-buffer-list-filter-definitions + '(elisp \"elisp\" wg-buffer-list-filter-elisp)) + +After this form has been evaluated, `elisp' can be used wherever +other buffer-list-filter identifiers are used, like in +`wg-buffer-list-filter-order-alist'. + +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 associated unassociated 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-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 from the current workgroup buffers +killed with `kill-buffer'." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-switch-to-buffer t + "Non-nil means remap `switch-to-buffer' to `wg-switch-to-buffer'." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-switch-to-buffer-other-window t + "Non-nil means remap `switch-to-buffer-other-window' to +`wg-switch-to-buffer-other-window'. Otherwise, don't remap." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-switch-to-buffer-other-frame t + "Non-nil means remap `switch-to-buffer-other-frame' to +`wg-switch-to-buffer-other-frame'. Otherwise, don't remap." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-kill-buffer t + "Non-nil means remap `kill-buffer' to `wg-kill-buffer'. +Otherwise, don't remap." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-display-buffer t + "Non-nil means remap `display-buffer' to `wg-display-buffer'. +Otherwise, don't remap." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-insert-buffer t + "Non-nil means remap `insert-buffer' to `wg-insert-buffer'. +Otherwise, don't remap." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-next-buffer t + "Non-nil means remap `next-buffer' to `wg-next-buffer'. +Otherwise, don't remap." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-previous-buffer t + "Non-nil means remap `previous-buffer' to `wg-previous-buffer'. +Otherwise, don't remap." + :type 'boolean + :group 'workgroups) + +(defcustom wg-remap-bury-buffer 'bury + "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) + +(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) + + +;; morph customization + +(defcustom wg-morph-on t + "Non-nil means use `wg-morph' when restoring wconfigs." + :type 'boolean + :group 'workgroups) + +(defcustom wg-morph-hsteps 9 + "Columns/iteration to step window edges during `wg-morph'. +Values lower than 1 are invalid." + :type 'integer + :group 'workgroups) + +(defcustom wg-morph-vsteps 3 + "Rows/iteration to step window edges during `wg-morph'. +Values lower than 1 are invalid." + :type 'integer + :group 'workgroups) + +(defcustom wg-morph-terminal-hsteps 3 + "Used instead of `wg-morph-hsteps' in terminal frames. +If nil, `wg-morph-hsteps' is used." + :type 'integer + :group 'workgroups) + +(defcustom wg-morph-terminal-vsteps 1 + "Used instead of `wg-morph-vsteps' in terminal frames. +If nil, `wg-morph-vsteps' is used." + :type 'integer + :group 'workgroups) + +(defcustom wg-morph-truncate-partial-width-windows t + "Bound to `truncate-partial-width-windows' during `wg-morph'. +Non-nil, this prevents weird-looking continuation line behavior, +and can speed up morphing a little. Lines jump back to their +wrapped status when `wg-morph' is complete." + :type 'boolean + :group 'workgroups) + + +;; mode-line customization + +(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-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-strongly-associated + #("@" 0 1 (help-echo "This buffer is strongly associated with the \ +current workgroup")) + "Indicates that a buffer is strongly associated with the current workgroup." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-weakly-associated + #("~" 0 1 (help-echo "This buffer is weakly associated with the \ +current workgroup")) + "Indicates that a buffer is weakly associated with the current workgroup." + :type 'string + :group 'workgroups) + +(defcustom wg-mode-line-decor-unassociated + #("-" 0 1 (help-echo "This buffer is unassociated with the \ +current workgroup")) + "Indicates that a buffer is unassociated with the current workgroup." + :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) + + +;; display customization + +(defcustom wg-use-faces t + "Non-nil means use faces in various displays." + :type 'boolean + :group 'workgroups) + +(defcustom wg-time-format "%H:%M:%S %A, %B %d %Y" + "Format string for time display. Passed to `format-time-string'." + :type 'string + :group 'workgroups) + +(defcustom wg-display-battery t + "Non-nil means include `battery', when available, in the time display." + :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) + +(defcustom wg-associate-buffers t + "Non-nil means when emacs chooses a buffer to display in a +workgroup, prefer buffers whose most recent appearance was in +that workgroup." + :type 'boolean + :group 'workgroups) + +;;; vars + +(defvar workgroups-mode-map nil + "Workgroups Mode's keymap") + +(defvar wg-current-session nil + "Current session object.") + +(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-face-abbrevs nil + "Assoc list mapping face abbreviations to face names.") + +(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.") + +(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.") + + +;; 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-iswitchb-method-translations + `((switch-to-buffer . samewindow) + (switch-to-buffer-other-window . otherwindow) + (switch-to-buffer-other-frame . otherframe) + (kill-buffer . kill) + (insert-buffer . insert) + (display-buffer . display)) + "Alist mapping buffer commands to iswitchb 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 and morph vars + +(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-morph-max-steps 200 + "Maximum `wg-morph' iterations before forcing exit.") + +(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.") + + +(defvar wg-buffer-workgroup nil + "Buffer-local variable associating each buffer with the + workgroup in which it most recently appeared.") +(make-variable-buffer-local 'wg-buffer-workgroup) + +(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.") + +;;; faces + +(defmacro wg-defface (face key spec doc &rest args) + "`defface' wrapper adding a lookup key used by `wg-fontify'." + (declare (indent 2)) + `(progn + (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) + + +(provide 'workgroups-variables) diff --git a/workgroups-wconfig-restore.el b/workgroups-wconfig-restore.el new file mode 100644 index 0000000000000000000000000000000000000000..ad8f720f5079a5ca6fc9b316d50fc3b6ac57b8bb --- /dev/null +++ b/workgroups-wconfig-restore.el @@ -0,0 +1,149 @@ +;;; wconfig restoration + +(defun wg-restore-default-buffer () + "Switch to `wg-default-buffer'." + (switch-to-buffer wg-default-buffer t)) + +(defun wg-restore-existing-buffer (buf) + "Switch to and return BUF's referrent (some live buffer) if it exists." + (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))) + (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 + (message "Attempt to restore nonexistent file: %S" file-name) + nil)))) + +(defun wg-restore-special-buffer (buf) + "Restore a buffer 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." + (let (wg-buffer-auto-association-on) + (or (wg-restore-existing-buffer buf) + (wg-restore-special-buffer buf) + (wg-restore-file-buffer buf) + (progn (wg-restore-default-buffer) nil)))) + +(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))))) + +;; FIXME: nix these or move them to the vars section +(defvar wg-incorrectly-restored-bufs nil + "FIXME: docstring this") + +(defvar wg-record-incorrectly-restored-bufs nil + "FIXME: docstring this") + +(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))))))) + +(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) + (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)))) + +(defun wg-wconfig-restore-frame-position (wconfig) + "Restore `selected-frame's position from WCONFIG." + (wg-when-let ((left (wg-wconfig-left wconfig)) + (top (wg-wconfig-top wconfig))) + (set-frame-position (selected-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))) + +;; FIXME: throw a specific error if the restoration was unsuccessful +(defun wg-restore-wconfig (wconfig) + "Restore WCONFIG in `selected-frame'." + (let ((wg-record-incorrectly-restored-bufs t) + (wg-incorrectly-restored-bufs nil)) + (wg-barf-on-active-minibuffer) + (when wg-restore-frame-position + (wg-wconfig-restore-frame-position wconfig)) + (let ((wtree (wg-resize-frame-scale-wtree wconfig))) + (wg-restore-window-tree + (if (not (wg-morph-p)) wtree (wg-morph wtree)))) + (when wg-restore-scroll-bars + (wg-wconfig-restore-scroll-bars 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))))) + + + +(provide 'workgroups-wconfig-restore) diff --git a/workgroups2.el b/workgroups2.el new file mode 100644 index 0000000000000000000000000000000000000000..b1e75133ecfb81ed1f98fad7d8b6e7a39ce83d65 --- /dev/null +++ b/workgroups2.el @@ -0,0 +1,198 @@ +;;; workgroups2 - Workspaces for Emacs +;; +;; Copyright (C) 2013 Sergey Pashinin +;; Copyright (C) 2010, 2011 tlh +;; +;; Author: Sergey Pashinin +;; Keywords: session management window-configuration persistence +;; Homepage: https://github.com/pashinin/workgroups2 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +;; USA + +;;; Commentary: +;; +;; Workgroups is an Emacs session manager providing window-configuration +;; persistence, switching, undo/redo, killing/yanking, animated +;; morphing, per-workgroup buffer-lists, and more. +;; +;; +;; Installation and Usage +;; ---------------------- +;; See the file README.md in this directory, or at +;; +;; https://github.com/pashinin/workgroups2 +;; +;; +;; Symbol naming conventions +;; ------------------------- +;; * bufobj always refers to a Workgroups buffer (wg-buf) or an Emacs buffer +;; * W always refers to a Workgroups window (wg-win) or window tree (wg-wtree). +;; * SW always refers to a sub-window or sub-window-tree of a wtree. +;; * WL always refers to the window list of a wtree. +;; * LN, TN, RN and BN always refer to the LEFT, TOP, RIGHT and BOTTOM +;; edges of an edge list, where N is a differentiating integer. +;; * LS, HS, LB and HB always refer to the LOW-SIDE, HIGH-SIDE, LOW-BOUND +;; and HIGH-BOUND of a bounds list. See `wg-with-bounds'. +;; +;; +;;; Code: + + +(require 'cl) +(require 'workgroups-compat) +(require 'workgroups-utils-basic) +(require 'workgroups-pickel) + +(eval-when-compile ;; bytecomp warnings begone! + (require 'ido nil t) + (require 'iswitchb nil t)) + +(require 'workgroups-variables) +(require 'workgroups-functions) +(require 'workgroups-advice) +(require 'workgroups-commands) +(require 'workgroups-keys) + + + +;;; workgroups-everywhere + +(define-minor-mode workgroups-everywhere + "Use Workgroups' buffer list filters everywhere `read-buffer' is used." + :global t + :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))) + + + +;;; wg-minibuffer-mode + +(defvar wg-minibuffer-mode-minor-mode-map-entry + (cons 'wg-minibuffer-mode wg-minibuffer-mode-map) + "`wg-minibuffer-mode's entry in `minor-mode-map-alist'.") + +(define-minor-mode wg-minibuffer-mode + "Minor mode for Workgroups' minibuffer commands." + :global t + :group 'workgroups + (when wg-minibuffer-mode + (add-to-list 'minor-mode-map-alist + wg-minibuffer-mode-minor-mode-map-entry))) + +(defun wg-turn-on-minibuffer-mode () + "`minibuffer-setup-hook' to turn on `wg-minibuffer-mode'." + (when wg-current-buffer-list-filter-id + (wg-minibuffer-mode 1))) + +(defun wg-turn-off-minibuffer-mode () + "`minibuffer-exit-hook' to turn off `wg-minibuffer-mode'." + (wg-minibuffer-mode -1)) + + + +;;; workgroups-mode + +(defun wg-find-session-file-on-workgroups-mode-entry () + "FIXME: docstring this" + (when (and wg-use-default-session-file + (file-exists-p wg-default-session-file)) + (condition-case err + (wg-find-session-file wg-default-session-file) + (error (message "Error finding `wg-default-session-file': %s" err))))) + +(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-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 + '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-setup-hook 'wg-turn-on-minibuffer-mode + 'minibuffer-exit-hook 'wg-flag-just-exited-minibuffer + 'minibuffer-exit-hook 'wg-turn-off-minibuffer-mode + 'ido-make-buffer-list-hook 'wg-set-ido-buffer-list + 'iswitchb-make-buflist-hook 'wg-set-iswitchb-buffer-list + 'kill-buffer-hook 'wg-auto-dissociate-buffer-hook + 'kill-buffer-hook 'wg-update-buffer-in-buf-list + 'window-configuration-change-hook 'wg-associate-frame-buffers + 'after-make-frame-functions 'wg-after-make-frame)) + +(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'." + (pushnew 'workgroups-mode minor-mode-list) + (pushnew '(workgroups-mode " wg") 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 workgroups-mode (&optional arg) + "Turns `workgroups-mode' on and off. +If ARG is null, toggle `workgroups-mode'. +If ARG is an integer greater than zero, turn on `workgroups-mode'. +If ARG is an integer less one, turn off `workgroups-mode'. +If ARG is anything else, turn on `workgroups-mode'." + (interactive (list current-prefix-arg)) + (setq workgroups-mode + (cond ((not arg) (not workgroups-mode)) + ((integerp arg) (if (> arg 0) t nil)) + (t))) + (cond + (workgroups-mode + (wg-reset-internal) + (wg-add-workgroups-mode-minor-mode-entries) + (wg-enable-all-advice) + (wg-add-or-remove-workgroups-hooks nil) + ;;(mapcar 'wg-after-make-frame (frame-list)) + (mapc 'wg-after-make-frame (frame-list)) + (wg-add-mode-line-display) + (wg-find-session-file-on-workgroups-mode-entry) + (run-hooks 'workgroups-mode-hook)) + (t + (wg-save-session-on-workgroups-mode-exit) + (wg-disable-all-advice) + (wg-add-or-remove-workgroups-hooks t) + (wg-remove-mode-line-display) + (run-hooks 'workgroups-mode-exit-hook))) + (wg-fontified-message + (:cmd "Workgroups Mode: ") + (:msg (if workgroups-mode "on" "off"))) + workgroups-mode) + +(provide 'workgroups2) +;;; workgroups.el ends here