Changeset - 69ab704a7974
[Not reviewed]
0 5 0
Sergey Pashinin - 11 years ago 2014-08-23 16:57:04
sergey@pashinin.com
wg-when-let replaced
5 files changed with 14 insertions and 33 deletions:
0 comments (0 inline, 0 general)
src/workgroups-advice.el
Show inline comments
 
;;; workgroups-advice --- change some functions behaviour
 
;;; Commentary:
 
;;; Code:
 

	
 
(require 'workgroups-utils-basic)
 
(require 'workgroups-session)
 
(require 'workgroups-association)
 

	
 

	
 
;; `wg-pre-window-configuration-change-hook' implementation advice
 
(cl-macrolet ((define-p-w-c-c-h-advice
 
             (fn)
 
             `(defadvice ,fn (before wg-pre-window-configuration-change-hook)
 
                "Call `wg-update-working-wconfig-hook' before this
 
function to save up-to-date undo information before the
 
window-configuration changes."
 
                (run-hooks 'wg-pre-window-configuration-change-hook))))
 
  (define-p-w-c-c-h-advice split-window)
 
  (define-p-w-c-c-h-advice enlarge-window)
 
  (define-p-w-c-c-h-advice delete-window)
 
  (define-p-w-c-c-h-advice delete-other-windows)
 
  (define-p-w-c-c-h-advice delete-windows-on)
 
  (define-p-w-c-c-h-advice switch-to-buffer)
 
  (define-p-w-c-c-h-advice set-window-buffer))
 

	
 

	
 
;; `save-buffers-kill-emacs' advice
 

	
 
(defadvice save-buffers-kill-emacs (around wg-freeze-wconfig)
 
  "`save-buffers-kill-emacs' calls `list-processes' when active
 
processes exist, screwing up the window config right before
 
Workgroups saves it.  This advice freezes `wg-current-wconfig' in
 
its correct state, prior to any window-config changes caused by
 
`s-b-k-e'."
 
  (wg-with-current-wconfig nil (wg-frame-to-wconfig)
 
    ad-do-it))
 

	
 

	
 
;; `select-frame' advice
 

	
 
(defadvice select-frame (before wg-update-current-workgroup-working-wconfig)
 
  "Update `selected-frame's current workgroup's working-wconfig.
 
Before selecting a new frame."
 
  (when wg-update-current-workgroup-working-wconfig-on-select-frame
 
    (wg-update-current-workgroup-working-wconfig)))
 

	
 

	
 
;; enable all advice
 

	
 
(defun wg-enable-all-advice ()
 
  "Enable and activate all of Workgroups' advice."
 
  ;; switch-to-buffer
 
  (ad-enable-advice 'switch-to-buffer 'after 'wg-auto-associate-buffer)
 
  (ad-enable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-activate 'switch-to-buffer)
 

	
 
  ;; set-window-buffer
 
  (ad-enable-advice 'set-window-buffer 'after 'wg-auto-associate-buffer)
 
  (ad-enable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-activate 'set-window-buffer)
 

	
 
  ;; split-window
 
  (ad-enable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-activate 'split-window)
 

	
 
  ;; enlarge-window
 
  (ad-enable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-activate 'enlarge-window)
 

	
 
  ;; delete-window
 
  (ad-enable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-activate 'delete-window)
 

	
 
  ;; delete-other-windows
 
  (ad-enable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-activate 'delete-other-windows)
 

	
 
  ;; delete-windows-on
 
  (ad-enable-advice 'delete-windows-on 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-activate 'delete-windows-on)
 

	
 
  ;; save-buffers-kill-emacs
 
  (ad-enable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig)
 
  (ad-activate 'save-buffers-kill-emacs)
 

	
 
  ;; select-frame
 
  ;;(ad-enable-advice 'select-frame 'before
 
  ;;                  'wg-update-current-workgroup-working-wconfig)
 
  ;;(ad-activate 'select-frame)
 
  )
 

	
 

	
 
;; disable all advice
 
;; (wg-disable-all-advice)
 
(defun wg-disable-all-advice ()
 
  "Disable and deactivate all of Workgroups' advice."
 
  ;; switch-to-buffer
 
  (ad-disable-advice 'switch-to-buffer 'after  'wg-auto-associate-buffer)
 
  (ad-disable-advice 'switch-to-buffer 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-deactivate 'switch-to-buffer)
 

	
 
  ;; set-window-buffer
 
  (ad-disable-advice 'set-window-buffer 'after  'wg-auto-associate-buffer)
 
  (ad-disable-advice 'set-window-buffer 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-deactivate 'set-window-buffer)
 

	
 
  ;; split-window
 
  (ad-disable-advice 'split-window 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-deactivate 'split-window)
 

	
 
  ;; enlarge-window
 
  (ad-disable-advice 'enlarge-window 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-deactivate 'enlarge-window)
 

	
 
  ;; delete-window
 
  (ad-disable-advice 'delete-window 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-deactivate 'delete-window)
 

	
 
  ;; delete-other-windows
 
  (ad-disable-advice 'delete-other-windows 'before 'wg-pre-window-configuration-change-hook)
 
  (ad-deactivate 'delete-other-windows)
 

	
 
  ;; delete-windows-on
 
  (ad-disable-advice 'delete-windows-on    'before 'wg-pre-window-configuration-change-hook)
 
  (ad-deactivate 'delete-windows-on)
 

	
 
  ;; save-buffers-kill-emacs
 
  (ad-disable-advice 'save-buffers-kill-emacs 'around 'wg-freeze-wconfig)
 
  (ad-deactivate 'save-buffers-kill-emacs)
 

	
 
  ;; select-frame
 
  ;;(ad-disable-advice 'select-frame 'before
 
  ;;                   'wg-update-current-workgroup-working-wconfig)
 
  ;;(ad-deactivate 'select-frame)
 
  )
 

	
 

	
 
;; buffer auto-association advice
 

	
 
(defcustom wg-buffer-auto-association-on t
 
  "Non-nil means buffer auto-association is on.
 
-nil means it's off.  See `wg-buffer-auto-association'."
 
  :type 'boolean
 
  :group 'workgroups)
 

	
 
(defcustom wg-buffer-auto-association 'weak
 
  "Specifies the behavior for auto-associating buffers with workgroups.
 

	
 
When a buffer is made visible in a window it can be automatically
 
associated with the current workgroup in the window's frame.
 
This setting determines whether and how that happens.
 

	
 
Allowable values:
 

	
 
`weak' - weakly associate the buffer with the workgroup
 

	
 
`strong' - strongly associate the buffer with the workgroup
 

	
 
A function (a function-symbol or a lambda) - `funcall' the function to
 
determine whether and how to associate the buffer with the
 
workgroup.  The function should accept two arguments -- the
 
buffer and the workgroup -- and should return one of the
 
allowable values for this variable.
 

	
 
`nil' or any other value - don't associate the buffer with the
 
workgroup.
 

	
 
Becomes workgroup-local when set with `wg-set-workgroup-parameter'.
 
Becomes session-local when set with `wg-set-session-parameter'."
 
  :type 'sexp
 
  :group 'workgroups)
 

	
 
(defcustom wg-dissociate-buffer-on-kill-buffer t
 
  "Non-nil means dissociate from the current workgroup buffers
 
killed with `kill-buffer'."
 
  :type 'boolean
 
  :group 'workgroups)
 

	
 
(defun wg-auto-associate-buffer-helper (workgroup buffer assoc)
 
  "Associate BUFFER with WORKGROUP based on ASSOC.
 
See `wg-buffer-auto-association' for allowable values of ASSOC."
 
  (cond ((memq assoc '(weak strong))
 
         (wg-workgroup-associate-bufobj workgroup buffer (eq assoc 'weak)))
 
        ((functionp assoc)
 
         (wg-auto-associate-buffer-helper
 
          workgroup buffer (funcall assoc workgroup buffer)))
 
        (t nil)))
 

	
 
(defun wg-auto-associate-buffer (buffer &optional frame)
 
  "Conditionally associate BUFFER with the current workgroup in FRAME.
 
Frame defaults to `selected-frame'.  See `wg-buffer-auto-association'."
 
  (when wg-buffer-auto-association-on
 
    (wg-when-let ((wg (wg-current-workgroup t frame))
 
    (-when-let* ((wg (wg-current-workgroup t frame))
 
                 (b (get-buffer buffer)))
 
      (unless (or (wg-workgroup-bufobj-association-type wg buffer)
 
                  (member wg wg-deactivation-list)
 
                  (member (buffer-name b) wg-associate-blacklist)
 
                  (not (or (buffer-file-name b)
 
                           (eq (buffer-local-value 'major-mode b) 'dired-mode))))
 
        (wg-auto-associate-buffer-helper
 
         wg buffer (wg-local-value 'wg-buffer-auto-association wg))))))
 

	
 
(defadvice switch-to-buffer (after wg-auto-associate-buffer)
 
  "Automatically associate the buffer with the current workgroup."
 
  (wg-auto-associate-buffer ad-return-value))
 

	
 
(defadvice set-window-buffer (after wg-auto-associate-buffer)
 
  "Automatically associate the buffer with the current workgroup."
 
  (wg-auto-associate-buffer
 
   (ad-get-arg 1)
 
   (window-frame (or (ad-get-arg 0) (selected-window)))))
 

	
 
(provide 'workgroups-advice)
 
;;; workgroups-advice.el ends here
src/workgroups-buf.el
Show inline comments
 
;;; workgroups-buf.el --- BUFFER class
 
;;; Commentary:
 
;;
 
;; Workgroups Data Structures:
 
;;   https://github.com/pashinin/workgroups2/wiki/Workgroups-data-structures
 
;;
 
;;
 
;; BUFFER is the most low level part Workgroups operates with (except
 
;; serializing Emacs objects functions).
 
;;
 
;; Different buffers we have:
 
;;  - live buffers     (just switch-to them)
 
;;  - files/dirs       (open them)
 
;;  - special buffers  (shells, unknown modes - write support for them)
 
;;
 
;; Another different types of "buffers":
 
;;  - standard Emacs buffer (as you know it)
 
;;  - Workgroups Buffer object (Elisp object, a representation of Emacs buffer)
 
;;; Code:
 

	
 
(require 'workgroups-pickel)
 
(require 'workgroups-specialbufs)
 
(require 'workgroups-structs)
 

	
 
;;; Variables
 

	
 
(defvar wg-buffer-workgroup nil
 
  "A workgroup in which this buffer most recently appeared.
 
Buffer-local.")
 
(make-variable-buffer-local 'wg-buffer-workgroup)
 

	
 
(defcustom wg-default-buffer "*scratch*"
 
  "Show this in case everything else fails.
 
When a buffer can't be restored, when creating a blank wg."
 
  :type 'string
 
  :group 'workgroups)
 

	
 

	
 
;;; Functions
 

	
 
(defmacro wg-buf-list ()
 
  "Setf'able `wg-current-session' buf-list slot accessor."
 
  `(wg-session-buf-list (wg-current-session)))
 

	
 
(defun wg-restore-default-buffer (&optional switch)
 
  "Return `wg-default-buffer' and maybe SWITCH to it."
 
  (if switch
 
      (switch-to-buffer wg-default-buffer t)
 
    (get-buffer-create wg-default-buffer)))
 

	
 
(defun wg-restore-existing-buffer (buf &optional switch)
 
  "Return existing buffer from BUF and maybe SWITCH to it."
 
  (wg-when-let ((b (wg-find-buf-in-buffer-list buf (wg-buffer-list-emacs))))
 
  (-when-let (b (wg-find-buf-in-buffer-list buf (wg-buffer-list-emacs)))
 
    (if switch (switch-to-buffer b t))
 
    (with-current-buffer b
 
      (wg-set-buffer-uid-or-error (wg-buf-uid buf))
 
      b)))
 

	
 
(defun wg-restore-file-buffer (buf &optional switch)
 
  "Restore BUF by finding its file and maybe SWITCH to it.
 
Return the created buffer.
 
If BUF's file doesn't exist, call `wg-restore-default-buffer'"
 
  ;;(wg-when-let ((file-name (wg-buf-file-name buf)))
 
  ;;(-when-let ((file-name (wg-buf-file-name buf)))
 
  (let ((file-name (wg-buf-file-name buf)))
 
    (when (and file-name
 
               (or wg-restore-remote-buffers
 
                   (not (file-remote-p file-name))))
 
      (cond ((file-exists-p file-name)
 
             ;; jit ignore errors
 
             ;;(ignore-errors
 
             (condition-case err
 
                 (let ((b (find-file-noselect file-name nil nil nil)))
 
                   (with-current-buffer b
 
                     (rename-buffer (wg-buf-name buf) t)
 
                     (wg-set-buffer-uid-or-error (wg-buf-uid buf))
 
                     (when wg-restore-mark
 
                       (set-mark (wg-buf-mark buf))
 
                       (deactivate-mark))
 
                     (wg-deserialize-buffer-local-variables buf)
 
                     )
 
                   (if switch (switch-to-buffer b))
 
                   b)
 
               (error
 
                (message "Error while restoring a file %s:\n  %s" file-name (error-message-string err))
 
                nil)))
 
            (t
 
             ;; try directory
 
             (if (file-directory-p (file-name-directory file-name))
 
                 (dired (file-name-directory file-name))
 
               (progn
 
                 (message "Attempt to restore nonexistent file: %S" file-name)
 
                 nil))
 
             )))))
 

	
 
(defun wg-restore-special-buffer (buf &optional switch)
 
  "Restore a buffer BUF with DESERIALIZER-FN and maybe SWITCH to it."
 
  (wg-when-let
 
  (-when-let*
 
      ((special-data (wg-buf-special-data buf))
 
       (buffer (save-window-excursion
 
                 (condition-case err
 
                     (funcall (car special-data) buf)
 
                   (error (message "Error deserializing %S: %S" (wg-buf-name buf) err)
 
                          nil)))))
 
    (if switch (switch-to-buffer buffer t))
 
    (with-current-buffer buffer
 
      (wg-set-buffer-uid-or-error (wg-buf-uid buf)))
 
    buffer))
 

	
 
(defun wg-restore-buffer (buf &optional switch)
 
  "Restore BUF, return it and maybe SWITCH to it."
 
  (fset 'buffer-list wg-buffer-list-original)
 
  (prog1
 
      (or (wg-restore-existing-buffer buf switch)
 
          (wg-restore-special-buffer buf switch)  ;; non existent dired problem
 
          (wg-restore-file-buffer buf switch)
 
          (progn (wg-restore-default-buffer switch) nil))
 
    (if wg-mess-with-buffer-list
 
        (fset 'buffer-list wg-buffer-list-function))))
 

	
 

	
 

	
 
;;; buffer object utils
 

	
 
(defun wg-buffer-uid (buffer-or-name)
 
  "Return BUFFER-OR-NAME's buffer-local value of `wg-buffer-uid'."
 
  (buffer-local-value 'wg-buffer-uid (wg-get-buffer buffer-or-name)))
 

	
 
(defun wg-bufobj-uid (bufobj)
 
  "Return BUFOBJ's uid."
 
  (cl-etypecase bufobj
 
    (buffer (wg-buffer-uid bufobj))
 
    (wg-buf (wg-buf-uid bufobj))
 
    (string (wg-bufobj-uid (wg-get-buffer bufobj)))))
 

	
 
(defun wg-bufobj-name (bufobj)
 
  "Return BUFOBJ's buffer name."
 
  (cl-etypecase bufobj
 
    (buffer (buffer-name bufobj))
 
    (wg-buf (wg-buf-name bufobj))
 
    (string (wg-buffer-name bufobj))))
 

	
 
(defun wg-bufobj-file-name (bufobj)
 
  "Return BUFOBJ's filename."
 
  (cl-etypecase bufobj
 
    (buffer (buffer-file-name bufobj))
 
    (wg-buf (wg-buf-file-name bufobj))
 
    (string (wg-bufobj-file-name (wg-get-buffer bufobj)))))
 

	
 
(defun wg-buf-major-mode (buf)
 
  "Return BUF's `major-mode'.
 
It's stored in BUF's local-vars list, since it's a local variable."
 
  (wg-aget (wg-buf-local-vars buf) 'major-mode))
 

	
 
(defun wg-buffer-major-mode (bufobj)
 
  "Return BUFOBJ's `major-mode'.
 
It works with Emacs buffer, Workgroups buffer object and a simple string."
 
  (cl-etypecase bufobj
 
    (buffer (wg-buffer-major-mode bufobj))
 
    (wg-buf (wg-buf-major-mode bufobj))
 
    (string (wg-buffer-major-mode bufobj))))
 

	
 
;; `wg-equal-bufobjs' and `wg-find-bufobj' may need to be made a lot smarter
 
(defun wg-equal-bufobjs (bufobj1 bufobj2)
 
  "Return t if BUFOBJ1 is \"equal\" to BUFOBJ2."
 
  (let ((fname1 (wg-bufobj-file-name bufobj1))
 
        (fname2 (wg-bufobj-file-name bufobj2)))
 
    (cond ((and fname1 fname2) (string= fname1 fname2))
 
          ((or fname1 fname2) nil)
 
          ((string= (wg-bufobj-name bufobj1) (wg-bufobj-name bufobj2)) t))))
 

	
 
(defun wg-find-bufobj (bufobj bufobj-list)
 
  "Find BUFOBJ in BUFOBJ-LIST, testing with `wg-equal-bufobjs'."
 
  (cl-find bufobj bufobj-list :test 'wg-equal-bufobjs))
 

	
 
(defun wg-find-bufobj-by-uid (uid bufobj-list)
 
  "Find the bufobj in BUFOBJ-LIST with uid UID."
 
  (cl-find uid bufobj-list :test 'string= :key 'wg-bufobj-uid))
 

	
 
(defun wg-find-buf-in-buf-list (buf buf-list)
 
  "Find BUF in BUF-LIST.
 
This is only here for completeness."
 
  (cl-find buf buf-list))
 

	
 
(defun wg-find-buffer-in-buffer-list (buffer-or-name buffer-list)
 
  "Find BUFFER-OR-NAME in BUFFER-LIST."
 
  (cl-find (wg-get-buffer buffer-or-name) buffer-list :key 'wg-get-buffer))
 

	
 
(defun wg-find-buffer-in-buf-list (buffer-or-name buf-list)
 
  "Find BUFFER-OR-NAME in BUF-LIST."
 
  (aif (wg-buffer-uid buffer-or-name)
 
      (wg-find-bufobj-by-uid it buf-list)
 
    (wg-find-bufobj buffer-or-name buf-list)))
 

	
 
(defun wg-find-buf-in-buffer-list (buf buffer-list)
 
  "Find BUF in BUFFER-LIST."
 
  (or (wg-find-bufobj-by-uid (wg-buf-uid buf) buffer-list)
 
      (wg-find-bufobj buf buffer-list)))
 

	
 
(defun wg-find-buf-by-uid (uid)
 
  "Find a buf in `wg-buf-list' by UID."
 
  (wg-find-bufobj-by-uid uid (wg-buf-list)))
 

	
 
(defun wg-set-buffer-uid-or-error (uid &optional buffer)
 
  "Set BUFFER's buffer local value of `wg-buffer-uid' to UID.
 
If BUFFER already has a buffer local value of `wg-buffer-uid',
 
and it's not equal to UID, error."
 
  (if wg-buffer-uid
 
      ;;(if (string= wg-buffer-uid uid) uid
 
      ;;  (error "uids don't match %S and %S" uid wg-buffer-uid))
 
      (setq wg-buffer-uid uid)))
 

	
 

	
 
(defun wg-buffer-special-data (buffer)
 
  "Return BUFFER's auxiliary serialization, or nil."
 
  (cl-some (lambda (fn) (funcall fn buffer)) wg-special-buffer-serdes-functions))
 

	
 

	
 
(defun wg-serialize-buffer-local-variables ()
 
  "Return an alist of buffer-local variable symbols and their values.
 
See `wg-buffer-local-variables-alist' for details."
 
  (wg-docar (entry wg-buffer-local-variables-alist)
 
    (wg-dbind (var ser des) entry
 
      (when (local-variable-p var)
 
        (cons var (if ser (funcall ser) (symbol-value var)))))))
 

	
 
(defun wg-buffer-to-buf (buffer)
 
  "Return the serialization (a wg-buf) of Emacs buffer BUFFER."
 
  (with-current-buffer buffer
 
    (wg-make-buf
 
     :name           (buffer-name)
 
     :file-name      (buffer-file-name)
 
     :point          (point)
 
     :mark           (mark)
 
     :local-vars     (wg-serialize-buffer-local-variables)
 
     :special-data   (wg-buffer-special-data buffer))))
 

	
 
(defun wg-add-buffer-to-buf-list (buffer)
 
  "Make a buf from BUFFER, and add it to `wg-buf-list' if necessary.
 
If there isn't already a buf corresponding to BUFFER in
 
`wg-buf-list', make one and add it.  Return BUFFER's uid
 
in either case."
 
  (with-current-buffer buffer
 
    (setq wg-buffer-uid
 
          (aif (wg-find-buffer-in-buf-list buffer (wg-buf-list))
 
              (wg-buf-uid it)
 
            (let ((buf (wg-buffer-to-buf buffer)))
 
              (push buf (wg-buf-list))
 
              (wg-buf-uid buf))))))
 

	
 
(defun wg-buffer-uid-or-add (buffer)
 
  "Return BUFFER's uid.
 
If there isn't already a buf corresponding to BUFFER in
 
`wg-buf-list', make one and add it."
 
  (or (wg-buffer-uid buffer) (wg-add-buffer-to-buf-list buffer)))
 

	
 
(defun wg-bufobj-uid-or-add (bufobj)
 
  "If BUFOBJ is a wg-buf, return its uid.
 
If BUFOBJ is a buffer or a buffer name, see `wg-buffer-uid-or-add'."
 
  (cl-etypecase bufobj
 
    (wg-buf (wg-buf-uid bufobj)) ;; possibly also add to `wg-buf-list'
 
    (buffer (wg-buffer-uid-or-add bufobj))
 
    (string (wg-bufobj-uid-or-add (wg-get-buffer bufobj)))))
 

	
 

	
 
(defun wg-reset-buffer (buffer)
 
  "Return BUFFER.
 
Currently only sets BUFFER's `wg-buffer-uid' to nil."
 
  (with-current-buffer buffer (setq wg-buffer-uid nil)))
 

	
 

	
 

	
 
;;; buffer-list-filter commands
 

	
 
(defun wg-update-buffer-in-buf-list (&optional buffer)
 
  "Update BUFFER's corresponding buf in `wg-buf-list'.
 
BUFFER nil defaults to `current-buffer'."
 
  (let ((buffer (or buffer (current-buffer))))
 
    (wg-when-let ((uid (wg-buffer-uid buffer))
 
    (-when-let* ((uid (wg-buffer-uid buffer))
 
                 (old-buf (wg-find-buf-by-uid uid))
 
                 (new-buf (wg-buffer-to-buf buffer)))
 
      (setf (wg-buf-uid new-buf) (wg-buf-uid old-buf))
 
      (wg-asetf (wg-buf-list) (cons new-buf (remove old-buf it))))))
 

	
 
(defun wg-update-buf-list (&optional buffer-list)
 
  "Update all bufs in `wg-buf-list' corresponding to buffers in BUFFER-LIST."
 
  (mapc 'wg-update-buffer-in-buf-list (or buffer-list (wg-buffer-list-emacs))))
 

	
 
(defun wg-buffer-list-display (buffer-list)
 
  "Return the BUFFER-LIST display string."
 
  (wg-display-internal 'wg-buffer-display buffer-list))
 

	
 
;; buffer-list filters
 

	
 
(defun wg-buffer-list-filter-all (workgroup initial)
 
  "Return all buffers in INITIAL."
 
  initial)
 

	
 
;; buffer-list-filter context
 

	
 
(defmacro wg-prior-mapping (mode command)
 
  "Return whatever COMMAND would call if MODE wasn't on."
 
  `(or (let (,mode) (command-remapping ,command)) ,command))
 

	
 
(provide 'workgroups-buf)
 
;;; workgroups-buf.el ends here
src/workgroups-utils-basic.el
Show inline comments
 
;;; workgroups-utils.el --- Utilities used by Workgroups
 
;;; Commentary:
 
;;
 
;; A bunch of general purpose-ish utilities used by Workgroups.
 
;;
 
;;; Code:
 

	
 
;;; utils used in macros
 

	
 
(require 'dash)
 
(require 'cl-lib)
 
(require 'anaphora)
 
(require 'workgroups-faces)
 
(require 'workgroups-variables)
 

	
 
(defmacro wg-with-gensyms (syms &rest body)
 
  "Bind all symbols in SYMS to `gensym's, and eval BODY."
 
  (declare (indent 1))
 
  `(let (,@(mapcar (lambda (sym) `(,sym (cl-gensym))) syms)) ,@body))
 

	
 
(defmacro wg-dbind (args expr &rest body)
 
  "Bind the variables in ARGS to the result of EXPR and execute BODY.
 
Abbreviation of `destructuring-bind'."
 
  (declare (indent 2))
 
  `(cl-destructuring-bind ,args ,expr ,@body))
 

	
 
(defun wg-partition (list &optional n step)
 
  "Take LIST, return a list of N length sublists, offset by STEP.
 
N defaults to 2, and STEP defaults to N.
 
Iterative to prevent stack overflow."
 
  (let* ((n (or n 2)) (step (or step n)) acc)
 
    (while list
 
      (push (-take n list) acc)
 
      (setq list (nthcdr step list)))
 
    (nreverse acc)))
 

	
 

	
 

	
 
;;; bindings
 

	
 
(defmacro wg-when-let (binds &rest body)
 
  "Like `let*' but when all BINDS are non-nil - eval BODY."
 
  (declare (indent 1))
 
  (wg-dbind (bind . binds) binds
 
    (when (consp bind)
 
      `(let (,bind)
 
         (when ,(car bind)
 
           ,(if (not binds) `(progn ,@body)
 
              `(wg-when-let ,binds ,@body)))))))
 

	
 
(defmacro wg-when-boundp (symbols &rest body)
 
  "When all SYMBOLS are bound, `eval' BODY."
 
  (declare (indent 1))
 
  `(when (and ,@(mapcar (lambda (sym) `(boundp ',sym)) symbols))
 
     ,@body))
 

	
 

	
 

	
 
;;; do-style wrappers
 

	
 
(defmacro wg-docar (spec &rest body)
 
  "do-style wrapper for `mapcar'.
 

	
 
\(fn (VAR LIST) BODY...)"
 
  (declare (indent 1))
 
  `(mapcar (lambda (,(car spec)) ,@body) ,(cadr spec)))
 

	
 
(defmacro wg-dohash (spec &rest body)
 
  "do-style wrapper for `maphash'.
 

	
 
\(fn (KEY VALUE TABLE [RESULT]) BODY...)"
 
  (declare (indent 1))
 
  (wg-dbind (key val table &optional result) spec
 
    `(progn (maphash (lambda (,key ,val) ,@body) ,table) ,result)))
 

	
 
(defmacro wg-doconcat (spec &rest body)
 
  "do-style wrapper for `mapconcat'.
 

	
 
\(fn (VAR SEQ [SEPARATOR]) BODY...)"
 
  (declare (indent 1))
 
  (wg-dbind (elt seq &optional sep) spec
 
    `(mapconcat (lambda (,elt) ,@body) ,seq (or ,sep ""))))
 

	
 

	
 

	
 
;;; anaphora
 

	
 
(defmacro wg-asetf (&rest places-and-values)
 
  "Anaphoric `setf'."
 
  `(progn ,@(mapcar (lambda (pv) `(let ((it ,(car pv))) (setf ,@pv)))
 
                    (wg-partition places-and-values 2))))
 

	
 

	
 

	
 
;;; other control structures
 

	
 
(defmacro wg-destructuring-dolist (spec &rest body)
 
  "Loop over a list.
 
Evaluate BODY, destructuring LIST into SPEC, then evaluate RESULT
 
to get a return value, defaulting to nil.  The only hitch is that
 
spec must end in dotted style, collecting the rest of the list
 
into a var, like so: (a (b c) . rest)
 

	
 
\(fn (SPEC LIST [RESULT]) BODY...)"
 
  (declare (indent 1))
 
  (wg-dbind (loopspec list &optional result) spec
 
    (let ((rest (cdr (last loopspec))))
 
      (wg-with-gensyms (list-sym)
 
        `(let ((,list-sym ,list))
 
           (while ,list-sym
 
             (wg-dbind ,loopspec ,list-sym
 
               ,@body
 
               (setq ,list-sym ,rest)))
 
           ,result)))))
 

	
 

	
 
;;; numbers
 

	
 
(defun wg-step-to (n m step)
 
  "Increment or decrement N toward M by STEP.
 
Return M when the difference between N and M is less than STEP."
 
  (cond ((= n m) n)
 
        ((< n m) (min (+ n step) m))
 
        ((> n m) (max (- n step) m))))
 

	
 
(defun wg-within (num lo hi &optional hi-inclusive)
 
  "Return t when NUM is within bounds LO and HI.
 
HI-INCLUSIVE non-nil means the HI bound is inclusive."
 
  (and (>= num lo) (if hi-inclusive (<= num hi) (< num hi))))
 

	
 
(defun wg-int-to-b36-one-digit (i)
 
  "Return a character in 0..9 or A..Z from I, and integer 0<=I<32.
 
Cribbed from `org-id-int-to-b36-one-digit'."
 
  (cond ((not (wg-within i 0 36))
 
         (error "%s out of range" i))
 
        ((< i 10) (+ ?0 i))
 
        ((< i 36) (+ ?A i -10))))
 

	
 
(defun wg-b36-to-int-one-digit (i)
 
  "Turn a character 0..9, A..Z, a..z into a number 0..61.
 
The input I may be a character, or a single-letter string.
 
Cribbed from `org-id-b36-to-int-one-digit'."
 
  (and (stringp i) (setq i (string-to-char i)))
 
  (cond ((and (>= i ?0) (<= i ?9)) (- i ?0))
 
        ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10))
 
        (t (error "Invalid b36 character"))))
 

	
 
(defun wg-int-to-b36 (i &optional length)
 
  "Return a base 36 string from I."
 
  (let ((base 36) b36)
 
    (cl-labels ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36)
 
                         (setq i (/ i base))))
 
      (add-digit)
 
      (while (> i 0) (add-digit))
 
      (setq b36 (cl-map 'string 'identity b36))
 
      (if (not length) b36
 
        (concat (make-string (max 0 (- length (length b36))) ?0) b36)))))
 

	
 
(defun wg-b36-to-int (str)
 
  "Convert STR, a base-36 string, into the corresponding integer.
 
Cribbed from `org-id-b36-to-int'."
 
  (let ((result 0))
 
    (mapc (lambda (i)
 
            (setq result (+ (* result 36)
 
                            (wg-b36-to-int-one-digit i))))
 
          str)
 
    result))
 

	
 

	
 

	
 
;;; lists
 

	
 
(defmacro wg-removef-p (item seq-place &rest keys)
 
  "If ITEM is a `member*' of SEQ-PLACE, remove it from SEQ-PLACE and return t.
 
Otherwise return nil.  KEYS can be any keywords accepted by `remove*'."
 
  `(> (length ,seq-place)
 
      (length (setf ,seq-place (cl-remove ,item ,seq-place ,@keys)))))
 

	
 
(defmacro wg-pushnew-p (item seq-place &rest keys)
 
  "If ITEM is not a `member' of SEQ-PLACE, push it to SEQ-PLACE and return t.
 
Otherwise return nil.  KEYS can be any keyword args accepted by `pushnew'."
 
  `(< (length ,seq-place)
 
      (length (cl-pushnew ,item ,seq-place ,@keys))))
 

	
 
(defun wg-range (start end)
 
  "Return a list of integers from START up to but not including END."
 
  (let (accum)
 
    (dotimes (i (- end start) (nreverse accum))
 
      (push (+ start i) accum))))
 

	
 
(defun wg-rotate-list (list &optional offset)
 
  "Rotate LIST by OFFSET.  Positive OFFSET rotates left, negative right."
 
  (when list
 
    (let ((split (mod (or offset 1) (length list))))
 
      (append (nthcdr split list) (-take split list)))))
 

	
 
(defun wg-center-rotate-list (list)
 
  "Rotate LIST so it's first elt is in the center.  When LIST's
 
length is even, the first elt is left nearer the front."
 
  (wg-rotate-list list (- (/ (1- (length list)) 2))))
 

	
 
(defun wg-insert-after (elt list index)
 
  "Insert ELT into LIST after INDEX."
 
  (let ((new-list (cl-copy-list list)))
 
    (push elt (cdr (nthcdr index new-list)))
 
    new-list))
 

	
 
(defun wg-insert-before (elt list index)
 
  "Insert ELT into LIST before INDEX."
 
  (if (zerop index) (cons elt list)
 
    (wg-insert-after elt list (1- index))))
 

	
 
(defun wg-move-elt (elt list index &rest keys)
 
  "Move ELT before INDEX in LIST.
 
KEYS is passed to `remove*'."
 
  (wg-insert-before elt (apply 'cl-remove elt list keys) index))
 

	
 
(defun wg-cyclic-nth (list n)
 
  "Return the Nth element of LIST, modded by the length of list."
 
  (nth (mod n (length list)) list))
 

	
 
(defun wg-cyclic-offset-elt (elt list n)
 
  "Cyclically offset ELT's position in LIST by N."
 
  (wg-when-let ((pos (cl-position elt list)))
 
  (-when-let (pos (cl-position elt list))
 
    (wg-move-elt elt list (mod (+ n pos) (length list)))))
 

	
 
(defun wg-cyclic-nth-from-elt (elt list n &rest keys)
 
  "Return the elt in LIST N places cyclically from ELT.
 
If ELT is not present is LIST, return nil.
 
KEYS is passed to `position'."
 
  (wg-when-let ((pos (apply 'cl-position elt list keys)))
 
  (-when-let (pos (apply 'cl-position elt list keys))
 
    (wg-cyclic-nth list (+ pos n))))
 

	
 
(defun wg-util-swap (elt1 elt2 list)
 
  "Return a copy of LIST with ELT1 and ELT2 swapped.
 
Return nil when ELT1 and ELT2 aren't both present."
 
  (wg-when-let ((p1 (cl-position elt1 list))
 
  (-when-let* ((p1 (cl-position elt1 list))
 
               (p2 (cl-position elt2 list)))
 
    (wg-move-elt elt1 (wg-move-elt elt2 list p1) p2)))
 

	
 
(defun wg-dups-p (list &rest keys)
 
  "Return non-nil when LIST contains duplicate elements.
 

	
 
Keywords supported: :test :key
 

	
 
\(fn LIST [KEYWORD VALUE]...)"
 
  (let ((test (or (plist-get keys :test) 'eq))
 
        (key (or (plist-get keys :key) 'identity)))
 
    (cl-loop for (elt . rest) on list
 
             for elt = (funcall key elt)
 
             when (cl-find elt rest :test test :key key) return elt)))
 

	
 
(defun wg-string-list-union (&optional list1 list2)
 
  "Return the `union' of LIST1 and LIST2, using `string=' as the test.
 
This only exists to get rid of duplicate lambdas in a few reductions."
 
  (cl-union list1 list2 :test 'string=))
 

	
 

	
 

	
 
;;; alists
 

	
 
(defun wg-make-alist (&rest kvps)
 
  "Return a new alist from KVPS."
 
  (let (alist)
 
    (while kvps
 
      (push (cons (car kvps) (cadr kvps)) alist)
 
      (setq kvps (cddr kvps)))
 
    (nreverse alist)))
 

	
 
(defun wg-aget (alist key &optional default)
 
  "Return the value of KEY in ALIST. Uses `assq'.
 
If PARAM is not found, return DEFAULT which defaults to nil."
 
  (aif (assq key alist) (cdr it) default))
 

	
 
(defun wg-acopy (alist)
 
  "Return a copy of ALIST's toplevel list structure."
 
  (mapcar (lambda (kvp) (cons (car kvp) (cdr kvp))) alist))
 

	
 
(defun wg-aput (alist key value)
 
  "Return a new alist from ALIST with KEY's value set to VALUE."
 
  (let* ((found nil)
 
         (new (wg-docar (kvp alist)
 
                (if (not (eq key (car kvp))) kvp
 
                  (setq found (cons key value))))))
 
    (if found new (cons (cons key value) new))))
 

	
 
(defun wg-aremove (alist key)
 
  "`remove' KEY's key-value-pair from ALIST."
 
  (remove (assoc key alist) alist))
 

	
 

	
 
;;; symbols and strings
 

	
 
(defun wg-toggle (symbol)
 
  "Toggle SYMBOL's truthiness."
 
  (set symbol (not (symbol-value symbol))))
 

	
 
(defun wg-symcat (&rest symbols-and-strings)
 
  "Return a new interned symbol by concatenating SYMBOLS-AND-STRINGS."
 
  (intern (mapconcat (lambda (obj) (if (symbolp obj) (symbol-name obj) obj))
 
                     symbols-and-strings "")))
 

	
 
(defun wg-make-string (times string &optional separator)
 
  "Like `make-string', but includes a separator."
 
  (mapconcat 'identity (make-list times string) (or separator "")))
 

	
 

	
 

	
 
;;; buffers
 

	
 
(defun wg-get-buffer (buffer-or-name)
 
  "Return BUFFER-OR-NAME's buffer, or error."
 
  (or (get-buffer buffer-or-name)
 
      (error "%S does not identify a buffer" buffer-or-name)))
 

	
 
(defun wg-buffer-name (buffer-or-name)
 
  "Return BUFFER-OR-NAME's `buffer-name', or error."
 
  (buffer-name (wg-get-buffer buffer-or-name)))
 

	
 
(defun wg-buffer-file-name (buffer-or-name)
 
  "Return BUFFER-OR-NAME's `buffer-file-name', or error."
 
  (buffer-file-name (wg-get-buffer buffer-or-name)))
 

	
 
(defun wg-buffer-major-mode (buffer-or-name)
 
  "Return BUFFER's major-mode."
 
  (with-current-buffer buffer-or-name major-mode))
 

	
 
(defun wg-current-buffer-p (buffer-or-name)
 
  "Return t if BUFFER-OR-NAME is the current buffer, nil otherwise."
 
  (eq (wg-get-buffer buffer-or-name) (current-buffer)))
 

	
 
(defmacro wg-buffer-local-setq (buffer var value)
 
  "`setq' VAR to VALUE while BUFFER is current.
 
Note that this won't make VAR buffer-local if it isn't already."
 
  `(with-current-buffer ,buffer (setq ,var ,value)))
 

	
 
(defun wg-interesting-buffers ()
 
  "Return a list of only the interesting buffers in `buffer-list'."
 
  (cl-remove-if (lambda (bname) (string-match "^ " bname))
 
                (wg-buffer-list-emacs) :key 'buffer-name))
 

	
 
(defun wg-get-first-buffer-matching-regexp (regexp &optional buffer-list)
 
  "Return the first buffer in BUFFER-LIST with a name matching REGEXP.
 
BUFFER-LIST should contain buffer objects and/or buffer names."
 
  (cl-find regexp (or buffer-list (wg-buffer-list-emacs))
 
           :test 'string-match :key 'wg-buffer-name))
 

	
 

	
 

	
 
;;; files
 

	
 
(defun wg-write-sexp-to-file (sexp file)
 
  "Write the printable representation of SEXP to FILE."
 
  (with-temp-buffer
 
    (let ((print-level nil)  (print-length nil))
 
      (insert (format "%S" sexp)))
 
    (write-file file)))
 

	
 

	
 
;;; frames
 

	
 
(defun wg-cyclic-nth-from-frame (&optional n frame)
 
  "Return the frame N places away from FRAME in `frame-list' cyclically.
 
N defaults to 1, and FRAME defaults to `selected-frame'."
 
  (wg-cyclic-nth-from-elt
 
   (or frame (selected-frame)) (frame-list) (or n 1)))
 

	
 

	
 

	
 
;;; namespace-prefixed defstruct
 

	
 
(defmacro wg-defstruct (prefix name-form &rest slot-defs)
 
  "`defstruct' wrapper that namespace-prefixes all generated functions.
 
Note: this doesn't yet work with :conc-name, and possibly other
 
options."
 
  (declare (indent 2))
 
  (let* ((name (if (consp name-form) (car name-form) name-form))
 
         (prefixed-name (wg-symcat prefix "-" name)))
 
    (cl-labels ((rebind (opstr)
 
                      (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name)))
 
                        `((fset ',(wg-symcat prefix "-" opstr "-" name)
 
                                (symbol-function ',oldfnsym))
 
                          (fmakunbound ',oldfnsym)))))
 
      ;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not
 
      ;; known to be defined").  We can accomplish this with `declare-function'
 
      ;; too, but it annoyingly requires inclusion of the function's arglist,
 
      ;; which gets ugly.
 
      `(eval-and-compile
 
         (cl-defstruct ,(if (symbolp name-form) prefixed-name
 
                       `(,prefixed-name ,@(cdr name-form)))
 
           ,@slot-defs)
 
         ,@(rebind "make")
 
         ,@(rebind "copy")
 
         ',prefixed-name))))
 

	
 
(defmacro wg-with-slots (obj slot-bindings &rest body)
 
  "Bind OBJ's slot values to symbols in BINDS, then eval BODY.
 
The car of each element of SLOT-BINDINGS is the bound symbol, and
 
the cadr as the accessor function."
 
  (declare (indent 2))
 
  (wg-with-gensyms (objsym)
 
    `(let* ((,objsym ,obj)
 
            ,@(wg-docar (slot slot-bindings)
 
                `(,(car slot) (,(cadr slot) ,objsym))))
 
       ,@body)))
 

	
 

	
 

	
 
;;; misc
 

	
 
(defun wg-add-or-remove-hooks (remove &rest pairs)
 
  "Add FUNCTION to or remove it from HOOK, depending on REMOVE."
 
  (dolist (pair (wg-partition pairs 2))
 
    (funcall (if remove 'remove-hook 'add-hook)
 
             (car pair) (cadr pair))))
 

	
 
(defmacro wg-set-parameter (place parameter value)
 
  "Set PARAMETER to VALUE at PLACE.
 
This needs to be a macro to allow specification of a setf'able place."
 
  (wg-with-gensyms (p v)
 
    `(let ((,p ,parameter) (,v ,value))
 
       (wg-pickelable-or-error ,p)
 
       (wg-pickelable-or-error ,v)
 
       (setf ,place (wg-aput ,place ,p ,v))
 
       ,v)))
 

	
 

	
 
;;; uid utils
 

	
 
(defun wg-time-to-b36 ()
 
  "Convert `current-time' into a b36 string."
 
  (apply 'concat (wg-docar (time (current-time))
 
                   (wg-int-to-b36 time 4))))
 

	
 
(defun wg-b36-to-time (b36)
 
  "Parse the time in B36 string from UID."
 
  (cl-loop for i from 0 to 8 by 4
 
           collect (wg-b36-to-int (cl-subseq b36 i (+ i 4)))))
 
(defalias 'wg-uid-to-time 'wg-b36-to-time)
 

	
 
(defun wg-generate-uid (&optional prefix)
 
  "Return a new uid, optionally prefixed by PREFIX."
 
  (concat prefix (wg-time-to-b36) "-" (wg-int-to-b36 string-chars-consed)))
 

	
 
(defun wg-uid-to-seconds (uid)
 
  "Return the `float-time' parsed from UID with `wg-uid-to-time'."
 
  (float-time (wg-uid-to-time uid)))
 

	
 

	
 
(defun wg-get-value (arg)
 
  "Get a value of ARG if it exists."
 
  (if (boundp `,arg) (eval arg)))
 

	
 
(defmacro wg-support (mode pkg params)
 
  "Macro to create (de)serialization functions for a buffer.
 
You need to save/restore a specific MODE which is loaded from a
 
package PKG.  In PARAMS you give local variables to save and a
 
deserialization function."
 
  `(let ((mode-str (symbol-name ,mode))
 
         (args ,params))
 

	
 
     (eval `(defun ,(intern (format "wg-deserialize-%s-buffer" mode-str)) (buffer)
 
              "DeSerialization function created with `wg-support'.
 
Gets saved variables and runs code to restore a BUFFER."
 
              (when (require ',,pkg nil 'noerror)
 
                (wg-dbind (this-function variables) (wg-buf-special-data buffer)
 
                  (let ((default-directory (car variables))
 
                        (df (cdr (assoc 'deserialize ',,params)))
 
                        (user-vars (car (cdr variables))))
 
                    (if df
 
                        (funcall df buffer user-vars)
 
                      (get-buffer-create wg-default-buffer))
 
                    )))))
 

	
 
     (eval `(defun ,(intern (format "wg-serialize-%s-buffer" mode-str)) (buffer)
 
              "Serialization function created with `wg-support'.
 
Saves some variables to restore a BUFFER later."
 
              (when (get-buffer buffer)
 
                (with-current-buffer buffer
 
                  (when (eq major-mode ',,mode)
 
                    (let ((sf (cdr (assoc 'serialize ',,params)))
 
                          (save (cdr (assoc 'save ',,params))))
 
                      (list ',(intern (format "wg-deserialize-%s-buffer" mode-str))
 
                            (list default-directory
 
                                  (if sf (funcall sf buffer)
 
                                    (if save (mapcar 'wg-get-value save)))
 
                                  ))))))))
 
     ;; Maybe change a docstring for functions
 
     ;;(put (intern (format "wg-serialize-%s-buffer" (symbol-name mode)))
 
     ;;     'function-documentation
 
     ;;     (format "A function created by `wg-support'."))
 

	
 
     ;; Add function to `wg-special-buffer-serdes-functions' variable
 
     (eval `(add-to-list 'wg-special-buffer-serdes-functions
 
                         ',(intern (format "wg-serialize-%s-buffer" mode-str)) t))
 
     ))
 

	
 
(defvar wg-current-session nil "Current session object.")
 
(defun wg-current-session (&optional noerror)
 
  "Return `wg-current-session' or scream unless NOERROR."
 
  (or wg-current-session
 
      (unless noerror
 
        (error "No session is defined"))))
 

	
 
;; locate-dominating-file
 
(defun wg-get-first-existing-dir (&optional dir)
 
  "Test if DIR exists and return it.
 
If not - try to go to the parent dir and do the same."
 
  (let* ((d (or dir default-directory)))
 
    (if (file-directory-p d) d
 
      (let* ((cur d) (parent (file-name-directory (directory-file-name cur))))
 
        (while (and (> (length cur) (length parent))
 
                    (not (file-directory-p parent)))
 
          (message "Test %s" parent)
 
          (setq cur parent)
 
          (setq parent (file-name-directory (directory-file-name cur))))
 
        parent))))
 

	
 
(provide 'workgroups-utils-basic)
 
;;; workgroups-utils-basic.el ends here
src/workgroups-wconfig.el
Show inline comments
 
;;; workgroups-wconfig.el --- WCONFIG
 
;;; Commentary:
 
;; This is a window-configuration, a buffer layout, whatever you call
 
;; it...  This is actually what you want to be saved and restored.
 
;; (Well, technically it is (window-tree + some frame parameters))
 
;;; Code:
 

	
 
(require 'workgroups-wtree)
 

	
 
(defun wg-frame-to-wconfig (&optional frame)
 
  "Return the serialization (a wg-wconfig) of Emacs frame FRAME.
 
FRAME nil defaults to `selected-frame'."
 
  (let* ((frame (or frame (selected-frame)))
 
         (fullscrn (frame-parameter frame 'fullscreen)))
 
    (wg-make-wconfig
 
     :left                  (frame-parameter frame 'left)
 
     :top                   (frame-parameter frame 'top)
 
     :width                 (frame-parameter frame 'width)
 
     :height                (frame-parameter frame 'height)
 
     :parameters            `((fullscreen . ,fullscrn))
 
     :vertical-scroll-bars  (frame-parameter frame 'vertical-scroll-bars)
 
     :scroll-bar-width      (frame-parameter frame 'scroll-bar-width)
 
     :wtree                 (wg-window-tree-to-wtree (window-tree frame))
 
     )))
 

	
 
(defun wg-current-wconfig ()
 
  "Return the current wconfig.
 
If `wg-current-wconfig' is non-nil, return it.  Otherwise return
 
`wg-frame-to-wconfig'."
 
  (or (frame-parameter nil 'wg-current-wconfig)
 
      (wg-frame-to-wconfig)))
 

	
 
(defmacro wg-with-current-wconfig (frame wconfig &rest body)
 
  "Eval BODY with WCONFIG current in FRAME.
 
FRAME nil defaults to `selected-frame'."
 
  (declare (indent 2))
 
  (wg-with-gensyms (frame-sym old-value)
 
    `(let* ((,frame-sym (or ,frame (selected-frame)))
 
            (,old-value (frame-parameter ,frame-sym 'wg-current-wconfig)))
 
       (unwind-protect
 
           (progn
 
             (set-frame-parameter ,frame-sym 'wg-current-wconfig ,wconfig)
 
             ,@body)
 
         (when (frame-live-p ,frame-sym)
 
           (set-frame-parameter ,frame-sym 'wg-current-wconfig ,old-value))))))
 

	
 
(defun wg-make-blank-wconfig (&optional buffer)
 
  "Return a new blank wconfig.
 
BUFFER or `wg-default-buffer' is visible in the only window."
 
  (save-window-excursion
 
    (delete-other-windows)
 
    (switch-to-buffer (or buffer wg-default-buffer))
 
    (wg-frame-to-wconfig)))
 

	
 
(defun wg-wconfig-move-window (wconfig offset)
 
  "Offset `selected-window' OFFSET places in WCONFIG."
 
  (wg-asetf (wg-wconfig-wtree wconfig) (wg-wtree-move-window it offset))
 
  wconfig)
 

	
 

	
 
;;; base wconfig updating
 

	
 
(defun wg-update-working-wconfig-on-delete-frame (frame)
 
  "Update FRAME's current workgroup's working-wconfig before
 
FRAME is deleted, so we don't lose its state."
 
  (with-selected-frame frame
 
    (wg-update-current-workgroup-working-wconfig)))
 

	
 

	
 
(defun wg-wconfig-buf-uids (wconfig)
 
  "Return WCONFIG's wtree's `wg-wtree-buf-uids'."
 
  (if (not (wg-wconfig-wtree wconfig))
 
      (error "WTREE is nil in `wg-wconfig-buf-uids'!"))
 
  (wg-wtree-unique-buf-uids (wg-wconfig-wtree wconfig)))
 

	
 

	
 

	
 

	
 

	
 
(defun wg-wconfig-restore-frame-position (wconfig &optional frame)
 
  "Use WCONFIG to restore FRAME's position.
 
If frame is nil then `selected-frame'."
 
  (wg-when-let ((left (wg-wconfig-left wconfig))
 
  (-when-let* ((left (wg-wconfig-left wconfig))
 
               (top (wg-wconfig-top wconfig)))
 
    ;; Check that arguments are integers
 
    ;; Problem: https://github.com/pashinin/workgroups2/issues/15
 
    (if (and (integerp left)
 
             (integerp top))
 
        (set-frame-position frame left top))))
 

	
 
(defun wg-wconfig-restore-scroll-bars (wconfig)
 
  "Restore `selected-frame's scroll-bar settings from WCONFIG."
 
  (set-frame-parameter
 
   nil 'vertical-scroll-bars (wg-wconfig-vertical-scroll-bars wconfig))
 
  (set-frame-parameter
 
   nil 'scroll-bar-width (wg-wconfig-scroll-bar-width wconfig)))
 

	
 
;;(defun wg-wconfig-restore-fullscreen (wconfig)
 
;;  "Restore `selected-frame's fullscreen settings from WCONFIG."
 
;;  (set-frame-parameter
 
;;   nil 'fullscreen (wg-wconfig-parameters wconfig))
 
;;  )
 

	
 
(defun wg-scale-wconfigs-wtree (wconfig new-width new-height)
 
  "Scale WCONFIG's wtree with NEW-WIDTH and NEW-HEIGHT.
 
Return a copy WCONFIG's wtree scaled with `wg-scale-wtree' by the
 
ratio or NEW-WIDTH to WCONFIG's width, and NEW-HEIGHT to
 
WCONFIG's height."
 
  (wg-normalize-wtree
 
   (wg-scale-wtree
 
    (wg-wconfig-wtree wconfig)
 
    (/ (float new-width)  (wg-wconfig-width wconfig))
 
    (/ (float new-height) (wg-wconfig-height wconfig)))))
 

	
 
(defun wg-scale-wconfig-to-frame (wconfig)
 
  "Scale WCONFIG buffers to fit current frame size.
 
Return a scaled copy of WCONFIG."
 
  (interactive)
 
  (wg-scale-wconfigs-wtree wconfig
 
                           (frame-parameter nil 'width)
 
                           (frame-parameter nil 'height)))
 

	
 
(defun wg-frame-resize-and-position (wconfig &optional frame)
 
  "Apply WCONFIG's size and position to a FRAME."
 
  (interactive)
 
  (unless frame (setq frame (selected-frame)))
 
  (let* ((params (wg-wconfig-parameters wconfig))
 
         fullscreen)
 
    (set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params)
 
                                               (cdr (assoc 'fullscreen params))
 
                                             nil))
 
    (when (and wg-restore-frame-position
 
               (not (frame-parameter frame 'fullscreen)))
 
      (wg-wconfig-restore-frame-position wconfig frame))
 
    ))
 

	
 
(defun wg-restore-frame-size-position (wconfig &optional fs)
 
  "Smart-restore of frame size and position.
 

	
 
Depending on `wg-remember-frame-for-each-wg' frame parameters may
 
be restored for each workgroup.
 

	
 
If `wg-remember-frame-for-each-wg' is nil (by default) then
 
current frame parameters are saved/restored to/from first
 
workgroup. And frame parameters for all other workgroups are just
 
ignored.
 
"
 
  (interactive)
 
  (let* ((params (wg-wconfig-parameters wconfig))
 
         fullscreen)
 
    ;; Frame maximized / fullscreen / none
 
    (unless wg-remember-frame-for-each-wg
 
      (setq params (wg-wconfig-parameters (wg-workgroup-working-wconfig (wg-first-workgroup)))))
 
    (setq fullscreen (if (assoc 'fullscreen params)
 
                         (cdr (assoc 'fullscreen params))
 
                       nil))
 
    (when (and fs
 
               fullscreen
 
               (or wg-remember-frame-for-each-wg
 
                   (null (wg-current-workgroup t))))
 
      (set-frame-parameter nil 'fullscreen fullscreen)
 
      ;; I had bugs restoring maximized frame:
 
      ;; Frame could be maximized but buffers are not scaled to fit it.
 
      ;;
 
      ;; Maybe because of `set-frame-parameter' takes some time to finish and is async.
 
      ;; So I tried this and it helped
 
      (sleep-for 0 100))
 

	
 
    ;; Position
 
    (when (and wg-restore-frame-position
 
               wg-remember-frame-for-each-wg
 
               (not (frame-parameter nil 'fullscreen)))
 
      (wg-wconfig-restore-frame-position wconfig))
 
    ))
 

	
 

	
 
(defun wg-restore-frames ()
 
  "Try to recreate opened frames, take info from session's 'frame-list parameter."
 
  (interactive)
 
  (delete-other-frames)
 
  (when (wg-current-session t)
 
    (let ((fl (wg-session-parameter (wg-current-session t) 'frame-list nil))
 
          (frame (selected-frame)))
 
      (mapc (lambda (wconfig)
 
              (with-selected-frame (make-frame)
 
                ;;(wg-frame-resize-and-position wconfig)
 
                ;;(wg-restore-frame-size-position wconfig)
 
                ;;(wg-wconfig-restore-frame-position wconfig)
 
                (wg-restore-wconfig wconfig)
 
                )) fl)
 
      (select-frame-set-input-focus frame))))
 

	
 
;; FIXME: throw a specific error if the restoration was unsuccessful
 
(defun wg-restore-wconfig (wconfig &optional frame)
 
  "Restore a workgroup configuration WCONFIG in a FRAME.
 
Runs each time you're switching workgroups."
 
  (unless frame (setq frame (selected-frame)))
 
  (let ((wg-record-incorrectly-restored-bufs t)
 
        (wg-incorrectly-restored-bufs nil)
 
        (params (wg-wconfig-parameters wconfig))
 
        fullscreen)
 
    (wg-barf-on-active-minibuffer)
 
    (when wg-restore-scroll-bars
 
      (wg-wconfig-restore-scroll-bars wconfig))
 

	
 
    (when (null (wg-current-workgroup t))
 
      (set-frame-parameter frame 'fullscreen (if (assoc 'fullscreen params)
 
                                                 (cdr (assoc 'fullscreen params))
 
                                               nil)))
 

	
 
    ;; Restore frame position
 
    (when (and wg-restore-frame-position
 
               (not (frame-parameter nil 'fullscreen))
 
               (null (wg-current-workgroup t)))
 
      (wg-wconfig-restore-frame-position wconfig frame))
 

	
 
    ;; Restore buffers
 
    (wg-restore-window-tree (wg-scale-wconfig-to-frame wconfig))
 

	
 
    (when wg-incorrectly-restored-bufs
 
      (message "Unable to restore these buffers: %S\
 
If you want, restore them manually and try again."
 
               (mapcar 'wg-buf-name wg-incorrectly-restored-bufs)))))
 

	
 

	
 
;;; saved wconfig commands
 

	
 
(defun wg-save-wconfig ()
 
  "Save the current wconfig to the current workgroup's saved wconfigs."
 
  (interactive)
 
  (let* ((workgroup (wg-current-workgroup))
 
         (name (wg-read-saved-wconfig-name workgroup))
 
         (wconfig (wg-current-wconfig)))
 
    (setf (wg-wconfig-name wconfig) name)
 
    (wg-workgroup-save-wconfig workgroup wconfig)
 
    (wg-fontified-message
 
      (:cmd "Saved: ")
 
      (:cur name))))
 

	
 
(defun wg-restore-saved-wconfig ()
 
  "Restore one of the current workgroup's saved wconfigs in `selected-frame'."
 
  (interactive)
 
  (let ((workgroup (wg-current-workgroup)))
 
    (wg-restore-wconfig-undoably
 
     (wg-workgroup-get-saved-wconfig
 
      workgroup
 
      (ido-completing-read "Saved wconfig: "
 
                           (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup))
 
                           nil t)))))
 

	
 
(defun wg-kill-saved-wconfig ()
 
  "Kill one of the current workgroup's saved wconfigs.
 
Also add it to the wconfig kill-ring."
 
  (interactive)
 
  (let* ((workgroup (wg-current-workgroup))
 
         (wconfig (wg-read-saved-wconfig workgroup)))
 
    (wg-workgroup-kill-saved-wconfig workgroup wconfig)
 
    (wg-add-to-wconfig-kill-ring wconfig)
 
    (wg-fontified-message
 
      (:cmd "Deleted: ")
 
      (:cur (wg-wconfig-name wconfig)))))
 

	
 

	
 
(defun wg-reverse-wconfig (wconfig &optional dir)
 
  "Reverse WCONFIG's wtree's wlist in direction DIR."
 
  (wg-asetf (wg-wconfig-wtree wconfig) (wg-reverse-wlist it dir))
 
  wconfig)
 

	
 

	
 
(provide 'workgroups-wconfig)
 
;;; workgroups-wconfig.el ends here
src/workgroups-workgroup.el
Show inline comments
 
;;; workgroups-workgroup.el --- workgroup functions
 
;;; Commentary:
 
;;; Code:
 

	
 
(require 'dash)
 
(require 'ring)
 
(require 'workgroups-wconfig)
 
(require 'workgroups-minibuffer)
 

	
 
;;
 
;; Variables
 
;;
 
(defvar wg-deactivation-list nil
 
  "A stack of workgroups that are currently being switched away from.
 
Used to avoid associating the old workgroup's buffers with the
 
new workgroup during a switch.")
 

	
 
(defcustom wg-confirm-on-get-workgroup-create nil
 
  "Non-nil means request confirmation before creating a new
 
workgroup when `wg-get-workgroup-create' is called with a string
 
that doesn't name an existing workgroup."
 
  :type 'boolean
 
  :group 'workgroups)
 

	
 
(defun wg-flag-workgroup-modified (workgroup)
 
  "Set WORKGROUP's and the current session's modified flags."
 
  (when wg-flag-modified
 
    (setf (wg-workgroup-modified workgroup) t)
 
    (setf (wg-session-modified (wg-current-session)) t)))
 

	
 
(defun wg-current-workgroup (&optional noerror frame)
 
  "Return the current workgroup in FRAME, or error unless NOERROR."
 
  (or wg-current-workgroup
 
      (aif (frame-parameter frame 'wg-current-workgroup-uid)
 
          (wg-find-workgroup-by :uid it noerror)
 
        (unless noerror (error "No current workgroup in this frame")))))
 

	
 
(defun wg-previous-workgroup (&optional noerror frame)
 
  "Return the previous workgroup in FRAME, or error unless NOERROR."
 
  (aif (frame-parameter frame 'wg-previous-workgroup-uid)
 
      (wg-find-workgroup-by :uid it noerror)
 
    (unless noerror (error "No previous workgroup in this frame"))))
 

	
 
(defun wg-set-current-workgroup (workgroup &optional frame)
 
  "Set the current workgroup to WORKGROUP.
 
WORKGROUP should be a workgroup or nil."
 
  (set-frame-parameter frame 'wg-current-workgroup-uid
 
                       (when workgroup (wg-workgroup-uid workgroup))))
 

	
 
(defun wg-set-previous-workgroup (workgroup &optional frame)
 
  "Set the previous workgroup to WORKGROUP.
 
WORKGROUP should be a workgroup or nil."
 
  (set-frame-parameter frame 'wg-previous-workgroup-uid
 
                       (when workgroup (wg-workgroup-uid workgroup))))
 

	
 
(defun wg-current-workgroup-p (workgroup &optional frame)
 
  "Return t when WORKGROUP is the current workgroup, nil otherwise."
 
  (awhen (wg-current-workgroup t frame)
 
    (eq workgroup it)))
 

	
 
(defun wg-previous-workgroup-p (workgroup &optional frame)
 
  "Return t when WORKGROUP is the previous workgroup, nil otherwise."
 
  (awhen (wg-previous-workgroup t frame)
 
    (eq workgroup it)))
 

	
 
(defmacro wg-with-current-workgroup (workgroup &rest body)
 
  "Execute forms in BODY with WORKGROUP temporarily current.
 
WORKGROUP should be any workgroup identifier accepted by
 
`wg-get-workgroup'.  The value returned is the last form
 
in BODY."
 
  (declare (indent 1))
 
  `(let ((wg-current-workgroup (wg-get-workgroup ,workgroup)))
 
     ,@body))
 

	
 
(defun wg-get-workgroup (obj &optional noerror)
 
  "Return a workgroup from OBJ.
 
If OBJ is a workgroup, return it.
 
If OBJ is a string, return the workgroup named OBJ, or error unless NOERROR.
 
If OBJ is nil, return the current workgroup, or error unless NOERROR."
 
  (cond ((wg-workgroup-p obj) obj)
 
        ((stringp obj) (wg-find-workgroup-by :name obj noerror))
 
        ((null obj) (wg-current-workgroup noerror))
 
        (t (error "Can't get workgroup from type:: %S" (type-of obj)))))
 

	
 

	
 

	
 
;;; workgroup parameters
 
;;
 
;; Quick test:
 
;; (wg-workgroup-parameters (wg-current-workgroup))
 
;; (wg-set-workgroup-parameter (wg-current-workgroup) 'test1 t)
 
;; (wg-workgroup-parameter (wg-current-workgroup) 'test1)
 
(defun wg-workgroup-parameter (workgroup parameter &optional default)
 
  "Return WORKGROUP's value for PARAMETER.
 
If PARAMETER is not found, return DEFAULT which defaults to nil.
 
WORKGROUP should be accepted by `wg-get-workgroup'."
 
  (wg-aget (wg-workgroup-parameters (wg-get-workgroup workgroup))
 
           parameter default))
 

	
 
(defun wg-set-workgroup-parameter (workgroup parameter value)
 
  "Set WORKGROUP's value of PARAMETER to VALUE.
 
WORKGROUP should be a value accepted by `wg-get-workgroup'.
 
Return VALUE."
 
  (let ((workgroup (wg-get-workgroup workgroup)))
 
    (wg-set-parameter (wg-workgroup-parameters workgroup) parameter value)
 
    (wg-flag-workgroup-modified workgroup)
 
    value))
 

	
 
(defun wg-remove-workgroup-parameter (workgroup parameter)
 
  "Remove PARAMETER from WORKGROUP's parameters."
 
  (let ((workgroup (wg-get-workgroup workgroup)))
 
    (wg-flag-workgroup-modified workgroup)
 
    (wg-asetf (wg-workgroup-parameters workgroup) (wg-aremove it parameter))))
 

	
 
(defun wg-workgroup-local-value (variable &optional workgroup)
 
  "Return the value of VARIABLE in WORKGROUP.
 
WORKGROUP nil defaults to the current workgroup.  If there is no
 
current workgroup, or if VARIABLE does not have a workgroup-local
 
binding in WORKGROUP, resolve VARIABLE with `wg-session-local-value'."
 
  (let ((workgroup (wg-get-workgroup workgroup t)))
 
    (if (not workgroup) (wg-session-local-value variable)
 
      (let* ((undefined (cl-gensym))
 
             (value (wg-workgroup-parameter workgroup variable undefined)))
 
        (if (not (eq value undefined)) value
 
          (wg-session-local-value variable))))))
 

	
 
(defalias 'wg-local-value 'wg-workgroup-local-value)
 

	
 

	
 
;;; workgroup saved wconfigs
 

	
 
(defun wg-workgroup-saved-wconfig-names (workgroup)
 
  "Return a new list of the names of all WORKGROUP's saved wconfigs."
 
  (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup)))
 

	
 
(defun wg-workgroup-get-saved-wconfig (workgroup wconfig-or-name)
 
  "Return the wconfig in WORKGROUP's saved wconfigs named WCONFIG-OR-NAME.
 
WCONFIG-OR-NAME must be either a string or a wconfig.  If
 
WCONFIG-OR-NAME is a string and there is no saved wconfig with
 
that name, return nil.  If WCONFIG-OR-NAME is a wconfig, and it
 
is a member of WORKGROUP's saved wconfigs, return is as given.
 
Otherwise return nil."
 
  (let ((wconfigs (wg-workgroup-saved-wconfigs workgroup)))
 
    (cl-etypecase wconfig-or-name
 
      (wg-wconfig (car (memq wconfig-or-name wconfigs)))
 
      (string (cl-find wconfig-or-name wconfigs
 
                       :key 'wg-wconfig-name
 
                       :test 'string=)))))
 

	
 
(defun wg-workgroup-save-wconfig (workgroup wconfig)
 
  "Add WCONFIG to WORKGROUP's saved wconfigs.  WCONFIG must have
 
a name.  If there's already a wconfig with the same name in
 
WORKGROUP's saved wconfigs, replace it."
 
  (let ((name (wg-wconfig-name wconfig)))
 
    (unless name (error "Attempt to save a nameless wconfig"))
 
    (setf (wg-workgroup-modified workgroup) t)
 
    (wg-asetf (wg-workgroup-saved-wconfigs workgroup)
 
              (cons wconfig (cl-remove name it
 
                                       :key 'wg-wconfig-name
 
                                       :test 'string=)))))
 

	
 
(defun wg-workgroup-kill-saved-wconfig (workgroup wconfig-or-name)
 
  "Delete WCONFIG-OR-NAME from WORKGROUP's saved wconfigs.
 
WCONFIG-OR-NAME is resolved with `wg-workgroup-get-saved-wconfig'."
 
  (wg-when-let ((wconfig (wg-workgroup-get-saved-wconfig
 
                          workgroup wconfig-or-name)))
 
  (-when-let (wconfig (wg-workgroup-get-saved-wconfig
 
                       workgroup wconfig-or-name))
 
    (wg-asetf (wg-workgroup-saved-wconfigs workgroup) (remq wconfig it)
 
              (wg-workgroup-modified workgroup) t)))
 

	
 

	
 

	
 
(defun wg-workgroup-base-wconfig-buf-uids (workgroup)
 
  "Return a new list of all unique buf uids in WORKGROUP's working wconfig."
 
  (wg-wconfig-buf-uids (wg-workgroup-base-wconfig workgroup)))
 

	
 
(defun wg-workgroup-saved-wconfigs-buf-uids (workgroup)
 
  "Return a new list of all unique buf uids in WORKGROUP's base wconfig."
 
  (cl-reduce 'wg-string-list-union
 
             (wg-workgroup-saved-wconfigs workgroup)
 
             :key 'wg-wconfig-buf-uids))
 

	
 
(defun wg-workgroup-all-wconfig-buf-uids (workgroup)
 
  "Return a new list of all unique buf uids in WORKGROUP's wconfigs."
 
  (cl-union (wg-workgroup-base-wconfig-buf-uids workgroup)
 
            (wg-workgroup-saved-wconfigs-buf-uids workgroup)
 
            :test 'string=))
 

	
 
(defun wg-workgroup-all-buf-uids (workgroup)
 
  "Return a new list of all unique buf uids in WORKGROUP."
 
  (cl-reduce 'wg-string-list-union
 
             (list (wg-workgroup-base-wconfig-buf-uids workgroup)
 
                   (wg-workgroup-saved-wconfigs-buf-uids workgroup))))
 

	
 

	
 

	
 
;;; workgroup restoration
 

	
 
(defun wg-restore-workgroup (workgroup)
 
  "Restore WORKGROUP in `selected-frame'."
 
  (let (wg-flag-modified)
 
    (wg-restore-wconfig-undoably (wg-workgroup-working-wconfig workgroup) t)))
 

	
 

	
 
(defun wg-workgroup-list-or-error (&optional noerror)
 
  "Return the value of `wg-current-session's :workgroup-list slot.
 
Or scream unless NOERROR."
 
  (or (wg-workgroup-list)
 
      (unless noerror
 
        (error "No workgroups are defined"))))
 

	
 
(defun wg-find-workgroup-by (slotkey value &optional noerror)
 
  "Return the workgroup on which ACCESSOR returns VALUE or error."
 
  (let ((accessor (cl-ecase slotkey
 
                    (:name 'wg-workgroup-name)
 
                    (:uid  'wg-workgroup-uid))))
 
    (or (cl-find value (wg-workgroup-list-or-error noerror) :test 'equal :key accessor)
 
        (unless noerror
 
          (error "No are no workgroups with a %S of %S"
 
                 accessor value)))))
 

	
 
(defun wg-first-workgroup ()
 
  "Return a first workgroup."
 
  (car (wg-workgroup-list-or-error)))
 

	
 
(defun wg-cyclic-nth-from-workgroup (workgroup &optional n)
 
  "Return the workgroup N places from WORKGROUP in `wg-workgroup-list'."
 
  (wg-cyclic-nth-from-elt workgroup (wg-workgroup-list-or-error) (or n 1)))
 

	
 

	
 
(defun wg-read-workgroup-name (&optional require-match)
 
  "Read a workgroup name from `wg-workgroup-names'.
 
REQUIRE-MATCH to match."
 
  (ido-completing-read "Workgroup: " (wg-workgroup-names) nil require-match nil nil
 
   (awhen (wg-current-workgroup t) (wg-workgroup-name it))))
 

	
 
(defun wg-new-default-workgroup-name ()
 
  "Return a new, unique, default workgroup name."
 
  (let ((names (wg-workgroup-names t)) (index -1) result)
 
    (while (not result)
 
      (let ((new-name (format "wg%s" (cl-incf index))))
 
        (unless (member new-name names)
 
          (setq result new-name))))
 
    result))
 

	
 
(defun wg-unique-workgroup-name-p (new-name)
 
  "Return t if NEW-NAME is unique in `wg-workgroup-list', nil otherwise."
 
  (cl-every (lambda (existing-name) (not (equal new-name existing-name)))
 
            (wg-workgroup-names t)))
 

	
 
(defun wg-read-saved-wconfig-name (workgroup &optional prompt require-match)
 
  "Read the name of a saved wconfig, completing on the names of
 
WORKGROUP's saved wconfigs."
 
  (ido-completing-read (or prompt "Saved wconfig name: ")
 
                       (wg-workgroup-saved-wconfig-names workgroup)
 
                       nil require-match))
 

	
 
(defun wg-read-saved-wconfig (workgroup)
 
  "Read the name of and return one of WORKGROUP's saved wconfigs."
 
  (wg-workgroup-get-saved-wconfig
 
   workgroup (wg-read-saved-wconfig-name workgroup nil t)))
 

	
 

	
 
;;; workgroup-list reorganization commands
 

	
 
(defun wg-swap-workgroups ()
 
  "Swap the previous and current workgroups."
 
  (interactive)
 
  (wg-swap-workgroups-in-workgroup-list
 
   (wg-current-workgroup) (wg-previous-workgroup))
 
  (wg-fontified-message
 
    (:cmd "Swapped:  ")
 
    (wg-workgroup-list-display)))
 

	
 
(defun wg-offset-workgroup-left (&optional workgroup n)
 
  "Offset WORKGROUP leftward in `wg-workgroup-list' cyclically."
 
  (interactive (list nil current-prefix-arg))
 
  (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n -1))
 
  (wg-fontified-message
 
    (:cmd "Offset left: ")
 
    (wg-workgroup-list-display)))
 

	
 
(defun wg-offset-workgroup-right (&optional workgroup n)
 
  "Offset WORKGROUP rightward in `wg-workgroup-list' cyclically."
 
  (interactive (list nil current-prefix-arg))
 
  (wg-cyclic-offset-workgroup (wg-get-workgroup workgroup) (or n 1))
 
  (wg-fontified-message
 
    (:cmd "Offset right: ")
 
    (wg-workgroup-list-display)))
 

	
 

	
 
;;; undo/redo commands
 

	
 
(defun wg-undo-wconfig-change (&optional workgroup)
 
  "Undo a change to the current workgroup's window-configuration."
 
  (interactive)
 
  (let* ((workgroup (wg-get-workgroup workgroup))
 
         (undid? (wg-workgroup-offset-position-in-undo-list workgroup 1)))
 
    (wg-fontified-message
 
      (:cmd "Undo")
 
      (:cur (if undid? "" "  No more undo info")))))
 

	
 
(defun wg-redo-wconfig-change (&optional workgroup)
 
  "Redo a change to the current workgroup's window-configuration."
 
  (interactive)
 
  (let* ((workgroup (wg-get-workgroup workgroup))
 
         (redid? (wg-workgroup-offset-position-in-undo-list workgroup -1)))
 
    (wg-fontified-message
 
      (:cmd "Redo")
 
      (:cur (if redid? "" "  No more redo info")))))
 

	
 
(defun wg-undo-once-all-workgroups ()
 
  "Do what the name says.  Useful for instance when you
 
accidentally call `wg-revert-all-workgroups' and want to return
 
all workgroups to their un-reverted state."
 
  (interactive)
 
  (mapc 'wg-undo-wconfig-change (wg-workgroup-list-or-error))
 
  (wg-message "Undid once on all workgroups."))
 

	
 
(defun wg-redo-once-all-workgroups ()
 
  "Do what the name says.  Probably useless.  Included for
 
symetry with `wg-undo-once-all-workgroups'."
 
  (interactive)
 
  (mapc 'wg-redo-wconfig-change (wg-workgroup-list-or-error))
 
  (wg-message "Redid once on all workgroups."))
 

	
 

	
 

	
 
;;; window-tree commands
 
;;
 
;; TODO: These are half-hearted.  Clean them up; allow specification of the
 
;; window-tree depth at which to operate; add complex window creation commands;
 
;; and add window splitting, deletion and locking commands.
 

	
 
(defun wg-reverse-frame-horizontally (&optional workgroup)
 
  "Reverse the order of all horizontally split wtrees."
 
  (interactive)
 
  (wg-restore-wconfig-undoably
 
   (wg-reverse-wconfig
 
    (wg-workgroup-working-wconfig
 
     (wg-get-workgroup workgroup)))))
 

	
 
(defun wg-reverse-frame-vertically (&optional workgroup)
 
  "Reverse the order of all vertically split wtrees."
 
  (interactive)
 
  (wg-restore-wconfig-undoably
 
   (wg-reverse-wconfig
 
    (wg-workgroup-working-wconfig
 
     (wg-get-workgroup workgroup))
 
    t)))
 

	
 
(defun wg-reverse-frame-horizontally-and-vertically (&optional workgroup)
 
  "Reverse the order of all wtrees."
 
  (interactive)
 
  (wg-restore-wconfig-undoably
 
   (wg-reverse-wconfig
 
    (wg-workgroup-working-wconfig
 
     (wg-get-workgroup workgroup))
 
    'both)))
 

	
 

	
 
;;; misc commands
 

	
 
(defun wg-rename-workgroup (workgroup newname)
 
  "Rename WORKGROUP to NEWNAME."
 
  (interactive (list nil (wg-read-new-workgroup-name "New name: ")))
 
  (let* ((workgroup (wg-get-workgroup workgroup))
 
         (oldname (wg-workgroup-name workgroup)))
 
    (setf (wg-workgroup-name workgroup) newname)
 
    (wg-flag-workgroup-modified workgroup)
 
    (wg-fontified-message
 
      (:cmd "Renamed: ")
 
      (:cur oldname)
 
      (:msg " to ")
 
      (:cur (wg-workgroup-name workgroup)))))
 

	
 
(defun wg-reset (&optional force)
 
  "Reset Workgroups.
 
Resets all frame parameters, buffer-local vars, the current
 
Workgroups session object, etc."
 
  (interactive "P")
 
  (unless (or force wg-no-confirm-on-destructive-operation
 
              (y-or-n-p "Really reset Workgroups? "))
 
    (error "Canceled"))
 
  (wg-reset-internal)
 
  (wg-fontified-message (:cmd "Reset: ") (:msg "Workgroups")))
 

	
 

	
 
(defun wg-query-and-save-if-modified ()
 
  "Query for save when `wg-modified-p'."
 
  (or (not (wg-modified-p))
 
      (when (y-or-n-p "Save modified workgroups? ")
 
        (wg-save-session))))
 

	
 

	
 
;;; workgroup creation commands
 

	
 
(defun wg-create-workgroup (name &optional blank)
 
  "Create and add a workgroup named NAME.
 
Optional argument BLANK non-nil (set interactively with a prefix
 
arg) means use a blank, one window window-config.  Otherwise use
 
the current window-configuration.  Keep in mind that even though
 
the current window-config may be used, other parameters of the
 
current workgroup are not copied to the created workgroup.  For
 
that, use `wg-clone-workgroup'."
 
  (interactive (list (wg-read-new-workgroup-name) current-prefix-arg))
 
  (wg-switch-to-workgroup (wg-make-and-add-workgroup name blank))
 
  (wg-fontified-message
 
    (:cmd "Created: ") (:cur name) "  " (wg-workgroup-list-display)))
 

	
 
(defun wg-clone-workgroup (workgroup name)
 
  "Create and add a clone of WORKGROUP named NAME.
 
Keep in mind that only WORKGROUP's top-level alist structure is
 
copied, so destructive operations on the keys or values of
 
WORKGROUP will be reflected in the clone, and vice-versa.  Be
 
safe -- don't mutate them."
 
  (interactive (list nil (wg-read-new-workgroup-name)))
 
  (let* ((workgroup (wg-get-workgroup workgroup))
 
         (clone (wg-copy-workgroup workgroup)))
 
    (setf (wg-workgroup-name clone) name
 
          (wg-workgroup-uid clone) (wg-generate-uid))
 
    (when (wg-check-and-add-workgroup clone)
 
      (wg-flag-workgroup-modified clone))
 
    (wg-set-workgroup-working-wconfig
 
     clone (wg-workgroup-working-wconfig workgroup))
 
    (wg-switch-to-workgroup clone)
 
    (wg-fontified-message
 
      (:cmd "Cloned: ")
 
      (:cur (wg-workgroup-name workgroup))
 
      (:msg " to ")
 
      (:cur name) "  "
 
      (wg-workgroup-list-display))))
 

	
 

	
 

	
 
;;; workgroup switching commands
 
(defun wg-switch-to-workgroup (workgroup &optional noerror)
 
  "Switch to WORKGROUP.
 
NOERROR means fail silently."
 
  (interactive (list (wg-read-workgroup-name)))
 

	
 
  (fset 'buffer-list wg-buffer-list-original)
 

	
 
  ;; Mark if ECB is active
 
  (if (wg-current-workgroup t)
 
      (wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb (and (boundp 'ecb-minor-mode)
 
                                                                     ecb-minor-mode)))
 
  ;;(wg-set-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config (ecb-current-window-configuration))
 
  ;; (type-of (ecb-current-window-configuration))
 
  ;; (type-of (car (ecb-current-window-configuration)))
 
  ;; (type-of (car (nthcdr 3 (ecb-current-window-configuration))))
 
  ;; (wg-pickelable-or-error (ecb-current-window-configuration))
 
  ;;(ecb-current-window-configuration)
 
  ;;)
 

	
 
  (let ((workgroup (wg-get-workgroup-create workgroup))
 
        (current (wg-current-workgroup t)))
 
    (when (and (eq workgroup current) (not noerror))
 
      (error "Already on: %s" (wg-workgroup-name current)))
 
    (when current (push current wg-deactivation-list))
 
    (unwind-protect
 
        (progn
 
          ;; Before switching - turn off ECB
 
          ;; https://github.com/pashinin/workgroups2/issues/34
 
          (if (and (boundp 'ecb-minor-mode)
 
                   (boundp 'ecb-frame)
 
                   (fboundp 'ecb-deactivate)
 
                   ecb-minor-mode
 
                   (equal ecb-frame (selected-frame)))
 
              (let ((ecb-split-edit-window-after-start 'before-deactivation))
 
                (ecb-deactivate)))
 

	
 
          (wg-restore-workgroup workgroup)
 
          (wg-set-previous-workgroup current)
 
          (wg-set-current-workgroup workgroup)
 

	
 
          ;; Save "last-workgroup" to the session params
 
          (if (and (wg-current-session t)
 
                   (wg-current-workgroup t))
 
              (wg-set-session-parameter (wg-current-session t)
 
                                        'last-workgroup
 
                                        (wg-workgroup-name (wg-current-workgroup))))
 

	
 
          ;; If a workgroup had ECB - turn it on
 
          (if (and (boundp 'ecb-minor-mode)
 
                   (not ecb-minor-mode)
 
                   (fboundp 'ecb-activate)
 
                   (wg-workgroup-parameter (wg-current-workgroup t) 'ecb nil))
 
              (let ((ecb-split-edit-window-after-start 'before-deactivation))
 
                (ecb-activate)))
 
          ;;(ecb-last-window-config-before-deactivation
 
          ;; (wg-workgroup-parameter (wg-current-workgroup t) 'ecb-win-config nil)))
 

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

	
 
          (if wg-mess-with-buffer-list
 
              (fset 'buffer-list wg-buffer-list-function))
 
          (wg-fontified-message
 
            (:cmd "Switched: ")
 
            (wg-workgroup-name (wg-current-workgroup t))
 
            ))
 
      (when current (pop wg-deactivation-list)))))
 

	
 
(defun wg-switch-to-workgroup-other-frame (workgroup &optional n)
 
  "Switch to WORKGROUP in the frame N places cyclically from `selected-frame'.
 
Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."
 
  (interactive (list (wg-read-workgroup-name) current-prefix-arg))
 
  (with-selected-frame (wg-cyclic-nth-from-frame (or n 1))
 
    (wg-switch-to-workgroup workgroup)))
 

	
 
(defun wg-switch-to-workgroup-at-index (index)
 
  "Switch to the workgroup at INDEX in `wg-workgroup-list'."
 
  (interactive (list (or current-prefix-arg (wg-read-workgroup-index))))
 
  (let ((wl (wg-workgroup-list-or-error)))
 
    (wg-switch-to-workgroup
 
     (or (nth index wl) (error "There are only %d workgroups" (length wl))))))
 

	
 
(cl-macrolet
 
    ((define-range-of-switch-to-workgroup-at-index (num)
 
       `(progn
 
          ,@(wg-docar (i (wg-range 0 num))
 
              `(defun ,(intern (format "wg-switch-to-workgroup-at-index-%d" i)) ()
 
                 ,(format "Switch to the workgroup at index %d." i)
 
                 (interactive)
 
                 (wg-switch-to-workgroup-at-index ,i))))))
 
  (define-range-of-switch-to-workgroup-at-index 10))
 

	
 
(defun wg-switch-to-cyclic-nth-from-workgroup (workgroup n)
 
  "Switch N workgroups cyclically from WORKGROUP in `wg-workgroup-list.'"
 
  (let ((workgroup-list (wg-workgroup-list-or-error))
 
        (workgroup (wg-get-workgroup workgroup t)))
 
    (wg-switch-to-workgroup
 
     (cond ((not workgroup) (car workgroup-list))
 
           ((= 1 (length workgroup-list)) (error "There's only one workgroup"))
 
           (t (wg-cyclic-nth-from-workgroup workgroup n))))))
 

	
 
(defun wg-switch-to-workgroup-left (&optional workgroup n)
 
  "Switch to the workgroup (- N) places from WORKGROUP in `wg-workgroup-list'.
 
Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."
 
  (interactive (list nil current-prefix-arg))
 
  (wg-switch-to-cyclic-nth-from-workgroup workgroup (- (or n 1))))
 

	
 
(defun wg-switch-to-workgroup-right (&optional workgroup n)
 
  "Switch to the workgroup N places from WORKGROUP in `wg-workgroup-list'.
 
Use `current-prefix-arg' for N if non-nil.  Otherwise N defaults to 1."
 
  (interactive (list nil current-prefix-arg))
 
  (wg-switch-to-cyclic-nth-from-workgroup workgroup (or n 1)))
 

	
 
(defun wg-switch-to-previous-workgroup ()
 
  "Switch to the previous workgroup."
 
  (interactive)
 
  (wg-switch-to-workgroup (wg-previous-workgroup)))
 

	
 

	
 

	
 
;;; workgroup killing commands
 

	
 
(defun wg-wconfig-kill-ring ()
 
  "Return `wg-wconfig-kill-ring', creating it first if necessary."
 
  (or wg-wconfig-kill-ring
 
      (setq wg-wconfig-kill-ring (make-ring wg-wconfig-kill-ring-max))))
 

	
 
(defun wg-add-to-wconfig-kill-ring (wconfig)
 
  "Add WCONFIG to `wg-wconfig-kill-ring'."
 
  (ring-insert (wg-wconfig-kill-ring) wconfig))
 

	
 
(defun wg-kill-workgroup (&optional workgroup)
 
  "Kill WORKGROUP, saving its working-wconfig to the kill ring."
 
  (interactive)
 
  (let* ((workgroup (wg-get-workgroup workgroup))
 
         (to (or (wg-previous-workgroup t)
 
                 (wg-cyclic-nth-from-workgroup workgroup))))
 
    (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))
 
    (wg-delete-workgroup workgroup)
 
    (if (eq workgroup to) (wg-restore-wconfig (wg-make-blank-wconfig))
 
      (wg-switch-to-workgroup to))
 
    (wg-fontified-message
 
      (:cmd "Killed: ")
 
      (:cur (wg-workgroup-name workgroup)) "  "
 
      (wg-workgroup-list-display))))
 

	
 
(defun wg-kill-ring-save-base-wconfig (&optional workgroup)
 
  "Save WORKGROUP's base wconfig to the kill ring."
 
  (interactive)
 
  (let ((workgroup (wg-get-workgroup workgroup)))
 
    (wg-add-to-wconfig-kill-ring (wg-workgroup-base-wconfig workgroup))
 
    (wg-fontified-message
 
      (:cmd "Saved: ") (:cur (wg-workgroup-name workgroup))
 
      (:cur "'s ") (:msg "base wconfig to the kill ring"))))
 

	
 
(defun wg-kill-ring-save-working-wconfig (&optional workgroup)
 
  "Save WORKGROUP's working-wconfig to `wg-wconfig-kill-ring'."
 
  (interactive)
 
  (let ((workgroup (wg-get-workgroup workgroup)))
 
    (wg-add-to-wconfig-kill-ring (wg-workgroup-working-wconfig workgroup))
 
    (wg-fontified-message
 
      (:cmd "Saved: ") (:cur (wg-workgroup-name workgroup))
 
      (:cur "'s ") (:msg "working-wconfig to the kill ring"))))
 

	
 
(defun wg-yank-wconfig ()
 
  "Restore a wconfig from `wg-wconfig-kill-ring'.
 
Successive yanks restore wconfigs sequentially from the kill
 
ring, starting at the front."
 
  (interactive)
 
  (when (zerop (ring-length (wg-wconfig-kill-ring)))
 
    (error "The kill-ring is empty"))
 
  (let ((pos (if (not (eq real-last-command 'wg-yank-wconfig)) 0
 
               (1+ (or (get 'wg-yank-wconfig :position) 0)))))
 
    (put 'wg-yank-wconfig :position pos)
 
    (wg-restore-wconfig-undoably (ring-ref (wg-wconfig-kill-ring) pos))
 
    (wg-fontified-message
 
      (:cmd "Yanked: ")
 
      (:msg (format "%S" pos)) "  "
 
      (wg-workgroup-list-display))))
 

	
 
(defun wg-kill-workgroup-and-buffers (&optional workgroup)
 
  "Kill WORKGROUP and the buffers in its working-wconfig."
 
  (interactive)
 
  (let* ((workgroup (wg-get-workgroup workgroup))
 
         (bufs (save-window-excursion
 
                 (wg-restore-workgroup workgroup)
 
                 (mapcar #'window-buffer (window-list)))))
 
    (wg-kill-workgroup workgroup)
 
    (mapc #'kill-buffer bufs)
 
    (wg-fontified-message
 
      (:cmd "Killed: ")
 
      (:cur (wg-workgroup-name workgroup))
 
      (:msg " and its buffers ") "\n"
 
      (wg-workgroup-list-display))))
 

	
 
(defun wg-delete-other-workgroups (&optional workgroup)
 
  "Delete all workgroups but WORKGROUP."
 
  (interactive)
 
  (let ((workgroup (wg-get-workgroup workgroup)))
 
    (unless (or wg-no-confirm-on-destructive-operation
 
                (y-or-n-p "Really delete all other workgroups? "))
 
      (error "Cancelled"))
 
    (dolist (w (wg-workgroup-list-or-error))
 
      (unless (eq w workgroup)
 
        (wg-delete-workgroup w)))
 
    (unless (wg-current-workgroup-p workgroup)
 
      (wg-switch-to-workgroup workgroup))
 
    (wg-fontified-message
 
      (:cmd "Deleted: ")
 
      (:msg "All workgroups but ")
 
      (:cur (wg-workgroup-name workgroup)))))
 

	
 

	
 

	
 
;;; workgroup updating and reverting commands
 

	
 
(defun wg-revert-workgroup (&optional workgroup)
 
  "Restore WORKGROUP's window configuration to its state at the last save."
 
  (interactive)
 
  (let* ((workgroup (wg-get-workgroup workgroup))
 
         (base-wconfig (wg-workgroup-base-wconfig workgroup)))
 
    (if (wg-current-workgroup-p workgroup)
 
        (wg-restore-wconfig-undoably base-wconfig)
 
      (wg-add-wconfig-to-undo-list workgroup base-wconfig))
 
    (wg-fontified-message
 
      (:cmd "Reverted: ")
 
      (:cur (wg-workgroup-name workgroup)))))
 

	
 
(defun wg-revert-all-workgroups ()
 
  "Revert all workgroups to their base wconfigs.
 
Only workgroups' working-wconfigs in `selected-frame' are
 
reverted."
 
  (interactive)
 
  (mapc #'wg-revert-workgroup (wg-workgroup-list-or-error))
 
  (wg-fontified-message
 
    (:cmd "Reverted: ")
 
    (:msg "All")))
 

	
 

	
 

	
 
;;; workgroup working-wconfig and wconfig undo/redo
 

	
 
(defun wg-workgroup-state-table (&optional frame)
 
  "Return FRAME's workgroup table, creating it first if necessary."
 
  (or (frame-parameter frame 'wg-workgroup-state-table)
 
      (let ((wtree (make-hash-table :test 'equal)))
 
        (set-frame-parameter frame 'wg-workgroup-state-table wtree)
 
        wtree)))
 

	
 
(defun wg-get-workgroup-state (workgroup &optional frame)
 
  "Return WORKGROUP's state table in a FRAME."
 
  (let ((uid (wg-workgroup-uid workgroup))
 
        (state-table (wg-workgroup-state-table frame)))
 
    (or (gethash uid state-table)
 
        (let ((wgs (wg-make-workgroup-state
 
                    :undo-pointer 0
 
                    :undo-list
 
                    (list (or (wg-workgroup-selected-frame-wconfig workgroup)
 
                              (wg-workgroup-base-wconfig workgroup))))))
 
          (puthash uid wgs state-table)
 
          wgs))))
 

	
 
(defmacro wg-with-undo (workgroup spec &rest body)
 
  "Bind WORKGROUP's undo state to SPEC and eval BODY."
 
  (declare (indent 2))
 
  (wg-dbind (state undo-pointer undo-list) spec
 
    `(let* ((,state (wg-get-workgroup-state ,workgroup))
 
            (,undo-pointer (wg-workgroup-state-undo-pointer ,state))
 
            (,undo-list (wg-workgroup-state-undo-list ,state)))
 
       ,@body)))
 

	
 
(defun wg-flag-just-exited-minibuffer ()
 
  "Added to `minibuffer-exit-hook'."
 
  (setq wg-just-exited-minibuffer t))
 

	
 
(defun wg-flag-window-configuration-changed ()
 
  "Set `wg-window-configuration-changed' to t.
 
But only if not the minibuffer was just exited.  Added to
 
`window-configuration-change-hook'."
 
  (if wg-just-exited-minibuffer
 
      (setq wg-just-exited-minibuffer nil)
 
    (setq wg-window-configuration-changed t)))
 

	
 
(defun wg-unflag-undoify-window-configuration-change ()
 
  "Set `wg-undoify-window-configuration-change' to nil, exempting
 
from undoification any window-configuration changes caused by the
 
current command."
 
  (setq wg-undoify-window-configuration-change nil))
 

	
 
(defun wg-set-workgroup-working-wconfig (workgroup wconfig)
 
  "Set the working-wconfig of WORKGROUP to WCONFIG."
 
  (wg-flag-workgroup-modified workgroup)
 
  (setf (wg-workgroup-selected-frame-wconfig workgroup) wconfig)
 
  (wg-with-undo workgroup (state undo-pointer undo-list)
 
    (setcar (nthcdr undo-pointer undo-list) wconfig)))
 

	
 
(defun wg-add-wconfig-to-undo-list (workgroup wconfig)
 
  "Add WCONFIG to WORKGROUP's undo list, truncating its future if necessary."
 
  (wg-with-undo workgroup (state undo-pointer undo-list)
 
    (let ((undo-list (cons nil (nthcdr undo-pointer undo-list))))
 
      (awhen (nthcdr wg-wconfig-undo-list-max undo-list) (setcdr it nil))
 
      (setf (wg-workgroup-state-undo-list state) undo-list))
 
    (setf (wg-workgroup-state-undo-pointer state) 0))
 
  (wg-set-workgroup-working-wconfig workgroup wconfig))
 

	
 
(defun wg-workgroup-working-wconfig (workgroup &optional noupdate)
 
  "Return WORKGROUP's working-wconfig.
 
If WORKGROUP is the current workgroup in `selected-frame', and
 
NOUPDATE is nil, set its working wconfig in `selected-frame' to
 
`wg-current-wconfig' and return the updated wconfig.  Otherwise
 
return WORKGROUP's current undo state."
 
  (if (and (not noupdate) (wg-current-workgroup-p workgroup))
 
      (wg-set-workgroup-working-wconfig workgroup (wg-current-wconfig))
 
    (wg-with-undo workgroup (state undo-pointer undo-list)
 
      (nth undo-pointer undo-list))))
 

	
 
(defun wg-update-current-workgroup-working-wconfig ()
 
  "Update `selected-frame's current workgroup's working-wconfig with `wg-current-wconfig'."
 
  (awhen (wg-current-workgroup t)
 
    (wg-set-workgroup-working-wconfig it (wg-current-wconfig))))
 

	
 
(defun wg-restore-wconfig-undoably (wconfig &optional noundo)
 
  "Restore WCONFIG in `selected-frame', saving undo information.
 
Skip undo when NOUNDO."
 
  (when noundo (wg-unflag-undoify-window-configuration-change))
 
  (wg-update-current-workgroup-working-wconfig)
 
  (wg-restore-wconfig wconfig))
 

	
 
(defun wg-workgroup-offset-position-in-undo-list (workgroup increment)
 
  "Increment WORKGROUP's undo-pointer by INCREMENT.
 
Also restore the wconfig at the incremented undo-pointer if
 
WORKGROUP is current."
 
  (wg-with-undo workgroup (state undo-pointer undo-list)
 
    (let ((new-pointer (+ undo-pointer increment)))
 
      (when (wg-within new-pointer 0 (length undo-list))
 
        (when (wg-current-workgroup-p workgroup)
 
          (wg-restore-wconfig-undoably (nth new-pointer undo-list) t))
 
        (setf (wg-workgroup-state-undo-pointer state) new-pointer)))))
 

	
 
(defun wg-undoify-window-configuration-change ()
 
  "Conditionally `wg-add-wconfig-to-undo-list'.
 
Added to `post-command-hook'."
 
  (when (and
 
         wg-window-configuration-changed         ;; When the window config has changed,
 
         wg-undoify-window-configuration-change  ;; and undoification is still on for the current command
 
         (wg-minibuffer-inactive-p))             ;; and the change didn't occur while the minibuffer is active,
 
    (wg-when-let ((workgroup (wg-current-workgroup t)))  ;; and there's a current workgroup,
 
    (-when-let (workgroup (wg-current-workgroup t))  ;; and there's a current workgroup,
 
      ;; add the current wconfig to that workgroup's undo list:
 
      (wg-add-wconfig-to-undo-list workgroup (wg-current-wconfig))))
 
  ;; Reset all flags no matter what:
 
  (setq wg-window-configuration-changed nil
 
        wg-undoify-window-configuration-change t
 
        wg-already-updated-working-wconfig nil))
 

	
 
(defun wg-update-working-wconfig-hook ()
 
  "Used in before advice on all functions that trigger `window-configuration-change-hook'.
 
To save up to date undo info before the change."
 
  (when (and (not wg-already-updated-working-wconfig)
 
             (wg-minibuffer-inactive-p))
 
    (wg-update-current-workgroup-working-wconfig)
 
    (setq wg-already-updated-working-wconfig t)))
 

	
 

	
 
(defun wg-workgroup-gc-buf-uids (workgroup)
 
  "Remove buf uids from WORKGROUP that have no referent in `wg-buf-list'."
 
  (wg-asetf (wg-workgroup-strong-buf-uids workgroup)
 
            (cl-remove-if-not 'wg-find-buf-by-uid it)
 
            (wg-workgroup-weak-buf-uids workgroup)
 
            (cl-remove-if-not 'wg-find-buf-by-uid it)))
 

	
 
(defun wg-gc-buf-uids ()
 
  "Remove from all workgroups those buf uids that have no referent in `wg-buf-list'."
 
  (mapc 'wg-workgroup-gc-buf-uids (wg-workgroup-list)))
 

	
 

	
 

	
 
(defun wg-display-internal (elt-fn list)
 
  "Return display string built by calling ELT-FN on each element of LIST."
 
  (let ((div (wg-add-face :div wg-list-display-decor-divider))
 
        (wwidth (window-width (minibuffer-window)))
 
        (i -1)
 
        (str))
 
    (setq str
 
          (wg-fontify
 
            (:brace wg-list-display-decor-left-brace)
 
            (if (not list) (funcall elt-fn nil nil)
 
              (wg-doconcat (elt list div) (funcall elt-fn elt (cl-incf i))))
 
            (:brace wg-list-display-decor-right-brace)))
 
    ;; (subseq str 0 wwidth)
 
    ))
 

	
 
(defun wg-workgroup-list-display (&optional workgroup-list)
 
  "Return the Workgroups list display string.
 
The string contains the names of all workgroups in `wg-workgroup-list',
 
decorated with faces, dividers and strings identifying the
 
current and previous workgroups."
 
  (wg-display-internal 'wg-workgroup-display
 
                       (or workgroup-list (wg-workgroup-list))))
 

	
 
(defun wg-create-first-wg ()
 
  "Create a first workgroup if needed."
 
  (if (and workgroups-mode
 
           wg-session-load-on-start
 
           (= (length (wg-workgroup-list)) 0))
 
      (wg-create-workgroup wg-first-wg-name)))
 

	
 

	
 
(defun wg-pickel-workgroup-parameters (workgroup)
 
  "Return a copy of WORKGROUP after pickeling its parameters.
 
If WORKGROUP's parameters are non-nil, otherwise return
 
WORKGROUP."
 
  (if (not (wg-workgroup-parameters workgroup)) workgroup
 
    (let ((copy (wg-copy-workgroup workgroup)))
 
      (wg-asetf (wg-workgroup-parameters copy) (wg-pickel it))
 
      copy)))
 

	
 
(defun wg-unpickel-workgroup-parameters (workgroup)
 
  "If WORKGROUP's parameters are non-nil, return a copy of
 
WORKGROUP after unpickeling its parameters. Otherwise return
 
WORKGROUP."
 
  (if (not (wg-workgroup-parameters workgroup)) workgroup
 
    (let ((copy (wg-copy-workgroup workgroup)))
 
      (wg-asetf (wg-workgroup-parameters copy) (wg-unpickel it))
 
      copy)))
 

	
 
;;; workgroup-list ops
 

	
 
(defun wg-delete-workgroup (workgroup)
 
  "Remove WORKGROUP from `wg-workgroup-list'.
 
Also delete all references to it by `wg-workgroup-state-table',
 
`wg-current-workgroup' and `wg-previous-workgroup'."
 
  (dolist (frame (frame-list))
 
    (remhash (wg-workgroup-uid workgroup) (wg-workgroup-state-table frame))
 
    (when (wg-current-workgroup-p workgroup frame)
 
      (wg-set-current-workgroup nil frame))
 
    (when (wg-previous-workgroup-p workgroup frame)
 
      (wg-set-previous-workgroup nil frame)))
 
  (setf (wg-workgroup-list) (remove workgroup (wg-workgroup-list-or-error)))
 
  (setf (wg-session-modified (wg-current-session)) t)
 
  workgroup)
 

	
 
(defun wg-add-workgroup (workgroup &optional index)
 
  "Add WORKGROUP to `wg-workgroup-list' at INDEX or the end.
 
If a workgroup with the same name exists, overwrite it."
 
  (awhen (wg-find-workgroup-by :name (wg-workgroup-name workgroup) t)
 
    (unless index (setq index (cl-position it (wg-workgroup-list-or-error))))
 
    (wg-delete-workgroup it))
 
  (wg-asetf (wg-workgroup-list)
 
            (wg-insert-before workgroup it (or index (length it))))
 
  (setf (wg-session-modified (wg-current-session)) t)
 
  workgroup)
 

	
 
(defun wg-check-and-add-workgroup (workgroup)
 
  "Add WORKGROUP to `wg-workgroup-list'.
 
Ask to overwrite if a workgroup with the same name exists."
 
  (let ((name (wg-workgroup-name workgroup))
 
        (uid (wg-workgroup-uid workgroup)))
 
    (when (wg-find-workgroup-by :uid uid t)
 
      (error "A workgroup with uid %S already exists" uid))
 
    (when (wg-find-workgroup-by :name name t)
 
      (unless (or wg-no-confirm-on-destructive-operation
 
                  (y-or-n-p (format "%S exists. Overwrite? " name)))
 
        (error "Cancelled"))))
 
  (wg-add-workgroup workgroup))
 

	
 
(defun wg-make-and-add-workgroup (name &optional blank)
 
  "Create a workgroup named NAME with current `window-tree'.
 
If BLANK - then just scratch buffer.
 
Add it with `wg-check-and-add-workgroup'."
 
  (wg-check-and-add-workgroup
 
   (wg-make-workgroup
 
    :name name
 
    :base-wconfig (if blank (wg-make-blank-wconfig)
 
                    (wg-current-wconfig)))))
 

	
 
(defun wg-get-workgroup-create (workgroup)
 
  "Return the workgroup specified by WORKGROUP, creating a new one if needed.
 
If `wg-get-workgroup' on WORKGROUP returns a workgroup, return it.
 
Otherwise, if WORKGROUP is a string, create a new workgroup with
 
that name and return it.  Otherwise error."
 
  (or (wg-get-workgroup workgroup t)
 
      (if (stringp workgroup)
 
          (when (or (not wg-confirm-on-get-workgroup-create)
 
                    (y-or-n-p (format "%S doesn't exist.  Create it? "
 
                                      workgroup)))
 
            (wg-make-and-add-workgroup workgroup))
 
        ;; Call this again for its error message
 
        (wg-get-workgroup workgroup))))
 

	
 
(defun wg-cyclic-offset-workgroup (workgroup n)
 
  "Offset WORKGROUP's position in `wg-workgroup-list' by N."
 
  (let ((workgroup-list (wg-workgroup-list-or-error)))
 
    (unless (member workgroup workgroup-list)
 
      (error "Workgroup isn't present in `wg-workgroup-list'."))
 
    (setf (wg-workgroup-list) (wg-cyclic-offset-elt workgroup workgroup-list n)
 
          (wg-session-modified (wg-current-session)) t)))
 

	
 
(defun wg-swap-workgroups-in-workgroup-list (workgroup1 workgroup2)
 
  "Swap the positions of WORKGROUP1 and WORKGROUP2 in `wg-workgroup-list'."
 
  (let ((workgroup-list (wg-workgroup-list-or-error)))
 
    (when (eq workgroup1 workgroup2)
 
      (error "Can't swap a workgroup with itself"))
 
    (unless (and (memq workgroup1 workgroup-list)
 
                 (memq workgroup2 workgroup-list))
 
      (error "Both workgroups aren't present in `wg-workgroup-list'."))
 
    (setf (wg-workgroup-list) (wg-util-swap workgroup1 workgroup2 workgroup-list)
 
          (wg-session-modified (wg-current-session)) t)))
 

	
 

	
 
(provide 'workgroups-workgroup)
 
;;; workgroups-workgroup.el ends here
0 comments (0 inline, 0 general)