mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-18 9d27fc972e84736015ab3b1c331888a8fe3d1276
commit | author | age
5cb5f7 1 ;;; workgroups2.el --- New workspaces for Emacs
C 2 ;;; -*- coding: utf-8; lexical-binding: t -*-
3 ;;
4 ;; Copyright (C) 2013-2014 Sergey Pashinin
5 ;; Copyright (C) 2010-2011 tlh
6 ;;
7 ;; Author: Sergey Pashinin <sergey at pashinin dot com>
8 ;; Keywords: session management window-configuration persistence
9 ;; Package-Version: 20141102.1922
10 ;; Homepage: https://github.com/pashinin/workgroups2
11 ;; Version: 1.2.0
12 ;; Package-Requires: ((cl-lib "0.4") (dash "2.8.0") (anaphora "1.0.0") (f "0.17"))
13 ;;
14 ;; This program is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 2 of the License, or (at
17 ;; your option) any later version.
18 ;;
19 ;; This program is distributed in the hope that it will be useful, but
20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
22 ;; General Public License for more details.
23 ;;
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with this program; if not, write to the Free Software
26 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
27 ;; USA
28 ;;
29 ;;; Commentary:
30 ;;
31 ;; Workgroups2 is an Emacs session manager. It is based on the
32 ;; experimental branch of the original "workgroups" extension.
33 ;;
34 ;; If you find a bug - please post it here:
35 ;; https://github.com/pashinin/workgroups2/issues
36 ;;
37 ;;
38 ;; Install
39 ;; ----------------------
40 ;; See the README.md file at: https://github.com/pashinin/workgroups2
41 ;; Add the lines below to your .emacs configuration.
42 ;;
43 ;; (require 'workgroups2)
44 ;;
45 ;; <settings here>
46 ;;
47 ;; (workgroups-mode 1)  ; put this one at the bottom of .emacs
48 ;;
49 ;;
50 ;; Configure
51 ;; ----------------------
52 ;; ;; Change prefix key (before activating WG)
53 ;; (setq wg-prefix-key (kbd "C-c z"))
54 ;;
55 ;; ;; Change workgroups session file
56 ;; (setq wg-session-file "~/.emacs.d/.emacs_workgroups"
57 ;;
58 ;; ;; Set your own keyboard shortcuts to reload/save/switch WG:
59 ;; (global-set-key (kbd "<pause>")     'wg-reload-session)
60 ;; (global-set-key (kbd "C-S-<pause>") 'wg-save-session)
61 ;; (global-set-key (kbd "s-z")         'wg-switch-to-workgroup)
62 ;; (global-set-key (kbd "s-/")         'wg-switch-to-previous-workgroup)
63 ;;
64 ;;
65 ;; Use
66 ;; ----------------------
67 ;; Most commands start with prefix `wg-prefix-key'.
68 ;; You can change it before activating workgroups.
69 ;; By default prefix is: "C-c z"
70 ;;
71 ;; <prefix> <key>
72 ;;
73 ;; <prefix> c    - create workgroup
74 ;; <prefix> A    - rename workgroup
75 ;; <prefix> k    - kill workgroup
76 ;; <prefix> v    - switch to workgroup
77 ;; <prefix> C-s  - save session
78 ;; <prefix> C-f  - load session
79 ;;
80 ;;
81 ;; Help
82 ;; ----------------------
83 ;; Type "<prefix> ?" for more help
84 ;;
85 ;; See also: https://github.com/pashinin/workgroups2/wiki
86 ;;
87 ;;; Code:
88
89 (require 'cl-lib)
90 (require 'f)
91 (require 'dash)
92 (require 'ring)
93 (require 'anaphora)
94
95
96 (defconst wg-version "1.2.0" "Current version of Workgroups.")
97
98 (defgroup workgroups nil
99   "Workgroups for Emacs -- Emacs session manager"
100   :group 'convenience)
101
102 (defcustom wg-session-file "~/.emacs_workgroups"
103   "Default filename to be used to save workgroups."
104   :type 'file
105   :group 'workgroups)
106 (defvaralias 'wg-default-session-file 'wg-session-file)
107
108 (defcustom wg-prefix-key (kbd "C-c z")
109   "Workgroups' prefix key.
110 Setting this variable requires that `workgroups-mode' be turned
111 off and then on again to take effect."
112   :type 'string
113   :group 'workgroups)
114
115 (defvar workgroups-mode-map nil "Workgroups Mode's keymap.")
116
117 (defvar wg-incorrectly-restored-bufs nil
118   "FIXME: docstring this.")
119 ;; TODO: check it on switching WG
120
121 (defvar wg-record-incorrectly-restored-bufs nil
122   "FIXME: docstring this.")
123
124 (defvar wg-log-level 1
125   "Use later.
126 0 means no messages at all (for tests)")
127
128 (defcustom wg-emacs-exit-save-behavior 'save
129   "Determines save behavior on Emacs exit.
130
131 `ask'           Ask the user whether to save if there are unsaved changes
132 `save'          Call `wg-save-session' when there are unsaved changes
133 Anything else   Exit Emacs without saving changes"
134   :type 'symbol
135   :group 'workgroups)
136
137 (defcustom wg-workgroups-mode-exit-save-behavior 'save
138   "Determines save behavior on `workgroups-mode' exit.
139
140 `ask'           Ask the user whether to saveif there are unsaved changes
141 `save'          Call `wg-save-session' when there are unsaved changes
142 Anything else   Exit `workgroups-mode' without saving changes"
143   :type 'symbol
144   :group 'workgroups)
145
146 (defcustom wg-session-load-on-start (not (daemonp))
147   "Load a session file on Workgroups start.
148 Don't do it with Emacs --daemon option."
149   :type 'boolean
150   :group 'workgroups)
151 (defvaralias 'wg-use-default-session-file 'wg-session-load-on-start)
152
153 (defcustom workgroups-mode nil
154   "Non-nil if Workgroups mode is enabled."
155   :set 'custom-set-minor-mode
156   :initialize 'custom-initialize-default
157   :group 'workgroups
158   :type 'boolean)
159
160 (defcustom wg-first-wg-name "First workgroup"
161   "Title of the first workgroup created."
162   :type 'string
163   :group 'workgroups)
164
165 (defcustom wg-modeline-string " wg"
166   "Appears in modeline."
167   :type 'string
168   :group 'workgroups)
169
170 (defcustom wg-mode-line-display-on (not (featurep 'powerline))
171   "Toggles Workgroups' mode-line display."
172   :type 'boolean
173   :group 'workgroups
174   :set (lambda (sym val)
175          (custom-set-default sym val)
176          (force-mode-line-update)))
177
178 (defcustom wg-mode-line-use-faces nil
179   "Non-nil means use faces in the mode-line display.
180 It can be tricky to choose faces that are visible in both active
181 and inactive mode-lines, so this feature defaults to off."
182   :type 'boolean
183   :group 'workgroups)
184
185 (defcustom wg-mode-line-decor-left-brace "("
186   "String displayed at the left of the mode-line display."
187   :type 'string
188   :group 'workgroups)
189
190 (defcustom wg-mode-line-decor-right-brace ")"
191   "String displayed at the right of the mode-line display."
192   :type 'string
193   :group 'workgroups)
194
195 (defcustom wg-mode-line-decor-divider ":"
196   "String displayed between elements of the mode-line display."
197   :type 'string
198   :group 'workgroups)
199
200 (defcustom wg-mode-line-decor-window-dedicated
201   #("#" 0 1 (help-echo "This window is dedicated to its buffer."))
202   "Indicates that the window is dedicated to its buffer."
203   :type 'string
204   :group 'workgroups)
205
206 (defcustom wg-mode-line-decor-window-undedicated
207   #("-" 0 1 (help-echo "This window is not dedicated to its buffer."))
208   "Indicates that the window is not dedicated to its buffer."
209   :type 'string
210   :group 'workgroups)
211
212 (defcustom wg-mode-line-decor-session-modified
213   #("*" 0 1 (help-echo "The session is modified"))
214   "Indicates that the session is modified."
215   :type 'string
216   :group 'workgroups)
217
218 (defcustom wg-mode-line-decor-session-unmodified
219   #("-" 0 1 (help-echo "The session is unmodified"))
220   "Indicates that the session is unmodified."
221   :type 'string
222   :group 'workgroups)
223
224 (defcustom wg-mode-line-decor-workgroup-modified
225   #("*" 0 1 (help-echo "The current workgroup is modified"))
226   "Indicates that the current workgroup is modified."
227   :type 'string
228   :group 'workgroups)
229
230 (defcustom wg-mode-line-decor-workgroup-unmodified
231   #("-" 0 1 (help-echo "The current workgroup is unmodified"))
232   "Indicates that the current workgroup is unmodified."
233   :type 'string
234   :group 'workgroups)
235
236 (defcustom wg-load-last-workgroup t
237   "Load last active (not first) workgroup from all your workgroups if it exists."
238   :group 'workgroups
239   :type 'boolean)
240
241 (defcustom wg-control-frames t
242   "Save/restore frames."
243   :group 'workgroups
244   :type 'boolean)
245
246 (defcustom workgroups-mode-hook nil
247   "Hook run when `workgroups-mode' is turned on."
248   :type 'hook
249   :group 'workgroups)
250
251 (defcustom workgroups-mode-exit-hook nil
252   "Hook run when `workgroups-mode' is turned off."
253   :type 'hook
254   :group 'workgroups)
255
256 (defcustom wg-before-switch-to-workgroup-hook nil
257   "Hook run by `wg-switch-to-workgroup'."
258   :type 'hook
259   :group 'workgroups)
260
261 (defcustom wg-after-switch-to-workgroup-hook nil
262   "Hook run by `wg-switch-to-workgroup'."
263   :type 'hook
264   :group 'workgroups)
265 (define-obsolete-variable-alias 'wg-switch-to-workgroup-hook 'wg-after-switch-to-workgroup-hook)
266
267 (defcustom wg-pre-window-configuration-change-hook nil
268   "Hook run before any function that triggers `window-configuration-change-hook'."
269   :type 'hook
270   :group 'workgroups)
271
272 (defcustom wg-open-this-wg nil
273   "Try to open this workgroup on start.
274 If nil - nothing happens."
275   :type 'string
276   :group 'workgroups)
277
278
279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
280 ;;
281 ;; FIXME:
282 ;;
283 ;; Only set `wg-workgroup-base-wconfig' on `wg-save-session-as' or
284 ;; `delete-frame' and only with the most recently changed working-wconfig.
285 ;; Then, since it's not overwritten on every call to
286 ;; `wg-workgroup-working-wconfig', its restoration can be retried after manually
287 ;; recreating buffers that couldn't be restored.  So it takes over the
288 ;; 'incorrect restoration' portion of the base wconfig's duty.  All that leaves
289 ;; to base wconfigs is that they're a saved wconfig the user felt was important.
290 ;; So why not allow more of of them?  A workgroup could stash an unlimited
291 ;; number of wconfigs.
292 ;;
293 ;; TODO:
294 ;;
295 ;;   * Write new commands for restoring stashed wconfigs
296 ;;
297 ;;   * Add this message on improper restoration of `base-wconfig':
298 ;;
299 ;;       "Unable to restore 'buf1', 'buf2'... Hit C-whatever to retry after
300 ;;        manually recreating these buffers."
301 ;;
302 ;;
303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
304
305
306 ;; TODO: possibly add `buffer-file-coding-system', `text-scale-mode-amount'
307 (defcustom wg-buffer-local-variables-alist
308   `((major-mode nil wg-deserialize-buffer-major-mode)
309     (mark-ring wg-serialize-buffer-mark-ring wg-deserialize-buffer-mark-ring)
310     (left-fringe-width nil nil)
311     (right-fringe-width nil nil)
312     (fringes-outside-margins nil nil)
313     (left-margin-width nil nil)
314     (right-margin-width nil nil)
315     (vertical-scroll-bar nil nil))
316   "Alist mapping buffer-local variable symbols to serdes functions.
317
318 The `car' of each entry should be a buffer-local variable symbol.
319
320 The `cadr' of the entry should be either nil or a function of no
321 arguments.  If nil, the variable's value is used as-is, and
322 should have a readable printed representation.  If a function,
323 `funcall'ing it should yield a serialization of the value of the
324 variable.
325
326 The `caddr' of the entry should be either nil or a function of
327 one argument.  If nil, the serialized value from above is
328 assigned to the variable as-is.  It a function, `funcall'ing it
329 on the serialized value from above should do whatever is
330 necessary to properly restore the original value of the variable.
331 For example, in the case of `major-mode' it should funcall the
332 value (a major-mode function symbol) rather than just assigning
333 it to `major-mode'."
334   :type 'alist
335   :group 'workgroups)
336
337
338 (defcustom wg-nowg-string "No workgroups"
339   "Display this string if there are no workgroups and
340 `wg-display-nowg' is t."
341   :type 'string
342   :group 'workgroups)
343
344 (defcustom wg-display-nowg nil
345   "Display something if there are no workgroups."
346   :type 'boolean
347   :group 'workgroups)
348
349 (defcustom wg-restore-remote-buffers t
350   "Restore buffers that get \"t\" with `file-remote-p'."
351   :type 'boolean
352   :group 'workgroups)
353
354 (defcustom wg-restore-frame-position t
355   "Non-nil means restore frame position on workgroup restore."
356   :type 'boolean
357   :group 'workgroups)
358
359 (defcustom wg-restore-scroll-bars t
360   "Non-nil means restore scroll-bar settings on workgroup restore."
361   :type 'boolean
362   :group 'workgroups)
363
364 (defcustom wg-restore-fringes t
365   "Non-nil means restore fringe settings on workgroup restore."
366   :type 'boolean
367   :group 'workgroups)
368
369 (defcustom wg-restore-margins t
370   "Non-nil means restore margin settings on workgroup restore."
371   :type 'boolean
372   :group 'workgroups)
373
374 (defcustom wg-restore-point t
375   "Non-nil means restore `point' on workgroup restore.
376 This is included mainly so point restoration can be suspended
377 during `wg-morph' -- you probably want this non-nil."
378   :type 'boolean
379   :group 'workgroups)
380
381 (defcustom wg-restore-point-max t
382   "Controls point restoration when point is at `point-max'.
383 If `point' is at `point-max' when a wconfig is created, put
384 `point' back at `point-max' when the wconfig is restored, even if
385 `point-max' has increased in the meantime.  This is useful in,
386 say, irc buffers where `point-max' is constantly increasing."
387   :type 'boolean
388   :group 'workgroups)
389
390 (defcustom wg-restore-mark t
391   "Non-nil means restore mark data on workgroup restore."
392   :type 'boolean
393   :group 'workgroups)
394
395 (defcustom wg-restore-window-dedicated-p t
396   "Non-nil means restore `window-dedicated-p' on workgroup restore."
397   :type 'boolean
398   :group 'workgroups)
399
400 (defcustom wg-remember-frame-for-each-wg nil
401   "When switching workgroups - restore frame parameters for each workgroup.
402
403 When nil - save/restore frame parameters to/from the first workgroup."
404   :type 'boolean
405   :group 'workgroups)
406
407
408 (defcustom wg-wconfig-undo-list-max 20
409   "Number of past window configs to retain for undo."
410   :type 'integer
411   :group 'workgroups)
412
413 (defcustom wg-wconfig-kill-ring-max 20
414   "Maximum length of the `wg-wconfig-kill-ring'."
415   :type 'integer
416   :group 'workgroups)
417
418 (defvar wg-wconfig-kill-ring nil
419   "Ring of killed or kill-ring-saved wconfigs.")
420
421 (defvar wg-buffer-uid nil
422   "Symbol for the current buffer's wg-buf's uid.
423 Every Workgroups buffer object (wg-buf) has a uid.  When
424 Workgroups creates or encounters an Emacs buffer object
425 corresponding to a wg-buf, it tags it with the wg-buf's uid to
426 unambiguously pair the two.")
427 (make-variable-buffer-local 'wg-buffer-uid)
428
429 (defcustom wg-flag-modified t
430   "Show \"modified\" flags in modeline."
431   :type 'boolean
432   :group 'workgroups
433   :set (lambda (sym val)
434          (custom-set-default sym val)
435          (force-mode-line-update)))
436
437
438
439 (defvar wg-window-configuration-changed nil
440   "Flag set by `window-configuration-change-hook'.")
441
442 (defvar wg-already-updated-working-wconfig nil
443   "Flag set by `wg-update-working-wconfig-hook'.")
444
445 (defvar wg-undoify-window-configuration-change t
446   "Should windows undo info be updated or not.
447 When you change window configuration.")
448
449 (defvar wg-current-workgroup nil "Bound to the current workgroup.")
450
451 (defvar wg-window-min-width 2
452   "Bound to `window-min-width' when restoring wtrees.")
453
454 (defvar wg-window-min-height 1
455   "Bound to `window-min-height' when restoring wtrees.")
456
457 (defvar wg-window-min-pad 2
458   "Added to `wg-window-min-foo' to produce the actual minimum window size.")
459
460 (defvar wg-actual-min-width (+ wg-window-min-width wg-window-min-pad)
461   "Actual minimum window width when creating windows.")
462
463 (defvar wg-actual-min-height (+ wg-window-min-height wg-window-min-pad)
464   "Actual minimum window height when creating windows.")
465
466 (defvar wg-min-edges `(0 0 ,wg-actual-min-width ,wg-actual-min-height)
467   "Smallest allowable edge list of windows created by Workgroups.")
468
469 (defvar wg-null-edges '(0 0 0 0) "Null edge list.")
470
471 (defvar wg-window-tree-selected-window nil
472   "Used during wconfig restoration to hold the selected window.")
473
474 (defvar wg-buffer-workgroup nil
475   "A workgroup in which this buffer most recently appeared.
476 Buffer-local.")
477 (make-variable-buffer-local 'wg-buffer-workgroup)
478
479 (defcustom wg-default-buffer "*scratch*"
480   "Show this in case everything else fails.
481 When a buffer can't be restored, when creating a blank wg."
482   :type 'string
483   :group 'workgroups)
484
485
486 ;;
487 ;; Crazy stuff...
488 ;;
489 (defcustom wg-associate-blacklist (list "*helm mini*" "*Messages*" "*scratch*"
490                                         "*helm action*")
491   "Do not autoassociate these buffers."
492   :type 'list
493   :group 'workgroups)
494
495 (defconst wg-buffer-list-original (symbol-function 'buffer-list))
496 (fset 'wg-buffer-list-emacs wg-buffer-list-original)
497
498 (defun buffer-list (&optional frame)
499   "Redefinition of `buffer-list'.
500 Pass FRAME to it.
501 Remove file and dired buffers that are not associated with workgroup."
502   (let ((res (wg-buffer-list-emacs frame))
503         (wg-buf-uids (wg-workgroup-associated-buf-uids)))
504     (--remove (and (or (buffer-file-name it)
505                        (eq (buffer-local-value 'major-mode it) 'dired-mode))
506                    ;;(not (member b wg-buffers))
507                    (not (member (wg-buffer-uid-or-add it) wg-buf-uids)))
508               res)))
509
510 (defconst wg-buffer-list-function (symbol-function 'buffer-list))
511 (fset 'buffer-list wg-buffer-list-original)
512
513 ;; locate-dominating-file
514 (defcustom wg-mess-with-buffer-list nil
515   "Redefine `buffer-list' to show buffers for each workgroup.
516
517 Crazy stuff that allows to reduce amount of code, gives new
518 features but is fucking unstable, so disabled by default"
519   :type 'boolean
520   :group 'workgroups
521   :set (lambda (sym val)
522          (custom-set-default sym val)
523          (if (and workgroups-mode val)
524              (fset 'buffer-list wg-buffer-list-function)
525            (fset 'buffer-list wg-buffer-list-original))))
526 (fset 'buffer-list wg-buffer-list-original)
527
528 (defcustom wg-use-faces t
529   "Non-nil means use faces in various messages."
530   :type 'boolean
531   :group 'workgroups)
532
533 (defcustom wg-list-display-decor-left-brace "( "
534   "String displayed to the left of the list display."
535   :type 'string
536   :group 'workgroups)
537
538 (defcustom wg-list-display-decor-right-brace " )"
539   "String displayed to the right of the list display."
540   :type 'string
541   :group 'workgroups)
542
543 (defcustom wg-list-display-decor-divider " | "
544   "String displayed between elements of the list display."
545   :type 'string
546   :group 'workgroups)
547
548 (defcustom wg-list-display-decor-current-left "-<{ "
549   "String displayed to the left of the current element of the list display."
550   :type 'string
551   :group 'workgroups)
552
553 (defcustom wg-list-display-decor-current-right " }>-"
554   "String displayed to the right of the current element of the list display."
555   :type 'string
556   :group 'workgroups)
557
558 (defcustom wg-list-display-decor-previous-left "< "
559   "String displayed to the left of the previous element of the list display."
560   :type 'string
561   :group 'workgroups)
562
563 (defcustom wg-list-display-decor-previous-right " >"
564   "String displayed to the right of the previous element of the list display."
565   :type 'string
566   :group 'workgroups)
567
568
569 (defvar wg-face-abbrevs nil
570   "Assoc list mapping face abbreviations to face names.")
571
572 (defmacro wg-defface (face key spec doc &rest args)
573   "`defface' wrapper adding a lookup key used by `wg-fontify'."
574   (declare (indent 2))
575   `(progn
576      (cl-pushnew (cons ,key ',face) wg-face-abbrevs :test #'equal)
577      (defface ,face ,spec ,doc ,@args)))
578
579 (wg-defface wg-current-workgroup-face :cur
580   '((t :inherit font-lock-constant-face :bold nil))
581   "Face used for current elements in list displays."
582   :group 'workgroups)
583
584 (wg-defface wg-previous-workgroup-face :prev
585   '((t :inherit font-lock-keyword-face :bold nil))
586   "Face used for the name of the previous workgroup in the list display."
587   :group 'workgroups)
588
589 (wg-defface wg-other-workgroup-face :other
590   '((t :inherit font-lock-string-face :bold nil))
591   "Face used for the names of other workgroups in the list display."
592   :group 'workgroups)
593
594 (wg-defface wg-command-face :cmd
595   '((t :inherit font-lock-function-name-face :bold nil))
596   "Face used for command/operation strings."
597   :group 'workgroups)
598
599 (wg-defface wg-divider-face :div
600   '((t :inherit font-lock-builtin-face :bold nil))
601   "Face used for dividers."
602   :group 'workgroups)
603
604 (wg-defface wg-brace-face :brace
605   '((t :inherit font-lock-builtin-face :bold nil))
606   "Face used for left and right braces."
607   :group 'workgroups)
608
609 (wg-defface wg-message-face :msg
610   '((t :inherit font-lock-string-face :bold nil))
611   "Face used for messages."
612   :group 'workgroups)
613
614 (wg-defface wg-mode-line-face :mode
615   '((t :inherit font-lock-doc-face :bold nil))
616   "Face used for workgroup position and name in the mode-line display."
617   :group 'workgroups)
618
619 (wg-defface wg-filename-face :file
620   '((t :inherit font-lock-keyword-face :bold nil))
621   "Face used for filenames."
622   :group 'workgroups)
623
624
625 ;;; fancy displays
626
627 (defun wg-element-display (elt elt-string &optional current-elt-p previous-elt-p)
628   "Return display string for ELT."
629   (cond ((and current-elt-p (funcall current-elt-p elt))
630          (wg-fontify (:cur (concat wg-list-display-decor-current-left
631                                    elt-string
632                                    wg-list-display-decor-current-right))))
633         ((and previous-elt-p (funcall previous-elt-p elt))
634          (wg-fontify (:prev (concat wg-list-display-decor-previous-left
635                                     elt-string
636                                     wg-list-display-decor-previous-right))))
637         (t (wg-fontify (:other elt-string)))))
638
639 (defun wg-workgroup-display (workgroup index)
640   "Return display string for WORKGROUP at INDEX."
641   (if (not workgroup) wg-nowg-string
642     (wg-element-display
643      workgroup
644      (format "%d: %s" index (wg-workgroup-name workgroup))
645      'wg-current-workgroup-p
646      'wg-previous-workgroup-p)))
647
648 (defun wg-buffer-display (buffer index)
649   "Return display string for BUFFER.  INDEX is ignored."
650   (if (not buffer) "No buffers"
651     (wg-element-display
652      (wg-get-buffer buffer)
653      (format "%s" (wg-buffer-name buffer))
654      'wg-current-buffer-p)))
655
656 (defun wg-message (format-string &rest args)
657   "Call `message' with FORMAT-STRING and ARGS."
658   (if (> wg-log-level 0) (apply #'message format-string args)))
659
660 (defmacro wg-fontified-message (&rest format)
661   "`wg-fontify' FORMAT and call `wg-message' on it."
662   (declare (indent defun))
663   `(wg-message (wg-fontify ,@format)))
664
665 (defun wg-add-face (facekey string)
666   "Return a copy of STRING fontified according to FACEKEY.
667 FACEKEY must be a key in `wg-face-abbrevs'."
668   (let ((face (wg-aget wg-face-abbrevs facekey))
669         (string  (copy-sequence string)))
670     (unless face (error "No face with key %s" facekey))
671     (if (not wg-use-faces) string
672       (put-text-property 0 (length string) 'face face string)
673       string)))
674
675 (defmacro wg-fontify (&rest specs)
676   "A small fontification DSL.
677 The results of all SPECS are `concat'd together.
678 If a spec is a cons with a keyword car, apply `wg-add-face' to it.
679 Other conses get evaluated, and should produce a strings.
680 If a spec is a string it is used unmodified.
681 Anything else is formatted with %s to produce a string."
682   (declare (indent defun))
683   `(concat
684     ,@(wg-docar (spec specs)
685         (cond ((and (consp spec)
686                     (keywordp (car spec)))
687                `(wg-add-face ,@spec))
688               ;;((listp spec) (cdr (eval spec)))
689               ;;((listp spec)
690               ;; ;;(prin1-to-string (nth 1 (eval spec)))
691               ;; )
692               ((consp spec) spec)
693               ((stringp spec) spec)
694               (t `(format "%s" ,spec))))))
695
696 (defmacro wg-with-gensyms (syms &rest body)
697   "Bind all symbols in SYMS to `gensym's, and eval BODY."
698   (declare (indent 1))
699   `(let (,@(mapcar (lambda (sym) `(,sym (cl-gensym))) syms)) ,@body))
700
701 (defmacro wg-dbind (args expr &rest body)
702   "Bind the variables in ARGS to the result of EXPR and execute BODY.
703 Abbreviation of `destructuring-bind'."
704   (declare (indent 2))
705   `(cl-destructuring-bind ,args ,expr ,@body))
706
707 (defun wg-partition (list &optional n step)
708   "Take LIST, return a list of N length sublists, offset by STEP.
709 N defaults to 2, and STEP defaults to N.
710 Iterative to prevent stack overflow."
711   (let* ((n (or n 2)) (step (or step n)) acc)
712     (while list
713       (push (-take n list) acc)
714       (setq list (nthcdr step list)))
715     (nreverse acc)))
716
717 (defmacro wg-when-boundp (symbols &rest body)
718   "When all SYMBOLS are bound, `eval' BODY."
719   (declare (indent 1))
720   `(when (and ,@(mapcar (lambda (sym) `(boundp ',sym)) symbols))
721      ,@body))
722
723 (defmacro wg-docar (spec &rest body)
724   "do-style wrapper for `mapcar'.
725
726 \(fn (VAR LIST) BODY...)"
727   (declare (indent 1))
728   `(mapcar (lambda (,(car spec)) ,@body) ,(cadr spec)))
729
730 (defmacro wg-dohash (spec &rest body)
731   "do-style wrapper for `maphash'.
732
733 \(fn (KEY VALUE TABLE [RESULT]) BODY...)"
734   (declare (indent 1))
735   (wg-dbind (key val table &optional result) spec
736     `(progn (maphash (lambda (,key ,val) ,@body) ,table) ,result)))
737
738 (defmacro wg-doconcat (spec &rest body)
739   "do-style wrapper for `mapconcat'.
740
741 \(fn (VAR SEQ [SEPARATOR]) BODY...)"
742   (declare (indent 1))
743   (wg-dbind (elt seq &optional sep) spec
744     `(mapconcat (lambda (,elt) ,@body) ,seq (or ,sep ""))))
745
746 (defmacro wg-asetf (&rest places-and-values)
747   "Anaphoric `setf'."
748   `(progn ,@(mapcar (lambda (pv) `(let ((it ,(car pv))) (setf ,@pv)))
749                     (wg-partition places-and-values 2))))
750
751 (defmacro wg-destructuring-dolist (spec &rest body)
752   "Loop over a list.
753 Evaluate BODY, destructuring LIST into SPEC, then evaluate RESULT
754 to get a return value, defaulting to nil.  The only hitch is that
755 spec must end in dotted style, collecting the rest of the list
756 into a var, like so: (a (b c) . rest)
757
758 \(fn (SPEC LIST [RESULT]) BODY...)"
759   (declare (indent 1))
760   (wg-dbind (loopspec list &optional result) spec
761     (let ((rest (cdr (last loopspec))))
762       (wg-with-gensyms (list-sym)
763         `(let ((,list-sym ,list))
764            (while ,list-sym
765              (wg-dbind ,loopspec ,list-sym
766                ,@body
767                (setq ,list-sym ,rest)))
768            ,result)))))
769
770
771 ;;; numbers
772
773 (defun wg-step-to (n m step)
774   "Increment or decrement N toward M by STEP.
775 Return M when the difference between N and M is less than STEP."
776   (cond ((= n m) n)
777         ((< n m) (min (+ n step) m))
778         ((> n m) (max (- n step) m))))
779
780 (defun wg-within (num lo hi &optional hi-inclusive)
781   "Return t when NUM is within bounds LO and HI.
782 HI-INCLUSIVE non-nil means the HI bound is inclusive."
783   (and (>= num lo) (if hi-inclusive (<= num hi) (< num hi))))
784
785 (defun wg-int-to-b36-one-digit (i)
786   "Return a character in 0..9 or A..Z from I, and integer 0<=I<32.
787 Cribbed from `org-id-int-to-b36-one-digit'."
788   (cond ((not (wg-within i 0 36))
789          (error "%s out of range" i))
790         ((< i 10) (+ ?0 i))
791         ((< i 36) (+ ?A i -10))))
792
793 (defun wg-b36-to-int-one-digit (i)
794   "Turn a character 0..9, A..Z, a..z into a number 0..61.
795 The input I may be a character, or a single-letter string.
796 Cribbed from `org-id-b36-to-int-one-digit'."
797   (and (stringp i) (setq i (string-to-char i)))
798   (cond ((and (>= i ?0) (<= i ?9)) (- i ?0))
799         ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10))
800         (t (error "Invalid b36 character"))))
801
802 (defun wg-int-to-b36 (i &optional length)
803   "Return a base 36 string from I."
804   (let ((base 36) b36)
805     (cl-labels ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36)
806                            (setq i (/ i base))))
807       (add-digit)
808       (while (> i 0) (add-digit))
809       (setq b36 (cl-map 'string 'identity b36))
810       (if (not length) b36
811         (concat (make-string (max 0 (- length (length b36))) ?0) b36)))))
812
813 (defun wg-b36-to-int (str)
814   "Convert STR, a base-36 string, into the corresponding integer.
815 Cribbed from `org-id-b36-to-int'."
816   (let ((result 0))
817     (mapc (lambda (i)
818             (setq result (+ (* result 36)
819                             (wg-b36-to-int-one-digit i))))
820           str)
821     result))
822
823
824
825 ;;; lists
826
827 (defmacro wg-removef-p (item seq-place &rest keys)
828   "If ITEM is a `member*' of SEQ-PLACE, remove it from SEQ-PLACE and return t.
829 Otherwise return nil.  KEYS can be any keywords accepted by `remove*'."
830   `(> (length ,seq-place)
831       (length (setf ,seq-place (cl-remove ,item ,seq-place ,@keys)))))
832
833 (defmacro wg-pushnew-p (item seq-place &rest keys)
834   "If ITEM is not a `member' of SEQ-PLACE, push it to SEQ-PLACE and return t.
835 Otherwise return nil.  KEYS can be any keyword args accepted by `pushnew'."
836   `(< (length ,seq-place)
837       (length (cl-pushnew ,item ,seq-place ,@keys))))
838
839 (defun wg-range (start end)
840   "Return a list of integers from START up to but not including END."
841   (let (accum)
842     (dotimes (i (- end start) (nreverse accum))
843       (push (+ start i) accum))))
844
845 (defun wg-insert-before (elt list index)
846   "Insert ELT into LIST before INDEX."
847   (if (zerop index) (cons elt list)
848     (-insert-at index elt list)))
849
850 (defun wg-move-elt (elt list index &rest keys)
851   "Move ELT before INDEX in LIST.
852 KEYS is passed to `remove*'."
853   (wg-insert-before elt (apply 'cl-remove elt list keys) index))
854
855 (defun wg-cyclic-nth (list n)
856   "Return the Nth element of LIST, modded by the length of list."
857   (nth (mod n (length list)) list))
858
859 (defun wg-cyclic-offset-elt (elt list n)
860   "Cyclically offset ELT's position in LIST by N."
861   (-when-let (pos (cl-position elt list))
862     (wg-move-elt elt list (mod (+ n pos) (length list)))))
863
864 (defun wg-cyclic-nth-from-elt (elt list n &rest keys)
865   "Return the elt in LIST N places cyclically from ELT.
866 If ELT is not present is LIST, return nil.
867 KEYS is passed to `position'."
868   (-when-let (pos (apply 'cl-position elt list keys))
869     (wg-cyclic-nth list (+ pos n))))
870
871 (defun wg-util-swap (elt1 elt2 list)
872   "Return a copy of LIST with ELT1 and ELT2 swapped.
873 Return nil when ELT1 and ELT2 aren't both present."
874   (-when-let* ((p1 (cl-position elt1 list))
875                (p2 (cl-position elt2 list)))
876     (wg-move-elt elt1 (wg-move-elt elt2 list p1) p2)))
877
878 (defun wg-dups-p (list &rest keys)
879   "Return non-nil when LIST contains duplicate elements.
880
881 Keywords supported: :test :key
882
883 \(fn LIST [KEYWORD VALUE]...)"
884   (let ((test (or (plist-get keys :test) 'eq))
885         (key (or (plist-get keys :key) 'identity)))
886     (cl-loop for (elt . rest) on list
887              for elt = (funcall key elt)
888              when (cl-find elt rest :test test :key key) return elt)))
889
890 (defun wg-string-list-union (&optional list1 list2)
891   "Return the `union' of LIST1 and LIST2, using `string=' as the test.
892 This only exists to get rid of duplicate lambdas in a few reductions."
893   (cl-union list1 list2 :test 'string=))
894
895
896
897 ;;; alists
898
899 (defun wg-aget (alist key &optional default)
900   "Return the value of KEY in ALIST. Uses `assq'.
901 If PARAM is not found, return DEFAULT which defaults to nil."
902   (aif (assq key alist) (cdr it) default))
903
904 (defun wg-aput (alist key value)
905   "Return a new alist from ALIST with KEY's value set to VALUE."
906   (let* ((found nil)
907          (new (wg-docar (kvp alist)
908                 (if (not (eq key (car kvp))) kvp
909                   (setq found (cons key value))))))
910     (if found new (cons (cons key value) new))))
911
912 (defun wg-aremove (alist key)
913   "`remove' KEY's key-value-pair from ALIST."
914   (remove (assoc key alist) alist))
915
916
917 ;;; symbols and strings
918
919 (defun wg-toggle (symbol)
920   "Toggle SYMBOL's truthiness."
921   (set symbol (not (symbol-value symbol))))
922
923 (defun wg-get-buffer (buffer-or-name)
924   "Return BUFFER-OR-NAME's buffer, or error."
925   (or (get-buffer buffer-or-name)
926       (error "%S does not identify a buffer" buffer-or-name)))
927
928 (defun wg-buffer-name (buffer-or-name)
929   "Return BUFFER-OR-NAME's `buffer-name', or error."
930   (buffer-name (wg-get-buffer buffer-or-name)))
931
932 (defun wg-buffer-major-mode (buffer-or-name)
933   "Return BUFFER's major-mode."
934   (with-current-buffer buffer-or-name major-mode))
935
936 (defun wg-current-buffer-p (buffer-or-name)
937   "Return t if BUFFER-OR-NAME is the current buffer, nil otherwise."
938   (eq (wg-get-buffer buffer-or-name) (current-buffer)))
939
940 (defun wg-symcat (&rest symbols-and-strings)
941   "Return a new interned symbol by concatenating SYMBOLS-AND-STRINGS."
942   (intern (mapconcat (lambda (obj) (if (symbolp obj) (symbol-name obj) obj))
943                      symbols-and-strings "")))
944
945 (defmacro wg-defstruct (prefix name-form &rest slot-defs)
946   "`defstruct' wrapper that namespace-prefixes all generated functions.
947 Note: this doesn't yet work with :conc-name, and possibly other
948 options."
949   (declare (indent 2))
950   (let* ((name (if (consp name-form) (car name-form) name-form))
951          (prefixed-name (wg-symcat prefix "-" name)))
952     (cl-labels ((rebind (opstr)
953                         (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name)))
954                           `((fset ',(wg-symcat prefix "-" opstr "-" name)
955                                   (symbol-function ',oldfnsym))
956                             (fmakunbound ',oldfnsym)))))
957       ;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not
958       ;; known to be defined").  We can accomplish this with `declare-function'
959       ;; too, but it annoyingly requires inclusion of the function's arglist,
960       ;; which gets ugly.
961       `(eval-and-compile
962          (cl-defstruct ,(if (symbolp name-form) prefixed-name
963                           `(,prefixed-name ,@(cdr name-form)))
964            ,@slot-defs)
965          ,@(rebind "make")
966          ,@(rebind "copy")
967          ',prefixed-name))))
968
969 (wg-defstruct wg session
970   (uid (wg-generate-uid))
971   (name)
972   (modified)
973   (parameters)
974   (file-name)
975   (version wg-version)
976   (workgroup-list)
977   (buf-list))
978
979 (wg-defstruct wg workgroup
980   (uid (wg-generate-uid))
981   (name)
982   (modified)
983   (parameters)
984   (base-wconfig)
985   (selected-frame-wconfig)
986   (saved-wconfigs)
987   (strong-buf-uids)
988   (weak-buf-uids))
989
990 (wg-defstruct wg workgroup-state
991   (undo-pointer)
992   (undo-list))
993
994 (wg-defstruct wg wconfig
995   (uid (wg-generate-uid))
996   (name)
997   (parameters)
998   (left)
999   (top)
1000   (width)
1001   (height)
1002   (vertical-scroll-bars)
1003   (scroll-bar-width)
1004   (wtree))
1005
1006 (wg-defstruct wg wtree
1007   (uid)
1008   (dir)
1009   (edges)
1010   (wlist))
1011
1012 (wg-defstruct wg win
1013   (uid)
1014   (parameters)
1015   (edges)
1016   (point)
1017   (start)
1018   (hscroll)
1019   (dedicated)
1020   (selected)
1021   (minibuffer-scroll)
1022   (buf-uid))
1023
1024 (wg-defstruct wg buf
1025   (uid (wg-generate-uid))
1026   (name)
1027   (file-name)
1028   (point)
1029   (mark)
1030   (local-vars)
1031   (special-data)
1032   ;; This may be used later:
1033   (gc))
1034
1035
1036 (defmacro wg-with-slots (obj slot-bindings &rest body)
1037   "Bind OBJ's slot values to symbols in BINDS, then eval BODY.
1038 The car of each element of SLOT-BINDINGS is the bound symbol, and
1039 the cadr as the accessor function."
1040   (declare (indent 2))
1041   (wg-with-gensyms (objsym)
1042     `(let* ((,objsym ,obj)
1043             ,@(wg-docar (slot slot-bindings)
1044                 `(,(car slot) (,(cadr slot) ,objsym))))
1045        ,@body)))
1046
1047 (defun wg-add-or-remove-hooks (remove &rest pairs)
1048   "Add FUNCTION to or remove it from HOOK, depending on REMOVE."
1049   (dolist (pair (wg-partition pairs 2))
1050     (funcall (if remove 'remove-hook 'add-hook)
1051              (car pair) (cadr pair))))
1052
1053 (defmacro wg-set-parameter (place parameter value)
1054   "Set PARAMETER to VALUE at PLACE.
1055 This needs to be a macro to allow specification of a setf'able place."
1056   (wg-with-gensyms (p v)
1057     `(let ((,p ,parameter) (,v ,value))
1058        (wg-pickelable-or-error ,p)
1059        (wg-pickelable-or-error ,v)
1060        (setf ,place (wg-aput ,place ,p ,v))
1061        ,v)))
1062
1063 (defun wg-time-to-b36 ()
1064   "Convert `current-time' into a b36 string."
1065   (apply 'concat (wg-docar (time (current-time))
1066                    (wg-int-to-b36 time 4))))
1067
1068 (defun wg-b36-to-time (b36)
1069   "Parse the time in B36 string from UID."
1070   (cl-loop for i from 0 to 8 by 4
1071            collect (wg-b36-to-int (cl-subseq b36 i (+ i 4)))))
1072 (defalias 'wg-uid-to-time 'wg-b36-to-time)
1073
1074 (defun wg-generate-uid (&optional prefix)
1075   "Return a new uid, optionally prefixed by PREFIX."
1076   (concat prefix (wg-time-to-b36) "-" (wg-int-to-b36 string-chars-consed)))
1077
1078 (defun wg-uid-to-seconds (uid)
1079   "Return the `float-time' parsed from UID with `wg-uid-to-time'."
1080   (float-time (wg-uid-to-time uid)))
1081
1082
1083 (defun wg-get-value (arg)
1084   "Get a value of ARG if it exists."
1085   (if (boundp `,arg) arg))
1086
1087 (defmacro wg-support (mode pkg params)
1088   "Macro to create (de)serialization functions for a buffer.
1089 You need to save/restore a specific MODE which is loaded from a
1090 package PKG.  In PARAMS you give local variables to save and a
1091 deserialization function."
1092   (declare (indent 2))
1093   `(let ((mode-str (symbol-name ,mode))
1094          (args ,params))
1095
1096      (eval `(defun ,(intern (format "wg-deserialize-%s-buffer" mode-str)) (buffer)
1097               "DeSerialization function created with `wg-support'.
1098 Gets saved variables and runs code to restore a BUFFER."
1099               (when (require ',,pkg nil 'noerror)
1100                 (wg-dbind (this-function variables) (wg-buf-special-data buffer)
1101                   (let ((default-directory (car variables))
1102                         (df (cdr (assoc 'deserialize ',,params)))
1103                         (user-vars (cadr variables)))
1104                     (if df
1105                         (funcall df buffer user-vars)
1106                       (get-buffer-create wg-default-buffer))
1107                     )))))
1108
1109      (eval `(defun ,(intern (format "wg-serialize-%s-buffer" mode-str)) (buffer)
1110               "Serialization function created with `wg-support'.
1111 Saves some variables to restore a BUFFER later."
1112               (when (get-buffer buffer)
1113                 (with-current-buffer buffer
1114                   (when (eq major-mode ',,mode)
1115                     (let ((sf (cdr (assoc 'serialize ',,params)))
1116                           (save (cdr (assoc 'save ',,params))))
1117                       (list ',(intern (format "wg-deserialize-%s-buffer" mode-str))
1118                             (list default-directory
1119                                   (if sf
1120                                       (funcall sf buffer)
1121                                     (if save (mapcar 'wg-get-value save)))
1122                                   ))))))))
1123      ;; Maybe change a docstring for functions
1124      ;;(put (intern (format "wg-serialize-%s-buffer" (symbol-name mode)))
1125      ;;     'function-documentation
1126      ;;     (format "A function created by `wg-support'."))
1127
1128      ;; Add function to `wg-special-buffer-serdes-functions' variable
1129      (eval `(add-to-list 'wg-special-buffer-serdes-functions
1130                          ',(intern (format "wg-serialize-%s-buffer" mode-str)) t))
1131      ))
1132
1133 (defconst wg-font-lock-keywords
1134   '(("(\\(wg-support\\|wg-support\\)[ \t]*"
1135      (1 font-lock-keyword-face)
1136      ;;(2 font-lock-keyword-face)
1137      )))
1138 (font-lock-add-keywords 'emacs-lisp-mode wg-font-lock-keywords)
1139
1140 (defvar wg-current-session nil "Current session object.")
1141 (defun wg-current-session (&optional noerror)
1142   "Return `wg-current-session' or error unless NOERROR."
1143   (or wg-current-session
1144       (if workgroups-mode
1145           (unless noerror (error "No session is defined"))
1146         (unless noerror
1147           (error "Activate workgroups with (workgroups-mode 1)")))))
1148
1149 ;; locate-dominating-file
1150 (defun wg-get-first-existing-dir (&optional dir)
1151   "Test if DIR exists and return it.
1152 If not - try to go to the parent dir and do the same."
1153   (let* ((d (or dir default-directory)))
1154     (if (file-directory-p d) d
1155       (let* ((cur d) (parent (file-name-directory (directory-file-name cur))))
1156         (while (and (> (length cur) (length parent))
1157                     (not (file-directory-p parent)))
1158           (message "Test %s" parent)
1159           (setq cur parent)
1160           (setq parent (file-name-directory (directory-file-name cur))))
1161         parent))))
1162
1163
1164 (defvar wg-pickel-identifier '~pickel!~
1165   "Symbol identifying a stream as a pickel.")
1166
1167 (defvar wg-pickel-pickelable-types
1168   '(integer
1169     float
1170     symbol
1171     string
1172     cons
1173     vector
1174     hash-table
1175     buffer
1176     marker
1177     ;;window-configuration
1178     ;;frame
1179     ;;window
1180     ;;process
1181     )
1182   "Types pickel can serialize.")
1183
1184 (defvar wg-pickel-object-serializers
1185   '((integer    . identity)
1186     (float      . identity)
1187     (string     . identity)
1188     (symbol     . wg-pickel-symbol-serializer)
1189     (cons       . wg-pickel-cons-serializer)
1190     (vector     . wg-pickel-vector-serializer)
1191     (hash-table . wg-pickel-hash-table-serializer)
1192     (buffer     . wg-pickel-buffer-serializer)
1193     (marker     . wg-pickel-marker-serializer)
1194     ;;(window-configuration   . wg-pickel-window-configuration-serializer)
1195     )
1196   "Alist mapping types to object serialization functions.")
1197 (defvar wg-pickel-object-deserializers
1198   '((s . wg-pickel-deserialize-uninterned-symbol)
1199     (c . wg-pickel-deserialize-cons)
1200     (v . wg-pickel-deserialize-vector)
1201     (h . wg-pickel-deserialize-hash-table)
1202     (b . wg-pickel-deserialize-buffer)
1203     (m . wg-pickel-deserialize-marker)
1204     ;;(f . wg-pickel-deserialize-frame)
1205     )
1206   "Alist mapping type keys to object deserialization functions.")
1207
1208 (defvar wg-pickel-link-serializers
1209   '((cons       . wg-pickel-cons-link-serializer)
1210     (vector     . wg-pickel-vector-link-serializer)
1211     (hash-table . wg-pickel-hash-table-link-serializer))
1212   "Alist mapping types to link serialization functions.")
1213 (defvar wg-pickel-link-deserializers
1214   `((c . wg-pickel-cons-link-deserializer)
1215     (v . wg-pickel-vector-link-deserializer)
1216     (h . wg-pickel-hash-table-link-deserializer))
1217   "Alist mapping type keys to link deserialization functions.")
1218
1219
1220
1221 ;;; errors and predicates
1222
1223 (put 'wg-pickel-unpickelable-type-error
1224      'error-conditions
1225      '(error wg-pickel-errors wg-pickel-unpickelable-type-error))
1226
1227 (put 'wg-pickel-unpickelable-type-error
1228      'error-message
1229      "Attemp to pickel unpickelable type")
1230
1231 (defun wg-pickelable-or-error (obj)
1232   "Error when OBJ isn't pickelable."
1233   (unless (memq (type-of obj) wg-pickel-pickelable-types)
1234     (signal 'wg-pickel-unpickelable-type-error
1235             (format "Can't pickel objects of type: %S" (type-of obj))))
1236   (cl-typecase obj
1237     (cons
1238      (wg-pickelable-or-error (car obj))
1239      (wg-pickelable-or-error (cdr obj)))
1240     (vector
1241      (cl-map nil 'wg-pickelable-or-error obj))
1242     (hash-table
1243      (wg-dohash (key value obj)
1244        (wg-pickelable-or-error key)
1245        (wg-pickelable-or-error value)))))
1246
1247 (defun wg-pickelable-p (obj)
1248   (condition-case err
1249       (progn (wg-pickelable-or-error obj) t)
1250     (wg-pickel-unpickelable-type-error nil)))
1251
1252 (defun wg-pickel-p (obj)
1253   "Return t when OBJ is a pickel, nil otherwise."
1254   (and (consp obj) (eq (car obj) wg-pickel-identifier)))
1255
1256
1257
1258 ;; accessor functions
1259
1260 (defun wg-pickel-object-serializer (obj)
1261   "Return the object serializer for the `type-of' OBJ."
1262   (or (wg-aget wg-pickel-object-serializers (type-of obj))
1263       (error "Invalid type: %S" (type-of obj))))
1264
1265 (defun wg-pickel-link-serializer (obj)
1266   "Return the link serializer for the `type-of' OBJ."
1267   (wg-aget wg-pickel-link-serializers (type-of obj)))
1268
1269 (defun wg-pickel-object-deserializer (key)
1270   "Return the object deserializer for type key KEY, or error."
1271   (or (wg-aget wg-pickel-object-deserializers key)
1272       (error "Invalid object deserializer key: %S" key)))
1273
1274 (defun wg-pickel-link-deserializer (key)
1275   "Return the link deserializer for type key KEY, or error."
1276   (or (wg-aget wg-pickel-link-deserializers key)
1277       (error "Invalid link deserializer key: %S" key)))
1278
1279
1280
1281 ;;; bindings
1282
1283 (defun wg-pickel-make-bindings-table (obj)
1284   "Return a table binding unique subobjects of OBJ to ids."
1285   (let ((binds (make-hash-table :test 'eq))
1286         (id -1))
1287     (cl-labels
1288         ((inner (obj)
1289                 (unless (gethash obj binds)
1290                   (puthash obj (cl-incf id) binds)
1291                   (cl-case (type-of obj)
1292                     (cons
1293                      (inner (car obj))
1294                      (inner (cdr obj)))
1295                     (vector
1296                      (dotimes (idx (length obj))
1297                        (inner (aref obj idx))))
1298                     (hash-table
1299                      (wg-dohash (key val obj)
1300                        (inner key)
1301                        (inner val)))))))
1302       (inner obj)
1303       binds)))
1304
1305
1306
1307 ;;; Objects
1308 (defun wg-pickel-symbol-serializer (symbol)
1309   "Return SYMBOL's serialization."
1310   (cond ((eq symbol t) t)
1311         ((eq symbol nil) nil)
1312         ((intern-soft symbol) symbol)
1313         (t (list 's (symbol-name symbol)))))
1314 (defun wg-pickel-deserialize-uninterned-symbol (name)
1315   "Return a new uninterned symbol from NAME."
1316   (make-symbol name))
1317
1318
1319 ;; buffer
1320 (defun wg-pickel-buffer-serializer (buffer)
1321   "Return BUFFER's UID in workgroups buffer list."
1322   (list 'b (wg-add-buffer-to-buf-list buffer)))
1323 (defun wg-pickel-deserialize-buffer (uid)
1324   "Return a restored buffer from it's UID."
1325   (wg-restore-buffer (wg-find-buf-by-uid uid)))
1326
1327
1328 ;; marker
1329 (defun wg-pickel-marker-serializer (marker)
1330   "Return MARKER's data."
1331   (list 'm (list (marker-position marker)
1332                  (wg-add-buffer-to-buf-list (marker-buffer marker)))))
1333 (defun wg-pickel-deserialize-marker (data)
1334   "Return marker from it's DATA."
1335   (let ((m (make-marker)))
1336     (set-marker m (car data) (wg-pickel-deserialize-buffer (car (cdr data))))))
1337
1338
1339 ;; cons - http://www.gnu.org/software/emacs/manual/html_node/eintr/cons.html
1340 (defun wg-pickel-cons-serializer (cons)
1341   "Return CONS's serialization."
1342   (list 'c))
1343 (defun wg-pickel-deserialize-cons ()
1344   "Return a new cons cell initialized to nil."
1345   (cons nil nil))
1346 (defun wg-pickel-cons-link-serializer (cons binds)
1347   "Return the serialization of CONS's links in BINDS."
1348   (list 'c
1349         (gethash cons binds)
1350         (gethash (car cons) binds)
1351         (gethash (cdr cons) binds)))
1352 (defun wg-pickel-cons-link-deserializer (cons-id car-id cdr-id binds)
1353   "Relink a cons cell with its car and cdr in BINDS."
1354   (let ((cons (gethash cons-id binds)))
1355     (setcar cons (gethash car-id binds))
1356     (setcdr cons (gethash cdr-id binds))))
1357
1358
1359
1360 ;; vector - http://www.gnu.org/software/emacs/manual/html_node/elisp/Vector-Functions.html
1361 ;; (wg-unpickel (wg-pickel (make-vector 9 'Z)))
1362 ;;
1363 (defun wg-pickel-vector-serializer (vector)
1364   "Return VECTOR's serialization."
1365   (list 'v (length vector)))
1366 (defun wg-pickel-deserialize-vector (length)
1367   "Return a new vector of length LENGTH."
1368   (make-vector length nil))
1369 (defun wg-pickel-vector-link-serializer (vector binds)
1370   "Return the serialization of VECTOR's links in BINDS."
1371   (let (result)
1372     (dotimes (i (length vector) result)
1373       (setq result
1374             (nconc (list 'v
1375                          (gethash vector binds)
1376                          i
1377                          (gethash (aref vector i) binds))
1378                    result)))))
1379 (defun wg-pickel-vector-link-deserializer (vector-id index value-id binds)
1380   "Relink a vector with its elements in BINDS."
1381   (aset (gethash vector-id binds) index (gethash value-id binds)))
1382
1383
1384 ;; hash table - http://www.gnu.org/software/emacs/manual/html_node/elisp/Hash-Tables.html
1385 (defun wg-pickel-hash-table-serializer (table)
1386   "Return HASH-TABLE's serialization."
1387   (list 'h
1388         (hash-table-test table)
1389         (hash-table-size table)
1390         (hash-table-rehash-size table)
1391         (hash-table-rehash-threshold table)
1392         (hash-table-weakness table)))
1393 (defun wg-pickel-deserialize-hash-table (test size rsize rthresh weakness)
1394   "Return a new hash-table with the specified properties."
1395   (make-hash-table :test test :size size :rehash-size rsize
1396                    :rehash-threshold rthresh :weakness weakness))
1397 (defun wg-pickel-hash-table-link-serializer (table binds)
1398   "Return the serialization of TABLE's links in BINDS."
1399   (let (result)
1400     (wg-dohash (key value table result)
1401       (setq result
1402             (nconc (list 'h
1403                          (gethash key binds)
1404                          (gethash value binds)
1405                          (gethash table binds))
1406                    result)))))
1407 (defun wg-pickel-hash-table-link-deserializer (key-id value-id table-id binds)
1408   "Relink a hash-table with its keys and values in BINDS."
1409   (puthash (gethash key-id binds)
1410            (gethash value-id binds)
1411            (gethash table-id binds)))
1412
1413
1414 ;; TODO
1415 (defun wg-pickel-window-configuration-serializer (wc)
1416   "Return Window configuration WC's serialization."
1417   (list 'wc 1))
1418
1419
1420 (defun wg-pickel-serialize-objects (binds)
1421   "Return a list of serializations of the objects in BINDS."
1422   (let (result)
1423     (wg-dohash (obj id binds result)
1424       (setq result
1425             (nconc (list id (funcall (wg-pickel-object-serializer obj) obj))
1426                    result)))))
1427 (defun wg-pickel-deserialize-objects (serial-objects)
1428   "Return a hash-table of objects deserialized from SERIAL-OBJECTS."
1429   (let ((binds (make-hash-table)))
1430     (wg-destructuring-dolist ((id obj . rest) serial-objects binds)
1431       (puthash id
1432                (if (atom obj) obj
1433                  (wg-dbind (key . data) obj
1434                    (apply (wg-pickel-object-deserializer key) data)))
1435                binds))))
1436
1437
1438
1439 (defun wg-pickel-serialize-links (binds)
1440   "Return a list of serializations of the links between objects in BINDS."
1441   (let (result)
1442     (wg-dohash (obj id binds result)
1443       (awhen (wg-pickel-link-serializer obj)
1444         (setq result (nconc (funcall it obj binds) result))))))
1445 (defun wg-pickel-deserialize-links (serial-links binds)
1446   "Return BINDS after relinking all its objects according to SERIAL-LINKS."
1447   (wg-destructuring-dolist ((key arg1 arg2 arg3 . rest) serial-links binds)
1448     (funcall (wg-pickel-link-deserializer key) arg1 arg2 arg3 binds)))
1449
1450 (defun wg-pickel (obj)
1451   "Return the serialization of OBJ."
1452   (wg-pickelable-or-error obj)
1453   (let ((binds (wg-pickel-make-bindings-table obj)))
1454     (list wg-pickel-identifier
1455           (wg-pickel-serialize-objects binds)
1456           (wg-pickel-serialize-links binds)
1457           (gethash obj binds))))
1458
1459 (defun wg-pickel-to-string (obj)
1460   "Serialize OBJ to a string and return the string."
1461   (format "%S" (wg-pickel obj)))
1462
1463 (defun wg-unpickel (pickel)
1464   "Return the deserialization of PICKEL."
1465   (unless (wg-pickel-p pickel)
1466     (error "Attempt to unpickel a non-pickel."))
1467   (wg-dbind (id serial-objects serial-links result) pickel
1468     (gethash
1469      result
1470      (wg-pickel-deserialize-links
1471       serial-links
1472       (wg-pickel-deserialize-objects serial-objects)))))
1473
1474 ;; `wg-pre-window-configuration-change-hook' implementation advice
1475 (cl-macrolet ((define-p-w-c-c-h-advice
1476                 (fn)
1477                 `(defadvice ,fn (before wg-pre-window-configuration-change-hook)
1478                    "Call `wg-update-working-wconfig-hook' before this
1479 function to save up-to-date undo information before the
1480 window-configuration changes."
1481                    (run-hooks 'wg-pre-window-configuration-change-hook))))
1482   (define-p-w-c-c-h-advice split-window)
1483   (define-p-w-c-c-h-advice enlarge-window)
1484   (define-p-w-c-c-h-advice delete-window)
1485   (define-p-w-c-c-h-advice delete-other-windows)
1486   (define-p-w-c-c-h-advice delete-windows-on)
1487   (define-p-w-c-c-h-advice switch-to-buffer)
1488   (define-p-w-c-c-h-advice set-window-buffer))
1489
1490
1491 (defadvice save-buffers-kill-emacs (around wg-freeze-wconfig)
1492   "`save-buffers-kill-emacs' calls `list-processes' when active
1493 processes exist, screwing up the window config right before
1494 Workgroups saves it.  This advice freezes `wg-current-wconfig' in
1495 its correct state, prior to any window-config changes caused by
1496 `s-b-k-e'."
1497   (wg-with-current-wconfig nil (wg-frame-to-wconfig)
1498     ad-do-it))
1499
1500 (defadvice select-frame (before wg-update-current-workgroup-working-wconfig)
1501   "Update `selected-frame's current workgroup's working-wconfig.
1502 Before selecting a new frame."
1503   (wg-update-current-workgroup-working-wconfig))
1504
1505 (defun wg-enable-all-advice ()
1506   "Enable and activate all of Workgroups' advice."
1507   ;; switch-to-buffer
1508   (ad-enable-advice 'switch-to-buffer 'after 'wg-auto-associate-buffer)
1509   (ad-enable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook)
1510   (ad-activate 'switch-to-buffer)
1511
1512   ;; set-window-buffer
1513   (ad-enable-advice 'set-window-buffer 'after 'wg-auto-associate-buffer)
1514   (ad-enable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook)
1515   (ad-activate 'set-window-buffer)
1516
1517   ;; split-window
1518   (ad-enable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook)
1519   (ad-activate 'split-window)
1520
1521   ;; enlarge-window
1522   (ad-enable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook)
1523   (ad-activate 'enlarge-window)
1524
1525   ;; delete-window
1526   (ad-enable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook)
1527   (ad-activate 'delete-window)
1528
1529   ;; delete-other-windows
1530   (ad-enable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook)
1531   (ad-activate 'delete-other-windows)
1532
1533   ;; delete-windows-on
1534   (ad-enable-advice 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook)
1535   (ad-activate 'delete-windows-on)
1536
1537   ;; save-buffers-kill-emacs
1538   (ad-enable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig)
1539   (ad-activate 'save-buffers-kill-emacs)
1540
1541   ;; select-frame
1542   ;;(ad-enable-advice 'select-frame 'before
1543   ;;                  'wg-update-current-workgroup-working-wconfig)
1544   ;;(ad-activate 'select-frame)
1545   )
1546
1547
1548 ;; disable all advice
1549 ;; (wg-disable-all-advice)
1550 (defun wg-disable-all-advice ()
1551   "Disable and deactivate all of Workgroups' advice."
1552   ;; switch-to-buffer
1553   (ad-disable-advice 'switch-to-buffer 'after  'wg-auto-associate-buffer)
1554   (ad-disable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook)
1555   (ad-deactivate 'switch-to-buffer)
1556
1557   ;; set-window-buffer
1558   (ad-disable-advice 'set-window-buffer 'after  'wg-auto-associate-buffer)
1559   (ad-disable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook)
1560   (ad-deactivate 'set-window-buffer)
1561
1562   ;; split-window
1563   (ad-disable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook)
1564   (ad-deactivate 'split-window)
1565
1566   ;; enlarge-window
1567   (ad-disable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook)
1568   (ad-deactivate 'enlarge-window)
1569
1570   ;; delete-window
1571   (ad-disable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook)
1572   (ad-deactivate 'delete-window)
1573
1574   ;; delete-other-windows
1575   (ad-disable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook)
1576   (ad-deactivate 'delete-other-windows)
1577
1578   ;; delete-windows-on
1579   (ad-disable-advice 'delete-windows-on    'before 'wg-pre-window-configuration-change-hook)
1580   (ad-deactivate 'delete-windows-on)
1581
1582   ;; save-buffers-kill-emacs
1583   (ad-disable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig)
1584   (ad-deactivate 'save-buffers-kill-emacs)
1585
1586   ;; select-frame
1587   ;;(ad-disable-advice 'select-frame 'before
1588   ;;                   'wg-update-current-workgroup-working-wconfig)
1589   ;;(ad-deactivate 'select-frame)
1590   )
1591
1592
1593 ;; buffer auto-association advice
1594
1595 (defcustom wg-buffer-auto-association-on t
1596   "Non-nil means buffer auto-association is on.
1597 -nil means it's off.  See `wg-buffer-auto-association'."
1598   :type 'boolean
1599   :group 'workgroups)
1600
1601 (defcustom wg-buffer-auto-association 'weak
1602   "Specifies the behavior for auto-associating buffers with workgroups.
1603
1604 When a buffer is made visible in a window it can be automatically
1605 associated with the current workgroup in the window's frame.
1606 This setting determines whether and how that happens.
1607
1608 Allowable values:
1609
1610 `weak' - weakly associate the buffer with the workgroup
1611 `strong' - strongly associate the buffer with the workgroup
1612
1613 A function (a function-symbol or a lambda) - `funcall' the function to
1614 determine whether and how to associate the buffer with the
1615 workgroup.  The function should accept two arguments -- the
1616 buffer and the workgroup -- and should return one of the
1617 allowable values for this variable.
1618
1619 `nil' or any other value - don't associate the buffer with the
1620 workgroup.
1621
1622 Becomes workgroup-local when set with `wg-set-workgroup-parameter'.
1623 Becomes session-local when set with `wg-set-session-parameter'."
1624   :type 'sexp
1625   :group 'workgroups)
1626
1627 (defcustom wg-dissociate-buffer-on-kill-buffer t
1628   "Non-nil means dissociate buffers killed with `kill-buffer'."
1629   :type 'boolean
1630   :group 'workgroups)
1631
1632 (defun wg-auto-associate-buffer-helper (workgroup buffer assoc)
1633   "Associate BUFFER with WORKGROUP based on ASSOC.
1634 See `wg-buffer-auto-association' for allowable values of ASSOC."
1635   (cond ((memq assoc '(weak strong))
1636          (wg-workgroup-associate-bufobj workgroup buffer (eq assoc 'weak)))
1637         ((functionp assoc)
1638          (wg-auto-associate-buffer-helper
1639           workgroup buffer (funcall assoc workgroup buffer)))
1640         (t nil)))
1641
1642 (defun wg-auto-associate-buffer (buffer &optional frame)
1643   "Conditionally associate BUFFER with the current workgroup in FRAME.
1644 Frame defaults to `selected-frame'.  See `wg-buffer-auto-association'."
1645   (when wg-buffer-auto-association-on
1646     (-when-let* ((wg (wg-current-workgroup t frame))
1647                  (b (get-buffer buffer)))
1648       (unless (or (wg-workgroup-bufobj-association-type wg buffer)
1649                   (member wg wg-deactivation-list)
1650                   (member (buffer-name b) wg-associate-blacklist)
1651                   (not (or (buffer-file-name b)
1652                            (eq (buffer-local-value 'major-mode b) 'dired-mode))))
1653         (wg-auto-associate-buffer-helper
1654          wg buffer (wg-local-value 'wg-buffer-auto-association wg))))))
1655
1656 (defadvice switch-to-buffer (after wg-auto-associate-buffer)
1657   "Automatically associate the buffer with the current workgroup."
1658   (wg-auto-associate-buffer ad-return-value))
1659
1660 (defadvice set-window-buffer (after wg-auto-associate-buffer)
1661   "Automatically associate the buffer with the current workgroup."
1662   (wg-auto-associate-buffer
1663    (ad-get-arg 1)
1664    (window-frame (or (ad-get-arg 0) (selected-window)))))
1665
1666 (defun wg-mode-line-string ()
1667   "Return the string to be displayed in the mode-line."
1668   (let ((wg (wg-current-workgroup t))
1669         (wg-use-faces wg-mode-line-use-faces))
1670     (cond (wg (wg-fontify " "
1671                 (:brace wg-mode-line-decor-left-brace)
1672                 (:mode (wg-workgroup-name wg))
1673                 (if wg-flag-modified
1674                     (concat
1675                      (wg-add-face :div wg-mode-line-decor-divider)
1676                      ;;(if (window-dedicated-p)
1677                      ;;    wg-mode-line-decor-window-dedicated
1678                      ;;  wg-mode-line-decor-window-undedicated)
1679                      ;;(wg-add-face :div wg-mode-line-decor-divider)
1680                      (if (wg-session-modified (wg-current-session))
1681                          wg-mode-line-decor-session-modified
1682                        wg-mode-line-decor-session-unmodified)
1683                      (if (wg-workgroup-modified wg)
1684                          wg-mode-line-decor-workgroup-modified
1685                        wg-mode-line-decor-workgroup-unmodified)))
1686                 (:brace wg-mode-line-decor-right-brace)))
1687           (t (if wg-display-nowg
1688                  (wg-fontify " "
1689                    (:brace wg-mode-line-decor-left-brace)
1690                    (:mode wg-nowg-string)
1691                    (:brace wg-mode-line-decor-right-brace))
1692                "")))))
1693
1694 (defun wg-change-modeline ()
1695   "Add Workgroups' mode-line format to `mode-line-format'."
1696   (unless (assq 'wg-mode-line-display-on mode-line-format)
1697     (let ((format '(wg-mode-line-display-on (:eval (wg-mode-line-string))))
1698           (pos (or (cl-position 'mode-line-position mode-line-format) 10)))
1699       (set-default 'mode-line-format (-insert-at (1+ pos) format mode-line-format))
1700       (force-mode-line-update))))
1701
1702 (defun wg-remove-mode-line-display ()
1703   "Remove Workgroups' mode-line format from `mode-line-format'."
1704   (awhen (assq 'wg-mode-line-display-on mode-line-format)
1705     (set-default 'mode-line-format (remove it mode-line-format))
1706     (force-mode-line-update)))
1707
1708 (defun wg-add-workgroups-mode-minor-mode-entries ()
1709   "Add Workgroups' minor-mode entries.
1710 Adds entries to `minor-mode-list', `minor-mode-alist' and
1711 `minor-mode-map-alist'."
1712   (cl-pushnew 'workgroups-mode minor-mode-list)
1713   (cl-pushnew '(workgroups-mode wg-modeline-string) minor-mode-alist :test 'equal)
1714   (setq minor-mode-map-alist
1715         (cons (cons 'workgroups-mode (wg-make-workgroups-mode-map))
1716               (delete (assoc 'workgroups-mode minor-mode-map-alist)
1717                       minor-mode-map-alist))))
1718
1719 (defun wg-fill-keymap (keymap &rest binds)
1720   "Return KEYMAP after defining in it all keybindings in BINDS."
1721   (while binds
1722     (define-key keymap (car binds) (cadr binds))
1723     (setq binds (cddr binds)))
1724   keymap)
1725
1726 (defvar wg-prefixed-map
1727   (wg-fill-keymap
1728    (make-sparse-keymap)
1729
1730    ;; workgroups
1731    (kbd "C-c")        'wg-create-workgroup
1732    (kbd "c")          'wg-create-workgroup
1733    (kbd "C")          'wg-clone-workgroup
1734    (kbd "A")          'wg-rename-workgroup
1735    (kbd "C-'")        'wg-switch-to-workgroup
1736    (kbd "'")          'wg-switch-to-workgroup
1737    (kbd "C-v")        'wg-switch-to-workgroup
1738    (kbd "v")          'wg-switch-to-workgroup
1739
1740    ;; session
1741    (kbd "C-s")        'wg-save-session
1742    (kbd "C-w")        'wg-save-session-as
1743    (kbd "C-f")        'wg-open-session
1744
1745    ;; killing and yanking
1746    (kbd "C-k")        'wg-kill-workgroup
1747    (kbd "k")          'wg-kill-workgroup
1748    (kbd "M-W")        'wg-kill-ring-save-base-wconfig
1749    (kbd "M-w")        'wg-kill-ring-save-working-wconfig
1750    (kbd "C-y")        'wg-yank-wconfig
1751    (kbd "y")          'wg-yank-wconfig
1752    (kbd "M-k")        'wg-kill-workgroup-and-buffers
1753    (kbd "K")          'wg-delete-other-workgroups
1754
1755
1756    ;; workgroup switching
1757    (kbd "C-j")        'wg-switch-to-workgroup-at-index
1758    (kbd "j")          'wg-switch-to-workgroup-at-index
1759    (kbd "0")          'wg-switch-to-workgroup-at-index-0
1760    (kbd "1")          'wg-switch-to-workgroup-at-index-1
1761    (kbd "2")          'wg-switch-to-workgroup-at-index-2
1762    (kbd "3")          'wg-switch-to-workgroup-at-index-3
1763    (kbd "4")          'wg-switch-to-workgroup-at-index-4
1764    (kbd "5")          'wg-switch-to-workgroup-at-index-5
1765    (kbd "6")          'wg-switch-to-workgroup-at-index-6
1766    (kbd "7")          'wg-switch-to-workgroup-at-index-7
1767    (kbd "8")          'wg-switch-to-workgroup-at-index-8
1768    (kbd "9")          'wg-switch-to-workgroup-at-index-9
1769    (kbd "C-p")        'wg-switch-to-workgroup-left
1770    (kbd "p")          'wg-switch-to-workgroup-left
1771    (kbd "C-n")        'wg-switch-to-workgroup-right
1772    (kbd "n")          'wg-switch-to-workgroup-right
1773    (kbd "C-a")        'wg-switch-to-previous-workgroup
1774    (kbd "a")          'wg-switch-to-previous-workgroup
1775
1776
1777    ;; updating and reverting
1778    ;; wconfig undo/redo
1779    (kbd "C-r")        'wg-revert-workgroup
1780    (kbd "r")          'wg-revert-workgroup
1781    (kbd "C-S-r")      'wg-revert-all-workgroups
1782    (kbd "R")          'wg-revert-all-workgroups
1783    (kbd "<left>")     'wg-undo-wconfig-change
1784    (kbd "<right>")    'wg-redo-wconfig-change
1785    (kbd "[")          'wg-undo-wconfig-change
1786    (kbd "]")          'wg-redo-wconfig-change
1787    (kbd "{")          'wg-undo-once-all-workgroups
1788    (kbd "}")          'wg-redo-once-all-workgroups
1789
1790
1791    ;; wconfig save/restore
1792    (kbd "C-d C-s")    'wg-save-wconfig
1793    (kbd "C-d C-'")    'wg-restore-saved-wconfig
1794    (kbd "C-d C-k")    'wg-kill-saved-wconfig
1795
1796
1797    ;; workgroup movement
1798    (kbd "C-x")        'wg-swap-workgroups
1799    (kbd "C-,")        'wg-offset-workgroup-left
1800    (kbd "C-.")        'wg-offset-workgroup-right
1801
1802
1803    ;; window moving and frame reversal
1804    (kbd "|")          'wg-reverse-frame-horizontally
1805    (kbd "\\")         'wg-reverse-frame-vertically
1806    (kbd "/")          'wg-reverse-frame-horizontally-and-vertically
1807
1808
1809    ;; toggling
1810    (kbd "C-t C-m")    'wg-toggle-mode-line-display
1811    (kbd "C-t C-d")    'wg-toggle-window-dedicated-p
1812
1813
1814    ;; misc
1815    (kbd "!")          'wg-reset
1816    (kbd "?")          'wg-help
1817
1818    )
1819   "The keymap that sits on `wg-prefix-key'.")
1820
1821 (defun wg-make-workgroups-mode-map ()
1822   "Return Workgroups' minor-mode-map.
1823 This map includes `wg-prefixed-map' on `wg-prefix-key', as well
1824 as Workgroups' command remappings."
1825   (let ((map (make-sparse-keymap)))
1826     (define-key map wg-prefix-key
1827       wg-prefixed-map)
1828     (when (and (fboundp 'winner-undo)
1829                (fboundp 'winner-redo))
1830       (define-key map [remap winner-undo] 'wg-undo-wconfig-change)
1831       (define-key map [remap winner-redo] 'wg-redo-wconfig-change))
1832     (setq workgroups-mode-map map)))
1833
1834
1835 (defun wg-min-size (dir)
1836   "Return the minimum window size in split direction DIR."
1837   (if dir wg-window-min-height wg-window-min-width))
1838
1839 (defun wg-actual-min-size (dir)
1840   "Return the actual minimum window size in split direction DIR."
1841   (if dir wg-actual-min-height wg-actual-min-width))
1842
1843 (defmacro wg-with-edges (w spec &rest body)
1844   "Bind W's edge list to SPEC and eval BODY."
1845   (declare (indent 2))
1846   `(wg-dbind ,spec (wg-w-edges ,w) ,@body))
1847
1848 (defmacro wg-with-bounds (wtree dir spec &rest body)
1849   "Bind SPEC to W's bounds in DIR, and eval BODY.
1850 \"bounds\" are a direction-independent way of dealing with edge lists."
1851   (declare (indent 3))
1852   (wg-with-gensyms (dir-sym l1 t1 r1 b1)
1853     (wg-dbind (ls1 hs1 lb1 hb1) spec
1854       `(wg-with-edges ,wtree (,l1 ,t1 ,r1 ,b1)
1855          (cond (,dir (let ((,ls1 ,l1) (,hs1 ,r1) (,lb1 ,t1) (,hb1 ,b1))
1856                        ,@body))
1857                (t    (let ((,ls1 ,t1) (,hs1 ,b1) (,lb1 ,l1) (,hb1 ,r1))
1858                        ,@body)))))))
1859
1860 (defun wg-set-bounds (w dir ls hs lb hb)
1861   "Set W's edges in DIR with bounds LS HS LB and HB."
1862   (wg-set-edges w (if dir (list ls lb hs hb) (list lb ls hb hs))))
1863
1864 (defun wg-step-edges (edges1 edges2 hstep vstep)
1865   "Return W1's edges stepped once toward W2's by HSTEP and VSTEP."
1866   (wg-dbind (l1 t1 r1 b1) edges1
1867     (wg-dbind (l2 t2 r2 b2) edges2
1868       (let ((left (wg-step-to l1 l2 hstep))
1869             (top  (wg-step-to t1 t2 vstep)))
1870         (list left top
1871               (+ left (wg-step-to (- r1 l1) (- r2 l2) hstep))
1872               (+ top  (wg-step-to (- b1 t1) (- b2 t2) vstep)))))))
1873
1874 (defun wg-w-edge-operation (w edges op)
1875   "Return a copy of W with its edges mapped against EDGES through OP."
1876   (wg-set-edges w (cl-mapcar op (wg-w-edges w) edges)))
1877
1878 (defun wg-first-win (w)
1879   "Return the first actual window in W."
1880   (if (wg-win-p w) w
1881     (wg-first-win (car (wg-wtree-wlist w)))))
1882
1883 (defun wg-last-win (w)
1884   "Return the last actual window in W."
1885   (if (wg-win-p w) w
1886     (wg-last-win (-last-item (wg-wtree-wlist w)))))
1887
1888 (defun wg-minify-win (w)
1889   "Set W's edges to the smallest allowable."
1890   (let* ((edges (wg-w-edges w))
1891          (left (car edges))
1892          (top (cadr edges)))
1893     (wg-set-edges w (list left top
1894                           (+ left wg-actual-min-width)
1895                           (+ top  wg-actual-min-height)))))
1896
1897 (defun wg-minified-copy-of-last-win (w)
1898   "Minify a copy of the last actual window in W."
1899   (wg-minify-win (wg-copy-win (wg-last-win w))))
1900
1901 (defun wg-w-size (w &optional height)
1902   "Return the width or height of W, calculated from its edge list."
1903   (wg-with-edges w (l1 t1 r1 b1)
1904     (if height (- b1 t1) (- r1 l1))))
1905
1906 (defun wg-adjust-w-size (w width-fn height-fn &optional new-left new-top)
1907   "Adjust W's width and height with WIDTH-FN and HEIGHT-FN."
1908   (wg-with-edges w (left top right bottom)
1909     (let ((left (or new-left left)) (top (or new-top top)))
1910       (wg-set-edges (wg-copy-w w)
1911                     (list left
1912                           top
1913                           (+ left (funcall width-fn  (- right  left)))
1914                           (+ top  (funcall height-fn (- bottom top))))))))
1915
1916 (defun wg-scale-w-size (w width-scale height-scale)
1917   "Scale W's size by WIDTH-SCALE and HEIGHT-SCALE."
1918   (cl-labels
1919       ((wscale (width)  (truncate (* width  width-scale)))
1920        (hscale (height) (truncate (* height height-scale))))
1921     (wg-adjust-w-size w #'wscale #'hscale)))
1922
1923 (defun wg-restore-window (win)
1924   "Restore WIN in `selected-window'."
1925   (let ((selwin (selected-window))
1926         (buf (wg-find-buf-by-uid (wg-win-buf-uid win))))
1927     (if (not buf)
1928         (wg-restore-default-buffer)
1929       (when (wg-restore-buffer buf t)
1930
1931         ;; Restore various positions in WINDOW from their values in WIN
1932         ;; (wg-restore-window-positions win selwin)
1933         (let ((window (or selwin (selected-window))))
1934           (wg-with-slots win
1935               ((win-point wg-win-point)
1936                (win-start wg-win-start)
1937                (win-hscroll wg-win-hscroll))
1938             (set-window-start window win-start t)
1939             (set-window-hscroll window win-hscroll)
1940             (set-window-point
1941              window
1942              (cond ((not wg-restore-point) win-start)
1943                    ((eq win-point :max) (point-max))
1944                    (t win-point)))
1945             (when (>= win-start (point-max)) (recenter))))
1946
1947         (when wg-restore-window-dedicated-p
1948           (set-window-dedicated-p selwin (wg-win-dedicated win)))))
1949     (ignore-errors
1950       (set-window-prev-buffers
1951        selwin (wg-unpickel (wg-win-parameter win 'prev-buffers)))
1952       (set-window-next-buffers
1953        selwin (wg-unpickel (wg-win-parameter win 'next-buffers)))
1954       )))
1955
1956
1957 (defun wg-window-point (ewin)
1958   "Return `point' or :max.  See `wg-restore-point-max'.
1959 EWIN should be an Emacs window object."
1960   (let ((p (window-point ewin)))
1961     (if (and wg-restore-point-max (= p (point-max))) :max p)))
1962
1963 (defun wg-win-parameter (win parameter &optional default)
1964   "Return WIN's value for PARAMETER.
1965 If PARAMETER is not found, return DEFAULT which defaults to nil.
1966 SESSION nil defaults to the current session."
1967   (wg-aget (wg-win-parameters win) parameter default))
1968
1969 (defun wg-set-win-parameter (win parameter value)
1970   "Set WIN's value of PARAMETER to VALUE.
1971 SESSION nil means use the current session.
1972 Return value."
1973   (wg-set-parameter (wg-win-parameters win) parameter value)
1974   value)
1975 ;; (wg-win-parameters (wg-window-to-win (selected-window)))
1976
1977 (defun wg-remove-win-parameter (win parameter)
1978   "Remove parameter PARAMETER from WIN's parameters."
1979   (wg-asetf (wg-win-parameters win) (wg-aremove it parameter)))
1980
1981 (defun wg-window-to-win (&optional window)
1982   "Return the serialization (a wg-win) of Emacs window WINDOW."
1983   (let ((window (or window (selected-window)))
1984         (selected (eq window (selected-window)))
1985         win)
1986     (with-selected-window window
1987       (setq win
1988             (wg-make-win
1989              :edges              (window-edges window)
1990              :point              (wg-window-point window)
1991              :start              (window-start window)
1992              :hscroll            (window-hscroll window)
1993              :selected           selected
1994              :minibuffer-scroll  (eq window minibuffer-scroll-window)
1995              :dedicated          (window-dedicated-p window)
1996              :buf-uid            (wg-buffer-uid-or-add (window-buffer window))))
1997       (unless (version< emacs-version "24")
1998         ;; To solve: https://github.com/pashinin/workgroups2/issues/51
1999         ;; shouldn't ignore here
2000         (ignore-errors
2001           (wg-set-win-parameter
2002            win 'next-buffers (wg-pickel (remove nil (cl-subseq (window-next-buffers window) 0 4))))
2003           (wg-set-win-parameter
2004            win 'prev-buffers (wg-pickel (remove nil (cl-subseq (window-prev-buffers window) 0 4)))))))
2005     win))
2006
2007 (defun wg-toggle-window-dedicated-p ()
2008   "Toggle `window-dedicated-p' in `selected-window'."
2009   (interactive)
2010   (set-window-dedicated-p nil (not (window-dedicated-p)))
2011   (force-mode-line-update t)
2012   (wg-fontified-message
2013     (:cmd "Window:")
2014     (:cur (concat (unless (window-dedicated-p) " not") " dedicated"))))
2015
2016 (defun wg-w-edges (w)
2017   "Return W's edge list."
2018   (cl-etypecase w
2019     (wg-win (wg-win-edges w))
2020     (wg-wtree (wg-wtree-edges w))))
2021
2022 (defun wg-copy-w (w)
2023   "Return a copy of W.  W should be a wg-win or a wg-wtree."
2024   (cl-etypecase w
2025     (wg-win (wg-copy-win w))
2026     (wg-wtree (wg-copy-wtree w))))
2027
2028 (defun wg-set-edges (w edges)
2029   "Set W's EDGES list, and return W."
2030   (cl-etypecase w
2031     (wg-win (setf (wg-win-edges w) edges))
2032     (wg-wtree (setf (wg-wtree-edges w) edges)))
2033   w)
2034
2035 (defun wg-equal-wtrees (w1 w2)
2036   "Return t when W1 and W2 have equal structure."
2037   (cond ((and (wg-win-p w1) (wg-win-p w2))
2038          (equal (wg-w-edges w1) (wg-w-edges w2)))
2039         ((and (wg-wtree-p w1) (wg-wtree-p w2))
2040          (and (eq (wg-wtree-dir w1) (wg-wtree-dir w2))
2041               (equal (wg-wtree-edges w1) (wg-wtree-edges w2))
2042               (cl-every #'wg-equal-wtrees
2043                         (wg-wtree-wlist w1)
2044                         (wg-wtree-wlist w2))))))
2045
2046 (defun wg-normalize-wtree (wtree)
2047   "Clean up and return a new wtree from WTREE.
2048 Recalculate the edge lists of all subwins, and remove subwins
2049 outside of WTREE's bounds.  If there's only one element in the
2050 new wlist, return it instead of a new wtree."
2051   (if (wg-win-p wtree) wtree
2052     (wg-with-slots wtree ((dir wg-wtree-dir)
2053                           (wlist wg-wtree-wlist))
2054       (wg-with-bounds wtree dir (ls1 hs1 lb1 hb1)
2055         (let* ((min-size (wg-min-size dir))
2056                (max (- hb1 1 min-size))
2057                (lastw (-last-item wlist)))
2058           (cl-labels
2059               ((mapwl
2060                 (wl)
2061                 (wg-dbind (sw . rest) wl
2062                   (cons (wg-normalize-wtree
2063                          (wg-set-bounds
2064                           sw dir ls1 hs1 lb1
2065                           (setq lb1 (if (eq sw lastw) hb1
2066                                       (let ((hb2 (+ lb1 (wg-w-size sw dir))))
2067                                         (if (>= hb2 max) hb1 hb2))))))
2068                         (when (< lb1 max) (mapwl rest))))))
2069             (let ((new (mapwl wlist)))
2070               (if (not (cdr new)) (car new)
2071                 (setf (wg-wtree-wlist wtree) new)
2072                 wtree))))))))
2073
2074 (defun wg-scale-wtree (wtree wscale hscale)
2075   "Return a copy of WTREE with its dimensions scaled by WSCALE and HSCALE.
2076 All WTREE's subwins are scaled as well."
2077   (let ((scaled (wg-scale-w-size wtree wscale hscale)))
2078     (if (wg-win-p wtree) scaled
2079       (wg-asetf (wg-wtree-wlist scaled)
2080                 (wg-docar (sw it) (wg-scale-wtree sw wscale hscale)))
2081       scaled)))
2082
2083
2084 (defun wg-resize-frame-scale-wtree (wconfig)
2085   "Set FRAME's size to WCONFIG's, returning a possibly scaled wtree.
2086 If the frame size was set correctly, return WCONFIG's wtree
2087 unchanged.  If it wasn't, return a copy of WCONFIG's wtree scaled
2088 with `wg-scale-wconfigs-wtree' to fit the frame as it exists."
2089   (let ((frame (selected-frame)))
2090     (wg-with-slots wconfig ((wcwidth wg-wconfig-width)
2091                             (wcheight wg-wconfig-height))
2092       (when window-system (set-frame-size frame wcwidth wcheight))
2093       (let ((fwidth  (frame-parameter frame 'width))
2094             (fheight (frame-parameter frame 'height)))
2095         (if (and (= wcwidth fwidth) (= wcheight fheight))
2096             (wg-wconfig-wtree wconfig)
2097           (wg-scale-wconfigs-wtree wconfig fwidth fheight))))))
2098
2099 (defun wg-wtree-buf-uids (wtree)
2100   "Return a new list of the buf uids of all wins in WTREE."
2101   (if (not wtree)
2102       (error "WTREE is nil in `wg-wtree-buf-uids'!"))
2103   (wg-flatten-wtree wtree 'wg-win-buf-uid))
2104
2105
2106 (defun wg-wtree-unique-buf-uids (wtree)
2107   "Return a list of the unique buf uids of all wins in WTREE."
2108   (cl-remove-duplicates (wg-wtree-buf-uids wtree) :test 'string=))
2109
2110
2111 (defun wg-reset-window-tree ()
2112   "Delete all but one window in `selected-frame', and reset
2113 various parameters of that window in preparation for restoring
2114 a wtree."
2115   (delete-other-windows)
2116   (set-window-dedicated-p nil nil))
2117
2118 (defun wg-restore-window-tree-helper (w)
2119   "Recursion helper for `wg-restore-window-tree' W."
2120   (if (wg-wtree-p w)
2121       (cl-loop with dir = (wg-wtree-dir w)
2122                for (win . rest) on (wg-wtree-wlist w)
2123                do (when rest (split-window nil (wg-w-size win dir) (not dir)))
2124                do (wg-restore-window-tree-helper win))
2125     (wg-restore-window w)
2126     (when (wg-win-selected w)
2127       (setq wg-window-tree-selected-window (selected-window)))
2128     (when (wg-win-minibuffer-scroll w)
2129       (setq minibuffer-scroll-window (selected-window)))
2130     (other-window 1)))
2131
2132 (defun wg-restore-window-tree (wtree)
2133   "Restore WTREE in `selected-frame'."
2134   (let ((window-min-width wg-window-min-width)
2135         (window-min-height wg-window-min-height)
2136         (wg-window-tree-selected-window nil))
2137     (wg-reset-window-tree)
2138     (wg-restore-window-tree-helper wtree)
2139     (awhen wg-window-tree-selected-window (select-window it))))
2140
2141 (defun wg-window-tree-to-wtree (&optional window-tree)
2142   "Return the serialization (a wg-wtree) of Emacs window tree WINDOW-TREE."
2143   (wg-barf-on-active-minibuffer)
2144   (unless window-tree
2145     (setq window-tree (window-tree)))
2146   (cl-labels
2147       ((inner (w) (if (windowp w) (wg-window-to-win w)
2148                     (wg-dbind (dir edges . wins) w
2149                       (wg-make-wtree
2150                        :dir    dir
2151                        :edges  edges
2152                        :wlist  (mapcar #'inner wins))))))
2153     (let ((w (car window-tree)))
2154       (when (and (windowp w) (window-minibuffer-p w))
2155         (error "Workgroups can't operate on minibuffer-only frames."))
2156       (inner w))))
2157
2158
2159 (defun wg-flatten-wtree (wtree &optional key)
2160   "Return a new list by flattening WTREE.
2161 KEY non returns returns a list of WTREE's wins.
2162 KEY non-nil returns a list of the results of calling KEY on each win."
2163   (cl-labels
2164       ((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w))
2165                     (cl-mapcan #'inner (wg-wtree-wlist w)))))
2166     (inner wtree)))
2167
2168 (defun wg-reverse-wlist (w &optional dir)
2169   "Reverse W's wlist and those of all its sub-wtrees in direction DIR.
2170 If DIR is nil, reverse WTREE horizontally.
2171 If DIR is 'both, reverse WTREE both horizontally and vertically.
2172 Otherwise, reverse WTREE vertically."
2173   (cl-labels
2174       ((inner (w) (if (wg-win-p w) w
2175                     (wg-with-slots w ((d1 wg-wtree-dir))
2176                       (wg-make-wtree
2177                        :dir d1
2178                        :edges (wg-wtree-edges w)
2179                        :wlist (let ((wl2 (mapcar #'inner (wg-wtree-wlist w))))
2180                                 (if (or (eq dir 'both) (eq dir d1))
2181                                     (nreverse wl2)
2182                                   wl2)))))))
2183     (wg-normalize-wtree (inner w))))
2184
2185 (defun wg-wtree-move-window (wtree offset)
2186   "Offset `selected-window' OFFSET places in WTREE."
2187   (cl-labels
2188       ((inner (w) (if (wg-win-p w) w
2189                     (wg-with-slots w ((wlist wg-wtree-wlist))
2190                       (wg-make-wtree
2191                        :dir (wg-wtree-dir w)
2192                        :edges (wg-wtree-edges w)
2193                        :wlist (aif (cl-find t wlist :key 'wg-win-selected)
2194                                   (wg-cyclic-offset-elt it wlist offset)
2195                                 (mapcar #'inner wlist)))))))
2196     (wg-normalize-wtree (inner wtree))))
2197
2198 (defun wg-frame-to-wconfig (&optional frame)
2199   "Return the serialization (a wg-wconfig) of Emacs frame FRAME.
2200 FRAME nil defaults to `selected-frame'."
2201   (let* ((frame (or frame (selected-frame)))
2202          (fullscrn (frame-parameter frame 'fullscreen)))
2203     (wg-make-wconfig
2204      :left                  (frame-parameter frame 'left)
2205      :top                   (frame-parameter frame 'top)
2206      :width                 (frame-parameter frame 'width)
2207      :height                (frame-parameter frame 'height)
2208      :parameters            `((fullscreen . ,fullscrn))
2209      :vertical-scroll-bars  (frame-parameter frame 'vertical-scroll-bars)
2210      :scroll-bar-width      (frame-parameter frame 'scroll-bar-width)
2211      :wtree                 (wg-window-tree-to-wtree (window-tree frame))
2212      )))
2213
2214 (defun wg-current-wconfig ()
2215   "Return the current wconfig.
2216 If `wg-current-wconfig' is non-nil, return it.  Otherwise return
2217 `wg-frame-to-wconfig'."
2218   (or (frame-parameter nil 'wg-current-wconfig)
2219       (wg-frame-to-wconfig)))
2220
2221 (defmacro wg-with-current-wconfig (frame wconfig &rest body)
2222   "Eval BODY with WCONFIG current in FRAME.
2223 FRAME nil defaults to `selected-frame'."
2224   (declare (indent 2))
2225   (wg-with-gensyms (frame-sym old-value)
2226     `(let* ((,frame-sym (or ,frame (selected-frame)))
2227             (,old-value (frame-parameter ,frame-sym 'wg-current-wconfig)))
2228        (unwind-protect
2229            (progn
2230              (set-frame-parameter ,frame-sym 'wg-current-wconfig ,wconfig)
2231              ,@body)
2232          (when (frame-live-p ,frame-sym)
2233            (set-frame-parameter ,frame-sym 'wg-current-wconfig ,old-value))))))
2234
2235 (defun wg-make-blank-wconfig (&optional buffer)
2236   "Return a new blank wconfig.
2237 BUFFER or `wg-default-buffer' is visible in the only window."
2238   (save-window-excursion
2239     (delete-other-windows)
2240     (switch-to-buffer (or buffer wg-default-buffer))
2241     (wg-frame-to-wconfig)))
2242
2243 (defun wg-wconfig-move-window (wconfig offset)
2244   "Offset `selected-window' OFFSET places in WCONFIG."
2245   (wg-asetf (wg-wconfig-wtree wconfig) (wg-wtree-move-window it offset))
2246   wconfig)
2247
2248
2249 ;;; base wconfig updating
2250
2251 (defun wg-update-working-wconfig-on-delete-frame (frame)
2252   "Update FRAME's current workgroup's working-wconfig before
2253 FRAME is deleted, so we don't lose its state."
2254   (wg-flag-session-modified)
2255   (with-selected-frame frame
2256     (wg-update-current-workgroup-working-wconfig)))
2257
2258 (defun wg-update-working-wconfig-on-make-frame (frame)
2259   "Update FRAME's current workgroup's working-wconfig before
2260 FRAME is deleted, so we don't lose its state."
2261   (if (> (length (frame-list)) 1)
2262       (wg-flag-session-modified))
2263   ;;(with-selected-frame frame
2264   ;;  (wg-update-current-workgroup-working-wconfig))
2265   )
2266
2267 (defun wg-wconfig-buf-uids (wconfig)
2268   "Return WCONFIG's wtree's `wg-wtree-buf-uids'."
2269   (if (not (wg-wconfig-wtree wconfig))
2270       (error "WTREE is nil in `wg-wconfig-buf-uids'!"))
2271   (wg-wtree-unique-buf-uids (wg-wconfig-wtree wconfig)))
2272
2273
2274
2275
2276
2277 (defun wg-wconfig-restore-frame-position (wconfig &optional frame)
2278   "Use WCONFIG to restore FRAME's position.
2279 If frame is nil then `selected-frame'."
2280   (-when-let* ((left (wg-wconfig-left wconfig))
2281                (top (wg-wconfig-top wconfig)))
2282     ;; Check that arguments are integers
2283     ;; Problem: https://github.com/pashinin/workgroups2/issues/15
2284     (if (and (integerp left)
2285              (integerp top))
2286         (set-frame-position frame left top))))
2287
2288 (defun wg-wconfig-restore-scroll-bars (wconfig)
2289   "Restore `selected-frame's scroll-bar settings from WCONFIG."
2290   (set-frame-parameter
2291    nil 'vertical-scroll-bars (wg-wconfig-vertical-scroll-bars wconfig))
2292   (set-frame-parameter
2293    nil 'scroll-bar-width (wg-wconfig-scroll-bar-width wconfig)))
2294
2295 ;;(defun wg-wconfig-restore-fullscreen (wconfig)
2296 ;;  "Restore `selected-frame's fullscreen settings from WCONFIG."
2297 ;;  (set-frame-parameter
2298 ;;   nil 'fullscreen (wg-wconfig-parameters wconfig))
2299 ;;  )
2300
2301 (defun wg-scale-wconfigs-wtree (wconfig new-width new-height)
2302   "Scale WCONFIG's wtree with NEW-WIDTH and NEW-HEIGHT.
2303 Return a copy WCONFIG's wtree scaled with `wg-scale-wtree' by the
2304 ratio or NEW-WIDTH to WCONFIG's width, and NEW-HEIGHT to
2305 WCONFIG's height."
2306   (wg-normalize-wtree
2307    (wg-scale-wtree
2308     (wg-wconfig-wtree wconfig)
2309     (/ (float new-width)  (wg-wconfig-width wconfig))
2310     (/ (float new-height) (wg-wconfig-height wconfig)))))
2311
2312 (defun wg-scale-wconfig-to-frame (wconfig)
2313   "Scale WCONFIG buffers to fit current frame size.
2314 Return a scaled copy of WCONFIG."
2315   (interactive)
2316   (wg-scale-wconfigs-wtree wconfig
2317                            (frame-parameter nil 'width)
2318                            (frame-parameter nil 'height)))
2319
2320 (defun wg-frame-resize-and-position (wconfig &optional frame)
2321   "Apply WCONFIG's size and position to a FRAME."
2322   (interactive)
2323   (unless frame (setq frame (selected-frame)))
2324   (let* ((params (wg-wconfig-parameters wconfig))
2325          fullscreen)
2326     (set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params)
2327                                                (cdr (assoc 'fullscreen params))
2328                                              nil))
2329     (when (and wg-restore-frame-position
2330                (not (frame-parameter frame 'fullscreen)))
2331       (wg-wconfig-restore-frame-position wconfig frame))
2332     ))
2333
2334 (defun wg-restore-frame-size-position (wconfig &optional fs)
2335   "Smart-restore of frame size and position.
2336
2337 Depending on `wg-remember-frame-for-each-wg' frame parameters may
2338 be restored for each workgroup.
2339
2340 If `wg-remember-frame-for-each-wg' is nil (by default) then
2341 current frame parameters are saved/restored to/from first
2342 workgroup. And frame parameters for all other workgroups are just
2343 ignored.
2344 "
2345   (interactive)
2346   (let* ((params (wg-wconfig-parameters wconfig))
2347          fullscreen)
2348     ;; Frame maximized / fullscreen / none
2349     (unless wg-remember-frame-for-each-wg
2350       (setq params (wg-wconfig-parameters (wg-workgroup-working-wconfig (wg-first-workgroup)))))
2351     (setq fullscreen (if (assoc 'fullscreen params)
2352                          (cdr (assoc 'fullscreen params))
2353                        nil))
2354     (when (and fs
2355                fullscreen
2356                (or wg-remember-frame-for-each-wg
2357                    (null (wg-current-workgroup t))))
2358       (set-frame-parameter nil 'fullscreen fullscreen)
2359       ;; I had bugs restoring maximized frame:
2360       ;; Frame could be maximized but buffers are not scaled to fit it.
2361       ;;
2362       ;; Maybe because of `set-frame-parameter' takes some time to finish and is async.
2363       ;; So I tried this and it helped
2364       (sleep-for 0 100))
2365
2366     ;; Position
2367     (when (and wg-restore-frame-position
2368                wg-remember-frame-for-each-wg
2369                (not (frame-parameter nil 'fullscreen)))
2370       (wg-wconfig-restore-frame-position wconfig))
2371     ))
2372
2373
2374 (defun wg-restore-frames ()
2375   "Try to recreate opened frames, take info from session's 'frame-list parameter."
2376   (interactive)
2377   (delete-other-frames)
2378   (awhen (wg-current-session t)
2379     (let ((fl (wg-session-parameter 'frame-list nil it))
2380           (frame (selected-frame)))
2381       (mapc (lambda (wconfig)
2382               (with-selected-frame (make-frame)
2383                 ;;(wg-frame-resize-and-position wconfig)
2384                 ;;(wg-restore-frame-size-position wconfig)
2385                 ;;(wg-wconfig-restore-frame-position wconfig)
2386                 (wg-restore-wconfig wconfig)
2387                 )) fl)
2388       (select-frame-set-input-focus frame))))
2389
2390 ;; FIXME: throw a specific error if the restoration was unsuccessful
2391 (defun wg-restore-wconfig (wconfig &optional frame)
2392   "Restore a workgroup configuration WCONFIG in a FRAME.
2393 Runs each time you're switching workgroups."
2394   (unless frame (setq frame (selected-frame)))
2395   (let ((wg-record-incorrectly-restored-bufs t)
2396         (wg-incorrectly-restored-bufs nil)
2397         (params (wg-wconfig-parameters wconfig))
2398         fullscreen)
2399     (wg-barf-on-active-minibuffer)
2400     (when wg-restore-scroll-bars
2401       (wg-wconfig-restore-scroll-bars wconfig))
2402
2403     (when (null (wg-current-workgroup t))
2404       (set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params)
2405                                                  (cdr (assoc 'fullscreen params))
2406                                                nil)))
2407
2408     ;; Restore frame position
2409     (when (and wg-restore-frame-position
2410                (not (frame-parameter nil 'fullscreen))
2411                (null (wg-current-workgroup t)))
2412       (wg-wconfig-restore-frame-position wconfig frame))
2413
2414     ;; Restore buffers
2415     (wg-restore-window-tree (wg-scale-wconfig-to-frame wconfig))
2416
2417     (when wg-incorrectly-restored-bufs
2418       (message "Unable to restore these buffers: %S\
2419 If you want, restore them manually and try again."
2420                (mapcar 'wg-buf-name wg-incorrectly-restored-bufs)))))
2421
2422
2423 ;;; saved wconfig commands
2424
2425 (defun wg-save-wconfig ()
2426   "Save the current wconfig to the current workgroup's saved wconfigs."
2427   (interactive)
2428   (let* ((workgroup (wg-current-workgroup))
2429          (name (wg-read-saved-wconfig-name workgroup))
2430          (wconfig (wg-current-wconfig)))
2431     (setf (wg-wconfig-name wconfig) name)
2432     (wg-workgroup-save-wconfig wconfig workgroup)
2433     (wg-fontified-message
2434       (:cmd "Saved: ")
2435       (:cur name))))
2436
2437 (defun wg-restore-saved-wconfig ()
2438   "Restore one of the current workgroup's saved wconfigs in `selected-frame'."
2439   (interactive)
2440   (let ((workgroup (wg-current-workgroup)))
2441     (wg-restore-wconfig-undoably
2442      (wg-workgroup-get-saved-wconfig
2443       (wg-completing-read "Saved wconfig: "
2444                           (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup))
2445                           nil t)
2446       workgroup))))
2447
2448 (defun wg-kill-saved-wconfig ()
2449   "Kill one of the current workgroup's saved wconfigs.
2450 Also add it to the wconfig kill-ring."
2451   (interactive)
2452   (let* ((workgroup (wg-current-workgroup))
2453          (wconfig (wg-read-saved-wconfig workgroup)))
2454     (wg-workgroup-kill-saved-wconfig workgroup wconfig)
2455     (wg-add-to-wconfig-kill-ring wconfig)
2456     (wg-fontified-message
2457       (:cmd "Deleted: ")
2458       (:cur (wg-wconfig-name wconfig)))))
2459
2460
2461 (defun wg-reverse-wconfig (wconfig &optional dir)
2462   "Reverse WCONFIG's wtree's wlist in direction DIR."
2463   (wg-asetf (wg-wconfig-wtree wconfig) (wg-reverse-wlist it dir))
2464   wconfig)
2465
2466
2467 ;; specialbufs
2468 (defcustom wg-special-buffer-serdes-functions
2469   '(wg-serialize-comint-buffer
2470     )
2471   "Functions providing serialization/deserialization for complex buffers.
2472
2473 Use `wg-support' macro and this variable will be filled
2474 automatically.
2475
2476 An entry should be either a function symbol or a lambda, and should
2477 accept a single Emacs buffer object as an argument.
2478
2479 When a buffer is to be serialized, it is passed to each of these
2480 functions in turn until one returns non-nil, or the list ends.  A
2481 return value of nil indicates that the function can't handle
2482 buffers of that type.  A non-nil return value indicates that it
2483 can.  The first non-nil return value becomes the buffer's special
2484 serialization data.  The return value should be a cons, with a
2485 deserialization function (a function symbol or a lambda) as the car,
2486 and any other serialization data as the cdr.
2487
2488 When it comes time to deserialize the buffer, the deserialization
2489 function (the car of the cons mentioned above) is passed the
2490 wg-buf object, from which it should restore the buffer.  The
2491 special serialization data itself can be accessed
2492 with (cdr (wg-buf-special-data <wg-buf>)).  The deserialization
2493 function must return the restored Emacs buffer object.
2494
2495 See the definitions of the functions in this list for examples of
2496 how to write your own."
2497   :type 'alist
2498   :group 'workgroups)
2499
2500 ;; Dired
2501 (wg-support 'dired-mode 'dired
2502   `((deserialize . ,(lambda (buffer vars)
2503                       (when (or wg-restore-remote-buffers
2504                                 (not (file-remote-p default-directory)))
2505                         (let ((d (wg-get-first-existing-dir)))
2506                           (if (file-directory-p d) (dired d))))))))
2507
2508 ;; `Info-mode'     C-h i
2509 (wg-support 'Info-mode 'info
2510   `((save . (Info-current-file Info-current-node))
2511     (deserialize . ,(lambda (buffer vars)
2512                       ;;(with-current-buffer
2513                       ;;    (get-buffer-create (wg-buf-name buffer))
2514                       (aif vars
2515                           (if (fboundp 'Info-find-node)
2516                               (apply #'Info-find-node it))
2517                         (info)
2518                         (get-buffer (wg-buf-name buffer)))))))
2519
2520 ;; `help-mode'
2521 ;; Bug: https://github.com/pashinin/workgroups2/issues/29
2522 ;; bug in wg-get-value
2523 (wg-support 'help-mode 'help-mode
2524   `((save . (help-xref-stack-item help-xref-stack help-xref-forward-stack))
2525     (deserialize . ,(lambda (buffer vars)
2526                       (wg-dbind (item stack forward-stack) vars
2527                         (condition-case err
2528                             (apply (car item) (cdr item))
2529                           (error (message "%s" err)))
2530                         (awhen (get-buffer "*Help*")
2531                           (set-buffer it)
2532                           (wg-when-boundp (help-xref-stack help-xref-forward-stack)
2533                             (setq help-xref-stack stack
2534                                   help-xref-forward-stack forward-stack))))))))
2535
2536 ;; ielm
2537 (wg-support 'inferior-emacs-lisp-mode 'ielm
2538   `((deserialize . ,(lambda (buffer vars)
2539                       (ielm) (get-buffer "*ielm*")))))
2540
2541 ;; Magit status
2542 (wg-support 'magit-status-mode 'magit
2543   `((deserialize . ,(lambda (buffer vars)
2544                       (if (file-directory-p default-directory)
2545                           (magit-status default-directory)
2546                         (let ((d (wg-get-first-existing-dir)))
2547                           (if (file-directory-p d) (dired d))))))))
2548
2549 ;; Shell
2550 (wg-support 'shell-mode 'shell
2551   `((deserialize . ,(lambda (buffer vars)
2552                       (shell (wg-buf-name buffer))))))
2553
2554 ;; org-agenda buffer
2555 (defun wg-get-org-agenda-view-commands ()
2556   "Return commands to restore the state of Agenda buffer.
2557 Can be restored using \"(eval commands)\"."
2558   (interactive)
2559   (when (boundp 'org-agenda-buffer-name)
2560     (if (get-buffer org-agenda-buffer-name)
2561         (with-current-buffer org-agenda-buffer-name
2562           (let* ((p (or (and (looking-at "\\'") (1- (point))) (point)))
2563                  (series-redo-cmd (get-text-property p 'org-series-redo-cmd)))
2564             (if series-redo-cmd
2565                 (get-text-property p 'org-series-redo-cmd)
2566               (get-text-property p 'org-redo-cmd)))))))
2567
2568 (defun wg-run-agenda-cmd (f)
2569   "Run commands F in Agenda buffer.
2570 You can get these commands using `wg-get-org-agenda-view-commands'."
2571   (when (and (boundp 'org-agenda-buffer-name)
2572              (fboundp 'org-current-line)
2573              (fboundp 'org-goto-line))
2574     (if (get-buffer org-agenda-buffer-name)
2575         (save-window-excursion
2576           (with-current-buffer org-agenda-buffer-name
2577             (let* ((line (org-current-line)))
2578               (if f (eval f))
2579               (org-goto-line line)))))))
2580
2581 (wg-support 'org-agenda-mode 'org-agenda
2582   '((serialize . (lambda (buffer)
2583                    (wg-get-org-agenda-view-commands)))
2584     (deserialize . (lambda (buffer vars)
2585                      (org-agenda-list)
2586                      (awhen (get-buffer org-agenda-buffer-name)
2587                        (with-current-buffer it
2588                          (wg-run-agenda-cmd vars))
2589                        it)))))
2590
2591 ;; eshell
2592 (wg-support 'eshell-mode 'esh-mode
2593   '((deserialize . (lambda (buffer vars)
2594                      (prog1 (eshell t)
2595                        (rename-buffer (wg-buf-name buffer) t))))))
2596
2597 ;; term-mode
2598 ;;
2599 ;; This should work for `ansi-term's, too, as there doesn't seem to
2600 ;; be any difference between the two except how the name of the
2601 ;; buffer is generated.
2602 ;;
2603 (wg-support 'term-mode 'term
2604   `((serialize . ,(lambda (buffer)
2605                     (if (get-buffer-process buffer)
2606                         (-last-item (process-command (get-buffer-process buffer)))
2607                       "/bin/bash")))
2608     (deserialize . ,(lambda (buffer vars)
2609                       (cl-labels ((term-window-width () 80)
2610                                   (window-height () 24))
2611                         (prog1 (term vars)
2612                           (rename-buffer (wg-buf-name buffer) t)))))))
2613
2614 ;; `inferior-python-mode'
2615 (wg-support 'inferior-python-mode 'python
2616   `((save . (python-shell-interpreter python-shell-interpreter-args))
2617     (deserialize . ,(lambda (buffer vars)
2618                       (wg-dbind (pythoncmd pythonargs) vars
2619                         (run-python (concat pythoncmd " " pythonargs))
2620                         (awhen (get-buffer (process-buffer
2621                                             (python-shell-get-or-create-process)))
2622                           (with-current-buffer it (goto-char (point-max)))
2623                           it))))))
2624
2625
2626 ;; Sage shell ;;
2627 (wg-support 'inferior-sage-mode 'sage-mode
2628   `((deserialize . ,(lambda (buffer vars)
2629                       (save-window-excursion
2630                         (if (boundp' sage-command)
2631                             (run-sage t sage-command t)))
2632                       (if (boundp 'sage-buffer)
2633                           (awhen sage-buffer
2634                             (set-buffer it)
2635                             (switch-to-buffer sage-buffer)
2636                             (goto-char (point-max))))))))
2637
2638 ;; `inferior-ess-mode'     M-x R
2639 (wg-support 'inferior-ess-mode 'ess-inf
2640   `((save . (inferior-ess-program))
2641     (deserialize . ,(lambda (buffer vars)
2642                       (wg-dbind (cmd) vars
2643                         (let ((ess-ask-about-transfile nil)
2644                               (ess-ask-for-ess-directory nil)
2645                               (ess-history-file nil))
2646                           (R)
2647                           (get-buffer (wg-buf-name buffer))))))))
2648
2649 ;; `inferior-octave-mode'
2650 (wg-support 'inferior-octave-mode 'octave
2651   `((deserialize . ,(lambda (buffer vars)
2652                       (prog1 (run-octave)
2653                         (rename-buffer (wg-buf-name buffer) t))))))
2654
2655 ;; `prolog-inferior-mode'
2656 (wg-support 'prolog-inferior-mode 'prolog
2657   `((deserialize . ,(lambda (buffer vars)
2658                       (save-window-excursion
2659                         (run-prolog nil))
2660                       (switch-to-buffer "*prolog*")
2661                       (goto-char (point-max))))))
2662
2663 ;; `ensime-inf-mode'
2664 (wg-support 'ensime-inf-mode 'ensime
2665   `((deserialize . ,(lambda (buffer vars)
2666                       (save-window-excursion
2667                         (ensime-inf-switch))
2668                       (when (boundp 'ensime-inf-buffer-name)
2669                         (switch-to-buffer ensime-inf-buffer-name)
2670                         (goto-char (point-max)))))))
2671
2672 ;; compilation-mode
2673 ;;
2674 ;; I think it's not a good idea to compile a program just to switch
2675 ;; workgroups. So just restoring a buffer name.
2676 (wg-support 'compilation-mode 'compile
2677   `((serialize . ,(lambda (buffer)
2678                     (if (boundp' compilation-arguments) compilation-arguments)))
2679     (deserialize . ,(lambda (buffer vars)
2680                       (save-window-excursion
2681                         (get-buffer-create (wg-buf-name buffer)))
2682                       (with-current-buffer (wg-buf-name buffer)
2683                         (when (boundp' compilation-arguments)
2684                           (make-local-variable 'compilation-arguments)
2685                           (setq compilation-arguments vars)))
2686                       (switch-to-buffer (wg-buf-name buffer))
2687                       (goto-char (point-max))))))
2688
2689 ;; grep-mode
2690 ;; see grep.el - `compilation-start' - it is just a compilation buffer
2691 ;; local variables:
2692 ;; `compilation-arguments' == (cmd mode nil nil)
2693 (wg-support 'grep-mode 'grep
2694   `((serialize . ,(lambda (buffer)
2695                     (if (boundp' compilation-arguments) compilation-arguments)))
2696     (deserialize . ,(lambda (buffer vars)
2697                       (compilation-start (car vars) (nth 1 vars))
2698                       (switch-to-buffer "*grep*")))))
2699
2700
2701 ;; `speedbar-mode' (has bugs)
2702 ;; only from sr-speedbar.el
2703 ;;(wg-support 'speedbar-mode 'sr-speedbar
2704 ;;  `((deserialize . ,(lambda (buffer vars)
2705 ;;                      ;;(with-current-buffer (get-buffer-create "*SPEEDBAR*")
2706 ;;                        (with-no-warnings
2707 ;;                          (setq speedbar-buffer (get-buffer-create "*SPEEDBAR*"))
2708 ;;                          (setq speedbar-frame (selected-frame)
2709 ;;                                dframe-attached-frame (selected-frame)
2710 ;;                                speedbar-select-frame-method 'attached
2711 ;;                                speedbar-verbosity-level 0
2712 ;;                                speedbar-last-selected-file nil)
2713 ;;                          (set-buffer speedbar-buffer)
2714 ;;                          (speedbar-mode)
2715 ;;                          (speedbar-reconfigure-keymaps)
2716 ;;                          (speedbar-update-contents)
2717 ;;                          (speedbar-set-timer 1)
2718 ;;                          (aif (get-buffer-window "*SPEEDBAR*")
2719 ;;                              (set-window-dedicated-p it t))
2720 ;;                          (get-buffer-create "*SPEEDBAR*"))))))
2721
2722
2723 (defun wg-deserialize-slime-buffer (buf)
2724   "Deserialize `slime' buffer BUF."
2725   (when (require 'slime nil 'noerror)
2726     (wg-dbind (this-function args) (wg-buf-special-data buf)
2727       (let ((default-directory (car args))
2728             (arguments (nth 1 args)))
2729         (when (and (fboundp 'slime-start*)
2730                    (fboundp 'slime-process))
2731           (save-window-excursion
2732             (slime-start* arguments))
2733           (switch-to-buffer (process-buffer (slime-process)))
2734           (current-buffer))))))
2735
2736 ;; `comint-mode'  (general mode for all shells)
2737 ;;
2738 ;; It may have different shells. So we need to determine which shell is
2739 ;; now in `comint-mode' and how to restore it.
2740 ;;
2741 ;; Just executing `comint-exec' may be not enough because we can miss
2742 ;; some hooks or any other stuff that is executed when you run a
2743 ;; specific shell.
2744 (defun wg-serialize-comint-buffer (buffer)
2745   "Serialize comint BUFFER."
2746   (with-current-buffer buffer
2747     (if (fboundp 'comint-mode)
2748         (when (eq major-mode 'comint-mode)
2749           ;; `slime-inferior-lisp-args' var is used when in `slime'
2750           (when (and (boundp 'slime-inferior-lisp-args)
2751                      slime-inferior-lisp-args)
2752             (list 'wg-deserialize-slime-buffer
2753                   (list default-directory slime-inferior-lisp-args)
2754                   ))))))
2755
2756 ;; inf-mongo
2757 ;; https://github.com/tobiassvn/inf-mongo
2758 ;; `mongo-command' - command used to start inferior mongo
2759 (wg-support 'inf-mongo-mode 'inf-mongo
2760   `((serialize . ,(lambda (buffer)
2761                     (if (boundp 'inf-mongo-command) inf-mongo-command)))
2762     (deserialize . ,(lambda (buffer vars)
2763                       (save-window-excursion
2764                         (when (fboundp 'inf-mongo)
2765                           (inf-mongo vars)))
2766                       (when (get-buffer "*mongo*")
2767                         (switch-to-buffer "*mongo*")
2768                         (goto-char (point-max)))))))
2769
2770 (defun wg-temporarily-rename-buffer-if-exists (buffer)
2771   "Rename BUFFER if it exists."
2772   (when (get-buffer buffer)
2773     (with-current-buffer buffer
2774       (rename-buffer "*wg--temp-buffer*" t))))
2775
2776 ;; SML shell
2777 ;; Functions to serialize deserialize inferior sml buffer
2778 ;; `inf-sml-program' is the program run as inferior sml, is the
2779 ;; `inf-sml-args' are the extra parameters passed, `inf-sml-host'
2780 ;; is the host on which sml was running when serialized
2781 (wg-support 'inferior-sml-mode 'sml-mode
2782   `((serialize . ,(lambda (buffer)
2783                     (list (if (boundp 'sml-program-name) sml-program-name)
2784                           (if (boundp 'sml-default-arg) sml-default-arg)
2785                           (if (boundp 'sml-host-name) sml-host-name))))
2786     (deserialize . ,(lambda (buffer vars)
2787                       (wg-dbind (program args host) vars
2788                         (save-window-excursion
2789                           ;; If a inf-sml buffer already exists rename it temporarily
2790                           ;; otherwise `run-sml' will simply switch to the existing
2791                           ;; buffer, however we want to create a separate buffer with
2792                           ;; the serialized name
2793                           (let* ((inf-sml-buffer-name (concat "*"
2794                                                               (file-name-nondirectory program)
2795                                                               "*"))
2796                                  (existing-sml-buf (wg-temporarily-rename-buffer-if-exists
2797                                                     inf-sml-buffer-name)))
2798                             (with-current-buffer (run-sml program args host)
2799                               ;; Rename the buffer
2800                               (rename-buffer (wg-buf-name buffer) t)
2801
2802                               ;; Now we can re-rename the previously renamed buffer
2803                               (when existing-sml-buf
2804                                 (with-current-buffer existing-sml-buf
2805                                   (rename-buffer inf-sml-buffer-name t))))))
2806                         (switch-to-buffer (wg-buf-name buffer))
2807                         (goto-char (point-max)))))))
2808
2809 ;; Geiser repls
2810 ;; http://www.nongnu.org/geiser/
2811 (wg-support 'geiser-repl-mode 'geiser
2812   `((save . (geiser-impl--implementation))
2813     (deserialize . ,(lambda (buffer vars)
2814                       (when (fboundp 'run-geiser)
2815                         (wg-dbind (impl) vars
2816                           (run-geiser impl)
2817                           (goto-char (point-max))))
2818                       (switch-to-buffer (wg-buf-name buffer))))))
2819
2820 ;; w3m-mode
2821 (wg-support 'w3m-mode 'w3m
2822   `((save . (w3m-current-url))
2823     (deserialize . ,(lambda (buffer vars)
2824                       (wg-dbind (url) vars
2825                         (w3m-goto-url url))))))
2826
2827 ;; notmuch
2828 (wg-support 'notmuch-hello-mode 'notmuch
2829   `((deserialize . ,(lambda (buffer vars)
2830                       (notmuch)
2831                       (get-buffer (wg-buf-name buffer))))))
2832
2833 ;; Wanderlust modes:
2834 ;; WL - folders
2835 ;;(defun wg-deserialize-wl-folders-buffer (buf)
2836 ;;  ""
2837 ;;  (if (fboundp 'wl)
2838 ;;      (wg-dbind (this-function) (wg-buf-special-data buf)
2839 ;;        ;;(when (not (eq major-mode 'wl-folder-mode))
2840 ;;        (wl)
2841 ;;        (goto-char (point-max))
2842 ;;        (current-buffer)
2843 ;;        )))
2844 ;;
2845 ;;(defun wg-serialize-wl-folders-buffer (buffer)
2846 ;;  ""
2847 ;;  (if (fboundp 'wl)
2848 ;;      (with-current-buffer buffer
2849 ;;        (when (eq major-mode 'wl-folder-mode)
2850 ;;          (list 'wg-deserialize-wl-folders-buffer
2851 ;;                )))))
2852
2853 ;; WL - summary mode (list of mails)
2854 ;;(defun wg-deserialize-wl-summary-buffer (buf)
2855 ;;  ""
2856 ;;  (interactive)
2857 ;;  (if (fboundp 'wl)
2858 ;;      (wg-dbind (this-function param-list) (wg-buf-special-data buf)
2859 ;;        (when (not (eq major-mode 'wl-summary-mode))
2860 ;;          (let ((fld-name (car param-list)))
2861 ;;            ;;(switch-to-buffer "*scratch*")
2862 ;;            ;;(wl)
2863 ;;            ;;(wl-folder-jump-folder fld-name)
2864 ;;            ;;(message fld-name)
2865 ;;            ;;(goto-char (point-max))
2866 ;;            ;;(insert fld-name)
2867 ;;            (current-buffer)
2868 ;;          )))))
2869 ;;
2870 ;;(defun wg-serialize-wl-summary-buffer (buffer)
2871 ;;  ""
2872 ;;  (if (fboundp 'wl)
2873 ;;      (with-current-buffer buffer
2874 ;;        (when (eq major-mode 'wl-summary-mode)
2875 ;;          (list 'wg-deserialize-wl-summary-buffer
2876 ;;                (wg-take-until-unreadable (list wl-summary-buffer-folder-name))
2877 ;;                )))))
2878 ;;
2879 ;;
2880 ;;;; mime-view-mode
2881 ;;
2882 ;;(defun wg-deserialize-mime-view-buffer (buf)
2883 ;;  ""
2884 ;;  (wg-dbind (this-function) (wg-buf-special-data buf)
2885 ;;    (when (not (eq major-mode 'mime-view-mode))
2886 ;;      ;;(wl-summary-enter-handler 3570)     ; only in wl-summary-mode
2887 ;;      ;;(wl-summary-enter-handler)     ; only in wl-summary-mode
2888 ;;      (current-buffer)
2889 ;;      )))
2890 ;;
2891 ;;(defun wg-serialize-mime-view-buffer (buffer)
2892 ;;  ""
2893 ;;  (with-current-buffer buffer
2894 ;;    (when (eq major-mode 'mime-view-mode)
2895 ;;      (list 'wg-deserialize-mime-view-buffer
2896 ;;            ))))
2897
2898
2899 ;; emms-playlist-mode
2900 ;;
2901 ;; Help me on this one:
2902 ;; 1. How to start emms without any user interaction?
2903 ;;
2904 ;;(defun wg-deserialize-emms-buffer (buf)
2905 ;;  "Deserialize emms-playlist buffer BUF."
2906 ;;  (when (require 'emms-setup nil 'noerror)
2907 ;;    (require 'emms-player-mplayer)
2908 ;;    (emms-standard)
2909 ;;    (emms-default-players)
2910 ;;    (if (fboundp 'emms-playlist-mode)
2911 ;;        (wg-dbind (this-function args) (wg-buf-special-data buf)
2912 ;;          (let ((default-directory (car args)))
2913 ;;            (save-window-excursion
2914 ;;              ;;(emms)
2915 ;;              (if (or (null emms-playlist-buffer)
2916 ;;                      (not (buffer-live-p emms-playlist-buffer)))
2917 ;;                  ;;(call-interactively 'emms-add-file)
2918 ;;                  (emms-source-directory "/usr/data/disk_3/Music/SORT/")
2919 ;;                ))
2920 ;;            ;; (emms)
2921 ;;            ;;(with-current-buffer emms-playlist-buffer-name
2922 ;;            ;;(emms-source-playlist-directory-tree "/usr/data/disk_3/Music/SORT/")
2923 ;;            ;;(emms-source-directory "/usr/data/disk_3/Music/SORT")
2924 ;;            ;;(switch-to-buffer emms-playlist-buffer-name)
2925 ;;            (emms-playlist-mode-go)
2926 ;;            (current-buffer)
2927 ;;            )))))
2928 ;;
2929 ;;(defun wg-serialize-emms-buffer (buffer)
2930 ;;  "Serialize emms BUFFER."
2931 ;;  (with-current-buffer buffer
2932 ;;    (if (fboundp 'emms-playlist-mode)
2933 ;;        (when (eq major-mode 'emms-playlist-mode)
2934 ;;          (list 'wg-deserialize-emms-buffer
2935 ;;                (wg-take-until-unreadable (list default-directory))
2936 ;;                )))))
2937
2938
2939 ;;; buffer-local variable serdes
2940
2941 (defun wg-serialize-buffer-mark-ring ()
2942   "Return a new list of the positions of the marks in `mark-ring'."
2943   (mapcar 'marker-position mark-ring))
2944
2945 (defun wg-deserialize-buffer-mark-ring (positions)
2946   "Set `mark-ring' to a new list of markers created from POSITIONS."
2947   (setq mark-ring
2948         (mapcar (lambda (pos) (set-marker (make-marker) pos))
2949                 positions)))
2950
2951 (defun wg-deserialize-buffer-major-mode (major-mode-symbol)
2952   "Conditionally retore MAJOR-MODE-SYMBOL in `current-buffer'."
2953   (and (fboundp major-mode-symbol)
2954        (not (eq major-mode-symbol major-mode))
2955        (funcall major-mode-symbol)))
2956
2957 (defun wg-deserialize-buffer-local-variables (buf)
2958   "Restore BUF's buffer local variables in `current-buffer'."
2959   (cl-loop for ((var . val) . rest) on (wg-buf-local-vars buf)
2960            do (awhen (assq var wg-buffer-local-variables-alist)
2961                 (wg-dbind (var ser des) it
2962                   (if des (funcall des val)
2963                     (set var val))))))
2964
2965 (defmacro wg-workgroup-list ()
2966   "Setf'able `wg-current-session' modified slot accessor."
2967   `(wg-session-workgroup-list (wg-current-session)))
2968
2969 (defmacro wg-buf-list ()
2970   "Setf'able `wg-current-session' buf-list slot accessor."
2971   `(wg-session-buf-list (wg-current-session)))
2972
2973 (defun wg-restore-default-buffer (&optional switch)
2974   "Return `wg-default-buffer' and maybe SWITCH to it."
2975   (if switch
2976       (switch-to-buffer wg-default-buffer t)
2977     (get-buffer-create wg-default-buffer)))
2978
2979 (defun wg-restore-existing-buffer (buf &optional switch)
2980   "Return existing buffer from BUF and maybe SWITCH to it."
2981   (-when-let (b (wg-find-buf-in-buffer-list buf (wg-buffer-list-emacs)))
2982     (if switch (switch-to-buffer b t))
2983     (with-current-buffer b
2984       (wg-set-buffer-uid-or-error (wg-buf-uid buf))
2985       b)))
2986
2987 (defun wg-restore-file-buffer (buf &optional switch)
2988   "Restore BUF by finding its file and maybe SWITCH to it.
2989 Return the created buffer.
2990 If BUF's file doesn't exist, call `wg-restore-default-buffer'"
2991   ;;(-when-let ((file-name (wg-buf-file-name buf)))
2992   (let ((file-name (wg-buf-file-name buf)))
2993     (when (and file-name
2994                (or wg-restore-remote-buffers
2995                    (not (file-remote-p file-name))))
2996       (cond ((file-exists-p file-name)
2997              ;; jit ignore errors
2998              ;;(ignore-errors
2999              (condition-case err
3000                  (let ((b (find-file-noselect file-name nil nil nil)))
3001                    (with-current-buffer b
3002                      (rename-buffer (wg-buf-name buf) t)
3003                      (wg-set-buffer-uid-or-error (wg-buf-uid buf))
3004                      (when wg-restore-mark
3005                        (set-mark (wg-buf-mark buf))
3006                        (deactivate-mark))
3007                      (wg-deserialize-buffer-local-variables buf)
3008                      )
3009                    (if switch (switch-to-buffer b))
3010                    b)
3011                (error
3012                 (message "Error while restoring a file %s:\n  %s" file-name (error-message-string err))
3013                 nil)))
3014             (t
3015              ;; try directory
3016              (if (file-directory-p (file-name-directory file-name))
3017                  (dired (file-name-directory file-name))
3018                (progn
3019                  (message "Attempt to restore nonexistent file: %S" file-name)
3020                  nil))
3021              )))))
3022
3023 (defun wg-restore-special-buffer (buf &optional switch)
3024   "Restore a buffer BUF with DESERIALIZER-FN and maybe SWITCH to it."
3025   (-when-let*
3026       ((special-data (wg-buf-special-data buf))
3027        (buffer (save-window-excursion
3028                  (condition-case err
3029                      (funcall (car special-data) buf)
3030                    (error (message "Error deserializing %S: %S" (wg-buf-name buf) err)
3031                           nil)))))
3032     (if switch (switch-to-buffer buffer t))
3033     (with-current-buffer buffer
3034       (wg-set-buffer-uid-or-error (wg-buf-uid buf)))
3035     buffer))
3036
3037 (defun wg-restore-buffer (buf &optional switch)
3038   "Restore BUF, return it and maybe SWITCH to it."
3039   (when buf
3040   (fset 'buffer-list wg-buffer-list-original)
3041   (prog1
3042       (or (wg-restore-existing-buffer buf switch)
3043           (wg-restore-special-buffer buf switch)  ;; non existent dired problem
3044           (wg-restore-file-buffer buf switch)
3045           (progn (wg-restore-default-buffer switch) nil))
3046     (if wg-mess-with-buffer-list
3047         (fset 'buffer-list wg-buffer-list-function)))))
3048
3049
3050
3051 ;;; buffer object utils
3052
3053 (defun wg-completing-read (prompt choices &optional pred require-match initial-input history default)
3054   "Do a completing read.  Use `ido-mode` if enabled."
3055   (if ido-mode
3056       (ido-completing-read prompt choices pred require-match
3057                            initial-input history default)
3058     (completing-read prompt choices pred require-match
3059                      initial-input history default)))
3060
3061 (defun wg-buffer-uid (buffer-or-name)
3062   "Return BUFFER-OR-NAME's buffer-local value of `wg-buffer-uid'."
3063   (buffer-local-value 'wg-buffer-uid (wg-get-buffer buffer-or-name)))
3064
3065 (defun wg-bufobj-uid (bufobj)
3066   "Return BUFOBJ's uid."
3067   (cl-etypecase bufobj
3068     (buffer (wg-buffer-uid bufobj))
3069     (wg-buf (wg-buf-uid bufobj))
3070     (string (wg-bufobj-uid (wg-get-buffer bufobj)))))
3071
3072 (defun wg-bufobj-name (bufobj)
3073   "Return BUFOBJ's buffer name."
3074   (cl-etypecase bufobj
3075     (buffer (buffer-name bufobj))
3076     (wg-buf (wg-buf-name bufobj))
3077     (string (wg-buffer-name bufobj))))
3078
3079 (defun wg-bufobj-file-name (bufobj)
3080   "Return BUFOBJ's filename."
3081   (cl-etypecase bufobj
3082     (buffer (buffer-file-name bufobj))
3083     (wg-buf (wg-buf-file-name bufobj))
3084     (string (wg-bufobj-file-name (wg-get-buffer bufobj)))))
3085
3086 (defun wg-buf-major-mode (buf)
3087   "Return BUF's `major-mode'.
3088 It's stored in BUF's local-vars list, since it's a local variable."
3089   (wg-aget (wg-buf-local-vars buf) 'major-mode))
3090
3091 (defun wg-buffer-major-mode (bufobj)
3092   "Return BUFOBJ's `major-mode'.
3093 It works with Emacs buffer, Workgroups buffer object and a simple string."
3094   (cl-etypecase bufobj
3095     (buffer (wg-buffer-major-mode bufobj))
3096     (wg-buf (wg-buf-major-mode bufobj))
3097     (string (wg-buffer-major-mode bufobj))))
3098
3099 ;; `wg-equal-bufobjs' and `wg-find-bufobj' may need to be made a lot smarter
3100 (defun wg-equal-bufobjs (bufobj1 bufobj2)
3101   "Return t if BUFOBJ1 is \"equal\" to BUFOBJ2."
3102   (let ((fname1 (wg-bufobj-file-name bufobj1))
3103         (fname2 (wg-bufobj-file-name bufobj2)))
3104     (cond ((and fname1 fname2) (string= fname1 fname2))
3105           ((or fname1 fname2) nil)
3106           ((string= (wg-bufobj-name bufobj1) (wg-bufobj-name bufobj2)) t))))
3107
3108 (defun wg-find-bufobj (bufobj bufobj-list)
3109   "Find BUFOBJ in BUFOBJ-LIST, testing with `wg-equal-bufobjs'."
3110   (cl-find bufobj bufobj-list :test 'wg-equal-bufobjs))
3111
3112 (defun wg-find-bufobj-by-uid (uid bufobj-list)
3113   "Find the bufobj in BUFOBJ-LIST with uid UID."
3114   (cl-find uid bufobj-list :test 'string= :key 'wg-bufobj-uid))
3115
3116 (defun wg-find-buffer-in-buf-list (buffer-or-name buf-list)
3117   "Find BUFFER-OR-NAME in BUF-LIST."
3118   (aif (wg-buffer-uid buffer-or-name)
3119       (wg-find-bufobj-by-uid it buf-list)
3120     (wg-find-bufobj buffer-or-name buf-list)))
3121
3122 (defun wg-find-buf-in-buffer-list (buf buffer-list)
3123   "Find BUF in BUFFER-LIST."
3124   (or (wg-find-bufobj-by-uid (wg-buf-uid buf) buffer-list)
3125       (wg-find-bufobj buf buffer-list)))
3126
3127 (defun wg-find-buf-by-uid (uid)
3128   "Find a buf in `wg-buf-list' by UID."
3129   (when uid
3130     (wg-find-bufobj-by-uid uid (wg-buf-list))))
3131
3132 (defun wg-set-buffer-uid-or-error (uid &optional buffer)
3133   "Change UID value of a BUFFER's local var `wg-buffer-uid'.
3134 If BUFFER already has a buffer local value of `wg-buffer-uid',
3135 and it's not equal to UID, error."
3136   (if wg-buffer-uid
3137       ;;(if (string= wg-buffer-uid uid) uid
3138       ;;  (error "uids don't match %S and %S" uid wg-buffer-uid))
3139       (setq wg-buffer-uid uid)))
3140
3141
3142 (defun wg-buffer-special-data (buffer)
3143   "Return BUFFER's auxiliary serialization, or nil."
3144   (cl-some (lambda (fn) (funcall fn buffer)) wg-special-buffer-serdes-functions))
3145
3146
3147 (defun wg-serialize-buffer-local-variables ()
3148   "Return an alist of buffer-local variable symbols and their values.
3149 See `wg-buffer-local-variables-alist' for details."
3150   (wg-docar (entry wg-buffer-local-variables-alist)
3151     (wg-dbind (var ser des) entry
3152       (when (local-variable-p var)
3153         (cons var (if ser (funcall ser) (symbol-value var)))))))
3154
3155 (defun wg-buffer-to-buf (buffer)
3156   "Return the serialization (a wg-buf) of Emacs buffer BUFFER."
3157   (with-current-buffer buffer
3158     (wg-make-buf
3159      :name           (buffer-name)
3160      :file-name      (buffer-file-name)
3161      :point          (point)
3162      :mark           (mark)
3163      :local-vars     (wg-serialize-buffer-local-variables)
3164      :special-data   (wg-buffer-special-data buffer))))
3165
3166 (defun wg-add-buffer-to-buf-list (buffer)
3167   "Make a buf from BUFFER, and add it to `wg-buf-list' if necessary.
3168 If there isn't already a buf corresponding to BUFFER in
3169 `wg-buf-list', make one and add it.  Return BUFFER's uid
3170 in either case."
3171   (when buffer
3172   (with-current-buffer buffer
3173     (setq wg-buffer-uid
3174           (aif (wg-find-buffer-in-buf-list buffer (wg-buf-list))
3175               (wg-buf-uid it)
3176             (let ((buf (wg-buffer-to-buf buffer)))
3177               (push buf (wg-buf-list))
3178               (wg-buf-uid buf)))))))
3179
3180 (defun wg-buffer-uid-or-add (buffer)
3181   "Return BUFFER's uid.
3182 If there isn't already a buf corresponding to BUFFER in
3183 `wg-buf-list', make one and add it."
3184   (or (wg-buffer-uid buffer) (wg-add-buffer-to-buf-list buffer)))
3185
3186 (defun wg-bufobj-uid-or-add (bufobj)
3187   "If BUFOBJ is a wg-buf, return its uid.
3188 If BUFOBJ is a buffer or a buffer name, see `wg-buffer-uid-or-add'."
3189   (cl-etypecase bufobj
3190     (wg-buf (wg-buf-uid bufobj)) ;; possibly also add to `wg-buf-list'
3191     (buffer (wg-buffer-uid-or-add bufobj))
3192     (string (wg-bufobj-uid-or-add (wg-get-buffer bufobj)))))
3193
3194 (defun wg-reset-buffer (buffer)
3195   "Return BUFFER.
3196 Currently only sets BUFFER's `wg-buffer-uid' to nil."
3197   (with-current-buffer buffer (setq wg-buffer-uid nil)))
3198
3199 (defun wg-update-buffer-in-buf-list (&optional buffer)
3200   "Update BUFFER's corresponding buf in `wg-buf-list'.
3201 BUFFER nil defaults to `current-buffer'."
3202   (let ((buffer (or buffer (current-buffer))))
3203     (-when-let* ((uid (wg-buffer-uid buffer))
3204                  (old-buf (wg-find-buf-by-uid uid))
3205                  (new-buf (wg-buffer-to-buf buffer)))
3206       (setf (wg-buf-uid new-buf) (wg-buf-uid old-buf))
3207       (wg-asetf (wg-buf-list) (cons new-buf (remove old-buf it))))))
3208
3209 (defvar wg-just-exited-minibuffer nil
3210   "Flag set by `minibuffer-exit-hook'.
3211 To exempt from undoification those window-configuration changes
3212 caused by exiting the minibuffer.  This is ugly, but necessary.
3213 It may seem like we could just null out
3214 `wg-undoify-window-configuration-change' in
3215 `minibuffer-exit-hook', but that also prevents undoification of
3216 window configuration changes triggered by commands called with
3217 `execute-extended-command' -- i.e. it's just too coarse.")
3218
3219 (defcustom wg-no-confirm-on-destructive-operation nil
3220   "Do not request confirmation before various destructive operations."
3221   :type 'boolean
3222   :group 'workgroups)
3223
3224 (defcustom wg-minibuffer-message-timeout 0.75
3225   "Bound to `minibuffer-message-timeout' when messaging while the
3226 minibuffer is active."
3227   :type 'float
3228   :group 'workgroups)
3229
3230 (defun wg-read-object (prompt test warning &optional initial-contents keymap
3231                               read hist default-value inherit-input-method)
3232   "PROMPT for an object that satisfies TEST.  WARNING if necessary.
3233 INITIAL-CONTENTS KEYMAP READ HIST DEFAULT-VALUE
3234 INHERIT-INPUT-METHOD are `read-from-minibuffer's args."
3235   (cl-labels ((read () (read-from-minibuffer
3236                         prompt initial-contents keymap read hist
3237                         default-value inherit-input-method)))
3238     (let ((obj (read)))
3239       (when (and (equal obj "") default-value) (setq obj default-value))
3240       (while (not (funcall test obj))
3241         (message warning)
3242         (sit-for wg-minibuffer-message-timeout)
3243         (setq obj (read)))
3244       obj)))
3245
3246 (defun wg-read-new-workgroup-name (&optional prompt)
3247   "Read a non-empty name string from the minibuffer.
3248 Print PROMPT"
3249   (let ((default (wg-new-default-workgroup-name)))
3250     (wg-read-object
3251      (or prompt (format "Name (default: %S): " default))
3252      (lambda (new) (and (stringp new)
3253                         (not (equal new ""))
3254                         (wg-unique-workgroup-name-p new)))
3255      "Please enter a unique, non-empty name"
3256      nil nil nil nil default)))
3257
3258 (defun wg-read-workgroup-index ()
3259   "Prompt for the index of a workgroup."
3260   (let ((max (1- (length (wg-workgroup-list-or-error)))))
3261     (wg-read-object
3262      (format "%s\n\nEnter [0-%d]: " (wg-workgroup-list-display) max)
3263      (lambda (obj) (and (integerp obj) (wg-within obj 0 max t)))
3264      (format "Please enter an integer [%d-%d]" 0 max)
3265      nil nil t)))
3266
3267 (defun wg-minibuffer-inactive-p ()
3268   "Return t when `minibuffer-depth' is zero, nil otherwise."
3269   (zerop (minibuffer-depth)))
3270
3271 (defun wg-barf-on-active-minibuffer ()
3272   "Throw an error when the minibuffer is active."
3273   (when (not (wg-minibuffer-inactive-p))
3274     (error "Exit minibuffer to use workgroups functions!")))
3275
3276 (defvar wg-deactivation-list nil
3277   "A stack of workgroups that are currently being switched away from.
3278 Used to avoid associating the old workgroup's buffers with the
3279 new workgroup during a switch.")
3280
3281 (defun wg-flag-session-modified (&optional session)
3282   "Set SESSION's modified flag."
3283   (when (and wg-flag-modified
3284              (or session (wg-current-session t)))
3285     (setf (wg-session-modified (or session (wg-current-session t))) t)))
3286
3287 (defun wg-flag-workgroup-modified (&optional workgroup)
3288   "Set WORKGROUP's and the current session's modified flags."
3289   (unless workgroup
3290     (setq workgroup (wg-get-workgroup nil t)))
3291   (when (and wg-flag-modified workgroup)
3292     (setf (wg-workgroup-modified workgroup) t)
3293     (wg-flag-session-modified)))
3294
3295 (defun wg-current-workgroup (&optional noerror frame)
3296   "Return current workgroup in frame.
3297 Error unless NOERROR, in FRAME if specified."
3298   (or wg-current-workgroup
3299       (aif (frame-parameter frame 'wg-current-workgroup-uid)
3300           (wg-find-workgroup-by :uid it noerror)
3301         (unless noerror (error "No current workgroup in this frame")))))
3302
3303 (defun wg-previous-workgroup (&optional noerror frame)
3304   "Return the previous workgroup in FRAME, or error unless NOERROR."
3305   (aif (frame-parameter frame 'wg-previous-workgroup-uid)
3306       (wg-find-workgroup-by :uid it noerror)
3307     (unless noerror (error "No previous workgroup in this frame"))))
3308
3309 (defun wg-set-current-workgroup (workgroup &optional frame)
3310   "Set the current workgroup to WORKGROUP in FRAME.
3311 WORKGROUP should be a workgroup or nil."
3312   (set-frame-parameter frame 'wg-current-workgroup-uid
3313                        (when workgroup (wg-workgroup-uid workgroup))))
3314
3315 (defun wg-set-previous-workgroup (workgroup &optional frame)
3316   "Set the previous workgroup to WORKGROUP in FRAME.
3317 WORKGROUP should be a workgroup or nil."
3318   (set-frame-parameter frame 'wg-previous-workgroup-uid
3319                        (when workgroup (wg-workgroup-uid workgroup))))
3320
3321 (defun wg-current-workgroup-p (workgroup &optional frame)
3322   "Return t when WORKGROUP is the current workgroup, nil otherwise."
3323   (awhen (wg-current-workgroup t frame)
3324     (eq workgroup it)))
3325
3326 (defun wg-previous-workgroup-p (workgroup &optional frame)
3327   "Return t when WORKGROUP is the previous workgroup, nil otherwise."
3328   (awhen (wg-previous-workgroup t frame)
3329     (eq workgroup it)))
3330
3331 (defun wg-get-workgroup (obj &optional noerror)
3332   "Return a workgroup from OBJ.
3333 If OBJ is a workgroup, return it.
3334 If OBJ is a string, return the workgroup named OBJ, or error unless NOERROR.
3335 If OBJ is nil, return the current workgroup, or error unless NOERROR."
3336   (cond ((wg-workgroup-p obj) obj)
3337         ((stringp obj) (wg-find-workgroup-by :name obj noerror))
3338         ((null obj) (wg-current-workgroup noerror))
3339         (t (error "Can't get workgroup from type:: %S" (type-of obj)))))
3340
3341
3342 ;;; workgroup parameters
3343 ;;
3344 ;; Quick test:
3345 ;; (wg-workgroup-parameters (wg-current-workgroup))
3346 ;; (wg-set-workgroup-parameter (wg-current-workgroup) 'test1 t)
3347 ;; (wg-workgroup-parameter (wg-current-workgroup) 'test1)
3348 (defun wg-workgroup-parameter (workgroup parameter &optional default)
3349   "Return WORKGROUP's value for PARAMETER.
3350 If PARAMETER is not found, return DEFAULT which defaults to nil.
3351 WORKGROUP should be accepted by `wg-get-workgroup'."
3352   (wg-aget (wg-workgroup-parameters (wg-get-workgroup workgroup))
3353            parameter default))
3354
3355 (defun wg-set-workgroup-parameter (parameter value &optional workgroup)
3356   "Set PARAMETER to VALUE in a WORKGROUP.
3357 WORKGROUP should be a value accepted by `wg-get-workgroup'.
3358 Return VALUE."
3359   (-when-let (workgroup (wg-get-workgroup (or workgroup (wg-current-workgroup t)) t))
3360     (wg-set-parameter (wg-workgroup-parameters workgroup) parameter value)
3361     (wg-flag-workgroup-modified workgroup)
3362     value))
3363
3364 (defun wg-remove-workgroup-parameter (parameter &optional workgroup)
3365   "Remove PARAMETER from WORKGROUP's parameters."
3366   (-when-let (workgroup (wg-get-workgroup workgroup t))
3367     (wg-flag-workgroup-modified workgroup)
3368     (wg-asetf (wg-workgroup-parameters workgroup) (wg-aremove it parameter))))
3369
3370 (defun wg-workgroup-local-value (variable &optional workgroup)
3371   "Return the value of VARIABLE in WORKGROUP.
3372 WORKGROUP nil defaults to the current workgroup.  If there is no
3373 current workgroup, or if VARIABLE does not have a workgroup-local
3374 binding in WORKGROUP, resolve VARIABLE with `wg-session-local-value'."
3375   (let ((workgroup (wg-get-workgroup workgroup t)))
3376     (if (not workgroup) (wg-session-local-value variable)
3377       (let* ((undefined (cl-gensym))
3378              (value (wg-workgroup-parameter workgroup variable undefined)))
3379         (if (not (eq value undefined)) value
3380           (wg-session-local-value variable))))))
3381 (defalias 'wg-local-value 'wg-workgroup-local-value)
3382
3383
3384 (defun wg-workgroup-saved-wconfig-names (workgroup)
3385   "Return a new list of the names of all WORKGROUP's saved wconfigs."
3386   (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup)))
3387
3388 (defun wg-workgroup-get-saved-wconfig (wconfig-or-name &optional workgroup)
3389   "Return the wconfig by WCONFIG-OR-NAME from WORKGROUP's saved wconfigs.
3390 WCONFIG-OR-NAME must be either a string or a wconfig.  If
3391 WCONFIG-OR-NAME is a string and there is no saved wconfig with
3392 that name, return nil.  If WCONFIG-OR-NAME is a wconfig, and it
3393 is a member of WORKGROUP's saved wconfigs, return is as given.
3394 Otherwise return nil."
3395   (let ((wconfigs (wg-workgroup-saved-wconfigs (or workgroup (wg-current-workgroup)))))
3396     (cl-etypecase wconfig-or-name
3397       (wg-wconfig (car (memq wconfig-or-name wconfigs)))
3398       (string (cl-find wconfig-or-name wconfigs
3399                        :key 'wg-wconfig-name
3400                        :test 'string=)))))
3401
3402 (defun wg-workgroup-save-wconfig (wconfig &optional workgroup)
3403   "Add WCONFIG to WORKGROUP's saved wconfigs.
3404 WCONFIG must have a name.  If there's already a wconfig with the
3405 same name in WORKGROUP's saved wconfigs, replace it."
3406   (let ((name (wg-wconfig-name wconfig)))
3407     (unless name (error "Attempt to save a nameless wconfig"))
3408     (setf (wg-workgroup-modified workgroup) t)
3409     (wg-asetf (wg-workgroup-saved-wconfigs workgroup)
3410               (cons wconfig (cl-remove name it
3411                                        :key 'wg-wconfig-name
3412                                        :test 'string=)))))
3413
3414 (defun wg-workgroup-kill-saved-wconfig (workgroup wconfig-or-name)
3415   "Delete WCONFIG-OR-NAME from WORKGROUP's saved wconfigs.
3416 WCONFIG-OR-NAME is resolved with `wg-workgroup-get-saved-wconfig'."
3417   (-when-let (wconfig (wg-workgroup-get-saved-wconfig
3418                        workgroup wconfig-or-name))
3419     (wg-asetf (wg-workgroup-saved-wconfigs workgroup) (remq wconfig it)
3420               (wg-workgroup-modified workgroup) t)))
3421
3422
3423
3424 (defun wg-workgroup-base-wconfig-buf-uids (workgroup)
3425   "Return a new list of all unique buf uids in WORKGROUP's working wconfig."
3426   (wg-wconfig-buf-uids (wg-workgroup-base-wconfig workgroup)))
3427
3428 (defun wg-workgroup-saved-wconfigs-buf-uids (workgroup)
3429   "Return a new list of all unique buf uids in WORKGROUP's base wconfig."
3430   (cl-reduce 'wg-string-list-union
3431              (wg-workgroup-saved-wconfigs workgroup)
3432              :key 'wg-wconfig-buf-uids))
3433
3434 (defun wg-workgroup-all-wconfig-buf-uids (workgroup)
3435   "Return a new list of all unique buf uids in WORKGROUP's wconfigs."
3436   (cl-union (wg-workgroup-base-wconfig-buf-uids workgroup)
3437             (wg-workgroup-saved-wconfigs-buf-uids workgroup)
3438             :test 'string=))
3439
3440 (defun wg-workgroup-all-buf-uids (workgroup)
3441   "Return a new list of all unique buf uids in WORKGROUP."
3442   (cl-reduce 'wg-string-list-union
3443              (list (wg-workgroup-base-wconfig-buf-uids workgroup)
3444                    (wg-workgroup-saved-wconfigs-buf-uids workgroup))))
3445
3446 (defun wg-restore-workgroup (workgroup)
3447   "Restore WORKGROUP in `selected-frame'."
3448   (let (wg-flag-modified)
3449     (wg-restore-wconfig-undoably (wg-workgroup-working-wconfig workgroup) t)))
3450
3451 (defun wg-workgroup-list-or-error (&optional noerror)
3452   "Return the value of `wg-current-session's :workgroup-list slot.
3453 Or scream unless NOERROR."
3454   (aif (wg-current-session noerror)
3455       (or (wg-session-workgroup-list it)
3456           (unless noerror (error "No workgroups are defined.")))
3457     (unless noerror (error "Current session is nil. No workgroups are defined"))))
3458
3459 (defun wg-find-workgroup-by (slotkey value &optional noerror)
3460   "Return the workgroup on which ACCESSOR returns VALUE or error."
3461   (let ((accessor (cl-ecase slotkey
3462                     (:name 'wg-workgroup-name)
3463                     (:uid  'wg-workgroup-uid))))
3464     (or (cl-find value (wg-workgroup-list-or-error noerror) :test 'equal :key accessor)
3465         (unless noerror
3466           (error "There are no workgroups with a %S of %S"
3467                  accessor value)))))
3468
3469 (defun wg-cyclic-nth-from-workgroup (workgroup &optional n)
3470   "Return the workgroup N places from WORKGROUP in `wg-workgroup-list'."
3471   (wg-cyclic-nth-from-elt workgroup (wg-workgroup-list-or-error) (or n 1)))
3472
3473 (defun wg-workgroup-names (&optional noerror)
3474   "Return a list of workgroup names or scream unless NOERROR."
3475   (mapcar 'wg-workgroup-name (wg-workgroup-list-or-error noerror)))
3476
3477 (defun wg-read-workgroup-name (&optional require-match)
3478   "Read a workgroup name from `wg-workgroup-names'.
3479 REQUIRE-MATCH to match."
3480   (wg-completing-read "Workgroup: " (wg-workgroup-names) nil require-match nil nil
3481                       (awhen (wg-current-workgroup t) (wg-workgroup-name it))))
3482
3483 (defun wg-new-default-workgroup-name ()
3484   "Return a new, unique, default workgroup name."
3485   (let ((names (wg-workgroup-names t)) (index -1) result)
3486     (while (not result)
3487       (let ((new-name (format "wg%s" (cl-incf index))))
3488         (unless (member new-name names)
3489           (setq result new-name))))
3490     result))
3491
3492 (defun wg-unique-workgroup-name-p (new-name)
3493   "Return t if NEW-NAME is unique in `wg-workgroup-list', nil otherwise."
3494   (cl-every (lambda (existing-name) (not (equal new-name existing-name)))
3495             (wg-workgroup-names t)))
3496
3497 (defun wg-read-saved-wconfig-name (workgroup &optional prompt require-match)
3498   "Read the name of a saved wconfig, completing on the names of
3499 WORKGROUP's saved wconfigs."
3500   (wg-completing-read (or prompt "Saved wconfig name: ")
3501                       (wg-workgroup-saved-wconfig-names workgroup)
3502                       nil require-match))
3503
3504 (defun wg-read-saved-wconfig (workgroup)
3505   "Read the name of and return one of WORKGROUP's saved wconfigs."
3506   (wg-workgroup-get-saved-wconfig
3507    workgroup (wg-read-saved-wconfig-name workgroup nil t)))
3508
3509
3510 ;;; workgroup-list reorganization commands
3511
3512 (defun wg-swap-workgroups ()
3513   "Swap the previous and current workgroups."
3514   (interactive)
3515   (wg-swap-workgroups-in-workgroup-list
3516    (wg-current-workgroup) (wg-previous-workgroup))
3517   (wg-fontified-message
3518     (:cmd "Swapped:  ")
3519     (wg-workgroup-list-display)))
3520
3521 (defun wg-offset-workgroup-left (&optional workgroup n)
3522   "Offset WORKGROUP leftward in `wg-workgroup-list' cyclically."
3523   (interactive (list nil current-prefix-arg))
3524   (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n -1))
3525   (wg-fontified-message
3526     (:cmd "Offset left: ")
3527     (wg-workgroup-list-display)))
3528
3529 (defun wg-offset-workgroup-right (&optional workgroup n)
3530   "Offset WORKGROUP rightward in `wg-workgroup-list' cyclically."
3531   (interactive (list nil current-prefix-arg))
3532   (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n 1))
3533   (wg-fontified-message
3534     (:cmd "Offset right: ")
3535     (wg-workgroup-list-display)))
3536
3537
3538 ;;; undo/redo commands
3539
3540 (defun wg-undo-wconfig-change (&optional workgroup)
3541   "Undo a change to the current workgroup's window-configuration."
3542   (interactive)
3543   (let* ((workgroup (wg-get-workgroup workgroup))
3544          (undid? (wg-workgroup-offset-position-in-undo-list workgroup 1)))
3545     (wg-fontified-message
3546       (:cmd "Undo")
3547       (:cur (if undid? "" "  No more undo info")))))
3548
3549 (defun wg-redo-wconfig-change (&optional workgroup)
3550   "Redo a change to the current workgroup's window-configuration."
3551   (interactive)
3552   (let* ((workgroup (wg-get-workgroup workgroup))
3553          (redid? (wg-workgroup-offset-position-in-undo-list workgroup -1)))
3554     (wg-fontified-message
3555       (:cmd "Redo")
3556       (:cur (if redid? "" "  No more redo info")))))
3557
3558 (defun wg-undo-once-all-workgroups ()
3559   "Do what the name says.  Useful for instance when you
3560 accidentally call `wg-revert-all-workgroups' and want to return
3561 all workgroups to their un-reverted state."
3562   (interactive)
3563   (mapc 'wg-undo-wconfig-change (wg-workgroup-list-or-error))
3564   (wg-message "Undid once on all workgroups."))
3565
3566 (defun wg-redo-once-all-workgroups ()
3567   "Do what the name says.  Probably useless.  Included for
3568 symetry with `wg-undo-once-all-workgroups'."
3569   (interactive)
3570   (mapc 'wg-redo-wconfig-change (wg-workgroup-list-or-error))
3571   (wg-message "Redid once on all workgroups."))
3572
3573
3574
3575 ;;; window-tree commands
3576 ;;
3577 ;; TODO: These are half-hearted.  Clean them up; allow specification of the
3578 ;; window-tree depth at which to operate; add complex window creation commands;
3579 ;; and add window splitting, deletion and locking commands.
3580
3581 (defun wg-reverse-frame-horizontally (&optional workgroup)
3582   "Reverse the order of all horizontally split wtrees."
3583   (interactive)
3584   (wg-restore-wconfig-undoably
3585    (wg-reverse-wconfig
3586     (wg-workgroup-working-wconfig
3587      (wg-get-workgroup workgroup)))))
3588
3589 (defun wg-reverse-frame-vertically (&optional workgroup)
3590   "Reverse the order of all vertically split wtrees."
3591   (interactive)
3592   (wg-restore-wconfig-undoably
3593    (wg-reverse-wconfig
3594     (wg-workgroup-working-wconfig
3595      (wg-get-workgroup workgroup))
3596     t)))
3597
3598 (defun wg-reverse-frame-horizontally-and-vertically (&optional workgroup)
3599   "Reverse the order of all wtrees."
3600   (interactive)
3601   (wg-restore-wconfig-undoably
3602    (wg-reverse-wconfig
3603     (wg-workgroup-working-wconfig
3604      (wg-get-workgroup workgroup))
3605     'both)))
3606
3607 (defun wg-rename-workgroup (newname &optional workgroup)
3608   "Set NEWNAME to WORKGROUP's name."
3609   (interactive (list (wg-read-new-workgroup-name "New name: ") nil))
3610   (-when-let (workgroup (wg-get-workgroup workgroup))
3611     (let* ((oldname (wg-workgroup-name workgroup)))
3612       (setf (wg-workgroup-name workgroup) newname)
3613       (wg-flag-workgroup-modified workgroup)
3614       (wg-fontified-message
3615         (:cmd "Renamed: ")
3616         (:cur oldname)
3617         (:msg " to ")
3618         (:cur (wg-workgroup-name workgroup))))))
3619
3620 (defun wg-reset (&optional force)
3621   "Reset Workgroups.
3622 Resets all frame parameters, buffer-local vars, the current
3623 Workgroups session object, etc."
3624   (interactive "P")
3625   (unless (or force wg-no-confirm-on-destructive-operation
3626               (y-or-n-p "Really reset Workgroups? "))
3627     (error "Canceled"))
3628   (wg-reset-internal)
3629   (wg-fontified-message (:cmd "Reset: ") (:msg "Workgroups")))
3630
3631 (defun wg-query-and-save-if-modified ()
3632   "Query for save when `wg-modified-p'."
3633   (or (not (wg-modified-p))
3634       (when (y-or-n-p "Save modified workgroups? ")
3635         (wg-save-session))))
3636
3637 (defun wg-create-workgroup (name &optional blank)
3638   "Create and add a workgroup named NAME.
3639 Optional argument BLANK non-nil (set interactively with a prefix
3640 arg) means use a blank, one window window-config.  Otherwise use
3641 the current window-configuration.  Keep in mind that even though
3642 the current window-config may be used, other parameters of the
3643 current workgroup are not copied to the created workgroup.  For
3644 that, use `wg-clone-workgroup'."
3645   (interactive (list (wg-read-new-workgroup-name) current-prefix-arg))
3646   (wg-switch-to-workgroup (wg-make-and-add-workgroup name blank))
3647   (wg-fontified-message
3648     (:cmd "Created: ") (:cur name) "  " (wg-workgroup-list-display)))
3649
3650 (defun wg-clone-workgroup (workgroup name)
3651   "Create and add a clone of WORKGROUP named NAME.
3652 Keep in mind that only WORKGROUP's top level alist structure is
3653 copied, so destructive operations on the keys or values of
3654 WORKGROUP will be reflected in the clone, and vice-versa.  Be
3655 safe -- don't mutate them."
3656   (interactive (list nil (wg-read-new-workgroup-name)))
3657   (let* ((workgroup (wg-get-workgroup workgroup))
3658          (clone (wg-copy-workgroup workgroup)))
3659     (setf (wg-workgroup-name clone) name
3660           (wg-workgroup-uid clone) (wg-generate-uid))
3661     (when (wg-check-and-add-workgroup clone)
3662       (wg-flag-workgroup-modified clone))
3663     (wg-set-workgroup-working-wconfig
3664      clone (wg-workgroup-working-wconfig workgroup))
3665     (wg-switch-to-workgroup clone)
3666     (wg-fontified-message
3667       (:cmd "Cloned: ")
3668       (:cur (wg-workgroup-name workgroup))
3669       (:msg " to ")
3670       (:cur name) "  "
3671       (wg-workgroup-list-display))))
3672
3673 (defun wg-switch-to-workgroup (workgroup &optional noerror)
3674   "Switch to WORKGROUP.
3675 NOERROR means fail silently."
3676   (interactive (list (wg-read-workgroup-name)))
3677   (fset 'buffer-list wg-buffer-list-original)
3678   (let ((workgroup (wg-get-workgroup-create workgroup))
3679         (current (wg-current-workgroup t)))
3680     (when (and (eq workgroup current) (not noerror))
3681       (error "Already on: %s" (wg-workgroup-name current)))
3682     (when current (push current wg-deactivation-list))
3683     (unwind-protect
3684         (progn
3685           ;; Before switch
3686           (run-hooks 'wg-before-switch-to-workgroup-hook)
3687           ;; Save info about some hard-to-work-with libraries
3688           (let (wg-flag-modified)
3689             (wg-set-workgroup-parameter 'ecb (and (boundp 'ecb-minor-mode)
3690                                                   ecb-minor-mode)))
3691           ;;(wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config (ecb-current-window-configuration))
3692           ;; (type-of (ecb-current-window-configuration))
3693           ;; (type-of (car (ecb-current-window-configuration)))
3694           ;; (type-of (car (nthcdr 3 (ecb-current-window-configuration))))
3695           ;; (wg-pickelable-or-error (ecb-current-window-configuration))
3696           ;;(ecb-current-window-configuration)
3697           ;;)
3698
3699           ;; Before switching - turn off ECB
3700           ;; https://github.com/pashinin/workgroups2/issues/34
3701           (if (and (boundp 'ecb-minor-mode)
3702                    (boundp 'ecb-frame)
3703                    (fboundp 'ecb-deactivate)
3704                    ecb-minor-mode
3705                    (equal ecb-frame (selected-frame)))
3706               (let ((ecb-split-edit-window-after-start 'before-deactivation))
3707                 (ecb-deactivate)))
3708
3709           ;; Switch
3710           (wg-restore-workgroup workgroup)
3711           (wg-set-previous-workgroup current)
3712           (wg-set-current-workgroup workgroup)
3713
3714           ;; After switch
3715           ;; Save "last-workgroup" to the session params
3716           (let (wg-flag-modified)
3717             (awhen (wg-current-workgroup t)
3718               (wg-set-session-parameter 'last-workgroup (wg-workgroup-name it)))
3719             (awhen (wg-previous-workgroup t)
3720               (wg-set-session-parameter 'prev-workgroup (wg-workgroup-name it))))
3721
3722           ;; If a workgroup had ECB - turn it on
3723           (if (and (boundp 'ecb-minor-mode)
3724                    (not ecb-minor-mode)
3725                    (fboundp 'ecb-activate)
3726                    (wg-workgroup-parameter (wg-current-workgroup t) 'ecb nil))
3727               (let ((ecb-split-edit-window-after-start 'before-deactivation))
3728                 (ecb-activate)))
3729           ;;(ecb-last-window-config-before-deactivation
3730           ;; (wg-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config nil)))
3731
3732           ;; `sr-speedbar'
3733           ;; if *SPEEDBAR* buffer is visible - set some variables
3734           (let* ((buffers (mapcar 'window-buffer (window-list)))
3735                  (buffer-names (mapcar 'buffer-name buffers)))
3736             (when (and (featurep 'sr-speedbar)
3737                        (member sr-speedbar-buffer-name buffer-names))
3738               (setq sr-speedbar-window (get-buffer-window sr-speedbar-buffer-name))))
3739
3740           ;; Finally
3741           (if wg-mess-with-buffer-list
3742               (fset 'buffer-list wg-buffer-list-function))
3743           (wg-fontified-message (:cmd "Switched: ") (wg-workgroup-name (wg-current-workgroup t)))
3744           (run-hooks 'wg-after-switch-to-workgroup-hook))
3745       (when current (pop wg-deactivation-list)))))
3746
3747 (defun wg-switch-to-workgroup-at-index (index)
3748   "Switch to the workgroup at INDEX in `wg-workgroup-list'."
3749   (interactive (list (or current-prefix-arg (wg-read-workgroup-index))))
3750   (let ((wl (wg-workgroup-list-or-error)))
3751     (wg-switch-to-workgroup
3752      (or (nth index wl) (error "There are only %d workgroups" (length wl))))))
3753
3754 (cl-macrolet
3755     ((define-range-of-switch-to-workgroup-at-index (num)
3756        `(progn
3757           ,@(wg-docar (i (wg-range 0 num))
3758               `(defun ,(intern (format "wg-switch-to-workgroup-at-index-%d" i)) ()
3759                  ,(format "Switch to the workgroup at index %d." i)
3760                  (interactive)
3761                  (wg-switch-to-workgroup-at-index ,i))))))
3762   (define-range-of-switch-to-workgroup-at-index 10))
3763
3764 (defun wg-switch-to-cyclic-nth-from-workgroup (workgroup n)
3765   "Switch N workgroups cyclically from WORKGROUP in `wg-workgroup-list.'"
3766   (let ((workgroup-list (wg-workgroup-list-or-error))
3767         (workgroup (wg-get-workgroup workgroup t)))
3768     (wg-switch-to-workgroup
3769      (cond ((not workgroup) (car workgroup-list))
3770            ((= 1 (length workgroup-list)) (error "There's only one workgroup"))
3771            (t (wg-cyclic-nth-from-workgroup workgroup n))))))
3772
3773 (defun wg-switch-to-workgroup-left (&optional workgroup n)
3774   "Switch to WORKGROUP that is (- N) places away from WORKGROUP in `wg-workgroup-list'.
3775 Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."
3776   (interactive (list nil current-prefix-arg))
3777   (wg-switch-to-cyclic-nth-from-workgroup workgroup (- (or n 1))))
3778
3779 (defun wg-switch-to-workgroup-right (&optional workgroup n)
3780   "Switch to the workgroup N places from WORKGROUP in `wg-workgroup-list'.
3781 Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."
3782   (interactive (list nil current-prefix-arg))
3783   (wg-switch-to-cyclic-nth-from-workgroup workgroup (or n 1)))
3784
3785 (defun wg-switch-to-previous-workgroup ()
3786   "Switch to the previous workgroup."
3787   (interactive)
3788   (wg-switch-to-workgroup (wg-previous-workgroup)))
3789
3790 (defun wg-wconfig-kill-ring ()
3791   "Return `wg-wconfig-kill-ring', creating it first if necessary."
3792   (or wg-wconfig-kill-ring
3793       (setq wg-wconfig-kill-ring (make-ring wg-wconfig-kill-ring-max))))
3794
3795 (defun wg-add-to-wconfig-kill-ring (wconfig)
3796   "Add WCONFIG to `wg-wconfig-kill-ring'."
3797   (ring-insert (wg-wconfig-kill-ring) wconfig))
3798
3799 (defun wg-kill-workgroup (&optional workgroup)
3800   "Kill WORKGROUP, saving its working-wconfig to the kill ring."
3801   (interactive)
3802   (let* ((workgroup (wg-get-workgroup workgroup))
3803          (to (or (wg-previous-workgroup t)
3804                  (wg-cyclic-nth-from-workgroup workgroup))))
3805     (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))
3806     (wg-delete-workgroup workgroup)
3807     (if (eq workgroup to) (wg-restore-wconfig (wg-make-blank-wconfig))
3808       (wg-switch-to-workgroup to))
3809     (wg-fontified-message
3810       (:cmd "Killed: ")
3811       (:cur (wg-workgroup-name workgroup)) "  "
3812       (wg-workgroup-list-display))))
3813
3814 (defun wg-kill-ring-save-base-wconfig (&optional workgroup)
3815   "Save WORKGROUP's base wconfig to the kill ring."
3816   (interactive)
3817   (let ((workgroup (wg-get-workgroup workgroup)))
3818     (wg-add-to-wconfig-kill-ring (wg-workgroup-base-wconfig workgroup))
3819     (wg-fontified-message
3820       (:cmd "Saved: ") (:cur (wg-workgroup-name workgroup))
3821       (:cur "'s ") (:msg "base wconfig to the kill ring"))))
3822
3823 (defun wg-kill-ring-save-working-wconfig (&optional workgroup)
3824   "Save WORKGROUP's working-wconfig to `wg-wconfig-kill-ring'."
3825   (interactive)
3826   (let ((workgroup (wg-get-workgroup workgroup)))
3827     (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))
3828     (wg-fontified-message
3829       (:cmd "Saved: ") (:cur (wg-workgroup-name workgroup))
3830       (:cur "'s ") (:msg "working-wconfig to the kill ring"))))
3831
3832 (defun wg-yank-wconfig ()
3833   "Restore a wconfig from `wg-wconfig-kill-ring'.
3834 Successive yanks restore wconfigs sequentially from the kill
3835 ring, starting at the front."
3836   (interactive)
3837   (when (zerop (ring-length (wg-wconfig-kill-ring)))
3838     (error "The kill-ring is empty"))
3839   (let ((pos (if (not (eq real-last-command 'wg-yank-wconfig)) 0
3840                (1+ (or (get 'wg-yank-wconfig :position) 0)))))
3841     (put 'wg-yank-wconfig :position pos)
3842     (wg-restore-wconfig-undoably (ring-ref (wg-wconfig-kill-ring) pos))
3843     (wg-fontified-message
3844       (:cmd "Yanked: ")
3845       (:msg (format "%S" pos)) "  "
3846       (wg-workgroup-list-display))))
3847
3848 (defun wg-kill-workgroup-and-buffers (&optional workgroup)
3849   "Kill WORKGROUP and the buffers in its working-wconfig."
3850   (interactive)
3851   (let* ((workgroup (wg-get-workgroup workgroup))
3852          (bufs (save-window-excursion
3853                  (wg-restore-workgroup workgroup)
3854                  (mapcar #'window-buffer (window-list)))))
3855     (wg-kill-workgroup workgroup)
3856     (mapc #'kill-buffer bufs)
3857     (wg-fontified-message
3858       (:cmd "Killed: ")
3859       (:cur (wg-workgroup-name workgroup))
3860       (:msg " and its buffers ") "\n"
3861       (wg-workgroup-list-display))))
3862
3863 (defun wg-delete-other-workgroups (&optional workgroup)
3864   "Delete all workgroups but WORKGROUP."
3865   (interactive)
3866   (let ((workgroup (wg-get-workgroup workgroup)))
3867     (unless (or wg-no-confirm-on-destructive-operation
3868                 (y-or-n-p "Really delete all other workgroups? "))
3869       (error "Cancelled"))
3870     (dolist (w (wg-workgroup-list-or-error))
3871       (unless (eq w workgroup)
3872         (wg-delete-workgroup w)))
3873     (unless (wg-current-workgroup-p workgroup)
3874       (wg-switch-to-workgroup workgroup))
3875     (wg-fontified-message
3876       (:cmd "Deleted: ")
3877       (:msg "All workgroups but ")
3878       (:cur (wg-workgroup-name workgroup)))))
3879
3880 (defun wg-revert-workgroup (&optional workgroup)
3881   "Restore WORKGROUP's window configuration to its state at the last save."
3882   (interactive)
3883   (let* ((workgroup (wg-get-workgroup workgroup))
3884          (base-wconfig (wg-workgroup-base-wconfig workgroup)))
3885     (if (wg-current-workgroup-p workgroup)
3886         (wg-restore-wconfig-undoably base-wconfig)
3887       (wg-add-wconfig-to-undo-list workgroup base-wconfig))
3888     (wg-fontified-message
3889       (:cmd "Reverted: ")
3890       (:cur (wg-workgroup-name workgroup)))))
3891
3892 (defun wg-revert-all-workgroups ()
3893   "Revert all workgroups to their base wconfigs.
3894 Only workgroups' working-wconfigs in `selected-frame' are
3895 reverted."
3896   (interactive)
3897   (mapc #'wg-revert-workgroup (wg-workgroup-list-or-error))
3898   (wg-fontified-message
3899     (:cmd "Reverted: ")
3900     (:msg "All")))
3901
3902 (defun wg-workgroup-state-table (&optional frame)
3903   "Return FRAME's workgroup table, creating it first if necessary."
3904   (or (frame-parameter frame 'wg-workgroup-state-table)
3905       (let ((wtree (make-hash-table :test 'equal)))
3906         (set-frame-parameter frame 'wg-workgroup-state-table wtree)
3907         wtree)))
3908
3909 (defun wg-get-workgroup-state (workgroup &optional frame)
3910   "Return WORKGROUP's state table in a FRAME."
3911   (let ((uid (wg-workgroup-uid workgroup))
3912         (state-table (wg-workgroup-state-table frame)))
3913     (or (gethash uid state-table)
3914         (let ((wgs (wg-make-workgroup-state
3915                     :undo-pointer 0
3916                     :undo-list
3917                     (list (or (wg-workgroup-selected-frame-wconfig workgroup)
3918                               (wg-workgroup-base-wconfig workgroup))))))
3919           (puthash uid wgs state-table)
3920           wgs))))
3921
3922 (defmacro wg-with-undo (workgroup spec &rest body)
3923   "Bind WORKGROUP's undo state to SPEC and eval BODY."
3924   (declare (indent 2))
3925   (wg-dbind (state undo-pointer undo-list) spec
3926     `(let* ((,state (wg-get-workgroup-state ,workgroup))
3927             (,undo-pointer (wg-workgroup-state-undo-pointer ,state))
3928             (,undo-list (wg-workgroup-state-undo-list ,state)))
3929        ,@body)))
3930
3931 (defun wg-flag-just-exited-minibuffer ()
3932   "Added to `minibuffer-exit-hook'."
3933   (setq wg-just-exited-minibuffer t))
3934
3935 (defun wg-flag-window-configuration-changed ()
3936   "Set `wg-window-configuration-changed' to t.
3937 But only if not the minibuffer was just exited.  Added to
3938 `window-configuration-change-hook'."
3939   (if wg-just-exited-minibuffer
3940       (setq wg-just-exited-minibuffer nil)
3941     (progn
3942       (wg-flag-workgroup-modified)
3943       (setq wg-window-configuration-changed t))))
3944
3945 (defun wg-unflag-undoify-window-configuration-change ()
3946   "Set `wg-undoify-window-configuration-change' to nil, exempting
3947 from undoification any window-configuration changes caused by the
3948 current command."
3949   (setq wg-undoify-window-configuration-change nil))
3950
3951 (defun wg-set-workgroup-working-wconfig (workgroup wconfig)
3952   "Set the working-wconfig of WORKGROUP to WCONFIG."
3953   (wg-flag-workgroup-modified workgroup)
3954   (setf (wg-workgroup-selected-frame-wconfig workgroup) wconfig)
3955   (wg-with-undo workgroup (state undo-pointer undo-list)
3956     (setcar (nthcdr undo-pointer undo-list) wconfig)))
3957
3958 (defun wg-add-wconfig-to-undo-list (workgroup wconfig)
3959   "Add WCONFIG to WORKGROUP's undo list, truncating its future if necessary."
3960   (wg-with-undo workgroup (state undo-pointer undo-list)
3961     (let ((undo-list (cons nil (nthcdr undo-pointer undo-list))))
3962       (awhen (nthcdr wg-wconfig-undo-list-max undo-list) (setcdr it nil))
3963       (setf (wg-workgroup-state-undo-list state) undo-list))
3964     (setf (wg-workgroup-state-undo-pointer state) 0))
3965   (wg-set-workgroup-working-wconfig workgroup wconfig))
3966
3967 (defun wg-workgroup-working-wconfig (workgroup &optional noupdate)
3968   "Return WORKGROUP's working-wconfig.
3969 If WORKGROUP is the current workgroup in `selected-frame', and
3970 NOUPDATE is nil, set its working wconfig in `selected-frame' to
3971 `wg-current-wconfig' and return the updated wconfig.  Otherwise
3972 return WORKGROUP's current undo state."
3973   (if (and (not noupdate) (wg-current-workgroup-p workgroup))
3974       (wg-set-workgroup-working-wconfig workgroup (wg-current-wconfig))
3975     (wg-with-undo workgroup (state undo-pointer undo-list)
3976       (nth undo-pointer undo-list))))
3977
3978 (defun wg-update-current-workgroup-working-wconfig ()
3979   "Update `selected-frame's current workgroup's working-wconfig with `wg-current-wconfig'."
3980   (awhen (wg-current-workgroup t)
3981     (wg-set-workgroup-working-wconfig it (wg-current-wconfig))))
3982
3983 (defun wg-restore-wconfig-undoably (wconfig &optional noundo)
3984   "Restore WCONFIG in `selected-frame', saving undo information.
3985 Skip undo when NOUNDO."
3986   (when noundo (wg-unflag-undoify-window-configuration-change))
3987   (wg-update-current-workgroup-working-wconfig)
3988   (wg-restore-wconfig wconfig))
3989
3990 (defun wg-workgroup-offset-position-in-undo-list (workgroup increment)
3991   "Increment WORKGROUP's undo-pointer by INCREMENT.
3992 Also restore the wconfig at the incremented undo-pointer if
3993 WORKGROUP is current."
3994   (wg-with-undo workgroup (state undo-pointer undo-list)
3995     (let ((new-pointer (+ undo-pointer increment)))
3996       (when (wg-within new-pointer 0 (length undo-list))
3997         (when (wg-current-workgroup-p workgroup)
3998           (wg-restore-wconfig-undoably (nth new-pointer undo-list) t))
3999         (setf (wg-workgroup-state-undo-pointer state) new-pointer)))))
4000
4001 (defun wg-undoify-window-configuration-change ()
4002   "Conditionally `wg-add-wconfig-to-undo-list'.
4003 Added to `post-command-hook'."
4004   (when (and wg-window-configuration-changed         ;; When the window config has changed,
4005              wg-undoify-window-configuration-change  ;; and undoification is still on for the current command
4006              (wg-minibuffer-inactive-p))             ;; and the change didn't occur while the minibuffer is active,
4007     (-when-let (workgroup (wg-current-workgroup t))  ;; and there's a current workgroup,
4008       ;; add the current wconfig to that workgroup's undo list:
4009       (wg-add-wconfig-to-undo-list workgroup (wg-current-wconfig))))
4010   ;; Reset all flags no matter what:
4011   (setq wg-window-configuration-changed nil
4012         wg-undoify-window-configuration-change t
4013         wg-already-updated-working-wconfig nil))
4014
4015 (defun wg-update-working-wconfig-hook ()
4016   "Used in before advice on all functions that trigger `window-configuration-change-hook'.
4017 To save up to date undo info before the change."
4018   (when (and (not wg-already-updated-working-wconfig)
4019              (wg-minibuffer-inactive-p))
4020     (wg-update-current-workgroup-working-wconfig)
4021     (setq wg-already-updated-working-wconfig t)))
4022
4023 (defun wg-workgroup-gc-buf-uids (workgroup)
4024   "Remove buf uids from WORKGROUP that have no referent in `wg-buf-list'."
4025   (wg-asetf (wg-workgroup-strong-buf-uids workgroup)
4026             (cl-remove-if-not 'wg-find-buf-by-uid it)
4027             (wg-workgroup-weak-buf-uids workgroup)
4028             (cl-remove-if-not 'wg-find-buf-by-uid it)))
4029
4030 (defun wg-display-internal (elt-fn list)
4031   "Return display string built by calling ELT-FN on each element of LIST."
4032   (let ((div (wg-add-face :div wg-list-display-decor-divider))
4033         (wwidth (window-width (minibuffer-window)))
4034         (i -1)
4035         (str))
4036     (setq str
4037           (wg-fontify
4038             (:brace wg-list-display-decor-left-brace)
4039             (if (not list) (funcall elt-fn nil nil)
4040               (wg-doconcat (elt list div) (funcall elt-fn elt (cl-incf i))))
4041             (:brace wg-list-display-decor-right-brace)))
4042     ;; (subseq str 0 wwidth)
4043     ))
4044
4045 (defun wg-workgroup-list-display (&optional workgroup-list)
4046   "Return the WORKGROUP-LIST display string.
4047 The string contains the names of all workgroups in `wg-workgroup-list',
4048 decorated with faces, dividers and strings identifying the
4049 current and previous workgroups."
4050   (if (wg-current-session t)
4051       (wg-display-internal 'wg-workgroup-display
4052                            (or workgroup-list (wg-workgroup-list)))))
4053
4054 (defun wg-create-first-wg ()
4055   "Create a first workgroup if needed."
4056   (when (and workgroups-mode
4057              wg-session-load-on-start
4058              (= (length (wg-workgroup-list)) 0))
4059     (wg-create-workgroup wg-first-wg-name)
4060     (wg-mark-everything-unmodified)))
4061
4062 (defun wg-pickel-workgroup-parameters (workgroup)
4063   "Return a copy of WORKGROUP after pickeling its parameters.
4064 If WORKGROUP's parameters are non-nil, otherwise return
4065 WORKGROUP."
4066   (if (not (wg-workgroup-parameters workgroup)) workgroup
4067     (let ((copy (wg-copy-workgroup workgroup)))
4068       (wg-asetf (wg-workgroup-parameters copy) (wg-pickel it))
4069       copy)))
4070
4071 (defun wg-unpickel-workgroup-parameters (workgroup)
4072   "If WORKGROUP's parameters are non-nil, return a copy of
4073 WORKGROUP after unpickeling its parameters. Otherwise return
4074 WORKGROUP."
4075   (if (not (wg-workgroup-parameters workgroup)) workgroup
4076     (let ((copy (wg-copy-workgroup workgroup)))
4077       (wg-asetf (wg-workgroup-parameters copy) (wg-unpickel it))
4078       copy)))
4079
4080 (defun wg-delete-workgroup (workgroup)
4081   "Remove WORKGROUP from `wg-workgroup-list'.
4082 Also delete all references to it by `wg-workgroup-state-table',
4083 `wg-current-workgroup' and `wg-previous-workgroup'."
4084   (dolist (frame (frame-list))
4085     (remhash (wg-workgroup-uid workgroup) (wg-workgroup-state-table frame))
4086     (when (wg-current-workgroup-p workgroup frame)
4087       (wg-set-current-workgroup nil frame))
4088     (when (wg-previous-workgroup-p workgroup frame)
4089       (wg-set-previous-workgroup nil frame)))
4090   (setf (wg-workgroup-list) (remove workgroup (wg-workgroup-list-or-error)))
4091   (wg-flag-session-modified)
4092   workgroup)
4093
4094 (defun wg-add-workgroup (workgroup &optional index)
4095   "Add WORKGROUP to `wg-workgroup-list' at INDEX or the end.
4096 If a workgroup with the same name exists, overwrite it."
4097   (awhen (wg-find-workgroup-by :name (wg-workgroup-name workgroup) t)
4098     (unless index (setq index (cl-position it (wg-workgroup-list-or-error))))
4099     (wg-delete-workgroup it))
4100   (wg-asetf (wg-workgroup-list)
4101             (wg-insert-before workgroup it (or index (length it))))
4102   (wg-flag-session-modified)
4103   workgroup)
4104
4105 (defun wg-check-and-add-workgroup (workgroup)
4106   "Add WORKGROUP to `wg-workgroup-list'.
4107 Ask to overwrite if a workgroup with the same name exists."
4108   (let ((name (wg-workgroup-name workgroup))
4109         (uid (wg-workgroup-uid workgroup)))
4110     (when (wg-find-workgroup-by :uid uid t)
4111       (error "A workgroup with uid %S already exists" uid))
4112     (when (wg-find-workgroup-by :name name t)
4113       (unless (or wg-no-confirm-on-destructive-operation
4114                   (y-or-n-p (format "%S exists. Overwrite? " name)))
4115         (error "Cancelled"))))
4116   (wg-add-workgroup workgroup))
4117
4118 (defun wg-make-and-add-workgroup (name &optional blank)
4119   "Create a workgroup named NAME with current `window-tree'.
4120 If BLANK - then just scratch buffer.
4121 Add it with `wg-check-and-add-workgroup'."
4122   (wg-check-and-add-workgroup
4123    (wg-make-workgroup
4124     :name name
4125     :base-wconfig (if blank (wg-make-blank-wconfig)
4126                     (wg-current-wconfig)))))
4127
4128 (defun wg-get-workgroup-create (workgroup)
4129   "Return the workgroup specified by WORKGROUP, creating a new one if needed.
4130 If `wg-get-workgroup' on WORKGROUP returns a workgroup, return it.
4131 Otherwise, if WORKGROUP is a string, create a new workgroup with
4132 that name and return it.  Otherwise error."
4133   (or (wg-get-workgroup workgroup t)
4134       (if (stringp workgroup)
4135           (wg-make-and-add-workgroup workgroup)
4136         (wg-get-workgroup workgroup))))  ; Call this again for its error message
4137
4138 (defun wg-cyclic-offset-workgroup (workgroup n)
4139   "Offset WORKGROUP's position in `wg-workgroup-list' by N."
4140   (let ((workgroup-list (wg-workgroup-list-or-error)))
4141     (unless (member workgroup workgroup-list)
4142       (error "Workgroup isn't present in `wg-workgroup-list'."))
4143     (setf (wg-workgroup-list) (wg-cyclic-offset-elt workgroup workgroup-list n)
4144           (wg-session-modified (wg-current-session)) t)))
4145
4146 (defun wg-swap-workgroups-in-workgroup-list (workgroup1 workgroup2)
4147   "Swap the positions of WORKGROUP1 and WORKGROUP2 in `wg-workgroup-list'."
4148   (let ((workgroup-list (wg-workgroup-list-or-error)))
4149     (when (eq workgroup1 workgroup2)
4150       (error "Can't swap a workgroup with itself"))
4151     (unless (and (memq workgroup1 workgroup-list)
4152                  (memq workgroup2 workgroup-list))
4153       (error "Both workgroups aren't present in `wg-workgroup-list'."))
4154     (setf (wg-workgroup-list) (wg-util-swap workgroup1 workgroup2 workgroup-list)
4155           (wg-session-modified (wg-current-session)) t)))
4156
4157 (defun wg-session-uids-consistent-p ()
4158   "Return t if there are no duplicate bufs or buf uids in the wrong places.
4159 nil otherwise."
4160   (and (not (wg-dups-p (wg-buf-list) :key 'wg-buf-uid :test 'string=))
4161        (not (wg-dups-p (wg-workgroup-list) :key 'wg-workgroup-uid :test 'string=))))
4162
4163 (defun wg-open-session (filename)
4164   "Load a session visiting FILENAME, creating one if none already exists."
4165   (interactive "FFind session file: ")
4166   (cond ((file-exists-p filename)
4167          ;; TODO: handle errors when reading object
4168          (let ((session (read (f-read-text filename))))
4169            (unless (wg-session-p session)
4170              (error "%S is not a Workgroups session file." filename))
4171            (setf (wg-session-file-name session) filename)
4172            (wg-reset-internal (wg-unpickel-session-parameters session)))
4173
4174          (if wg-control-frames (wg-restore-frames))
4175
4176          (awhen (wg-workgroup-list)
4177            (if (and wg-open-this-wg
4178                     (member wg-open-this-wg (wg-workgroup-names)))
4179                (wg-switch-to-workgroup wg-open-this-wg)
4180              (if (and wg-load-last-workgroup
4181                       (member (wg-session-parameter 'last-workgroup) (wg-workgroup-names)))
4182                  (wg-switch-to-workgroup (wg-session-parameter 'last-workgroup))
4183                (wg-switch-to-workgroup (car it))))
4184            (awhen (wg-session-parameter 'prev-workgroup)
4185              (when (and (member it (wg-workgroup-names))
4186                         (wg-get-workgroup it t))
4187                (wg-set-previous-workgroup (wg-get-workgroup it t)))))
4188          (wg-fontified-message (:cmd "Loaded: ") (:file filename))
4189          (wg-mark-everything-unmodified))
4190         (t
4191          (wg-query-and-save-if-modified)
4192          (wg-reset-internal (wg-make-session :file-name filename))
4193          (wg-fontified-message (:cmd "(New Workgroups session file)")))))
4194 (defalias 'wg-find-session-file 'wg-open-session)
4195
4196 (defun wg-write-sexp-to-file (sexp file)
4197   "Write the printable representation of SEXP to FILE."
4198   (with-temp-buffer
4199     (let ((print-level nil)  (print-length nil))
4200       (insert (format "%S" sexp)))
4201     (write-file file)))
4202
4203 ;; FIXME: Duplicate buf names probably shouldn't be allowed.  An unrelated error
4204 ;; causes two *scratch* buffers to be present, triggering the "uids don't match"
4205 ;; error.  Write something to remove bufs with duplicate names.
4206 (defun wg-perform-session-maintenance ()
4207   "Perform various maintenance operations on the current Workgroups session."
4208   (wg-update-current-workgroup-working-wconfig)
4209
4210   ;; Update every workgroup's base wconfig with `wg-workgroup-update-base-wconfig'
4211   (dolist (workgroup (wg-workgroup-list))
4212     (awhen (wg-workgroup-selected-frame-wconfig workgroup)
4213       (setf (wg-workgroup-base-wconfig workgroup) it
4214             (wg-workgroup-selected-frame-wconfig workgroup) nil)))
4215
4216   ;; Garbage collection
4217
4218   ;; Commenting this will cause a constantly growing session file:
4219   ;; (tried to comment this block to solve https://github.com/pashinin/workgroups2/issues/48)
4220   (let ((all-buf-uids (wg-all-buf-uids)))
4221     (wg-asetf (wg-buf-list)
4222               (cl-remove-if-not (lambda (uid) (member uid all-buf-uids)) it
4223                                 :key 'wg-buf-uid)))
4224
4225   (mapc 'wg-workgroup-gc-buf-uids (wg-workgroup-list))  ; Remove buf uids that have no referent in `wg-buf-list'
4226   (mapc 'wg-update-buffer-in-buf-list (wg-buffer-list-emacs)))
4227
4228 (defun wg-save-session-as (filename &optional confirm)
4229   "Write the current session into file FILENAME.
4230 This makes the session visit that file, and marks it as not modified.
4231
4232 If optional second arg CONFIRM is non-nil, this function asks for
4233 confirmation before overwriting an existing file.  Interactively,
4234 confirmation is required unless you supply a prefix argument."
4235   (interactive (list (read-file-name "Save session as: ")
4236                      (not current-prefix-arg)))
4237   (when (and confirm (file-exists-p filename))
4238     (unless (y-or-n-p (format "File `%s' exists; overwrite? " filename))
4239       (error "Cancelled")))
4240   (unless (file-writable-p filename)
4241     (error "File %s can't be written to" filename))
4242   (wg-perform-session-maintenance)
4243   (setf (wg-session-file-name (wg-current-session)) filename)
4244   (setf (wg-session-version (wg-current-session)) wg-version)
4245
4246   ;; Save opened frames as a session parameter "frame-list".
4247   ;; Exclude `selected-frame' and daemon one (if any).
4248   ;; http://stackoverflow.com/questions/21151992/why-emacs-as-daemon-gives-1-more-frame-than-is-opened
4249   (if wg-control-frames
4250       (let ((fl (frame-list)))
4251         ;; TODO: remove using dash
4252         (mapc (lambda (frame)
4253                 (if (string-equal "initial_terminal" (terminal-name frame))
4254                     (delete frame fl))) fl)
4255         (setq fl (delete (selected-frame) fl))
4256         (let (wg-flag-modified)
4257           (wg-set-session-parameter 'frame-list (mapcar 'wg-frame-to-wconfig fl)))))
4258   (wg-write-sexp-to-file (wg-pickel-all-session-parameters) filename)
4259   (wg-fontified-message (:cmd "Wrote: ") (:file filename))
4260   (wg-mark-everything-unmodified))
4261 (defalias 'wg-write-session-file 'wg-save-session-as)
4262
4263 (defun wg-get-session-file ()
4264   "Return the filename in which to save the session."
4265   (or (aif (wg-current-session t) (wg-session-file-name it))
4266       wg-session-file))
4267 ;;(read-file-name (format "Save session as [%s]: " wg-session-file))
4268
4269 (defun wg-save-session (&optional force)
4270   "Save the current Workgroups session if it's been modified.
4271 When FORCE - save session regardless of whether it's been modified."
4272   (interactive "P")
4273   ;;(if (and (not (wg-modified-p)) (not force))
4274   ;;    (wg-message "(The session is unmodified)")
4275   (wg-save-session-as (wg-get-session-file)))
4276
4277 (defun wg-reset-internal (&optional session)
4278   "Reset Workgroups, setting `wg-current-session' to SESSION.
4279 Resets all frame parameters, buffer-local vars, current session
4280 object, etc.  SESSION nil defaults to a new, blank session."
4281   (mapc 'wg-reset-frame (frame-list))
4282   (mapc 'wg-reset-buffer (wg-buffer-list-emacs))
4283   (setq wg-wconfig-kill-ring nil)
4284   (setq wg-current-session (or session (wg-make-session))))
4285
4286 (defun wg-all-buf-uids (&optional session buffer-list)
4287   "Return the union of all SESSION buf-uids and BUFFER-LIST uids."
4288   (cl-union (cl-reduce 'wg-string-list-union  ; (wg-session-all-buf-uids session)
4289                        (wg-session-workgroup-list (or session (wg-current-session)))
4290                        :key 'wg-workgroup-all-buf-uids)
4291             ;; (wg-buffer-list-all-uids buffer-list)
4292             (delq nil (mapcar 'wg-buffer-uid (or buffer-list (wg-buffer-list-emacs))))
4293             :test 'string=))
4294
4295 (defun wg-modified-p ()
4296   "Return t when the current session or any of its workgroups are modified."
4297   (aif (wg-current-session t)
4298       (or (wg-session-modified it)
4299           (cl-some 'wg-workgroup-modified (wg-workgroup-list)))))
4300
4301 (defun wg-mark-everything-unmodified ()
4302   "Mark the session and all workgroups as unmodified."
4303   (let (wg-undoify-window-configuration-change)    ; to skip WG's `post-command-hook' that marks "modified" again
4304     (-when-let (session (wg-current-session t))
4305       (setf (wg-session-modified session) nil))
4306     (dolist (workgroup (wg-workgroup-list))
4307       (setf (wg-workgroup-modified workgroup) nil))))
4308
4309 (defun wg-session-parameter (parameter &optional default session)
4310   "Return session's value for PARAMETER.
4311 If PARAMETER is not found, return DEFAULT which defaults to nil.
4312 SESSION nil defaults to the current session."
4313   (wg-aget (wg-session-parameters (or session (wg-current-session)))
4314            parameter default))
4315
4316 (defun wg-set-session-parameter (parameter value &optional session)
4317   "Set PARAMETER to VALUE in SESSION.
4318 SESSION nil means use the current session.  Return value."
4319   (-when-let (session (or session (wg-current-session t)))
4320     (wg-set-parameter (wg-session-parameters session) parameter value)
4321     (wg-flag-session-modified session)
4322     value))
4323
4324 (defun wg-remove-session-parameter (parameter &optional session)
4325   "Remove parameter PARAMETER from SESSION's parameters."
4326   (let ((session (or session (wg-current-session))))
4327     (wg-asetf (wg-session-parameters session) (wg-aremove it parameter))
4328     (wg-flag-session-modified session)))
4329
4330 (defun wg-session-local-value (variable &optional session)
4331   "Return the value of VARIABLE in SESSION.
4332 SESSION nil defaults to the current session.  If VARIABLE does
4333 not have a session-local binding in SESSION, the value is
4334 resolved by Emacs."
4335   (let* ((undefined (cl-gensym))
4336          (value (wg-session-parameter variable undefined session)))
4337     (if (not (eq value undefined)) value
4338       (symbol-value variable))))
4339
4340 (defun wg-reset-frame (frame)
4341   "Reset Workgroups' `frame-parameters' in FRAME to nil."
4342   (set-frame-parameter frame 'wg-workgroup-state-table nil)
4343   (set-frame-parameter frame 'wg-current-workgroup-uid nil)
4344   (set-frame-parameter frame 'wg-previous-workgroup-uid nil))
4345
4346 (defun wg-save-session-on-exit (behavior)
4347   "Perform session-saving operations based on BEHAVIOR."
4348   (cl-case behavior
4349     (ask (wg-query-and-save-if-modified))
4350     (save (wg-save-session))))
4351
4352 (defun wg-reload-session ()
4353   "Reload current workgroups session."
4354   (interactive)
4355   (let* ((file (wg-get-session-file))
4356          (exists (file-exists-p file)))
4357     (condition-case err
4358         (wg-open-session file)
4359       (progn
4360         (wg-create-first-wg)
4361         (message "Error loading session-file: %s" err))))
4362         ;; TODO: print what exactly happened
4363   (wg-create-first-wg))
4364
4365 (defun wg-save-session-on-emacs-exit ()
4366   "Call `wg-save-session-on-exit' with `wg-emacs-exit-save-behavior'.
4367 Added to `kill-emacs-query-functions'."
4368   (wg-save-session-on-exit wg-emacs-exit-save-behavior) t)
4369
4370 (defun wg-save-session-on-workgroups-mode-exit ()
4371   "Call `wg-save-session-on-exit' with `wg-workgroups-mode-exit-save-behavior'.
4372 Called when `workgroups-mode' is turned off."
4373   (wg-save-session-on-exit wg-workgroups-mode-exit-save-behavior) t)
4374
4375 (defun wg-pickel-all-session-parameters (&optional session)
4376   "Return a copy of SESSION after pickeling its parameters.
4377 And the parameters of all its workgroups."
4378   (let ((copy (wg-copy-session (or session (wg-current-session)))))
4379     (when (wg-session-parameters copy)
4380       (wg-asetf (wg-session-parameters copy) (wg-pickel it)))
4381     (wg-asetf (wg-session-workgroup-list copy)
4382               (cl-mapcar 'wg-pickel-workgroup-parameters it))
4383     copy))
4384
4385 (defun wg-unpickel-session-parameters (session)
4386   "Return a copy of SESSION after unpickeling its parameters.
4387 And the parameters of all its workgroups."
4388   (let ((copy (wg-copy-session session)))
4389     (when (wg-session-parameters copy)
4390       (wg-asetf (wg-session-parameters copy) (wg-unpickel it)))
4391     (wg-asetf (wg-session-workgroup-list copy)
4392               (cl-mapcar 'wg-unpickel-workgroup-parameters it))
4393     copy))
4394
4395 (defvar wg-buffer-workgroup nil
4396   "Associating each buffer with the workgroup.
4397 In which it most recently appeared.")
4398 (make-variable-buffer-local 'wg-buffer-workgroup)
4399
4400 (defun wg-workgroup-associated-buf-uids (&optional workgroup)
4401   "Return a new list containing all of WORKGROUP's associated buf uids."
4402   (awhen (or workgroup (wg-current-workgroup t))
4403     (append (wg-workgroup-strong-buf-uids it)
4404             (wg-workgroup-weak-buf-uids it))))
4405
4406 (defun wg-workgroup-associated-bufs (workgroup)
4407   "Return a new list containing all of WORKGROUP's associated bufs."
4408   (delete nil (mapcar 'wg-find-buf-by-uid
4409                       (wg-workgroup-associated-buf-uids workgroup))))
4410
4411 (defun wg-workgroup-associated-buffers (workgroup)
4412   "Return a new list containing all of WORKGROUP's associated buffer objects."
4413   (delete nil (mapcar 'wg-restore-buffer
4414                       (wg-workgroup-associated-bufs workgroup))))
4415
4416 (defun wg-workgroup-strongly-associate-bufobj (workgroup bufobj)
4417   "Strongly associate BUFOBJ with WORKGROUP."
4418   (let* ((uid (wg-bufobj-uid-or-add bufobj))
4419          (remp (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup)
4420                              :test 'string=))
4421          (addp (wg-pushnew-p uid (wg-workgroup-strong-buf-uids workgroup)
4422                              :test 'string=)))
4423     (when (or remp addp)
4424       (wg-flag-workgroup-modified workgroup)
4425       bufobj)))
4426
4427 (defun wg-workgroup-weakly-associate-bufobj (workgroup bufobj)
4428   "Weakly associate BUFOBJ with WORKGROUP."
4429   (let* ((uid (wg-bufobj-uid-or-add bufobj))
4430          (remp (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup)
4431                              :test 'string=))
4432          (addp (wg-pushnew-p uid (wg-workgroup-weak-buf-uids workgroup)
4433                              :test 'string=)))
4434     (when (or remp addp)
4435       (wg-flag-workgroup-modified workgroup)
4436       bufobj)))
4437
4438 (defun wg-workgroup-associate-bufobj (workgroup bufobj &optional weak)
4439   "Associate BUFOBJ with WORKGROUP.
4440 WEAK non-nil means weakly associate it.  Otherwise strongly associate it."
4441   (if weak (wg-workgroup-weakly-associate-bufobj workgroup bufobj)
4442     (wg-workgroup-strongly-associate-bufobj workgroup bufobj)))
4443
4444 (defun wg-workgroup-dissociate-bufobj (workgroup bufobj)
4445   "Dissociate BUFOBJ from WORKGROUP."
4446   (let* ((uid (wg-bufobj-uid-or-add bufobj))
4447          (rem1p (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup)
4448                               :test 'string=))
4449          (rem2p (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup)
4450                               :test 'string=)))
4451     (when (or rem1p rem2p)
4452       (wg-flag-workgroup-modified workgroup)
4453       bufobj)))
4454
4455 (defun wg-workgroup-dissociate-weakly-associated-buffers (workgroup)
4456   "Dissociate from WORKGROUP all weakly associated buffers."
4457   (when (wg-workgroup-weak-buf-uids workgroup)
4458     (wg-flag-workgroup-modified workgroup)
4459     (setf (wg-workgroup-weak-buf-uids workgroup) nil)))
4460
4461 (defun wg-workgroup-dissociate-strongly-associated-buffers (workgroup)
4462   "Dissociate from WORKGROUP all strongly associated buffers."
4463   (when (wg-workgroup-strong-buf-uids workgroup)
4464     (wg-flag-workgroup-modified workgroup)
4465     (setf (wg-workgroup-strong-buf-uids workgroup) nil)))
4466
4467 (defun wg-workgroup-dissociate-all-buffers (workgroup)
4468   "Dissociate from WORKGROUP all its associated buffers."
4469   (wg-workgroup-dissociate-weakly-associated-buffers workgroup)
4470   (wg-workgroup-dissociate-strongly-associated-buffers workgroup))
4471
4472 (defun wg-auto-dissociate-buffer-hook ()
4473   "`kill-buffer-hook' that automatically dissociates buffers from workgroups."
4474   (when wg-dissociate-buffer-on-kill-buffer
4475     (awhen (wg-current-workgroup t)
4476       (wg-workgroup-dissociate-bufobj it (current-buffer)))))
4477
4478 (defun wg-associate-buffer-with-workgroup (&optional workgroup buffer weak)
4479   "Associate BUFFER with WORKGROUP.
4480 WEAK non-nil means weakly associate BUFFER."
4481   (interactive (list nil nil current-prefix-arg))
4482   (let* ((workgroup (wg-get-workgroup workgroup))
4483          (buffer (or buffer (current-buffer)))
4484          (bname (buffer-name buffer))
4485          (wgname (wg-workgroup-name workgroup)))
4486     (if (wg-workgroup-associate-bufobj workgroup buffer weak)
4487         (wg-message "%s-associated %S with %s"
4488                     (if weak "Weakly" "Strongly") bname wgname)
4489       (wg-message "%S is already associated with %s" bname wgname))))
4490
4491 (defun wg-associate-visible-buffers-with-workgroup (&optional workgroup weak)
4492   "Associate all buffers visible in `selected-frame' with WORKGROUP.
4493 WEAK non-nil means weakly associate them.  Otherwise strongly
4494 associate them."
4495   (interactive (list nil current-prefix-arg))
4496   (let ((workgroup (wg-get-workgroup workgroup))
4497         (buffers (mapcar 'window-buffer (window-list))))
4498     (dolist (buffer buffers)
4499       (wg-workgroup-associate-bufobj workgroup buffer weak))
4500     (wg-fontified-message
4501       (:cmd (format "%s associated: " (if weak "Weakly" "Strongly")))
4502       (wg-display-internal 'wg-buffer-display buffers))))
4503
4504 (defun wg-dissociate-buffer-from-workgroup (&optional workgroup buffer)
4505   "Dissociate BUFFER from WORKGROUP."
4506   (interactive (list nil nil))
4507   (let ((workgroup (wg-get-workgroup workgroup))
4508         (buffer (or buffer (current-buffer))))
4509     (wg-message
4510      (if (wg-workgroup-dissociate-bufobj workgroup buffer)
4511          "Dissociated %S from %s" "%S isn't associated with %s")
4512      (wg-buffer-name buffer)
4513      (wg-workgroup-name workgroup))))
4514
4515 (defun wg-associate-buffers (workgroup window-or-emacs-window-tree)
4516   "Associate the buffers visible in window elements of
4517 WINDOW-OR-EMACS-WINDOW-TREE with the given WORKGROUP.
4518 WINDOW-OR-EMACS-WINDOW-TREE must be either a window or a tree of
4519 the form produced by `(car (window-tree))'."
4520   (if (windowp window-or-emacs-window-tree)
4521       (with-current-buffer (window-buffer window-or-emacs-window-tree)
4522         (setq wg-buffer-workgroup workgroup))
4523     (dolist (w (cddr window-or-emacs-window-tree))
4524       (when w (wg-associate-buffers workgroup w)))))
4525
4526 (defun wg-workgroup-bufobj-association-type (workgroup bufobj)
4527   "Return BUFOBJ's association-type in WORKGROUP, or nil if unassociated."
4528   (let ((uid (wg-bufobj-uid-or-add bufobj)))
4529     (or (and (member uid (wg-workgroup-strong-buf-uids workgroup)) 'strong)
4530         (and (member uid (wg-workgroup-weak-buf-uids workgroup)) 'weak))))
4531
4532 (defun wg-associate-frame-buffers ()
4533   "Associate visible buffers with the current workgroup.
4534 Unless it is currently being deactivated."
4535   (awhen (wg-current-workgroup :noerror)
4536     (unless (member it wg-deactivation-list)
4537       (wg-associate-buffers it (car (window-tree))))))
4538
4539 (defun wg-add-or-remove-workgroups-hooks (remove)
4540   "Add or remove all of Workgroups' hooks, depending on REMOVE."
4541   (wg-add-or-remove-hooks
4542    remove
4543    'kill-emacs-query-functions       'wg-save-session-on-emacs-exit
4544    'delete-frame-hook                'wg-update-working-wconfig-on-delete-frame
4545    'after-make-frame-functions       'wg-update-working-wconfig-on-make-frame
4546    'wg-pre-window-configuration-change-hook 'wg-update-working-wconfig-hook
4547    'window-configuration-change-hook 'wg-flag-window-configuration-changed
4548    'post-command-hook                'wg-undoify-window-configuration-change
4549    'minibuffer-exit-hook             'wg-flag-just-exited-minibuffer
4550    'kill-buffer-hook                 'wg-update-buffer-in-buf-list
4551    'kill-buffer-hook                 'wg-auto-dissociate-buffer-hook
4552    ;;'window-configuration-change-hook 'wg-associate-frame-buffers
4553    ))
4554
4555 ;;;###autoload
4556 (defun workgroups-mode (&optional arg)
4557   "Turn `workgroups-mode' on and off.
4558 ARG is nil - toggle
4559 ARG >= 1   - turn on
4560 ARG == 0   - turn off
4561 ARG is anything else, turn on `workgroups-mode'."
4562   (interactive (list current-prefix-arg))
4563   (setq workgroups-mode
4564         (cond ((not arg) (not workgroups-mode))
4565               ((integerp arg) (if (> arg 0) t nil))
4566               (t)))
4567   (cond
4568    (workgroups-mode
4569     (if (boundp 'desktop-restore-frames)
4570         (setq desktop-restore-frames nil))
4571     (wg-reset-internal)                              ; creates a new `wg-current-session'
4572     (wg-add-workgroups-mode-minor-mode-entries)
4573     (wg-enable-all-advice)
4574     (wg-add-or-remove-workgroups-hooks nil)
4575     (wg-change-modeline)
4576
4577     ;; some sr-speedbar hooks can harm
4578     (when (featurep 'sr-speedbar)
4579       (ad-disable-advice 'delete-other-windows 'around 'sr-speedbar-delete-other-window-advice)
4580       (ad-disable-advice 'delete-window 'before 'sr-speedbar-delete-window-advice))
4581
4582     ;; Load session
4583     (when (and wg-session-load-on-start
4584                (file-exists-p wg-session-file))
4585       (condition-case err
4586           (wg-open-session wg-session-file)
4587         (error (message "Error finding `wg-session-file': %s" err))))
4588     (run-hooks 'workgroups-mode-hook))
4589    (t
4590     (wg-save-session-on-workgroups-mode-exit)
4591     (wg-disable-all-advice)
4592     (wg-add-or-remove-workgroups-hooks t)
4593     (wg-remove-mode-line-display)
4594     (run-hooks 'workgroups-mode-exit-hook)))
4595   (wg-fontified-message
4596     (:cmd "Workgroups Mode: ") (:msg (if workgroups-mode "on" "off")))
4597   (wg-create-first-wg)
4598   workgroups-mode)
4599
4600 ;;;###autoload
4601 (defun wg-help ()
4602   "Just call `apropos-command' on \"^wg-\".
4603 There used to be a bunch of help-buffer construction stuff here,
4604 including a `wg-help' variable that basically duplicated every
4605 command's docstring;  But why, when there's `apropos-command'?"
4606   (interactive)
4607   (apropos-command "^wg-"))
4608
4609 ;; Remove after some time
4610 (defalias 'wg-switch-to-buffer 'switch-to-buffer)
4611
4612 (provide 'workgroups2)
4613 ;;; workgroups2.el ends here