Find file
Fetching contributors…
Cannot retrieve contributors at this time
2248 lines (1862 sloc) 77.4 KB
;;; workgroups.el --- workgroups for windows (for Emacs)
;; Copyright (C) 2010 tlh <>
;; File: workgroups.el
;; Author: tlh <>
;; Created: 2010-07-22
;; Version: 0.2.0
;; Keywords: session management window-configuration persistence
;; 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
;; 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:
;; See the file in `workgroups.el's directory
;;; Installation:
;;; Usage:
;;; Symbol naming conventions:
;; W always refers to a Workgroups window or window tree.
;; WT always refers to a Workgroups window tree.
;; 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)
;;; consts
(defconst wg-version "0.2.0"
"Current version of workgroups.")
(defconst wg-persisted-workgroups-tag 'workgroups
"This should be the car of any list of persisted workgroups.")
;;; customization
(defgroup workgroups nil
"Workgroup for Windows -- Emacs session manager"
:group 'convenience
:version wg-version)
(defcustom workgroups-mode-hook nil
"Hook run when workgroups-mode is turned on."
:type 'hook
:group 'workgroups)
;; FIXME: This complicates loading and byte-comp too much
(defcustom wg-prefix-key (kbd "C-z")
"Workgroups' prefix key."
:type 'string
:group 'workgroups
:set (lambda (sym val)
(custom-set-default sym val)
(when (and (boundp 'workgroups-mode) workgroups-mode)
(defcustom wg-switch-hook nil
"Hook run by `wg-switch-to-workgroup'."
:type 'hook
:group 'workgroups)
(defcustom wg-no-confirm nil
"Non-nil means don't request confirmation before various
destructive operations, like `wg-reset'. This doesn't modify
query-for-save behavior. Use
`wg-query-for-save-on-workgroups-mode-exit' and
`wg-query-for-save-on-emacs-exit' for that."
:type 'boolean
:group 'workgroups)
(defcustom wg-mode-line-on t
"Toggles Workgroups' mode-line display."
:type 'boolean
:group 'workgroups
:set (lambda (sym val)
(custom-set-default sym val)
(defcustom wg-kill-ring-size 20
"Maximum length of the `wg-kill-ring'."
:type 'integer
:group 'workgroups)
(defcustom wg-warning-timeout 0.7
"Seconds to display minibuffer warning messages."
:type 'float
:group 'workgroups)
;; save and load customization
(defcustom wg-switch-on-load t
"Non-nil means switch to the first workgroup in a file when it's loaded."
:type 'boolean
:group 'workgroups)
(defcustom wg-query-for-save-on-emacs-exit t
"Non-nil means query to save changes before exiting Emacs.
Exiting workgroups removes its `kill-emacs-query-functions' hook,
so if you set this to nil, you may want to set
`wg-query-for-save-on-workgroups-exit' to t."
:type 'boolean
:group 'workgroups)
(defcustom wg-query-for-save-on-workgroups-mode-exit t
"Non-nil means query to save changes before exiting `workgroups-mode'.
Exiting workgroups removes its `kill-emacs-query-functions' hook,
which is why this variable exists."
:type 'boolean
:group 'workgroups)
;; workgroup restoration customization
(defcustom wg-default-buffer "*scratch*"
"Buffer switched to when a blank workgroup is created.
Also used when a window's buffer can't be restored."
:type 'string
:group 'workgroups)
(defcustom wg-restore-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-mbs-window t
"Non-nil means restore `minibuffer-scroll-window' 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 on."
: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-dedicated t
"Non-nil means restore `window-dedicated-p' on workgroup restore."
:type 'boolean
: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-sit-for-seconds 0
"Seconds to `sit-for' between `wg-morph' iterations.
Should probably be zero unless `redisplay' is *really* fast on
your machine, and `wg-morph-hsteps' and `wg-morph-vsteps' are
already set as low as possible."
:type 'float
: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)
;; display customization
(defcustom wg-use-faces t
"Nil means don't use faces in various displays."
:type 'boolean
:group 'workgroups)
(defcustom wg-mode-line-left-brace "("
"String to the left of the mode-line display."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-right-brace ")"
"String to the right of the mode-line display."
:type 'string
:group 'workgroups)
(defcustom wg-mode-line-divider ":"
"String between workgroup position and name in the mode-line display."
:type 'string
:group 'workgroups)
(defcustom wg-display-left-brace "( "
"String to the left of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-display-right-brace " )"
"String to the right of the list display."
:type 'string
:group 'workgroups)
(defcustom wg-display-divider " | "
"String between workgroup names in the list display."
:type 'string
:group 'workgroups)
(defcustom wg-display-current-workgroup-left-decor "-<{ "
"String to the left of the current workgroup name in the list display."
:type 'string
:group 'workgroups)
(defcustom wg-display-current-workgroup-right-decor " }>-"
"String to the right of the current workgroup name in the list display."
:type 'string
:group 'workgroups)
(defcustom wg-display-previous-workgroup-left-decor "*"
"String to the left of the previous workgroup name in the list display."
:type 'string
:group 'workgroups)
(defcustom wg-display-previous-workgroup-right-decor "*"
"String to the right of the previous workgroup name in the list display."
:type 'string
: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)
;;; vars
(defvar wg-file nil
"Current workgroups file.")
(defvar wg-list nil
"List of currently defined workgroups.")
(defvar wg-frame-table (make-hash-table)
"Hash table keyed on frame, storing each frame's state.")
(defvar wg-dirty nil
"Non-nil when there are unsaved changes.")
(defvar wg-kill-ring nil
"Ring of killed or kill-ring-saved wconfigs.")
(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-morph-no-error t
"Non-nil means ignore errors during `wg-morph'.
The error message is sent to *messages* instead. This was added
when `wg-morph' was unstable, so that the screen wouldn't be left
in an inconsistent state. It's unnecessary now, as `wg-morph' is
stable, but is left here for the time being.")
(defvar wg-last-message nil
"Holds the last message Workgroups sent to the echo area.")
(defvar wg-selected-window nil
"Used during wconfig restoration to hold the selected window.")
(defvar wg-face-abbrevs nil
"Assoc list mapping face abbreviations to face names.")
;;; faces
(defmacro wg-defface (face key spec doc &rest args)
"`defface' wrapper adding a lookup key used by `wg-fontify'."
(declare (indent 2))
(pushnew (cons ,key ',face) wg-face-abbrevs :test #'equal)
(defface ,face ,spec ,doc ,@args)))
(wg-defface wg-current-workgroup-face :cur
'((((class color)) (:foreground "white")))
"Face used for the name of the current workgroup in the list display."
:group 'workgroups)
(wg-defface wg-previous-workgroup-face :prev
'((((class color)) (:foreground "light sky blue")))
"Face used for the name of the previous workgroup in the list display."
:group 'workgroups)
(wg-defface wg-other-workgroup-face :other
'((((class color)) (:foreground "light slate grey")))
"Face used for the names of other workgroups in the list display."
:group 'workgroups)
(wg-defface wg-command-face :cmd
'((((class color)) (:foreground "aquamarine")))
"Face used for command/operation strings."
:group 'workgroups)
(wg-defface wg-divider-face :div
'((((class color)) (:foreground "light slate blue")))
"Face used for dividers."
:group 'workgroups)
(wg-defface wg-brace-face :brace
'((((class color)) (:foreground "light slate blue")))
"Face used for left and right braces."
:group 'workgroups)
(wg-defface wg-message-face :msg
'((((class color)) (:foreground "light sky blue")))
"Face used for messages."
:group 'workgroups)
(wg-defface wg-mode-line-face :mode
'((((class color)) (:foreground "light sky blue")))
"Face used for workgroup position and name in the mode-line display."
:group 'workgroups)
(wg-defface wg-filename-face :file
'((((class color)) (:foreground "light sky blue")))
"Face used for filenames."
:group 'workgroups)
(wg-defface wg-frame-face :frame
'((((class color)) (:foreground "white")))
"Face used for frame names."
:group 'workgroups)
;;; utils
;; functions used in macros:
(defun wg-take (list n)
"Return a list of the first N elts in LIST."
(butlast list (- (length list) n)))
(defun wg-partition (list n &optional step)
"Return list of N-length sublists of LIST, offset by STEP.
Iterative to prevent stack overflow."
(let (acc)
(while list
(push (wg-take list n) acc)
(setq list (nthcdr (or step n) list)))
(nreverse acc)))
(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))
(defmacro wg-dohash (spec &rest body)
"do-style wrapper for `maphash'."
(declare (indent 1))
(wg-dbind (key val table &optional return) spec
`(progn (maphash (lambda (,key ,val) ,@body) ,table) ,return)))
(defmacro wg-doconcat (spec &rest body)
"do-style wrapper for `mapconcat'."
(declare (indent 1))
(wg-dbind (elt seq &optional sep) spec
`(mapconcat (lambda (,elt) ,@body) ,seq (or ,sep ""))))
(defmacro wg-docar (spec &rest body)
"do-style wrapper for `mapcar'."
(declare (indent 1))
`(mapcar (lambda (,(car spec)) ,@body) ,(cadr spec)))
(defmacro wg-get-some (spec &rest body)
"do-style wrapper for `some'.
Returns the elt itself, rather than the return value of the form."
(declare (indent 1))
(wg-dbind (sym list) spec
`(some (lambda (,sym) (when (progn ,@body) ,sym)) ,list)))
(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-until (test &rest body)
"`while' not."
(declare (indent 1))
`(while (not ,test) ,@body))
(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-aand (&rest args)
"Anaphoric `and'."
(declare (indent defun))
(cond ((null args) t)
((null (cdr args)) (car args))
(t `(aif ,(car args) (aand ,@(cdr args))))))
(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-last1 (list)
"Return the last element of LIST."
(car (last list)))
(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-insert-elt (elt list &optional pos)
"Insert ELT into LIST at POS or the end."
(let* ((len (length list)) (pos (or pos len)))
(when (wg-within pos 0 len t)
(append (wg-take list pos) (cons elt (nthcdr pos list))))))
(defun wg-move-elt (elt list pos)
"Move ELT to position POS in LIST."
(when (member elt list)
(wg-insert-elt elt (remove elt list) pos)))
(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)
"Return the elt in LIST N places cyclically from ELT.
If ELT is not present is LIST, return nil."
(wg-when-let ((pos (position elt list)))
(nth (mod (+ pos n) (length list)) list)))
(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-aget (alist key)
"Return the value of KEY in ALIST. Uses `assq'."
(cdr (assq key alist)))
(defun wg-acopy (alist)
"Return a copy of ALIST's toplevel list structure."
(wg-docar (kvp alist) (cons (car kvp) (cdr kvp))))
(defun wg-aset (alist key val)
"Set KEY's value to VAL in ALIST.
If KEY already exists in ALIST, destructively set its value.
Otherwise, cons a new key-value-pair onto ALIST."
(wg-aif (assq key alist) (progn (setcdr it val) alist)
(cons (cons key val) alist)))
(defun wg-aput (alist &rest key-value-pairs)
"Add all KEY-VALUE-PAIRS to a copy of ALIST, and return the copy."
(flet ((rec (alist kvps) (if (not kvps) alist
(wg-dbind (k v . rest) kvps
(wg-aset (rec alist rest) k v)))))
(rec (wg-acopy alist) key-value-pairs)))
(defun wg-get-alist (key val alist-list)
"Return the first alist in ALIST-LIST containing KEY and VAL."
(catch 'res
(dolist (alist alist-list)
(when (equal val (cdr (assoc key alist)))
(throw 'res 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))))))
(defmacro wg-fill-keymap (keymap &rest binds)
"Return KEYMAP after defining in it all keybindings in BINDS."
(declare (indent 1))
(wg-with-gensyms (km)
`(let ((,km ,keymap))
,@(wg-docar (b (wg-partition binds 2))
`(define-key ,km (kbd ,(car b)) ,(cadr b)))
(defun wg-write-sexp-to-file (sexp file)
"Write the printable representation of SEXP to FILE."
(let (print-level print-length)
(insert (format "%S" sexp))
(write-file file))))
(defun wg-read-sexp-from-file (file)
"Read and return an sexp from FILE."
(insert-file-contents file)
(goto-char (point-min))
(read (current-buffer))))
(defun wg-read-object (prompt test warning &rest args)
"PROMPT for an object that satisfies TEST, WARNING if necessary.
ARGS are `read-from-minibuffer's args, after PROMPT."
(let ((obj (apply #'read-from-minibuffer prompt args)))
(wg-until (funcall test obj)
(message warning)
(sit-for wg-warning-timeout)
(setq obj (apply #'read-from-minibuffer prompt args)))
;;; workgroups utils
(defun wg-type-of (obj)
"Return workgroups' object type of OBJ."
(wg-aget obj 'type))
(defun wg-type-p (type obj)
"Return t if OBJ is of type TYPE, nil otherwise."
(and (consp obj) (eq type (wg-type-of obj))))
(defun wg-type-check (type obj &optional noerror)
"Throw an error if OBJ is not of type TYPE."
(or (wg-type-p type obj)
(unless noerror
(error "%s is not of type %s" obj type))))
(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'."
(or frame (selected-frame)) (frame-list) (or n 1)))
(defun wg-add-face (facekey str)
"Return a copy of STR fontified according to FACEKEY.
FACEKEY must be a key in `wg-face-abbrevs'."
(let ((face (wg-aget wg-face-abbrevs facekey))
(str (copy-seq str)))
(unless face (error "No face with key %s" facekey))
(if (not wg-use-faces) str
(put-text-property 0 (length str) 'face face str)
(defmacro wg-fontify (&rest specs)
"A small fontification DSL. *WRITEME*"
(declare (indent defun))
,@(wg-docar (spec specs)
(typecase spec
(cons (if (keywordp (car spec))
,(car spec)
,(if (stringp (cadr spec))
(cadr spec)
`(format "%s" ,(cadr spec))))
`(progn ,spec)))
(string `(progn ,spec))
(atom `(format "%s" ,spec))))))
(defun wg-error-on-active-minibuffer ()
"Throw an error when the minibuffer is active."
(when (active-minibuffer-window)
(error "Workgroup operations aren't permitted while the \
minibuffer is active.")))
;;; type predicates
(defun wg-window-p (obj)
"Return t if OBJ is a Workgroups window, nil otherwise."
(wg-type-p 'window obj))
(defun wg-wtree-p (obj)
"Return t if OBJ is a Workgroups window tree, nil otherwise."
(wg-type-p 'wtree obj))
(defun wg-wconfig-p (obj)
"Return t if OBJ is a Workgroups window config, nil otherwise."
(wg-type-p 'wconfig obj))
(defun wg-workgroup-p (obj)
"Return t if OBJ is a workgroup, nil otherwise."
(wg-type-p 'workgroup obj))
;; window config utils
;; Accessors for common fields:
(defun wg-dir (w) (wg-aget w 'dir))
(defun wg-edges (w) (wg-aget w 'edges))
(defun wg-wlist (w) (wg-aget w 'wlist))
(defun wg-wtree (w) (wg-aget w 'wtree))
(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-edges ,w) ,@body))
(defun wg-put-edges (w left top right bottom)
"Return a copy of W with an edge list of LEFT TOP RIGHT and BOTTOM."
(wg-aput w 'edges (list left top right bottom)))
(defmacro wg-with-bounds (w 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 ,w (,l1 ,t1 ,r1 ,b1)
(cond (,dir (let ((,ls1 ,l1) (,hs1 ,r1) (,lb1 ,t1) (,hb1 ,b1))
(t (let ((,ls1 ,t1) (,hs1 ,b1) (,lb1 ,l1) (,hb1 ,r1))
(defun wg-put-bounds (w dir ls hs lb hb)
"Set W's edges in DIR with bounds LS HS LB and HB."
(if dir (wg-put-edges w ls lb hs hb) (wg-put-edges w 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-aput w 'edges (mapcar* op (wg-aget w 'edges) edges)))
(defun wg-first-win (w)
"Return the first actual window in W."
(if (wg-window-p w) w (wg-first-win (car (wg-wlist w)))))
(defun wg-last-win (w)
"Return the last actual window in W."
(if (wg-window-p w) w (wg-last-win (wg-last1 (wg-wlist w)))))
(defun wg-minify-win (w)
"Return a copy of W with the smallest allowable dimensions."
(let* ((edges (wg-edges w))
(left (car edges))
(top (cadr edges)))
(wg-put-edges w left top
(+ left wg-actual-min-width)
(+ top wg-actual-min-height))))
(defun wg-minify-last-win (w)
"Minify the last actual window in W."
(wg-minify-win (wg-last-win w)))
(defun wg-wsize (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-wsize (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-put-edges w left top
(+ left (funcall width-fn (- right left)))
(+ top (funcall height-fn (- bottom top)))))))
(defun wg-scale-wsize (w width-scale height-scale)
"Scale W's size by WIDTH-SCALE and HEIGHT-SCALE."
(flet ((wscale (width) (truncate (* width width-scale)))
(hscale (height) (truncate (* height height-scale))))
(wg-adjust-wsize w #'wscale #'hscale)))
(defun wg-equal-wtrees (w1 w2)
"Return t when W1 and W2 have equal structure."
(cond ((and (wg-window-p w1) (wg-window-p w2))
(equal (wg-edges w1) (wg-edges w2)))
((and (wg-wtree-p w1) (wg-wtree-p w2))
(and (eq (wg-dir w1) (wg-dir w2))
(equal (wg-edges w1) (wg-edges w2))
(every #'wg-equal-wtrees (wg-wlist w1) (wg-wlist w2))))))
;; FIXME: Require a minimum size to fix wscaling
(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-window-p wtree) wtree
(wg-abind wtree (dir 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)))
(flet ((mapwl
(wg-dbind (sw . rest) wl
(cons (wg-normalize-wtree
sw dir ls1 hs1 lb1
(setq lb1 (if (eq sw lastw) hb1
(let ((hb2 (+ lb1 (wg-wsize sw dir))))
(if (>= hb2 max) hb1 hb2))))))
(when (< lb1 max) (mapwl rest))))))
(let ((new (mapwl wlist)))
(if (cdr new) (wg-aput wtree 'wlist new)
(car new)))))))))
(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-wsize wtree wscale hscale)))
(if (wg-window-p wtree) scaled
(wg-aput scaled
'wlist (wg-docar (sw (wg-wlist scaled))
(wg-scale-wtree sw wscale hscale))))))
(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-wtree wconfig)
(/ (float new-width) (wg-aget wconfig 'width))
(/ (float new-height) (wg-aget wconfig 'height)))))
(defun w-set-frame-size-and-scale-wtree (wconfig &optional frame)
"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 (or frame (selected-frame))))
(wg-abind wconfig ((wcwidth width) (wcheight 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-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."
(flet ((inner (w) (if (wg-window-p w) w
(wg-abind w ((d1 dir) edges wlist)
d1 edges
(let ((wl2 (mapcar #'inner wlist)))
(if (or (eq dir 'both)
(and (not dir) (not d1))
(and dir d1))
(nreverse wl2) wl2)))))))
(wg-normalize-wtree (inner w))))
(defun wg-reverse-wconfig (&optional dir wconfig)
"Reverse WCONFIG's wtree's wlist in direction DIR."
(let ((wc (or wconfig (wg-make-wconfig))))
(wg-aput wc 'wtree (wg-reverse-wlist (wg-aget wc 'wtree) dir))))
(defun wg-wtree-move-window (wtree offset)
"Offset `selected-window' OFFSET places in WTREE."
(flet ((inner
(if (wg-window-p w) w
(wg-abind w ((d1 dir) edges wlist)
d1 edges
(wg-aif (wg-get-some (sw wlist) (wg-aget sw 'selwin))
(wg-cyclic-offset-elt it wlist offset)
(mapcar #'inner wlist)))))))
(wg-normalize-wtree (inner wtree))))
(defun wg-wconfig-move-window (offset &optional wconfig)
"Offset `selected-window' OFFSET places in WCONFIG."
(let ((wc (or wconfig (wg-make-wconfig))))
(wg-aput wc 'wtree (wg-wtree-move-window (wg-aget wc 'wtree) offset))))
;;; wconfig making
(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-ewin->window (ewin)
"Return a new workgroups window from EWIN.
EWIN should be an Emacs window object."
(with-current-buffer (window-buffer ewin)
`((type . window)
(edges . ,(window-edges ewin))
(bname . ,(buffer-name))
(fname . ,(buffer-file-name))
(point . ,(wg-window-point ewin))
(mark . ,(mark))
(markx . ,mark-active)
(wstart . ,(window-start ewin))
(hscroll . ,(window-hscroll ewin))
(sbars . ,(window-scroll-bars ewin))
(margins . ,(window-margins ewin))
(fringes . ,(window-fringes ewin))
(selwin . ,(eq ewin (selected-window)))
(mbswin . ,(eq ewin minibuffer-scroll-window))
(dedicated . ,(window-dedicated-p ewin)))))
(defun wg-make-wtree (dir edges wlist)
"Return a new Workgroups wtree from DIR EDGES and WLIST."
`((type . wtree)
(dir . ,dir)
(edges . ,edges)
(wlist . ,wlist)))
(defun wg-ewtree->wtree (&optional ewtree)
"Return a new Workgroups wtree from EWTREE or `window-tree'.
If specified, EWTREE should be an Emacs `window-tree'."
(flet ((inner (ewt) (if (windowp ewt) (wg-ewin->window ewt)
(wg-dbind (dir edges . wins) ewt
dir edges (mapcar #'inner wins))))))
(let ((ewt (car (or ewtree (window-tree)))))
(when (and (windowp ewt) (window-minibuffer-p ewt))
(error "Workgroups can't operate on minibuffer-only frames."))
(inner ewt))))
(defun wg-make-wconfig ()
"Return a new Workgroups window config from `selected-frame'."
(message nil)
`((type . wconfig)
(left . ,(frame-parameter nil 'left))
(top . ,(frame-parameter nil 'top))
(width . ,(frame-parameter nil 'width))
(height . ,(frame-parameter nil 'height))
(sbars . ,(frame-parameter nil 'vertical-scroll-bars))
(sbwid . ,(frame-parameter nil 'scroll-bar-width))
(wtree . ,(wg-ewtree->wtree))))
(defun wg-make-blank-wconfig (&optional buffer)
"Return a new blank wconfig.
BUFFER or `wg-default-buffer' is visible in the only window."
(switch-to-buffer (or buffer wg-default-buffer))
;;; wconfig restoring
(defun wg-switch-to-window-buffer (win)
"Switch to a buffer determined from WIN's fname and bname.
Return the buffer if it was found, nil otherwise."
(wg-abind win (fname bname)
(cond ((and fname (file-exists-p fname))
(find-file fname)
(rename-buffer bname)
((wg-awhen (get-buffer bname) (switch-to-buffer it)))
(t (switch-to-buffer wg-default-buffer) nil))))
(defun wg-restore-window (win)
"Restore WIN in `selected-window'."
(wg-abind win (point mark markx wstart hscroll sbars
fringes margins selwin mbswin dedicated)
(let ((sw (selected-window)))
(when selwin (setq wg-selected-window sw))
(when (wg-switch-to-window-buffer win)
(when (and wg-restore-mbs-window mbswin)
(setq minibuffer-scroll-window sw))
(when wg-restore-scroll-bars
sw (nth 0 sbars) (nth 2 sbars) (nth 3 sbars)))
(when wg-restore-fringes
(apply #'set-window-fringes sw fringes))
(when wg-restore-margins
(set-window-margins sw (car margins) (cdr margins)))
(when wg-restore-dedicated
(set-window-dedicated-p sw dedicated))
(set-window-hscroll sw hscroll)
(set-mark mark)
(unless markx (deactivate-mark))
(let ((pm (point-max)))
(set-window-start sw wstart t)
(goto-char (cond ((not wg-restore-point) wstart)
((eq point :max) pm)
(t point)))
(when (>= wstart pm) (recenter)))))))
(defun wg-restore-wtree (wtree)
"Restore WTREE in `selected-frame'."
(flet ((inner (w) (if (wg-wtree-p w)
(wg-abind w ((d dir) wlist)
(let ((lastw (wg-last1 wlist)))
(dolist (sw wlist)
(unless (eq sw lastw)
(split-window nil (wg-wsize sw d) (not d)))
(inner sw))))
(wg-restore-window w)
(other-window 1))))
(let ((window-min-width wg-window-min-width)
(window-min-height wg-window-min-height))
(set-window-dedicated-p nil nil)
(setq wg-selected-window nil)
(inner wtree)
(wg-awhen wg-selected-window (select-window it)))))
(defun wg-restore-wconfig (wconfig)
"Restore WCONFIG in `selected-frame'."
(let ((frame (selected-frame)) wtree)
(wg-abind wconfig (left top sbars sbwid)
(setq wtree (w-set-frame-size-and-scale-wtree wconfig frame))
(when (and wg-restore-position left top)
(set-frame-position frame left top))
(when (and wg-morph-on after-init-time)
(wg-morph (wg-ewtree->wtree) wtree wg-morph-no-error))
(wg-restore-wtree wtree)
(when wg-restore-scroll-bars
(set-frame-parameter frame 'vertical-scroll-bars sbars)
(set-frame-parameter frame 'scroll-bar-width sbwid)))))
(defun wg-restore-blank-wconfig ()
"Restore a new blank wconfig in `selected-frame'."
(wg-restore-wconfig (wg-make-blank-wconfig)))
;;; morph
(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-edges w1) (wg-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-wlist wt1)) (l1 (length wl1)) (d1 (wg-dir wt1))
(wl2 (wg-wlist wt2)) (l2 (length wl2)))
(cond ((= l1 l2) wl1)
((< l1 l2)
(cons (wg-minify-last-win (wg-rnth (1+ l1) wl2))
(if (< (wg-wsize (car wl1) d1)
(* 2 (wg-actual-min-size d1)))
(cons (wg-w-edge-operation (car wl1) wg-min-edges #'-)
(cdr wl1)))))
((> l1 l2)
(append (wg-take wl1 (1- l2))
(list (wg-make-wtree d1 wg-null-edges
(nthcdr (1- l2) wl1))))))))
(defun wg-morph-win->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-aput (if swap w2 w1) 'edges (wg-morph-step-edges w1 w2)))
(defun wg-morph-win->wtree (win wt)
"Return a new wtree with WIN's edges and WT's last two windows."
(wg-dir wt)
(wg-morph-step-edges win wt)
(let ((wg-morph-hsteps 2) (wg-morph-vsteps 2))
(wg-docar (w (wg-leave (wg-wlist wt) 2))
(wg-morph-win->win (wg-minify-last-win w) w)))))
(defun wg-morph-wtree->win (wt win &optional noswap)
"Grow the first window of WT and its subtrees one step toward WIN.
This eventually wipes WT's components, leaving only a window.
Swap WT's first actual window for WIN, unless NOSWAP is non-nil."
(if (wg-window-p wt) (wg-morph-win->win wt win (not noswap))
(wg-dir wt)
(wg-morph-step-edges wt win)
(wg-dbind (fwin . wins) (wg-wlist wt)
(cons (wg-morph-wtree->win fwin win noswap)
(wg-docar (sw wins)
(if (wg-window-p sw) sw
(wg-morph-wtree->win sw win t))))))))
(defun wg-morph-wtree->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-dir wt1)) (d2 (wg-dir wt2)))
d2 (wg-morph-step-edges wt1 wt2)
(if (not (eq (wg-dir wt1) (wg-dir wt2)))
(list (wg-minify-last-win wt2) wt1)
(mapcar* #'wg-morph-dispatch
(wg-morph-match-wlist wt1 wt2)
(wg-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-window-p w1) (wg-window-p w2))
(wg-morph-win->win w1 w2 t))
((and (wg-wtree-p w1) (wg-wtree-p w2))
(wg-morph-wtree->wtree w1 w2))
((and (wg-window-p w1) (wg-wtree-p w2))
(wg-morph-win->wtree w1 w2))
((and (wg-wtree-p w1) (wg-window-p w2))
(wg-morph-wtree->win w1 w2))))
(defun wg-morph (from to &optional noerror)
"Morph from wtree FROM to wtree TO.
Assumes both FROM and TO fit in `selected-frame'."
(let ((wg-morph-hsteps
(wg-morph-determine-steps wg-morph-hsteps wg-morph-terminal-hsteps))
(wg-morph-determine-steps wg-morph-vsteps wg-morph-terminal-vsteps))
(wg-restore-scroll-bars nil)
(wg-restore-fringes nil)
(wg-restore-margins nil)
(wg-restore-point nil)
(watchdog 0))
(condition-case err
(wg-until (wg-equal-wtrees from to)
(when (> (incf watchdog) wg-morph-max-steps)
(error "`wg-morph-max-steps' exceeded"))
(setq from (wg-normalize-wtree (wg-morph-dispatch from to)))
(wg-restore-wtree from)
(unless (zerop wg-morph-sit-for-seconds)
(sit-for wg-morph-sit-for-seconds t)))
(error (if noerror (message "%S" err) (error "%S" err))))))
;;; global error wrappers
(defun wg-file (&optional noerror)
"Return `wg-file' or error."
(or wg-file
(unless noerror
(error "Workgroups isn't visiting a file"))))
(defun wg-list (&optional noerror)
"Return `wg-list' or error."
(or wg-list
(unless noerror
(error "No workgroups are defined."))))
(defun wg-get-workgroup (key val &optional noerror)
"Return the workgroup whose KEY equals VAL or error."
(or (wg-get-alist key val (wg-list noerror))
(unless noerror
(error "There is no workgroup with an %S of %S" key val))))
;;; frame-table ops
(defmacro wg-with-frame-state (frame state &rest body)
"Bind FRAME and STATE and eval BODY.
FRAME is bound to `selected-frame', and STATE is bound to FRAME's
value in `wg-frame-table'."
(declare (indent 2))
`(let* ((,frame (selected-frame))
(,state (or (gethash ,frame wg-frame-table)
(puthash ,frame (make-hash-table)
(defun wg-frame-val (key)
"Return KEY's value in `selected-frame's state in `wg-frame-table'."
(wg-with-frame-state frame state
(gethash key state)))
(defun wg-set-frame-val (key val)
"Set KEY to VAL in `selected-frame's state in `wg-frame-table'."
(wg-with-frame-state frame state
(puthash key val state)))
(defun wg-delete-frame-key (key)
"Remove KEY from `selected-frame's state in `wg-frame-table'."
(wg-with-frame-state frame state
(remhash key state)))
(defun wg-delete-frame (frame)
"Remove FRAME from `wg-frame-table'."
(remhash frame wg-frame-table))
;;; workgroup property ops
(defun wg-get-workgroup-prop (prop workgroup)
"Return PROP's value in WORKGROUP."
(wg-type-check 'workgroup workgroup)
(wg-aget workgroup prop))
(defun wg-set-workgroup-prop (prop val workgroup &optional nodirty)
"Set PROP to VAL in WORKGROUP, setting `wg-dirty' unless NODIRTY."
(wg-type-check 'workgroup workgroup)
(setcdr (assq prop workgroup) val)
(unless nodirty (setq wg-dirty t)))
(defun wg-uid (workgroup)
"Return WORKGROUP's uid."
(wg-get-workgroup-prop 'uid workgroup))
(defun wg-set-uid (workgroup uid)
"Set the uid of WORKGROUP to UID."
(wg-set-workgroup-prop 'uid uid workgroup))
(defun wg-uids (&optional noerror)
"Return a list of workgroups uids."
(mapcar 'wg-uid (wg-list noerror)))
(defun wg-new-uid ()
"Return a uid greater than any in `wg-list'."
(let ((uids (wg-uids t)) (new -1))
(dolist (uid uids (1+ new))
(setq new (max uid new)))))
(defun wg-name (workgroup)
"Return the name of WORKGROUP."
(wg-get-workgroup-prop 'name workgroup))
(defun wg-set-name (workgroup name)
"Set the name of WORKGROUP to NAME."
(wg-set-workgroup-prop 'name name workgroup))
(defun wg-names (&optional noerror)
"Return a list of workgroup names."
(mapcar 'wg-name (wg-list noerror)))
;;; current and previous workgroup ops
(defun wg-get-frame-workgroup (key &optional noerror)
"Return the workgroup under KEY in `wg-frame-table'."
(or (wg-frame-val key)
(unless noerror
(error "There's no %s in the frame" key))))
(defun wg-current-workgroup (&optional noerror)
"Return the current workgroup."
(wg-get-frame-workgroup 'current-workgroup noerror))
(defun wg-set-current-workgroup (workgroup)
"Set the current workgroup to WORKGROUP."
(wg-set-frame-val 'current-workgroup workgroup))
(defun wg-previous-workgroup (&optional noerror)
"Return the previous workgroup."
(wg-get-frame-workgroup 'previous-workgroup noerror))
(defun wg-set-previous-workgroup (workgroup)
"Set the previous workgroup to WORKGROUP."
(wg-set-frame-val 'previous-workgroup workgroup))
;;; base and working configs
(defun wg-set-base-config (workgroup config)
"Set the base config of WORKGROUP to CONFIG."
(wg-set-workgroup-prop 'wconfig config workgroup))
(defun wg-base-config (workgroup)
"Return the base config of WORKGROUP."
(wg-get-workgroup-prop 'wconfig workgroup))
(defun wg-set-working-config (workgroup config)
"Set the working config of WORKGROUP to CONFIG."
(wg-set-frame-val (wg-uid workgroup) config))
(defun wg-update-working-config (workgroup)
"Set WORKGROUP's working config to the current window config."
(wg-set-working-config workgroup (wg-make-wconfig)))
(defun wg-working-config (workgroup)
"Return the working config of WORKGROUP.
If WORKGROUP is the current workgroup, update it first."
(when (eq workgroup (wg-current-workgroup t))
(wg-update-working-config workgroup))
(or (wg-frame-val (wg-uid workgroup))
(wg-base-config workgroup)))
;;; workgroup making and restoring
(defun wg-make-workgroup (uid name wconfig)
"Return a new workgroup from UID, NAME and WCONFIG."
`((type . workgroup)
(uid . ,uid)
(name . ,name)
(wconfig . ,wconfig)))
(defun wg-make-default-workgroup (name)
"Return a new workgroup named NAME with wconfig `wg-make-wconfig'."
(wg-make-workgroup nil name (wg-make-wconfig)))
(defun wg-make-blank-workgroup (name &optional buffer)
"Return a new blank workgroup named NAME, optionally viewing BUFFER."
(wg-make-workgroup nil name (wg-make-blank-wconfig buffer)))
(defun wg-restore-workgroup (workgroup &optional base)
"Restore WORKGROUP's working config, or base config is BASE is non-nil."
(wg-restore-wconfig (if base (wg-base-config workgroup)
(wg-working-config workgroup))))
;;; workgroups list ops
(defun wg-delete (workgroup)
"Remove WORKGROUP from `wg-list'.
Also delete all references to it in `wg-frame-table'."
(wg-dohash (frame state wg-frame-table)
(with-selected-frame frame
(wg-delete-frame-key (wg-uid workgroup))
(when (eq workgroup (wg-current-workgroup t))
(wg-set-current-workgroup nil))
(when (eq workgroup (wg-previous-workgroup t))
(wg-set-previous-workgroup nil))))
(setq wg-dirty t wg-list (remove workgroup (wg-list))))
(defun wg-add (new &optional pos)
"Add WORKGROUP to `wg-list'.
If a workgroup with the same name exists, overwrite it."
(wg-awhen (wg-get-workgroup 'name (wg-name new) t)
(unless pos (setq pos (position it wg-list)))
(wg-delete it))
(wg-set-uid new (wg-new-uid))
(setq wg-dirty t wg-list (wg-insert-elt new wg-list pos)))
(defun wg-check-and-add (workgroup)
"Add WORKGROUP to `wg-list'.
Query to overwrite if a workgroup with the same name exists."
(let ((name (wg-name workgroup)))
(when (wg-get-workgroup 'name name t)
(unless (or wg-no-confirm
(y-or-n-p (format "%S exists. Overwrite? " name)))
(error "Cancelled"))))
(wg-add workgroup))
(defun wg-cyclic-offset-workgroup (workgroup n)
"Offset WORKGROUP's position in `wg-list' by N."
(wg-aif (wg-cyclic-offset-elt workgroup (wg-list) n)
(setq wg-list it wg-dirty t)
(error "Workgroup isn't present in `wg-list'.")))
(defun wg-list-swap (w1 w2)
"Swap the positions of W1 and W2 in `wg-list'."
(when (eq w1 w2) (error "Can't swap a workgroup with itself"))
(wg-aif (wg-util-swap w1 w2 (wg-list))
(setq wg-list it wg-dirty t)
(error "Both workgroups aren't present in `wg-list'.")))
;;; buffer list ops
(defun wg-wtree-buffer-list (wtree)
"Return a list of unique buffer names visible in WTREE."
(flet ((rec (w) (if (wg-window-p w) (list (wg-aget w 'bname))
(mapcan #'rec (wg-wlist w)))))
(remove-duplicates (rec wtree) :test #'equal)))
(defun wg-workgroup-buffer-list (workgroup)
"Call `wg-wconfig-buffer-list' on WORKGROUP's working config."
(wg-wtree-buffer-list (wg-wtree (wg-working-config workgroup))))
(defun wg-buffer-list ()
"Call `wg-workgroup-buffer-list' on all workgroups in `wg-list'."
(mapcan #'wg-workgroup-buffer-list (wg-list t))
:test #'equal))
(defun wg-find-buffer (bname)
"Return the first workgroup in which a buffer named BNAME is visible."
(wg-get-some (wg (wg-list))
(member bname (wg-workgroup-buffer-list wg))))
;;; mode-line
(defun wg-mode-line-string ()
"Return the string to be displayed in the mode-line."
(let ((cur (wg-current-workgroup t)))
(cond (cur (wg-fontify " "
(:div wg-mode-line-left-brace)
(:mode (position cur (wg-list t)))
(:div wg-mode-line-divider)
(:mode (wg-name cur))
(:div wg-mode-line-right-brace)))
(t (wg-fontify " "
(:div wg-mode-line-left-brace)
(:mode "No workgroups")
(:div wg-mode-line-right-brace))))))
(defun wg-mode-line-add-display ()
"Add Workgroups' mode-line format to `mode-line-format'."
(unless (assq 'wg-mode-line-on mode-line-format)
(let ((format `(wg-mode-line-on (:eval (wg-mode-line-string))))
(pos (1+ (position 'mode-line-position mode-line-format))))
(set-default 'mode-line-format
(wg-insert-elt format mode-line-format pos)))))
(defun wg-mode-line-remove-display ()
"Remove Workgroups' mode-line format from `mode-line-format'."
(wg-awhen (assq 'wg-mode-line-on mode-line-format)
(set-default 'mode-line-format (remove it mode-line-format))
;;; minibuffer reading
(defun wg-completing-read (prompt choices &rest args)
"Call `completing-read' or `ido-completing-read'."
(apply (if (and (boundp 'ido-mode) ido-mode)
#'completing-read) prompt choices args))
(defun wg-read-workgroup (&optional noerror)
"Read a workgroup with `wg-completing-read'."
'name (wg-completing-read "Workgroup: " (wg-names))
(defun wg-read-buffer-name ()
"Read and return a buffer-name from `wg-buffer-list'."
(wg-completing-read "Workgroup buffers: " (wg-buffer-list)))
(defun wg-read-new-workgroup-name (&optional prompt)
"Read a non-empty name string from the minibuffer."
(or prompt "Name: ")
(lambda (obj) (and (stringp obj) (not (equal obj ""))))
"Please enter a unique, non-empty name"))
(defun wg-read-workgroup-index ()
"Prompt for the index of a workgroup."
(let ((max (1- (length (wg-list)))))
(format "%s\n\nEnter [0-%d]: " (wg-disp) max)
(lambda (obj) (and (integerp obj) (wg-within obj 0 max t)))
(format "Please enter an integer [%d-%d]" 0 max)
nil nil t)))
;;; messaging
(defun wg-msg (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-msg (&rest format)
"`wg-fontify' FORMAT and call `wg-msg' on it."
(declare (indent defun))
`(wg-msg (wg-fontify ,@format)))
;;; command utils
(defun wg-arg (&optional reverse noerror)
"Return a workgroup one way or another.
For use in interactive forms. If `current-prefix-arg' is nil,
return the current workgroup. Otherwise read a workgroup from
the minibuffer. If REVERSE is non-nil, `current-prefix-arg's
begavior is reversed."
(wg-list noerror)
(if (if reverse (not current-prefix-arg) current-prefix-arg)
(wg-read-workgroup noerror)
(wg-current-workgroup noerror)))
(defun wg-add-to-kill-ring (config)
"Add CONFIG to `wg-kill-ring'."
(push config wg-kill-ring)
(setq wg-kill-ring (wg-take wg-kill-ring wg-kill-ring-size)))
(defun wg-disp ()
"Return the Workgroups list display string.
The string contains the names of all workgroups in `wg-list',
decorated with faces, dividers and strings identifying the
current and previous workgroups."
(let ((wl (wg-list t))
(cur (wg-current-workgroup t))
(prev (wg-previous-workgroup t))
(div (wg-add-face :div wg-display-divider))
(cld wg-display-current-workgroup-left-decor)
(crd wg-display-current-workgroup-right-decor)
(pld wg-display-previous-workgroup-left-decor)
(prd wg-display-previous-workgroup-right-decor)
(i -1))
(:brace wg-display-left-brace)
(if (not wl) (wg-fontify (:msg "No workgroups are defined"))
(wg-doconcat (w wl div)
(let ((str (format "%d: %s" (incf i) (wg-name w))))
(cond ((eq w cur)
(wg-fontify (:cur (concat cld str crd))))
((eq w prev)
(wg-fontify (:prev (concat pld str prd))))
(t (wg-fontify (:other str)))))))
(:brace wg-display-right-brace))))
(defun wg-cyclic-nth-from-workgroup (&optional workgroup n)
"Return the workgroup N places from WORKGROUP in `wg-list'."
(wg-when-let ((wg (or workgroup (wg-current-workgroup t))))
(wg-cyclic-nth-from-elt wg (wg-list) (or n 1))))
;;; commands
(defun wg-switch-to-workgroup (workgroup &optional base)
"Switch to WORKGROUP.
BASE nil means restore WORKGROUP's working config.
BASE non-nil means restore WORKGROUP's base config."
(interactive (list (wg-read-workgroup) current-prefix-arg))
(wg-awhen (wg-current-workgroup t)
(when (eq it workgroup) (error "Already on: %s" (wg-name it)))
(wg-update-working-config it))
(wg-restore-workgroup workgroup base)
(wg-set-previous-workgroup (wg-current-workgroup t))
(wg-set-current-workgroup workgroup)
(run-hooks 'wg-switch-hook)
(wg-fontified-msg (:cmd "Switched: ") (wg-disp)))
(defun wg-create-workgroup (name)
"Create and add a workgroup named NAME.
If workgroups already exist, create a blank workgroup. If no
workgroups exist yet, create a workgroup from the current window
(interactive (list (wg-read-new-workgroup-name)))
(let ((w (if (wg-current-workgroup t) (wg-make-blank-workgroup name)
(wg-make-default-workgroup name))))
(wg-check-and-add w)
(wg-switch-to-workgroup w)
(wg-fontified-msg (:cmd "Created: ") (:cur name) " " (wg-disp))))
(defun wg-clone-workgroup (workgroup name)
"Create and add a clone of WORKGROUP named NAME."
(interactive (list (wg-arg) (wg-read-new-workgroup-name)))
(let ((new (wg-make-workgroup nil name (wg-base-config workgroup))))
(wg-check-and-add new)
(wg-set-working-config new (wg-working-config workgroup))
(wg-switch-to-workgroup new)
(:cmd "Cloned: ") (:cur (wg-name workgroup))
(:msg " to ") (:cur name) " " (wg-disp))))
(defun wg-kill-workgroup (workgroup)
"Kill WORKGROUP, saving its working config to the kill ring."
(interactive (list (wg-arg)))
(wg-add-to-kill-ring (wg-working-config workgroup))
(let ((to (or (wg-previous-workgroup t)
(wg-cyclic-nth-from-workgroup workgroup))))
(wg-delete workgroup)
(if (eq to workgroup) (wg-restore-blank-wconfig)
(wg-switch-to-workgroup to))
(:cmd "Killed: ") (:cur (wg-name workgroup)) " " (wg-disp))))
(defun wg-kill-ring-save-base-config (workgroup)
"Save WORKGROUP's base config to `wg-kill-ring'."
(interactive (list (wg-arg)))
(wg-add-to-kill-ring (wg-base-config workgroup))
(:cmd "Saved: ") (:cur (wg-name workgroup))
(:cur "'s ") (:msg "base config to the kill ring")))
(defun wg-kill-ring-save-working-config (workgroup)
"Save WORKGROUP's working config to `wg-kill-ring'."
(interactive (list (wg-arg)))
(wg-add-to-kill-ring (wg-working-config workgroup))
(:cmd "Saved: ") (:cur (wg-name workgroup))
(:cur "'s ") (:msg "working config to the kill ring")))
(defun wg-yank-config ()
"Restore a wconfig from `wg-kill-ring'.
Successive yanks restore wconfigs sequentially from the kill
ring, starting at the front."
(unless wg-kill-ring (error "The kill-ring is empty"))
(let ((pos (if (not (eq real-last-command 'wg-yank-config)) 0
(mod (1+ (or (get 'wg-yank-config :position) 0))
(length wg-kill-ring)))))
(put 'wg-yank-config :position pos)
(wg-restore-wconfig (nth pos wg-kill-ring))
(wg-fontified-msg (:cmd "Yanked: ") (:msg pos) " " (wg-disp))))
(defun wg-kill-workgroup-and-buffers (workgroup)
"Kill WORKGROUP and the buffers in its working config."
(interactive (list (wg-arg)))
(let ((bufs (save-window-excursion
(wg-restore-workgroup workgroup)
(mapcar #'window-buffer (window-list)))))
(wg-kill-workgroup workgroup)
(mapc #'kill-buffer bufs)
(:cmd "Killed: ") (:cur (wg-name workgroup))
(:msg " and its buffers ") "\n" (wg-disp))))
(defun wg-delete-other-workgroups (workgroup)
"Delete all workgroups but WORKGROUP."
(interactive (list (wg-arg)))
(unless (or wg-no-confirm (y-or-n-p "Really delete all other workgroups? "))
(error "Cancelled"))
(let ((cur (wg-current-workgroup)))
(mapc #'wg-delete (remove workgroup (wg-list)))
(unless (eq workgroup cur) (wg-switch-to-workgroup workgroup))
(:cmd "Deleted: ") (:msg "All workgroups but ")
(:cur (wg-name workgroup)))))
(defun wg-update-workgroup (workgroup)
"Set the base config of WORKGROUP to its working config in `selected-frame'."
(interactive (list (wg-arg)))
(wg-set-base-config workgroup (wg-working-config workgroup))
(:cmd "Updated: ") (:cur (wg-name workgroup))))
(defun wg-update-all-workgroups ()
"Update all workgroups' base configs.
Worgroups are updated with their working configs in the
(mapc #'wg-update-workgroup (wg-list))
(wg-fontified-msg (:cmd "Updated: ") (:msg "All")))
(defun wg-revert-workgroup (workgroup)
"Set the working config of WORKGROUP to its base config in `selected-frame'."
(interactive (list (wg-arg)))
workgroup (wg-base-config workgroup))
(when (eq workgroup (wg-current-workgroup))
(wg-restore-workgroup workgroup t))
(wg-fontified-msg (:cmd "Reverted: ") (:cur (wg-name workgroup))))
(defun wg-revert-all-workgroups ()
"Revert all workgroups to their base configs."
(mapc #'wg-revert-workgroup (wg-list))
(wg-fontified-msg (:cmd "Reverted: ") (:msg "All")))
(defun wg-switch-to-index (n)
"Switch to Nth workgroup in `wg-list'."
(interactive (list (or current-prefix-arg (wg-read-workgroup-index))))
(let ((wl (wg-list)))
(or (nth n wl) (error "There are only %d workgroups" (length wl))))))
;; Define wg-switch-to-index-[0-9]:
((defi (n)
`(defun ,(intern (format "wg-switch-to-index-%d" n)) ()
,(format "Switch to the workgroup at index %d in the list." n)
(interactive) (wg-switch-to-index ,n))))
(defi 0) (defi 1) (defi 2) (defi 3) (defi 4)
(defi 5) (defi 6) (defi 7) (defi 8) (defi 9))
(defun wg-switch-left (&optional workgroup n)
"Switch to the workgroup left of WORKGROUP in `wg-list'."
(interactive (list (wg-arg nil t) current-prefix-arg))
(or (wg-cyclic-nth-from-workgroup workgroup (or n -1))
(car (wg-list)))))
(defun wg-switch-right (&optional workgroup n)
"Switch to the workgroup right of WORKGROUP in `wg-list'."
(interactive (list (wg-arg nil t) current-prefix-arg))
(or (wg-cyclic-nth-from-workgroup workgroup n)
(car (wg-list)))))
(defun wg-switch-left-other-frame (&optional n)
"Like `wg-switch-left', but operates on the next frame."
(interactive "p")
(with-selected-frame (wg-cyclic-nth-from-frame (or n 1))
(defun wg-switch-right-other-frame (&optional n)
"Like `wg-switch-right', but operates on the next frame."
(interactive "p")
(with-selected-frame (wg-cyclic-nth-from-frame (or n -1))
(defun wg-switch-to-previous-workgroup ()
"Switch to the previous workgroup."
(wg-switch-to-workgroup (wg-previous-workgroup)))
(defun wg-swap-workgroups ()
"Swap the previous and current workgroups."
(wg-list-swap (wg-current-workgroup) (wg-previous-workgroup))
(wg-fontified-msg (:cmd "Swapped ") (wg-disp)))
(defun wg-offset-left (workgroup &optional n)
"Offset WORKGROUP leftward in `wg-list' cyclically."
(interactive (list (wg-arg) current-prefix-arg))
(wg-cyclic-offset-workgroup workgroup (or n -1))
(wg-fontified-msg (:cmd "Offset left: ") (wg-disp)))
(defun wg-offset-right (workgroup &optional n)
"Offset WORKGROUP rightward in `wg-list' cyclically."
(interactive (list (wg-arg) current-prefix-arg))
(wg-cyclic-offset-workgroup workgroup (or n 1))
(wg-fontified-msg (:cmd "Offset right: ") (wg-disp)))
(defun wg-rename-workgroup (workgroup newname)
(interactive (list (wg-arg) (wg-read-new-workgroup-name "New name: ")))
(let ((oldname (wg-name workgroup)))
(wg-set-name workgroup newname)
(:cmd "Renamed: ") (:cur oldname) (:msg " to ")
(:cur (wg-name workgroup)))))
(defun wg-reset (&optional force)
"Reset workgroups.
Deletes saved state in `wg-frame-table' and nulls out `wg-list',
`wg-file' and `wg-kill-ring'."
(interactive "P")
(unless (or force wg-no-confirm (y-or-n-p "Are you sure? "))
(error "Canceled"))
(clrhash wg-frame-table)
(setq wg-list nil wg-file nil wg-dirty nil)
(wg-fontified-msg (:cmd "Reset: ") (:msg "Workgroups")))
;;; file commands
(defun wg-save (file)
"Save workgroups to FILE.
Called interactively with a prefix arg, or if `wg-file'
is nil, read a filename. Otherwise use `wg-file'."
(list (if (or current-prefix-arg (not (wg-file t)))
(read-file-name "File: ") (wg-file))))
(cons wg-persisted-workgroups-tag (wg-list)) file)
(setq wg-dirty nil wg-file file)
(wg-fontified-msg (:cmd "Wrote: ") (:file file)))
(defun wg-load (file)
"Load workgroups from FILE.
Called interactively with a prefix arg, and if `wg-file'
is non-nil, use `wg-file'. Otherwise read a filename."
(list (if (and current-prefix-arg (wg-file t))
(wg-file) (read-file-name "File: "))))
(wg-dbind (tag . workgroups) (wg-read-sexp-from-file file)
(unless (or (eq tag wg-persisted-workgroups-tag)
;; Added for compatibility with old save files. This tag had to
;; be changed because it's formatted like a file-local variable,
;; causing workgroups-mode to toggle on or off when a file of
;; saved workgroups is visited (even though the symbol
;; `workgroups' denotes nothing in Workgroups except its
;; customization group -- yow!
(eq tag '-*-workgroups-*-))
(error "%S is not a workgroups file." file))
(wg-reset t)
(setq wg-list workgroups wg-file file))
(when wg-switch-on-load
(wg-awhen (wg-list t)
(wg-switch-to-workgroup (car it))))
(wg-fontified-msg (:cmd "Loaded: ") (:file file)))
(defun wg-find-file (file)
"Create a new workgroup and find file FILE in it."
(interactive "FFile: ")
(wg-create-workgroup (file-name-nondirectory file))
(find-file file))
(defun wg-find-file-read-only (file)
"Create a new workgroup and find FILE read-only in it."
(interactive "FFile: ")
(wg-create-workgroup (file-name-nondirectory file))
(find-file-read-only file))
(defun wg-get-by-buffer (buf)
"Switch to the first workgroup in which BUF is visible."
(interactive (list (wg-read-buffer-name)))
(wg-aif (wg-find-buffer buf) (wg-switch-to-workgroup it)
(error "No workgroup contains %S" buf)))
(defun wg-dired (dir &optional switches)
"Create a workgroup and open DIR in dired with SWITCHES."
(interactive (list (read-directory-name "Dired: ") current-prefix-arg))
(wg-create-workgroup dir)
(dired dir switches))
(defun wg-update-all-workgroups-and-save ()
"Call `wg-update-all-workgroups', the `wg-save'.
Keep in mind that workgroups will be updated with their
working-config in the current frame."
(call-interactively 'wg-save))
;;; mode-line commands
(defun wg-toggle-mode-line ()
"Toggle Workgroups' mode-line display."
(setq wg-mode-line-on (not wg-mode-line-on))
(:cmd "mode-line: ") (:msg (if wg-mode-line-on "on" "off"))))
;;; morph commands
(defun wg-toggle-morph ()
"Toggle `wg-morph', Workgroups' morphing animation."
(setq wg-morph-on (not wg-morph-on))
(:cmd "Morph: ") (:msg (if wg-morph-on "on" "off"))))
;;; Window movement commands
(defun wg-move-window-backward (offset)
"Move `selected-window' backward by OFFSET in its wlist."
(interactive (list (or current-prefix-arg -1)))
(wg-restore-wconfig (wg-wconfig-move-window offset)))
(defun wg-move-window-forward (offset)
"Move `selected-window' forward by OFFSET in its wlist."
(interactive (list (or current-prefix-arg 1)))
(wg-restore-wconfig (wg-wconfig-move-window offset)))
(defun wg-reverse-frame-horizontally ()
"Reverse the order of all horizontally split wtrees."
(wg-restore-wconfig (wg-reverse-wconfig)))
(defun wg-reverse-frame-vertically ()
"Reverse the order of all vertically split wtrees."
(wg-restore-wconfig (wg-reverse-wconfig t)))
(defun wg-reverse-frame-horizontally-and-vertically ()
"Reverse the order of all wtrees."
(wg-restore-wconfig (wg-reverse-wconfig 'both)))
;;; echo commands
(defun wg-echo-current-workgroup ()
"Display the name of the current workgroup in the echo area."
(:cmd "Current: ") (:cur (wg-name (wg-current-workgroup)))))
(defun wg-echo-all-workgroups ()
"Display the names of all workgroups in the echo area."
(wg-fontified-msg (:cmd "Workgroups: ") (wg-disp)))
(defun wg-echo-time ()
"Echo the current time. Optionally includes `battery' info."
(wg-msg ;; 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."
(: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."
(message "%s" wg-last-message))
;;; help
(defvar wg-help
"Switch to a workgroup"
"Create a new workgroup and switch to it"
"Create a clone of the current workgroug and switch to it"
"Kill a workgroup"
"Save the current workgroup's base config to the kill ring"
"Save the current workgroup's working config to the kill ring"
"Yank a config from the kill ring into the current frame"
"Kill a workgroup and all buffers visible in it"
"Delete all but the specified workgroup"
"Update a workgroup's base config with its working config"
"Update all workgroups' base configs with their working configs"
"Revert a workgroup's working config to its base config"
"Revert all workgroups' working configs to their base configs"
"Jump to a workgroup by its index in the workgroups list"
"Switch to the workgroup at index 0"
"Switch to the workgroup at index 1"
"Switch to the workgroup at index 2"
"Switch to the workgroup at index 3"
"Switch to the workgroup at index 4"
"Switch to the workgroup at index 5"
"Switch to the workgroup at index 6"
"Switch to the workgroup at index 7"
"Switch to the workgroup at index 8"
"Switch to the workgroup at index 9"
"Switch to the workgroup leftward cyclically in the workgroups list"
"Switch to the workgroup rightward cyclically in the workgroups list"
"Like `wg-switch-left', but operates in the next frame"
"Like `wg-switch-right', but operates in the next frame"
"Switch to the previously selected workgroup"
"Swap the positions of the current and previous workgroups"
"Offset a workgroup's position leftward cyclically in the workgroups list"
"Offset a workgroup's position rightward cyclically in the workgroups list"
"Rename a workgroup"
"Reset Workgroups' entire state."
"Save the workgroup list to a file"
"Load a workgroups list from a file"
"Create a new blank workgroup and find a file in it"
"Create a new blank workgroup and find a file read-only in it"
"Switch to the workgroup and config in which the specified buffer is visible"
"Create a new blank workgroup and open a dired buffer in it"
"Move `selected-window' backward in its wlist"
"Move `selected-window' forward in its wlist"
"Reverse the order of all horizontall window lists."
"Reverse the order of all vertical window lists."
"Reverse the order of all window lists."
"Toggle Workgroups' mode-line display"
"Toggle the morph animation on any wconfig change"
"Display the name of the current workgroup in the echo area"
"Display the names of all workgroups in the echo area"
"Display the current time in the echo area"
"Display the current version of Workgroups in the echo area"
"Display the last message Workgroups sent to the echo area in the echo area."
"Show this help message")
"List of commands and their help messages. Used by `wg-help'.")
(defun wg-help ()
"Display Workgroups' help buffer."
(with-output-to-temp-buffer "*workroups help*"
(princ "Workgroups' keybindings:\n\n")
(dolist (elt (wg-partition wg-help 2))
(wg-dbind (cmd help-string) elt
(princ (format "%15s %s\n"
(substitute-command-keys cmd)
;;; keymap
(defvar wg-map
(wg-fill-keymap (make-sparse-keymap)
;; workgroup creation
"C-c" 'wg-create-workgroup
"c" 'wg-create-workgroup
"C" 'wg-clone-workgroup
;; killing and yanking
"C-k" 'wg-kill-workgroup
"k" 'wg-kill-workgroup
"M-W" 'wg-kill-ring-save-base-config
"M-w" 'wg-kill-ring-save-working-config
"C-y" 'wg-yank-config
"y" 'wg-yank-config
"M-k" 'wg-kill-workgroup-and-buffers
"K" 'wg-delete-other-workgroups
;; updating and reverting
"C-u" 'wg-update-workgroup
"u" 'wg-update-workgroup
"C-S-u" 'wg-update-all-workgroups
"U" 'wg-update-all-workgroups
"C-r" 'wg-revert-workgroup
"r" 'wg-revert-workgroup
"C-S-r" 'wg-revert-all-workgroups
"R" 'wg-revert-all-workgroups
;; workgroup switching
"C-'" 'wg-switch-to-workgroup
"'" 'wg-switch-to-workgroup
"C-v" 'wg-switch-to-workgroup
"v" 'wg-switch-to-workgroup
"C-j" 'wg-switch-to-index
"j" 'wg-switch-to-index
"0" 'wg-switch-to-index-0
"1" 'wg-switch-to-index-1
"2" 'wg-switch-to-index-2
"3" 'wg-switch-to-index-3
"4" 'wg-switch-to-index-4
"5" 'wg-switch-to-index-5
"6" 'wg-switch-to-index-6
"7" 'wg-switch-to-index-7
"8" 'wg-switch-to-index-8
"9" 'wg-switch-to-index-9
"C-p" 'wg-switch-left
"p" 'wg-switch-left
"C-n" 'wg-switch-right
"n" 'wg-switch-right
"M-p" 'wg-switch-left-other-frame
"M-n" 'wg-switch-right-other-frame
"C-a" 'wg-switch-to-previous-workgroup
"a" 'wg-switch-to-previous-workgroup
;; workgroup movement
"C-x" 'wg-swap-workgroups
"C-," 'wg-offset-left
"C-." 'wg-offset-right
;; file and buffer
"C-s" 'wg-save
"C-l" 'wg-load
"S" 'wg-update-all-workgroups-and-save
"C-f" 'wg-find-file
"S-C-f" 'wg-find-file-read-only
"C-b" 'wg-get-by-buffer
"b" 'wg-get-by-buffer
"d" 'wg-dired
;; window moving and frame reversal
"<" 'wg-move-window-backward
">" 'wg-move-window-forward
"|" 'wg-reverse-frame-horizontally
"-" 'wg-reverse-frame-vertically
"+" 'wg-reverse-frame-horizontally-and-vertically
;; toggling
"C-i" 'wg-toggle-mode-line
"C-w" 'wg-toggle-morph
;; echoing
"S-C-e" 'wg-echo-current-workgroup
"E" 'wg-echo-current-workgroup
"C-e" 'wg-echo-all-workgroups
"e" 'wg-echo-all-workgroups
"C-t" 'wg-echo-time
"t" 'wg-echo-time
"V" 'wg-echo-version
"C-m" 'wg-echo-last-message
"m" 'wg-echo-last-message
;; misc
"A" 'wg-rename-workgroup
"!" 'wg-reset
"?" 'wg-help
"Workgroups' keymap.")
;;; mode definition
(defun wg-unset-prefix-key ()
"Restore the original definition of `wg-prefix-key'."
(wg-awhen (get 'wg-prefix-key :original)
(wg-dbind (key . def) it
(when (eq wg-map (lookup-key global-map key))
(global-set-key key def))
(put 'wg-prefix-key :original nil))))
(defun wg-set-prefix-key ()
"Define `wg-prefix-key' as `wg-map' in `global-map'."
(let ((key wg-prefix-key))
(put 'wg-prefix-key :original (cons key (lookup-key global-map key)))
(global-set-key key wg-map)))
(defun wg-query-for-save ()
"Query for save when `wg-dirty' is non-nil."
(or (not wg-dirty)
(not (y-or-n-p "Save modified workgroups? "))
(call-interactively 'wg-save)
(defun wg-emacs-exit-query ()
"Conditionally call `wg-query-for-save'.
Call `wg-query-for-save' when `wg-query-for-save-on-emacs-exit'
is non-nil."
(or (not wg-query-for-save-on-emacs-exit)
(defun wg-workgroups-mode-exit-query ()
"Conditionally call `wg-query-for-save'.
Call `wg-query-for-save' when
`wg-query-for-save-on-workgroups-mode-exit' is non-nil."
(or (not wg-query-for-save-on-workgroups-mode-exit)
(define-minor-mode workgroups-mode
"This 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'."
:lighter " wg"
:init-value nil
:global t
:group 'workgroups
(cond (workgroups-mode
(add-hook 'kill-emacs-query-functions 'wg-emacs-exit-query)
(add-hook 'delete-frame-functions 'wg-delete-frame)
(remove-hook 'kill-emacs-query-functions 'wg-emacs-exit-query)
(remove-hook 'delete-frame-functions 'wg-delete-frame)
;;; provide
(provide 'workgroups)
;;; workgroups.el ends here