workgroups2 Changeset - dedff6f56350

Changeset - dedff6f56350

Parent rev.

Child rev.

[Not reviewed]

0 4 0

Sergey Pashinin - 12 years ago 2014-02-26 00:10:50
sergey@pashinin.com

Use cl-flet instead of dflet

4 files changed with 19 insertions and 19 deletions:

src/workgroups-functions.el

src/workgroups-pickel.el

src/workgroups-specialbufs.el

src/workgroups-utils-basic.el

0 comments (0 inline, 0 general)

src/workgroups-functions.el

➞

Show inline comments

 ;;; workgroups-functions --- Functions you might find useful
 ;;; Commentary:
 ;;; Code:
 (require 'workgroups-compat)
 (require 'workgroups-variables)
 (require 'workgroups-utils-basic)
 (require 'workgroups-structs)
 ;;; session ops
 (defun wg-current-session (&optional noerror)
   "Return `wg-current-session', setting it first if necessary."
   (or wg-current-session
       (unless noerror
         (error "No session is defined"))))
 (defmacro wg-buf-list ()
   "setf'able `wg-current-session' buf-list slot accessor."
   `(wg-session-buf-list (wg-current-session)))
 (defmacro wg-workgroup-list ()
   "setf'able `wg-current-session' modified slot accessor."
   `(wg-session-workgroup-list (wg-current-session)))
 (defun wg-workgroup-list-or-error (&optional noerror)
   "Return the value of `wg-current-session's :workgroup-list slot."
   (or (wg-workgroup-list)
       (unless noerror
         (error "No workgroups are defined"))))
 (defun wg-modified-p ()
   "Return t when the current session or any of its workgroups are modified."
   (or (wg-session-modified (wg-current-session))
       (cl-some 'wg-workgroup-modified (wg-workgroup-list))))
 (defun wg-mark-everything-unmodified ()
   "Mark the session and all workgroups as unmodified."
   (setf (wg-session-modified (wg-current-session)) nil)
   (dolist (workgroup (wg-workgroup-list))
     (setf (wg-workgroup-modified workgroup) nil)))
 (defun wg-workgroup-names (&optional noerror)
   "Return a list of workgroup names."
   (mapcar 'wg-workgroup-name (wg-workgroup-list-or-error noerror)))
 ;;; session parameters
 (defun wg-session-parameter (session parameter &optional default)
   "Return SESSION's value for PARAMETER.
 If PARAMETER is not found, return DEFAULT which defaults to nil.
 SESSION nil defaults to the current session."
   (wg-aget (wg-session-parameters (or session (wg-current-session)))
            parameter default))
 (defun wg-set-session-parameter (session parameter value)
   "Set SESSION's value of PARAMETER to VALUE.
 SESSION nil means use the current session.
 Return value."
   (let ((session (or session (wg-current-session))))
     (wg-set-parameter (wg-session-parameters session) parameter value)
     (setf (wg-session-modified session) t)
     value))
 (defun wg-remove-session-parameter (session parameter)
   "Remove parameter PARAMETER from SESSION's parameters."
   (let ((session (or session (wg-current-session))))
     (wg-asetf (wg-session-parameters session) (wg-aremove it parameter))
     (setf (wg-session-modified session) t)))
 (defun wg-session-local-value (variable &optional session)
   "Return the value of VARIABLE in SESSION.
 SESSION nil defaults to the current session.  If VARIABLE does
 not have a session-local binding in SESSION, the value is
 resolved by Emacs."
   (let* ((undefined (cl-gensym))
          (value (wg-session-parameter session variable undefined)))
     (if (not (eq value undefined)) value
       (symbol-value variable))))
 ;;; 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-bufobj-major-mode (bufobj)
   "Return BUFOBJ's major-mode."
   (cl-etypecase bufobj
     (buffer (wg-buffer-major-mode bufobj))
     (wg-buf (wg-buf-major-mode bufobj))
     (string (wg-buffer-major-mode bufobj))))
 ;; `wg-equal-bufobjs' and `wg-find-bufobj' may need to be made a lot smarter
 (defun wg-equal-bufobjs (bufobj1 bufobj2)
   "Return t if BUFOBJ1 is \"equal\" to BUFOBJ2."
   (let ((fname1 (wg-bufobj-file-name bufobj1))
         (fname2 (wg-bufobj-file-name bufobj2)))
     (cond ((and fname1 fname2) (string= fname1 fname2))
           ((or fname1 fname2) nil)
           ((string= (wg-bufobj-name bufobj1) (wg-bufobj-name bufobj2)) t))))
 (defun wg-find-bufobj (bufobj bufobj-list)
   "Find BUFOBJ in BUFOBJ-LIST, testing with `wg-equal-bufobjs'."
   (cl-find bufobj bufobj-list :test 'wg-equal-bufobjs))
 (defun wg-find-bufobj-by-uid (uid bufobj-list)
   "Find the bufobj in BUFOBJ-LIST with uid UID."
   (cl-find uid bufobj-list :test 'string= :key 'wg-bufobj-uid))
 (defun wg-find-buf-in-buf-list (buf buf-list)
   "Find BUF in BUF-LIST.
 This is only here for completeness."
   (cl-find buf buf-list))
 (defun wg-find-buffer-in-buffer-list (buffer-or-name buffer-list)
   "Find BUFFER-OR-NAME in BUFFER-LIST."
   (cl-find (wg-get-buffer buffer-or-name) buffer-list :key 'wg-get-buffer))
 (defun wg-find-buffer-in-buf-list (buffer-or-name buf-list)
   "Find BUFFER-OR-NAME in BUF-LIST."
   (wg-aif (wg-buffer-uid buffer-or-name)
       (wg-find-bufobj-by-uid it buf-list)
     (wg-find-bufobj buffer-or-name buf-list)))
 (defun wg-find-buf-in-buffer-list (buf buffer-list)
   "Find BUF in BUFFER-LIST."
   (or (wg-find-bufobj-by-uid (wg-buf-uid buf) buffer-list)
       (wg-find-bufobj buf buffer-list)))
 (defun wg-find-buf-by-uid (uid)
   "Find a buf in `wg-buf-list' by UID."
   (wg-find-bufobj-by-uid uid (wg-buf-list)))
 (defun wg-set-buffer-uid-or-error (uid &optional buffer)
   "Set BUFFER's buffer local value of `wg-buffer-uid' to UID.
 If BUFFER already has a buffer local value of `wg-buffer-uid',
 and it's not equal to UID, error."
   (if wg-buffer-uid
       ;;(if (string= wg-buffer-uid uid) uid
       ;;  (error "uids don't match %S and %S" uid wg-buffer-uid))
     (setq wg-buffer-uid uid)))
 ;;; wconfig construction
 (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-window-point (ewin)
   "Return `point' or :max.  See `wg-restore-point-max'.
 EWIN should be an Emacs window object."
   (let ((p (window-point ewin)))
     (if (and wg-restore-point-max (= p (point-max))) :max p)))
 (defun wg-serialize-buffer-local-variables ()
   "Return an alist of buffer-local variable symbols and their values.
 See `wg-buffer-local-variables-alist' for details."
   (wg-docar (entry wg-buffer-local-variables-alist)
     (wg-dbind (var ser des) entry
       (when (local-variable-p var)
         (cons var (if ser (funcall ser) (symbol-value var)))))))
 (defun wg-buffer-to-buf (buffer)
   "Return the serialization (a wg-buf) of Emacs buffer BUFFER."
   (with-current-buffer buffer
     (wg-make-buf
      :name           (buffer-name)
      :file-name      (buffer-file-name)
      :point          (point)
      :mark           (mark)
      :local-vars     (wg-serialize-buffer-local-variables)
      :special-data   (wg-buffer-special-data buffer))))
 (defun wg-add-buffer-to-buf-list (buffer)
   "Make a buf from BUFFER, and add it to `wg-buf-list' if necessary.
 If there isn't already a buf corresponding to BUFFER in
 `wg-buf-list', make one and add it.  Return BUFFER's uid
 in either case."
   (with-current-buffer buffer
     (setq wg-buffer-uid
           (wg-aif (wg-find-buffer-in-buf-list buffer (wg-buf-list))
               (wg-buf-uid it)
             (let ((buf (wg-buffer-to-buf buffer)))
               (push buf (wg-buf-list))
               (wg-buf-uid buf))))))
 (defun wg-buffer-uid-or-add (buffer)
   "If there isn't already a buf corresponding to BUFFER in
 `wg-buf-list', make one and add it.  Return BUFFER's uid
 in either case."
   (or (wg-buffer-uid buffer) (wg-add-buffer-to-buf-list buffer)))
 (defun wg-bufobj-uid-or-add (bufobj)
   "If BUFOBJ is a wg-buf, return its uid.
 If BUFOBJ is a buffer or a buffer name, see `wg-buffer-uid-or-add'."
   (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)))))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; Notes on buffer and window properties:
 ;;
 ;; fringes, margins and scroll-bars are properly properties of buffers, but
 ;; their settings can be forced ephemerally in a window with the set-window-foo
 ;; functions.
 ;;
 ;; window-point is a property of a buffer/window pair, but won't set properly
 ;; unless the buffer is current -- i.e. (set-window-buffer some-window
 ;; some-buffer) (set-window-point some-window 0)) won't set some-buffer's point
 ;; in some-window unless some-buffer is also current.
 ;;
 ;; window-start and window-hscroll are properties of buffer/window pairs.
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun wg-window-to-win (window)
   "Return the serialization (a wg-win) of Emacs window WINDOW."
   (let ((selected (eq window (selected-window))))
     (with-selected-window window
       (wg-make-win
        :edges              (window-edges window)
        :point              (wg-window-point window)
        :start              (window-start window)
        :hscroll            (window-hscroll window)
        :selected           selected
        :minibuffer-scroll  (eq window minibuffer-scroll-window)
        :dedicated          (window-dedicated-p window)
        :buf-uid            (wg-buffer-uid-or-add (window-buffer window))))))
 (defun wg-window-tree-to-wtree (window-tree)
   "Return the serialization (a wg-wtree) of Emacs window tree WINDOW-TREE."
   (wg-barf-on-active-minibuffer)
-  (dflet
+  (cl-flet
       ((inner (w) (if (windowp w) (wg-window-to-win w)
                     (wg-dbind (dir edges . wins) w
                       (wg-make-wtree
                        :dir    dir
                        :edges  edges
                        :wlist  (mapcar #'inner wins))))))
     (let ((w (car window-tree)))
       (when (and (windowp w) (window-minibuffer-p w))
         (error "Workgroups can't operate on minibuffer-only frames."))
       (inner w))))
 (defun wg-frame-to-wconfig (&optional frame)
   "Return the serialization (a wg-wconfig) of Emacs frame FRAME.
 FRAME nil defaults to `selected-frame'."
   (let* ((frame (or frame (selected-frame)))
          (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)))
 ;;; win/wtree/wconfig utils
 (defun wg-w-edges (w)
   "Return W's edge list."
   (cl-etypecase w
     (wg-win (wg-win-edges w))
     (wg-wtree (wg-wtree-edges w))))
 (defun wg-copy-w (w)
   "Return a copy of W.  W should be a wg-win or a wg-wtree."
   (cl-etypecase w
     (wg-win (wg-copy-win w))
     (wg-wtree (wg-copy-wtree w))))
 (defun wg-set-edges (w edges)
   "Set W's edge list, and return W."
   (cl-etypecase w
     (wg-win (setf (wg-win-edges w) edges))
     (wg-wtree (setf (wg-wtree-edges w) edges)))
   w)
 (defun wg-min-size (dir)
   "Return the minimum window size in split direction DIR."
   (if dir wg-window-min-height wg-window-min-width))
 (defun wg-actual-min-size (dir)
   "Return the actual minimum window size in split direction DIR."
   (if dir wg-actual-min-height wg-actual-min-width))
 (defmacro wg-with-edges (w spec &rest body)
   "Bind W's edge list to SPEC and eval BODY."
   (declare (indent 2))
   `(wg-dbind ,spec (wg-w-edges ,w) ,@body))
 (defmacro wg-with-bounds (wtree dir spec &rest body)
   "Bind SPEC to W's bounds in DIR, and eval BODY.
 \"bounds\" are a direction-independent way of dealing with edge lists."
   (declare (indent 3))
   (wg-with-gensyms (dir-sym l1 t1 r1 b1)
     (wg-dbind (ls1 hs1 lb1 hb1) spec
       `(wg-with-edges ,wtree (,l1 ,t1 ,r1 ,b1)
          (cond (,dir (let ((,ls1 ,l1) (,hs1 ,r1) (,lb1 ,t1) (,hb1 ,b1))
                        ,@body))
                (t    (let ((,ls1 ,t1) (,hs1 ,b1) (,lb1 ,l1) (,hb1 ,r1))
                        ,@body)))))))
 (defun wg-set-bounds (w dir ls hs lb hb)
   "Set W's edges in DIR with bounds LS HS LB and HB."
   (wg-set-edges w (if dir (list ls lb hs hb) (list lb ls hb hs))))
 (defun wg-step-edges (edges1 edges2 hstep vstep)
   "Return W1's edges stepped once toward W2's by HSTEP and VSTEP."
   (wg-dbind (l1 t1 r1 b1) edges1
     (wg-dbind (l2 t2 r2 b2) edges2
       (let ((left (wg-step-to l1 l2 hstep))
             (top  (wg-step-to t1 t2 vstep)))
         (list left top
               (+ left (wg-step-to (- r1 l1) (- r2 l2) hstep))
               (+ top  (wg-step-to (- b1 t1) (- b2 t2) vstep)))))))
 (defun wg-w-edge-operation (w edges op)
   "Return a copy of W with its edges mapped against EDGES through OP."
   (wg-set-edges w (cl-mapcar op (wg-w-edges w) edges)))
 (defun wg-first-win (w)
   "Return the first actual window in W."
   (if (wg-win-p w) w
     (wg-first-win (car (wg-wtree-wlist w)))))
 (defun wg-last-win (w)
   "Return the last actual window in W."
   (if (wg-win-p w) w
     (wg-last-win (wg-last1 (wg-wtree-wlist w)))))
 (defun wg-minify-win (w)
   "Set W's edges to the smallest allowable."
   (let* ((edges (wg-w-edges w))
          (left (car edges))
          (top (cadr edges)))
     (wg-set-edges w (list left top
                           (+ left wg-actual-min-width)
                           (+ top  wg-actual-min-height)))))
 (defun wg-minified-copy-of-last-win (w)
   "Minify a copy of the last actual window in W."
   (wg-minify-win (wg-copy-win (wg-last-win w))))
 (defun wg-w-size (w &optional height)
   "Return the width or height of W, calculated from its edge list."
   (wg-with-edges w (l1 t1 r1 b1)
     (if height (- b1 t1) (- r1 l1))))
 (defun wg-adjust-w-size (w width-fn height-fn &optional new-left new-top)
   "Adjust W's width and height with WIDTH-FN and HEIGHT-FN."
   (wg-with-edges w (left top right bottom)
     (let ((left (or new-left left)) (top (or new-top top)))
       (wg-set-edges (wg-copy-w w)
                     (list left
                           top
                           (+ left (funcall width-fn  (- right  left)))
                           (+ top  (funcall height-fn (- bottom top))))))))
 (defun wg-scale-w-size (w width-scale height-scale)
   "Scale W's size by WIDTH-SCALE and HEIGHT-SCALE."
-  (dflet
+  (cl-flet
       ((wscale (width)  (truncate (* width  width-scale)))
        (hscale (height) (truncate (* height height-scale))))
     (wg-adjust-w-size w #'wscale #'hscale)))
 (defun wg-equal-wtrees (w1 w2)
   "Return t when W1 and W2 have equal structure."
   (cond ((and (wg-win-p w1) (wg-win-p w2))
          (equal (wg-w-edges w1) (wg-w-edges w2)))
         ((and (wg-wtree-p w1) (wg-wtree-p w2))
          (and (eq (wg-wtree-dir w1) (wg-wtree-dir w2))
               (equal (wg-wtree-edges w1) (wg-wtree-edges w2))
               (cl-every #'wg-equal-wtrees
                      (wg-wtree-wlist w1)
                      (wg-wtree-wlist w2))))))
 (defun wg-normalize-wtree (wtree)
   "Clean up and return a new wtree from WTREE.
 Recalculate the edge lists of all subwins, and remove subwins
 outside of WTREE's bounds.  If there's only one element in the
 new wlist, return it instead of a new wtree."
   (if (wg-win-p wtree) wtree
     (wg-with-slots wtree ((dir wg-wtree-dir)
                           (wlist wg-wtree-wlist))
       (wg-with-bounds wtree dir (ls1 hs1 lb1 hb1)
         (let* ((min-size (wg-min-size dir))
                (max (- hb1 1 min-size))
                (lastw (wg-last1 wlist)))
           ;;(wg--with-temporary-redefinitions
-          (dflet
+          (cl-flet
               ((mapwl
                 (wl)
                 (wg-dbind (sw . rest) wl
                   (cons (wg-normalize-wtree
                          (wg-set-bounds
                           sw dir ls1 hs1 lb1
                           (setq lb1 (if (eq sw lastw) hb1
                                       (let ((hb2 (+ lb1 (wg-w-size sw dir))))
                                         (if (>= hb2 max) hb1 hb2))))))
                         (when (< lb1 max) (mapwl rest))))))
             (let ((new (mapwl wlist)))
               (if (not (cdr new)) (car new)
                 (setf (wg-wtree-wlist wtree) new)
                 wtree))))))))
 (defun wg-scale-wtree (wtree wscale hscale)
   "Return a copy of WTREE with its dimensions scaled by WSCALE and HSCALE.
 All WTREE's subwins are scaled as well."
   (let ((scaled (wg-scale-w-size wtree wscale hscale)))
     (if (wg-win-p wtree) scaled
       (wg-asetf (wg-wtree-wlist scaled)
                 (wg-docar (sw it) (wg-scale-wtree sw wscale hscale)))
       scaled)))
 (defun wg-scale-wconfigs-wtree (wconfig new-width new-height)
   "Scale WCONFIG's wtree with NEW-WIDTH and NEW-HEIGHT.
 Return a copy WCONFIG's wtree scaled with `wg-scale-wtree' by the
 ratio or NEW-WIDTH to WCONFIG's width, and NEW-HEIGHT to
 WCONFIG's height."
   (wg-normalize-wtree
    (wg-scale-wtree
     (wg-wconfig-wtree wconfig)
     (/ (float new-width)  (wg-wconfig-width wconfig))
     (/ (float new-height) (wg-wconfig-height wconfig)))))
 ;; (wg-wconfig-width (wg-current-wconfig))
 (defun wg-resize-frame-scale-wtree (wconfig)
   "Set FRAME's size to WCONFIG's, returning a possibly scaled wtree.
 If the frame size was set correctly, return WCONFIG's wtree
 unchanged.  If it wasn't, return a copy of WCONFIG's wtree scaled
 with `wg-scale-wconfigs-wtree' to fit the frame as it exists."
   (let ((frame (selected-frame)))
     (wg-with-slots wconfig ((wcwidth wg-wconfig-width)
                             (wcheight wg-wconfig-height))
       (when window-system (set-frame-size frame wcwidth wcheight))
       (let ((fwidth  (frame-parameter frame 'width))
             (fheight (frame-parameter frame 'height)))
         (if (and (= wcwidth fwidth) (= wcheight fheight))
             (wg-wconfig-wtree wconfig)
           (wg-scale-wconfigs-wtree wconfig fwidth fheight))))))
 (defun wg-reverse-wlist (w &optional dir)
   "Reverse W's wlist and those of all its sub-wtrees in direction DIR.
 If DIR is nil, reverse WTREE horizontally.
 If DIR is 'both, reverse WTREE both horizontally and vertically.
 Otherwise, reverse WTREE vertically."
-  (dflet
+  (cl-flet
       ((inner (w) (if (wg-win-p w) w
                     (wg-with-slots w ((d1 wg-wtree-dir))
                       (wg-make-wtree
                        :dir d1
                        :edges (wg-wtree-edges w)
                        :wlist (let ((wl2 (mapcar #'inner (wg-wtree-wlist w))))
                                 (if (or (eq dir 'both) (eq dir d1))
                                     (nreverse wl2)
                                   wl2)))))))
     (wg-normalize-wtree (inner w))))
 (defun wg-wtree-move-window (wtree offset)
   "Offset `selected-window' OFFSET places in WTREE."
-  (dflet
+  (cl-flet
       ((inner (w) (if (wg-win-p w) w
                     (wg-with-slots w ((wlist wg-wtree-wlist))
                       (wg-make-wtree
                        :dir (wg-wtree-dir w)
                        :edges (wg-wtree-edges w)
                        :wlist (wg-aif (cl-find t wlist :key 'wg-win-selected)
                                   (wg-cyclic-offset-elt it wlist offset)
                                 (mapcar #'inner wlist)))))))
     (wg-normalize-wtree (inner wtree))))
 (defun wg-reverse-wconfig (wconfig &optional dir)
   "Reverse WCONFIG's wtree's wlist in direction DIR."
   (wg-asetf (wg-wconfig-wtree wconfig) (wg-reverse-wlist it dir))
   wconfig)
 (defun wg-wconfig-move-window (wconfig offset)
   "Offset `selected-window' OFFSET places in WCONFIG."
   (wg-asetf (wg-wconfig-wtree wconfig) (wg-wtree-move-window it offset))
   wconfig)
 (defun wg-flatten-wtree (wtree &optional key)
   "Return a new list by flattening WTREE.
 KEY non returns returns a list of WTREE's wins.
 KEY non-nil returns a list of the results of calling KEY on each win."
-  (dflet
+  (cl-flet
       ((inner (w) (if (wg-win-p w) (list (if key (funcall key w) w))
                     (cl-mapcan 'inner (wg-wtree-wlist w)))))
     (inner wtree)))
 (defun wg-win-list (wtree)
   "Construct and return a list of all wg-wins in WTREE."
   (wg-flatten-wtree wtree))
 (require 'workgroups-specialbufs)
 (require 'workgroups-restore)
 ;;; workgroup utils
 (defun wg-flag-workgroup-modified (workgroup)
   "Set WORKGROUP's and the current session's modified flags."
   (when wg-flag-modified
     (setf (wg-workgroup-modified workgroup) t)
     (setf (wg-session-modified (wg-current-session)) t)))
 (defun wg-find-workgroup-by (slotkey value &optional noerror)
   "Return the workgroup on which ACCESSOR returns VALUE or error."
   (let ((accessor (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."
   (interactive)
   (car (wg-workgroup-list-or-error)))
 (defun wg-current-workgroup (&optional noerror frame)
   "Return the current workgroup in FRAME, or error unless NOERROR."
   (or wg-current-workgroup
       (wg-aif (frame-parameter frame 'wg-current-workgroup-uid)
           (wg-find-workgroup-by :uid it noerror)
         (unless noerror (error "No current workgroup in this frame")))))
 (defun wg-previous-workgroup (&optional noerror frame)
   "Return the previous workgroup in FRAME, or error unless NOERROR."
   (wg-aif (frame-parameter frame 'wg-previous-workgroup-uid)
       (wg-find-workgroup-by :uid it noerror)
     (unless noerror (error "No previous workgroup in this frame"))))
 (defun wg-set-current-workgroup (workgroup &optional frame)
   "Set the current workgroup to WORKGROUP.
 WORKGROUP should be a workgroup or nil."
   (set-frame-parameter frame 'wg-current-workgroup-uid
                        (when workgroup (wg-workgroup-uid workgroup))))
 (defun wg-set-previous-workgroup (workgroup &optional frame)
   "Set the previous workgroup to WORKGROUP.
 WORKGROUP should be a workgroup or nil."
   (set-frame-parameter frame 'wg-previous-workgroup-uid
                        (when workgroup (wg-workgroup-uid workgroup))))
 (defun wg-current-workgroup-p (workgroup &optional frame)
   "Return t when WORKGROUP is the current workgroup, nil otherwise."
   (wg-awhen (wg-current-workgroup t frame)
     (eq workgroup it)))
 (defun wg-previous-workgroup-p (workgroup &optional frame)
   "Return t when WORKGROUP is the previous workgroup, nil otherwise."
   (wg-awhen (wg-previous-workgroup t frame)
     (eq workgroup it)))
 (defmacro wg-with-current-workgroup (workgroup &rest body)
   "Execute forms in BODY with WORKGROUP temporarily current.
 WORKGROUP should be any workgroup identifier accepted by
 `wg-get-workgroup'.  The value returned is the last form
 in BODY."
   (declare (indent 1))
   `(let ((wg-current-workgroup (wg-get-workgroup ,workgroup)))
      ,@body))
 (defun wg-get-workgroup (obj &optional noerror)
   "Return a workgroup from OBJ.
 If OBJ is a workgroup, return it.
 If OBJ is a string, return the workgroup named OBJ, or error unless NOERROR.
 If OBJ is nil, return the current workgroup, or error unless NOERROR."
   (cond ((wg-workgroup-p obj) obj)
         ((stringp obj) (wg-find-workgroup-by :name obj noerror))
         ((null obj) (wg-current-workgroup noerror))
         (t (error "Can't get workgroup from type:: %S" (type-of obj)))))
 ;;; workgroup parameters
 (defun wg-workgroup-parameter (workgroup parameter &optional default)
   "Return WORKGROUP's value for PARAMETER.
 If PARAMETER is not found, return DEFAULT which defaults to nil.
 WORKGROUP should be accepted by `wg-get-workgroup'."
   (wg-aget (wg-workgroup-parameters (wg-get-workgroup workgroup))
            parameter default))
 (defun wg-set-workgroup-parameter (workgroup parameter value)
   "Set WORKGROUP's value of PARAMETER to VALUE.
 WORKGROUP should be a value accepted by `wg-get-workgroup'.
 Return VALUE."
   (let ((workgroup (wg-get-workgroup workgroup)))
     (wg-set-parameter (wg-workgroup-parameters workgroup) parameter value)
     (wg-flag-workgroup-modified workgroup)
     value))
 (defun wg-remove-workgroup-parameter (workgroup parameter)
   "Remove PARAMETER from WORKGROUP's parameters."
   (let ((workgroup (wg-get-workgroup workgroup)))
     (wg-flag-workgroup-modified workgroup)
     (wg-asetf (wg-workgroup-parameters workgroup) (wg-aremove it parameter))))
 (defun wg-workgroup-local-value (variable &optional workgroup)
   "Return the value of VARIABLE in WORKGROUP.
 WORKGROUP nil defaults to the current workgroup.  If there is no
 current workgroup, or if VARIABLE does not have a workgroup-local
 binding in WORKGROUP, resolve VARIABLE with `wg-session-local-value'."
   (let ((workgroup (wg-get-workgroup workgroup t)))
     (if (not workgroup) (wg-session-local-value variable)
       (let* ((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 associated buffers
 (defun wg-workgroup-associated-buf-uids (workgroup)
   "Return a new list containing all of WORKGROUP's associated buf uids."
   (append (wg-workgroup-strong-buf-uids workgroup)
           (wg-workgroup-weak-buf-uids workgroup)))
 (defun wg-workgroup-associated-bufs (workgroup)
   "Return a new list containing all of WORKGROUP's associated bufs."
   (delete nil (mapcar 'wg-find-buf-by-uid
                       (wg-workgroup-associated-buf-uids workgroup))))
 (defun wg-workgroup-associated-buffers (workgroup &optional initial names)
   "Return a list of WORKGROUP's live associated buffers."
   (let ((assoc-bufs (wg-workgroup-associated-bufs workgroup)))
     (cl-remove-if-not
      (lambda (buffer) (wg-find-buffer-in-buf-list buffer assoc-bufs))
      (or initial (buffer-list)))))
 (defun wg-workgroup-bufobj-association-type (workgroup bufobj)
   "Return BUFOBJ's association-type in WORKGROUP, or nil if unassociated."
   (let ((uid (wg-bufobj-uid-or-add bufobj)))
     (or (and (member uid (wg-workgroup-strong-buf-uids workgroup)) 'strong)
         (and (member uid (wg-workgroup-weak-buf-uids workgroup)) 'weak))))
 (defun wg-workgroup-strongly-associate-bufobj (workgroup bufobj)
   "Strongly associate BUFOBJ with WORKGROUP."
   (let* ((uid (wg-bufobj-uid-or-add bufobj))
          (remp (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup)
                              :test 'string=))
          (addp (wg-pushnew-p uid (wg-workgroup-strong-buf-uids workgroup)
                              :test 'string=)))
     (when (or remp addp)
       (wg-flag-workgroup-modified workgroup)
       bufobj)))
 (defun wg-workgroup-weakly-associate-bufobj (workgroup bufobj)
   "Weakly associate BUFOBJ with WORKGROUP."
   (let* ((uid (wg-bufobj-uid-or-add bufobj))
          (remp (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup)
                              :test 'string=))
          (addp (wg-pushnew-p uid (wg-workgroup-weak-buf-uids workgroup)
                              :test 'string=)))
     (when (or remp addp)
       (wg-flag-workgroup-modified workgroup)
       bufobj)))
 (defun wg-workgroup-dissociate-bufobj (workgroup bufobj)
   "Dissociate BUFOBJ from WORKGROUP."
   (let* ((uid (wg-bufobj-uid-or-add bufobj))
          (rem1p (wg-removef-p uid (wg-workgroup-strong-buf-uids workgroup)
                               :test 'string=))
          (rem2p (wg-removef-p uid (wg-workgroup-weak-buf-uids workgroup)
                               :test 'string=)))
     (wg-awhen (or rem1p rem2p)
       (wg-flag-workgroup-modified workgroup)
       bufobj)))
 (defun wg-workgroup-associate-bufobj (workgroup bufobj &optional weak)
   "Associate BUFOBJ with WORKGROUP.
 WEAK non-nil means weakly associate it.  Otherwise strongly associate it."
   (if weak (wg-workgroup-weakly-associate-bufobj workgroup bufobj)
     (wg-workgroup-strongly-associate-bufobj workgroup bufobj)))
 (defun wg-workgroup-cycle-bufobj-association-type (workgroup bufobj)
   "Cycle the BUFOBJ's association type in WORKGROUP.
 If it's strongly associated with the workgroup, weakly associate it.
 If it's weakly associated with the workgroup, dissociate it.
 If it's unassociated with the workgroup, mark it as strongly associated."
   (cl-case (wg-workgroup-bufobj-association-type workgroup bufobj)
     (strong (wg-workgroup-weakly-associate-bufobj workgroup bufobj) 'weak)
     (weak (wg-workgroup-dissociate-bufobj workgroup bufobj) nil)
     (otherwise (wg-workgroup-strongly-associate-bufobj workgroup bufobj) 'strong)))
 (defun wg-workgroup-dissociate-weakly-associated-buffers (workgroup)
   "Dissociate from WORKGROUP all weakly associated buffers."
   (when (wg-workgroup-weak-buf-uids workgroup)
     (wg-flag-workgroup-modified workgroup)
     (setf (wg-workgroup-weak-buf-uids workgroup) nil)))
 (defun wg-workgroup-dissociate-strongly-associated-buffers (workgroup)
   "Dissociate from WORKGROUP all strongly associated buffers."
   (when (wg-workgroup-strong-buf-uids workgroup)
     (wg-flag-workgroup-modified workgroup)
     (setf (wg-workgroup-strong-buf-uids workgroup) nil)))
 (defun wg-workgroup-dissociate-all-buffers (workgroup)
   "Dissociate from WORKGROUP all its associated buffers."
   (wg-workgroup-dissociate-weakly-associated-buffers workgroup)
   (wg-workgroup-dissociate-strongly-associated-buffers workgroup))
 (defun wg-auto-dissociate-buffer-hook ()
   "`kill-buffer-hook' that automatically dissociates buffers from workgroups."
   (when wg-dissociate-buffer-on-kill-buffer
     (wg-awhen (wg-current-workgroup t)
       (wg-workgroup-dissociate-bufobj it (current-buffer)))))
 ;;; filtered buffer-list construction
 (defun wg-get-buffer-list-filter-id-flexibly (blf-id)
   "Return a buffer-list-filter-id one way or another."
   (or blf-id wg-current-buffer-list-filter-id 'all))
 (defun wg-get-buffer-list-filter-val (id key &optional noerror)
   "Return ID's KEY's value in `wg-buffer-list-filter-definitions'.
 Lots of possible errors here because
 `wg-buffer-list-filter-definitions' can be modified by the user."
   (let ((slot-num (cl-case key (symbol 0) (indicator 1) (constructor 2))))
     (if (not slot-num)
         (unless noerror
           (error "`%S' is not a valid buffer-list-filter definition slot" key))
       (let* ((id (wg-get-buffer-list-filter-id-flexibly id))
              (entry (assq id (wg-local-value
                               'wg-buffer-list-filter-definitions))))
         (if (not entry)
             (unless noerror
               (error "`%S' is an undefined buffer-list-filter" id))
           (or (nth slot-num entry)
               (unless noerror
                 (error "Slot `%S' is undefined in `%S's definition"
                        key id))))))))
 (defun wg-filtered-buffer-list (&optional names workgroup bfl-id initial)
   "Return a filtered buffer-list from NAMES, WORKGROUP, BLF-ID and INITIAL.
 NAMES non-nil means return a list of buffer-names instead of buffer objects.
 WORKGROUP non-nil should be any workgroup identifier accepted by
 `wg-get-workgroup'.
 BLF-ID non-nil should be the identifier of a defined buffer-list-filter.
 It defaults to `wg-get-buffer-list-filter-val'.
 INITIAL non-nil should be an initial buffer-list to filter.  It defaults to
 `wg-interesting-buffers'."
   (let ((buffer-list (funcall (wg-get-buffer-list-filter-val
                                (wg-get-buffer-list-filter-id-flexibly bfl-id)
                                'constructor)
                               (wg-get-workgroup workgroup)
                               (or initial (wg-interesting-buffers)))))
     (if names (mapcar 'wg-buffer-name buffer-list) buffer-list)))
 ;; buffer-list filters
 (defun wg-buffer-list-filter-all (workgroup initial)
   "Return all buffers in INITIAL."
   initial)
 (defun wg-buffer-list-filter-associated (workgroup initial)
   "Return only those buffers associated with WORKGROUP."
   (wg-workgroup-associated-buffers workgroup initial))
 (defun wg-buffer-list-filter-unassociated (workgroup initial)
   "Return only those buffer unassociated with WORKGROUP."
   (let ((buffers (wg-workgroup-associated-buffers workgroup initial)))
     (cl-remove-if (lambda (buffer) (member buffer buffers)) initial)))
 ;; buffer-list filtration utils
 (defun wg-filter-buffer-list-by-regexp (regexp buffer-list)
   "Return only those buffers in BUFFER-LIST with names matching REGEXP."
   (cl-remove-if-not (lambda (bname) (string-match regexp bname))
                  buffer-list :key 'buffer-name))
 (defun wg-filter-buffer-list-by-root-dir (root-dir buffer-list)
   "Return only those buffers in BUFFER-LIST visiting files undo ROOT-DIR."
   (cl-remove-if-not (lambda (f) (when f (wg-file-under-root-path-p root-dir f)))
                  buffer-list :key 'buffer-file-name))
 (defun wg-filter-buffer-list-by-major-mode (major-mode buffer-list)
   "Return only those buffers in BUFFER-LIST in major-mode MAJOR-MODE."
   (cl-remove-if-not (lambda (mm) (eq mm major-mode))
                  buffer-list :key 'wg-buffer-major-mode))
 ;; Example custom buffer-list-filters
 (defun wg-buffer-list-filter-irc (workgroup buffer-list)
   "Return only those buffers in BUFFER-LIST with names starting in \"#\"."
   (wg-filter-buffer-list-by-regexp "^#" buffer-list))
 (defun wg-buffer-list-filter-home-dir (workgroup buffer-list)
   "Return only those buffers in BUFFER-LIST visiting files under ~/."
   (wg-filter-buffer-list-by-root-dir "~/" buffer-list))
 (defun wg-buffer-list-filter-elisp (workgroup buffer-list)
   "Return only those buffers in BUFFER-LIST in `emacs-lisp-mode'."
   (wg-filter-buffer-list-by-major-mode 'emacs-lisp-mode buffer-list))
 (defun wg-buffer-list-filter-home-dir->elisp (workgroup buffer-list)
   "Example of chaining buffer-list filters.
 This returns all buffers under \"~/\" that are also in `emacs-lisp-mode'."
   (wg-buffer-list-filter-elisp
    nil (wg-buffer-list-filter-home-dir nil buffer-list)))
 ;; buffer-list-filter context
 (defun wg-buffer-list-filter-order (command)
   "Return WORKGROUP's buffer-list-filter order for COMMAND, or a default."
   (let ((bfo (wg-local-value 'wg-buffer-list-filter-order-alist)))
     (or (wg-aget bfo command) (wg-aget bfo 'default))))
 (defmacro wg-prior-mapping (mode command)
   "Return whatever COMMAND would call if MODE wasn't on."
   `(or (let (,mode) (command-remapping ,command)) ,command))
 (defun wg-filter-buffer-list-p ()
   "Return the current workgroup when buffer-list-filters are on."
   (and workgroups-mode wg-buffer-list-filtration-on (wg-current-workgroup t)))
 (defmacro wg-with-buffer-list-filters (command &rest body)
   "Create buffer-list filter context for COMMAND, and eval BODY.
 Binds `wg-current-buffer-list-filter-id' in BODY."
   (declare (indent 1))
   (wg-with-gensyms (order status)
     `(let* ((wg-previous-minibuffer-contents nil)
             (,order (wg-buffer-list-filter-order ,command)))
        (catch 'wg-result
          (while 'your-mom
            (let* ((wg-current-buffer-list-filter-id (car ,order))
                   (,status (catch 'wg-action (list 'done (progn ,@body)))))
              (cl-case (car ,status)
                (done (throw 'wg-result (cadr ,status)))
                (next (setq ,order (wg-rotate-list ,order 1))
                      (setq wg-previous-minibuffer-contents (cadr ,status)))
                (prev (setq ,order (wg-rotate-list ,order -1))
                      (setq wg-previous-minibuffer-contents
                            (cadr ,status))))))))))
 ;;; workgroup working-wconfig and wconfig undo/redo
 (defun wg-workgroup-state-table (&optional frame)
   "Return FRAME's workgroup table, creating it first if necessary."
   (or (frame-parameter frame 'wg-workgroup-state-table)
       (let ((wtree (make-hash-table :test 'equal)))
         (set-frame-parameter frame 'wg-workgroup-state-table wtree)
         wtree)))
 (defun wg-get-workgroup-state (workgroup &optional frame)
   "Return FRAME's WORKGROUP's state table."
   (let ((uid (wg-workgroup-uid workgroup))
         (state-table (wg-workgroup-state-table frame)))
     (or (gethash uid state-table)
         (let ((wgs (wg-make-workgroup-state
                     :undo-pointer 0
                     :undo-list
                     (list (or (wg-workgroup-selected-frame-wconfig workgroup)
                               (wg-workgroup-base-wconfig workgroup))))))
           (puthash uid wgs state-table)
           wgs))))
 (defmacro wg-with-undo (workgroup spec &rest body)
   "Bind WORKGROUP's undo state to SPEC and eval BODY."
   (declare (indent 2))
   (wg-dbind (state undo-pointer undo-list) spec
     `(let* ((,state (wg-get-workgroup-state ,workgroup))
             (,undo-pointer (wg-workgroup-state-undo-pointer ,state))
             (,undo-list (wg-workgroup-state-undo-list ,state)))
        ,@body)))
 (defun wg-flag-just-exited-minibuffer ()
   "Added to `minibuffer-exit-hook'."
   (setq wg-just-exited-minibuffer t))
 (defun wg-flag-window-configuration-changed ()
   "Set `wg-window-configuration-changed' to t unless the
 minibuffer was just exited.  Added to
 `window-configuration-change-hook'."
   (if wg-just-exited-minibuffer
       (setq wg-just-exited-minibuffer nil)
     (setq wg-window-configuration-changed t)))
 (defun wg-unflag-undoify-window-configuration-change ()
   "Set `wg-undoify-window-configuration-change' to nil, exempting
 from undoification any window-configuration changes caused by the
 current command."
   (setq wg-undoify-window-configuration-change nil))
 (defun wg-set-workgroup-working-wconfig (workgroup wconfig)
   "Set the working-wconfig of WORKGROUP to WCONFIG."
   (wg-flag-workgroup-modified workgroup)
   (setf (wg-workgroup-selected-frame-wconfig workgroup) wconfig)
   (wg-with-undo workgroup (state undo-pointer undo-list)
     (setcar (nthcdr undo-pointer undo-list) wconfig)))
 (defun wg-add-wconfig-to-undo-list (workgroup wconfig)
   "Add WCONFIG to WORKGROUP's undo list, truncating its future if necessary."
   (wg-with-undo workgroup (state undo-pointer undo-list)
     (let ((undo-list (cons nil (nthcdr undo-pointer undo-list))))
       (wg-awhen (nthcdr wg-wconfig-undo-list-max undo-list) (setcdr it nil))
       (setf (wg-workgroup-state-undo-list state) undo-list))
     (setf (wg-workgroup-state-undo-pointer state) 0))
   (wg-set-workgroup-working-wconfig workgroup wconfig))
 (defun wg-workgroup-working-wconfig (workgroup &optional noupdate)
   "Return WORKGROUP's working-wconfig.
 If WORKGROUP is the current workgroup in `selected-frame', and
 NOUPDATE is nil, set its working wconfig in `selected-frame' to
 `wg-current-wconfig' and return the updated wconfig.  Otherwise
 return WORKGROUP's current undo state."
   (if (and (not noupdate) (wg-current-workgroup-p workgroup))
       (wg-set-workgroup-working-wconfig workgroup (wg-current-wconfig))
     (wg-with-undo workgroup (state undo-pointer undo-list)
       (nth undo-pointer undo-list))))
 (defun wg-update-current-workgroup-working-wconfig ()
   "Update `selected-frame's current workgroup's working-wconfig
 with `wg-current-wconfig'."
   (wg-awhen (wg-current-workgroup t)
     (wg-set-workgroup-working-wconfig it (wg-current-wconfig))))
 (defun wg-restore-wconfig-undoably (wconfig &optional noundo)
   "Restore WCONFIG in `selected-frame', saving undo information."
   (when noundo (wg-unflag-undoify-window-configuration-change))
   (wg-update-current-workgroup-working-wconfig)
   (wg-restore-wconfig wconfig))
 (defun wg-workgroup-offset-position-in-undo-list (workgroup increment)
   "Increment WORKGROUP's undo-pointer by INCREMENT.
 Also restore the wconfig at the incremented undo-pointer if
 WORKGROUP is current."
   (wg-with-undo workgroup (state undo-pointer undo-list)
     (let ((new-pointer (+ undo-pointer increment)))
       (when (wg-within new-pointer 0 (length undo-list))
         (when (wg-current-workgroup-p workgroup)
           (wg-restore-wconfig-undoably (nth new-pointer undo-list) t))
         (setf (wg-workgroup-state-undo-pointer state) new-pointer)))))
 (defun wg-undoify-window-configuration-change ()
   "Conditionally `wg-add-wconfig-to-undo-list'.
 Added to `post-command-hook'."
   (when (and
          ;; When the window config has changed,
          wg-window-configuration-changed
          ;; and undoification is still on for the current command
          wg-undoify-window-configuration-change
          ;; and the change didn't occur while the minibuffer is active,
          (wg-minibuffer-inactive-p))
     ;; and there's a current workgroup,
     (wg-when-let ((workgroup (wg-current-workgroup t)))
       ;; add the current wconfig to that workgroup's undo list:
       (wg-add-wconfig-to-undo-list workgroup (wg-current-wconfig))))
   ;; Reset all flags no matter what:
   (setq wg-window-configuration-changed nil
         wg-undoify-window-configuration-change t
         wg-already-updated-working-wconfig nil))
 (defun wg-update-working-wconfig-hook ()
   "Used in before advice on all functions that trigger
 `window-configuration-change-hook' to save up to date undo info
 before the change."
   (when (and (not wg-already-updated-working-wconfig)
              (wg-minibuffer-inactive-p))
     (wg-update-current-workgroup-working-wconfig)
     (setq wg-already-updated-working-wconfig t)))
 ;;; base wconfig updating
 (defun wg-update-all-base-wconfigs ()
   "Update every workgroup's base wconfig with
 `wg-workgroup-update-base-wconfig'."
   (dolist (workgroup (wg-workgroup-list))
     (wg-awhen (wg-workgroup-selected-frame-wconfig workgroup)
       (setf (wg-workgroup-base-wconfig workgroup) it
             (wg-workgroup-selected-frame-wconfig workgroup) nil))))
 (defun wg-update-working-wconfig-on-delete-frame (frame)
   "Update FRAME's current workgroup's working-wconfig before
 FRAME is deleted, so we don't lose its state."
   (with-selected-frame frame
     (wg-update-current-workgroup-working-wconfig)))
 ;;; workgroup saved wconfigs
 (defun wg-workgroup-saved-wconfig-names (workgroup)
   "Return a new list of the names of all WORKGROUP's saved wconfigs."
   (mapcar 'wg-wconfig-name (wg-workgroup-saved-wconfigs workgroup)))
 (defun wg-workgroup-get-saved-wconfig (workgroup wconfig-or-name)
   "Return the wconfig in WORKGROUP's saved wconfigs named WCONFIG-OR-NAME.
 WCONFIG-OR-NAME must be either a string or a wconfig.  If
 WCONFIG-OR-NAME is a string and there is no saved wconfig with
 that name, return nil.  If WCONFIG-OR-NAME is a wconfig, and it
 is a member of WORKGROUP's saved wconfigs, return is as given.
 Otherwise return nil."
   (let ((wconfigs (wg-workgroup-saved-wconfigs workgroup)))
     (cl-etypecase wconfig-or-name
       (wg-wconfig (car (memq wconfig-or-name wconfigs)))
       (string (cl-find wconfig-or-name wconfigs
                     :key 'wg-wconfig-name
                     :test 'string=)))))
 (defun wg-workgroup-save-wconfig (workgroup wconfig)
   "Add WCONFIG to WORKGROUP's saved wconfigs.  WCONFIG must have
 a name.  If there's already a wconfig with the same name in
 WORKGROUP's saved wconfigs, replace it."
   (let ((name (wg-wconfig-name wconfig)))
     (unless name (error "Attempt to save a nameless wconfig"))
     (setf (wg-workgroup-modified workgroup) t)
     (wg-asetf (wg-workgroup-saved-wconfigs workgroup)
               (cons wconfig (cl-remove name it
                                        :key 'wg-wconfig-name
                                        :test 'string=)))))
 (defun wg-workgroup-kill-saved-wconfig (workgroup wconfig-or-name)
   "Delete WCONFIG-OR-NAME from WORKGROUP's saved wconfigs.
 WCONFIG-OR-NAME is resolved with `wg-workgroup-get-saved-wconfig'."
   (wg-when-let ((wconfig (wg-workgroup-get-saved-wconfig
                           workgroup wconfig-or-name)))
     (wg-asetf (wg-workgroup-saved-wconfigs workgroup) (remq wconfig it)
               (wg-workgroup-modified workgroup) t)))
 ;;; garbage collection
 ;; update buf list
 (defun wg-update-buffer-in-buf-list (&optional buffer)
   "Update BUFFER's corresponding buf in `wg-buf-list'.
 BUFFER nil defaults to `current-buffer'."
   (let ((buffer (or buffer (current-buffer))))
     (wg-when-let ((uid (wg-buffer-uid buffer))
                   (old-buf (wg-find-buf-by-uid uid))
                   (new-buf (wg-buffer-to-buf buffer)))
       (setf (wg-buf-uid new-buf) (wg-buf-uid old-buf))
       (wg-asetf (wg-buf-list) (cons new-buf (remove old-buf it))))))
 (defun wg-update-buf-list (&optional buffer-list)
   "Update all bufs in `wg-buf-list' corresponding to buffers in BUFFER-LIST."
   (mapc 'wg-update-buffer-in-buf-list (or buffer-list (buffer-list))))
 ;; gc buf uids
 (defun wg-workgroup-gc-buf-uids (workgroup)
   "Remove buf uids from WORKGROUP that have no referent in `wg-buf-list'."
   (wg-asetf (wg-workgroup-strong-buf-uids workgroup)
             (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)))
 ;; gc bufs
 (defun wg-wtree-buf-uids (wtree)
   "Return a new list of the buf uids of all wins in wtree."
   (wg-flatten-wtree wtree 'wg-win-buf-uid))
 (defun wg-wtree-unique-buf-uids (wtree)
   "Return a list of the unique buf uids of all wins in wtree."
   (cl-remove-duplicates (wg-wtree-buf-uids wtree) :test 'string=))
 (defun wg-wconfig-buf-uids (wconfig)
   "Return WCONFIG's wtree's `wg-wtree-buf-uids'."
   (wg-wtree-unique-buf-uids (wg-wconfig-wtree wconfig)))
 (defun wg-workgroup-base-wconfig-buf-uids (workgroup)
   "Return a new list of all unique buf uids in WORKGROUP's working wconfig."
   (wg-wconfig-buf-uids (wg-workgroup-base-wconfig workgroup)))
 (defun wg-workgroup-saved-wconfigs-buf-uids (workgroup)
   "Return a new list of all unique buf uids in WORKGROUP's base wconfig."
   (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)
                 (if wg-restore-associated-buffers
                     (wg-workgroup-associated-buf-uids workgroup))
                 )))
 (defun wg-session-all-buf-uids (&optional session)
   "Return a new list of all unique buf uids in SESSION.
 SESSION nil defaults to `wg-current-session'."
   (cl-reduce 'wg-string-list-union
           (wg-session-workgroup-list (or session (wg-current-session)))
           :key 'wg-workgroup-all-buf-uids))
 (defun wg-buffer-list-all-uids (&optional buffer-list)
   "Return a list of the uids of all buffers in BUFFER-LIST in
 which `wg-buffer-uid' is locally bound.
 BUFFER-LIST nil defaults to `buffer-list'."
   (delq nil (mapcar 'wg-buffer-uid (or buffer-list (buffer-list)))))
 (defun wg-all-buf-uids (&optional session buffer-list)
   "Return the union of `wg-session-all-buf-uids' and `wg-buffer-list-all-uids'."
   (cl-union (wg-session-all-buf-uids session)
          (wg-buffer-list-all-uids buffer-list)
          :test 'string=))
 (defun wg-gc-bufs ()
   "gc bufs from `wg-buf-list' that are no longer needed."
   (let ((all-buf-uids (wg-all-buf-uids)))
     (wg-asetf (wg-buf-list)
               (cl-remove-if-not (lambda (uid) (member uid all-buf-uids)) it
                              :key 'wg-buf-uid))))
 ;; FIXME: Duplicate buf names probably shouldn't be allowed.  An unrelated error
 ;; causes two *scratch* buffers to be present, triggering the "uids don't match"
 ;; error.  Write something to remove bufs with duplicate names.
 (defun wg-perform-session-maintenance ()
   "Perform various maintenance operations on the current Workgroups session."
   (wg-update-current-workgroup-working-wconfig)
   (wg-update-all-base-wconfigs)
   (wg-gc-bufs)
   (wg-gc-buf-uids)
   (wg-update-buf-list))
 ;; session consistency testing
 (defun wg-session-uids-consistent-p ()
   "Return t if there are no duplicate bufs or buf uids in the wrong places,
 nil otherwise."
   (and (cl-every (lambda (wg)
                 (not (wg-dups-p (wg-workgroup-associated-buf-uids wg)
                                 :test 'string=)))
               (wg-workgroup-list))
        (not (wg-dups-p (wg-buf-list) :key 'wg-buf-uid :test 'string=))
        (not (wg-dups-p (wg-workgroup-list) :key 'wg-workgroup-uid :test 'string=))))
 ;;; workgroup restoration
 (defun wg-restore-workgroup-associated-buffers-internal (workgroup)
   "Restore all the buffers associated with WORKGROUP that can be restored."
   (save-window-excursion
     (delete nil (mapcar 'wg-restore-buffer
                         (wg-workgroup-associated-bufs workgroup)))))
 (defun wg-restore-workgroup (workgroup)
   "Restore WORKGROUP in `selected-frame'."
   (when wg-restore-associated-buffers
     (wg-restore-workgroup-associated-buffers-internal workgroup))
   (let (wg-flag-modified)
     (wg-restore-wconfig-undoably
      (wg-workgroup-working-wconfig workgroup)
      t)))
 ;;; workgroup-list ops
 (defun wg-delete-workgroup (workgroup)
   "Remove WORKGROUP from `wg-workgroup-list'.
 Also delete all references to it by `wg-workgroup-state-table',
 `wg-current-workgroup' and `wg-previous-workgroup'."
   (dolist (frame (frame-list))
     (remhash (wg-workgroup-uid workgroup) (wg-workgroup-state-table frame))
     (when (wg-current-workgroup-p workgroup frame)
       (wg-set-current-workgroup nil frame))
     (when (wg-previous-workgroup-p workgroup frame)
       (wg-set-previous-workgroup nil frame)))
   (setf (wg-workgroup-list) (remove workgroup (wg-workgroup-list-or-error)))
   (setf (wg-session-modified (wg-current-session)) t)
   workgroup)
 (defun wg-add-workgroup (workgroup &optional index)
   "Add WORKGROUP to `wg-workgroup-list' at INDEX or the end.
 If a workgroup with the same name exists, overwrite it."
   (wg-awhen (wg-find-workgroup-by :name (wg-workgroup-name workgroup) t)
     (unless index (setq index (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 and add it with `wg-check-and-add-workgroup'."
   (wg-check-and-add-workgroup
    (wg-make-workgroup
     :name name
     :base-wconfig (if blank (wg-make-blank-wconfig)
                     (wg-current-wconfig)))))
 (defun wg-get-workgroup-create (workgroup)
   "Return the workgroup specified by WORKGROUP, creating a new one if needed.
 If `wg-get-workgroup' on WORKGROUP returns a workgroup, return it.
 Otherwise, if WORKGROUP is a string, create a new workgroup with
 that name and return it. Otherwise error."
   (or (wg-get-workgroup workgroup t)
       (if (stringp workgroup)
           (when (or (not wg-confirm-on-get-workgroup-create)
                     (y-or-n-p (format "%S doesn't exist.  Create it? "
                                       workgroup)))
             (wg-make-and-add-workgroup workgroup))
         ;; Call this again for its error message
         (wg-get-workgroup workgroup))))
 (defun wg-cyclic-offset-workgroup (workgroup n)
   "Offset WORKGROUP's position in `wg-workgroup-list' by N."
   (let ((workgroup-list (wg-workgroup-list-or-error)))
     (unless (member workgroup workgroup-list)
       (error "Workgroup isn't present in `wg-workgroup-list'."))
     (setf (wg-workgroup-list) (wg-cyclic-offset-elt workgroup workgroup-list n)
           (wg-session-modified (wg-current-session)) t)))
 (defun wg-swap-workgroups-in-workgroup-list (workgroup1 workgroup2)
   "Swap the positions of WORKGROUP1 and WORKGROUP2 in `wg-workgroup-list'."
   (let ((workgroup-list (wg-workgroup-list-or-error)))
     (when (eq workgroup1 workgroup2)
       (error "Can't swap a workgroup with itself"))
     (unless (and (memq workgroup1 workgroup-list)
                  (memq workgroup2 workgroup-list))
       (error "Both workgroups aren't present in `wg-workgroup-list'."))
     (setf (wg-workgroup-list) (wg-util-swap workgroup1 workgroup2 workgroup-list)
           (wg-session-modified (wg-current-session)) t)))
 (defun wg-cyclic-nth-from-workgroup (workgroup &optional n)
   "Return the workgroup N places from WORKGROUP in `wg-workgroup-list'."
   (wg-cyclic-nth-from-elt workgroup (wg-workgroup-list-or-error) (or n 1)))
 ;;; buffer association
 (defun wg-associate-buffers (workgroup window-or-emacs-window-tree)
   "Associate the buffers visible in window elements of
 WINDOW-OR-EMACS-WINDOW-TREE with the given WORKGROUP.
 WINDOW-OR-EMACS-WINDOW-TREE must be either a window or a tree of
 the form produced by `(car (window-tree))'."
   (wg-aif (windowp window-or-emacs-window-tree)
       (with-current-buffer (window-buffer window-or-emacs-window-tree)
         (setq wg-buffer-workgroup workgroup))
     (dolist (w (cddr window-or-emacs-window-tree))
       (when w (wg-associate-buffers workgroup w)))))
 (defun wg-associate-frame-buffers ()
   "Associate the buffers visible in the current frame with the
 current workgroup (unless it is currently being deactivated)."
   (wg-awhen (wg-current-workgroup :noerror)
     (unless (member it wg-deactivation-list)
       (wg-associate-buffers it (car (window-tree))))))
 (defun wg-associate-all-frame-buffers ()
   "Associate all visible buffers with the current
 workgroup (unless it is currently being deactivated)."
   (mapcar 'wg-associate-frame-buffers (frame-list)))
 (defun wg-buffer-predicate (buffer)
   "Return t iff the given BUFFER should be considered a candidate
 for display by `other-buffer' in the current workgroup."
   (or (not wg-associate-buffers)
       (wg-awhen (wg-current-workgroup :noerror)
         (with-current-buffer buffer
           (eq wg-buffer-workgroup it)))))
 (defun wg-after-make-frame (frame)
   (set-frame-parameter frame 'buffer-predicate
                        'wg-buffer-predicate))
 ;;; mode-line
 (defun wg-mode-line-buffer-association-indicator (workgroup)
   "Return a string indicating `current-buffer's association-type in WORKGROUP."
   (cl-case (wg-workgroup-bufobj-association-type workgroup (current-buffer))
     (strong wg-mode-line-decor-strongly-associated)
     (weak wg-mode-line-decor-weakly-associated)
     (otherwise wg-mode-line-decor-unassociated)))
 (defun wg-mode-line-string ()
   "Return the string to be displayed in the mode-line."
   (let ((wg (wg-current-workgroup t))
         (wg-use-faces wg-mode-line-use-faces))
     (cond (wg (wg-fontify " "
                 ;;(consp (cons :div wg-mode-line-decor-left-brace))
                 ;;(keywordp (car (cons :div wg-mode-line-decor-left-brace)))
                 ;;(:div wg-mode-line-decor-left-brace)
                 wg-mode-line-decor-left-brace
                 (wg-workgroup-name wg)
                 (if (not wg-mode-line-only-name)
                     (progn
                       wg-mode-line-decor-divider
                       (wg-mode-line-buffer-association-indicator wg)
                       wg-mode-line-decor-divider
                       (if (window-dedicated-p)
                                  wg-mode-line-decor-window-dedicated
                                wg-mode-line-decor-window-undedicated)
                       wg-mode-line-decor-divider
                       (if (wg-session-modified (wg-current-session))
                                  wg-mode-line-decor-session-modified
                                wg-mode-line-decor-session-unmodified)
                       (if (wg-workgroup-modified wg)
                           wg-mode-line-decor-workgroup-modified
                         wg-mode-line-decor-workgroup-unmodified)))
                 wg-mode-line-decor-right-brace))
           (t (if wg-display-nowg
                  (progn
                    (wg-fontify " "
                      wg-mode-line-decor-left-brace
                      wg-nowg-string
                      wg-mode-line-decor-right-brace))
                "")))))
 (defun wg-add-mode-line-display ()
   "Add Workgroups' mode-line format to `mode-line-format'."
   (unless (or (assq 'wg-mode-line-display-on mode-line-format)
               wg-mode-line-disable)
     (let ((format '(wg-mode-line-display-on (:eval (wg-mode-line-string))))
           (pos (or (cl-position 'mode-line-position mode-line-format) 10)))
       (set-default 'mode-line-format
                    (wg-insert-after format mode-line-format pos))
       (force-mode-line-update))))
 (defun wg-remove-mode-line-display ()
   "Remove Workgroups' mode-line format from `mode-line-format'."
   (wg-awhen (assq 'wg-mode-line-display-on mode-line-format)
     (set-default 'mode-line-format (remove it mode-line-format))
     (force-mode-line-update)))
 ;;; messaging
 (defun wg-message (format-string &rest args)
   "Call `message' with FORMAT-STRING and ARGS.
 Also save the msg to `wg-last-message'."
   (setq wg-last-message (apply #'message format-string args)))
 (defmacro wg-fontified-message (&rest format)
   "`wg-fontify' FORMAT and call `wg-message' on it."
   (declare (indent defun))
   `(wg-message (wg-fontify ,@format)))
 ;;; fancy displays
 ;; FIXME: add `wg-display-max-lines' to chop long display strings at max-line
 ;; and element-name boundaries
 (defun wg-element-display (elt elt-string &optional current-elt-p previous-elt-p)
   "Return display string for ELT."
   (cond ((and current-elt-p (funcall current-elt-p elt))
          (wg-fontify (:cur (concat wg-list-display-decor-current-left
                                    elt-string
                                    wg-list-display-decor-current-right))))
         ((and previous-elt-p (funcall previous-elt-p elt))
          (wg-fontify (:prev (concat wg-list-display-decor-previous-left
                                     elt-string
                                     wg-list-display-decor-previous-right))))
         (t (wg-fontify (:other elt-string)))))
 (defun wg-workgroup-display (workgroup index)
   "Return display string for WORKGROUP at INDEX."
   (if (not workgroup) wg-nowg-string
     (wg-element-display
      workgroup
      (format "%d: %s" index (wg-workgroup-name workgroup))
      'wg-current-workgroup-p
      'wg-previous-workgroup-p)))
 (defun wg-buffer-display (buffer index)
   "Return display string for BUFFER. INDEX is ignored."
   (if (not buffer) "No buffers"
     (wg-element-display
      (wg-get-buffer buffer)
      (format "%s" (wg-buffer-name buffer))
      'wg-current-buffer-p)))
 ;; (defun wg-display-internal (elt-fn list)
 ;;   "Return display string built by calling ELT-FN on each element of LIST."
 ;;   (let ((div (wg-add-face :div wg-list-display-decor-divider))
 ;;         (i -1))
 ;;     (wg-fontify
 ;;       (:brace wg-list-display-decor-left-brace)
 ;;       (if (not list) (funcall elt-fn nil nil)
 ;;         (wg-doconcat (elt list div) (funcall elt-fn elt (cl-incf i))))
 ;;       (:brace wg-list-display-decor-right-brace))))
 (defcustom wg-display-max-lines 1
   "FIXME: docstring this"
   :type 'integer
   :group 'workgroups)
 (defun wg-display-internal (elt-fn list)
   "Return display string built by calling ELT-FN on each element of LIST."
   (let ((div (wg-add-face :div wg-list-display-decor-divider))
         (wwidth (window-width (minibuffer-window)))
         (i -1)
         (str))
     (setq str
           (wg-fontify
             (:brace wg-list-display-decor-left-brace)
             (if (not list) (funcall elt-fn nil nil)
               (wg-doconcat (elt list div) (funcall elt-fn elt (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))))
 ;; TODO: Possibly add scroll animation for the buffer list display during
 ;; `wg-next-buffer' and `wg-previous-buffer'
 (defun wg-buffer-list-display (buffer-list)
   "Return the buffer-list display string."
   (wg-display-internal
    'wg-buffer-display
    (if wg-center-rotate-buffer-list-display
        (wg-center-rotate-list buffer-list) buffer-list)))
 (defun wg-buffer-list-filter-display (&optional workgroup blf-id)
   "Return a buffer-list-filter display string from WORKGROUP and BLF-ID."
   (wg-fontify
     "("
     (wg-workgroup-name (wg-get-workgroup workgroup))
     ":"
     (wg-get-buffer-list-filter-val blf-id 'indicator)
     ")"))
 (defun wg-buffer-list-filter-prompt (prompt &optional workgroup blf-id)
   "Return a prompt string from PROMPT indicating WORKGROUP and BLF-ID."
   (wg-fontify
     prompt " "
     (wg-buffer-list-filter-display workgroup blf-id)
     ": "))
 (defun wg-buffer-command-display (&optional buffer-list)
   "Return the buffer command display string."
   (concat
    (wg-buffer-list-filter-display) ": "
    (wg-buffer-list-display (or buffer-list (wg-filtered-buffer-list)))))
 (defun wg-timeline-display (position length)
   "Return a timeline visualization string from POSITION and LENGTH."
   (wg-fontify
     ;;(cons :div "-<{")
     "-<{"
     (wg-make-string (- length position) "-" "=")
     "O"
     (wg-make-string (1+ position) "-" "=")
     "}>-"))
 (defun wg-undo-timeline-display (workgroup)
   "Return WORKGROUP's undo timeline string."
   (wg-with-undo workgroup (state undo-pointer undo-list)
     (wg-timeline-display undo-pointer (length undo-list))))
 (require 'workgroups-ido)
 ;;; minibuffer reading
 (defun wg-read-buffer (prompt &optional default require-match)
   "Workgroups' version of `read-buffer'."
   (if (not (wg-filter-buffer-list-p))
       (funcall (wg-read-buffer-function) prompt default require-match)
     (wg-with-buffer-list-filters 'read-buffer
       (funcall (wg-read-buffer-function)
                (wg-buffer-list-filter-prompt
                 (wg-aif (string-match ": *$" prompt)
                     (substring prompt 0 it) prompt))
                default require-match))))
 ;; TODO: Add minibuffer commands for killing, cloning, etc.
 (defun wg-read-workgroup-name (&optional require-match)
   "Read a workgroup with `wg-completing-read'."
   (wg-completing-read
    "Workgroup: " (wg-workgroup-names) nil require-match nil nil
    (wg-awhen (wg-current-workgroup t) (wg-workgroup-name it))))
 (defun wg-new-default-workgroup-name ()
   "Return a new, unique, default workgroup name."
   (let ((names (wg-workgroup-names t)) (index -1) result)
     (while (not result)
       (let ((new-name (format "wg%s" (cl-incf index))))
         (unless (member new-name names)
           (setq result new-name))))
     result))
 (defun wg-unique-workgroup-name-p (new-name)
   "Return t if NEW-NAME is unique in `wg-workgroup-list', nil otherwise."
   (cl-every (lambda (existing-name) (not (equal new-name existing-name)))
          (wg-workgroup-names t)))
 (defun wg-read-new-workgroup-name (&optional prompt)
   "Read a non-empty name string from the minibuffer."
   (let ((default (wg-new-default-workgroup-name)))
     (wg-read-object
      (or prompt (format "Name (default: %S): " default))
      (lambda (new) (and (stringp new)
                         (not (equal new ""))
                         (wg-unique-workgroup-name-p new)))
      "Please enter a unique, non-empty name"
      nil nil nil nil default)))
 (defun wg-read-workgroup-index ()
   "Prompt for the index of a workgroup."
   (let ((max (1- (length (wg-workgroup-list-or-error)))))
     (wg-read-object
      (format "%s\n\nEnter [0-%d]: " (wg-workgroup-list-display) max)
      (lambda (obj) (and (integerp obj) (wg-within obj 0 max t)))
      (format "Please enter an integer [%d-%d]" 0 max)
      nil nil t)))
 (defun wg-read-saved-wconfig-name (workgroup &optional prompt require-match)
   "Read the name of a saved wconfig, completing on the names of
 WORKGROUP's saved wconfigs."
   (wg-completing-read
    (or prompt "Saved wconfig name: ")
    (wg-workgroup-saved-wconfig-names workgroup)
    nil require-match))
 (defun wg-read-saved-wconfig (workgroup)
   "Read the name of and return one of WORKGROUP's saved wconfigs."
   (wg-workgroup-get-saved-wconfig
    workgroup (wg-read-saved-wconfig-name workgroup nil t)))
 ;;; session resetting
 (defun wg-reset-frame (frame)
   "Reset Workgroups' frame-parameters in FRAME to nil."
   (set-frame-parameter frame 'wg-workgroup-state-table nil)
   (set-frame-parameter frame 'wg-current-workgroup-uid nil)
   (set-frame-parameter frame 'wg-previous-workgroup-uid nil))
 (defun wg-reset-buffer (buffer)
   "Return BUFFER.
 Currently only sets BUFFER's `wg-buffer-uid' to nil."
   (with-current-buffer buffer
     (setq wg-buffer-uid nil)))
 (defun wg-reset-internal (&optional session)
   "Reset Workgroups, setting `wg-current-session' to SESSION.
 Resets all frame parameters, buffer-local vars, current
 Workgroups session object, etc.  SESSION nil defaults to a new,
 blank session object."
   (mapc 'wg-reset-frame (frame-list))
   (mapc 'wg-reset-buffer (buffer-list))
   (setq wg-wconfig-kill-ring nil)
   (setq wg-current-session (or session (wg-make-session))))
 ;; Local Variables:
 ;; byte-compile-warnings: (not cl-functions)
 ;; End:
 (provide 'workgroups-functions)
 ;;; workgroups-functions.el ends here

src/workgroups-pickel.el

➞

Show inline comments

 ;;; workgroups-pickel.el --- Elisp object serdes used by Workgroups
 ;;
 ;; Copyright (C) 2010, 2011 tlh
 ;;
 ;; Author: tlh <thunkout at gmail dot com>
 ;; Keywords: serialization deserialization serdes
 ;; Homepage: https://github.com/tlh/workgroups.el
 ;; Version   1.0.0
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 ;; the Free Software Foundation; either version 2 of the License, or (at
 ;; your option) any later version.
 ;; This program is distributed in the hope that it will be useful, but
 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
 ;; USA
 ;;; Commentary:
 ;;
 ;;; Code:
 (require 'cl-lib)
 (require 'workgroups-compat)
 (require 'workgroups-utils-basic)
 ;;; vars
 (defvar wg-pickel-identifier '~pickel!~
   "Symbol identifying a stream as a pickel.")
 (defvar wg-pickel-pickelable-types
   '(integer float symbol string cons vector hash-table)
   "Types pickel can serialize.")
 (defvar wg-pickel-object-serializers
   '((integer    . identity)
     (float      . identity)
     (string     . identity)
     (symbol     . wg-pickel-symbol-serializer)
     (cons       . wg-pickel-cons-serializer)
     (vector     . wg-pickel-vector-serializer)
     (hash-table . wg-pickel-hash-table-serializer))
   "Alist mapping types to object serialization functions.")
 (defvar wg-pickel-link-serializers
   '((cons       . wg-pickel-cons-link-serializer)
     (vector     . wg-pickel-vector-link-serializer)
     (hash-table . wg-pickel-hash-table-link-serializer))
   "Alist mapping types to link serialization functions.")
 (defvar wg-pickel-object-deserializers
   '((s . wg-pickel-deserialize-uninterned-symbol)
     (c . wg-pickel-deserialize-cons)
     (v . wg-pickel-deserialize-vector)
     (h . wg-pickel-deserialize-hash-table))
   "Alist mapping type keys to object deserialization functions.")
 (defvar wg-pickel-link-deserializers
   `((c . wg-pickel-cons-link-deserializer)
     (v . wg-pickel-vector-link-deserializer)
     (h . wg-pickel-hash-table-link-deserializer))
   "Alist mapping type keys to link deserialization functions.")
 ;;; errors and predicates
 (put 'wg-pickel-unpickelable-type-error
      'error-conditions
      '(error wg-pickel-errors wg-pickel-unpickelable-type-error))
 (put 'wg-pickel-unpickelable-type-error
      'error-message
      "Attemp to pickel unpickelable type")
 (defun wg-pickelable-or-error (obj)
   "Error when OBJ isn't pickelable."
   (unless (memq (type-of obj) wg-pickel-pickelable-types)
     (signal 'wg-pickel-unpickelable-type-error
             (format "Can't pickel objects of type: %S" (type-of obj))))
   (cl-typecase obj
     (cons
      (wg-pickelable-or-error (car obj))
      (wg-pickelable-or-error (cdr obj)))
     (vector
      (cl-map nil 'wg-pickelable-or-error obj))
     (hash-table
      (wg-dohash (key value obj)
        (wg-pickelable-or-error key)
        (wg-pickelable-or-error value)))))
 (defun wg-pickelable-p (obj)
   (condition-case err
       (progn (wg-pickelable-or-error obj) t)
     (wg-pickel-unpickelable-type-error nil)))
 (defun wg-pickel-p (obj)
   "Return t when OBJ is a pickel, nil otherwise."
   (and (consp obj) (eq (car obj) wg-pickel-identifier)))
 ;; accessor functions
 (defun wg-pickel-object-serializer (obj)
   "Return the object serializer for the `type-of' OBJ."
   (or (wg-aget wg-pickel-object-serializers (type-of obj))
       (error "Invalid type: %S" (type-of obj))))
 (defun wg-pickel-link-serializer (obj)
   "Return the link serializer for the `type-of' OBJ."
   (wg-aget wg-pickel-link-serializers (type-of obj)))
 (defun wg-pickel-object-deserializer (key)
   "Return the object deserializer for type key KEY, or error."
   (or (wg-aget wg-pickel-object-deserializers key)
       (error "Invalid object deserializer key: %S" key)))
 (defun wg-pickel-link-deserializer (key)
   "Return the link deserializer for type key KEY, or error."
   (or (wg-aget wg-pickel-link-deserializers key)
       (error "Invalid link deserializer key: %S" key)))
 ;;; bindings
 (defun wg-pickel-make-bindings-table (obj)
   "Return a table binding unique subobjects of OBJ to ids."
   (let ((binds (make-hash-table :test 'eq))
         (id -1))
-    (dflet
+    (cl-flet
      ((inner (obj)
            (unless (gethash obj binds)
               (puthash obj (cl-incf id) binds)
               (cl-case (type-of obj)
                 (cons
                  (inner (car obj))
                  (inner (cdr obj)))
                 (vector
                  (dotimes (idx (length obj))
                    (inner (aref obj idx))))
                 (hash-table
                  (wg-dohash (key val obj)
                    (inner key)
                    (inner val)))))))
       (inner obj)
       binds)))
 ;;; object serialization
 (defun wg-pickel-symbol-serializer (symbol)
   "Return SYMBOL's serialization."
   (cond ((eq symbol t) t)
         ((eq symbol nil) nil)
         ((intern-soft symbol) symbol)
         (t (list 's (symbol-name symbol)))))
 (defun wg-pickel-cons-serializer (cons)
   "Return CONS's serialization."
   (list 'c))
 (defun wg-pickel-vector-serializer (vector)
   "Return VECTOR's serialization."
   (list 'v (length vector)))
 (defun wg-pickel-hash-table-serializer (table)
   "Return HASH-TABLE's serialization."
   (list 'h
         (hash-table-test table)
         (hash-table-size table)
         (hash-table-rehash-size table)
         (hash-table-rehash-threshold table)
         (hash-table-weakness table)))
 (defun wg-pickel-serialize-objects (binds)
   "Return a list of serializations of the objects in BINDS."
   (let (result)
     (wg-dohash (obj id binds result)
       (setq result
             (nconc (list id (funcall (wg-pickel-object-serializer obj) obj))
                    result)))))
 ;;; link serialization
 (defun wg-pickel-cons-link-serializer (cons binds)
   "Return the serialization of CONS's links in BINDS."
   (list 'c
         (gethash cons binds)
         (gethash (car cons) binds)
         (gethash (cdr cons) binds)))
 (defun wg-pickel-vector-link-serializer (vector binds)
   "Return the serialization of VECTOR's links in BINDS."
   (let (result)
     (dotimes (i (length vector) result)
       (setq result
             (nconc (list 'v
                          (gethash vector binds)
+                         i
                          (gethash (aref vector i) binds))
                    result)))))
 (defun wg-pickel-hash-table-link-serializer (table binds)
   "Return the serialization of TABLE's links in BINDS."
   (let (result)
     (wg-dohash (key value table result)
       (setq result
             (nconc (list 'h
                          (gethash key binds)
                          (gethash value binds)
                          (gethash table binds))
                    result)))))
 (defun wg-pickel-serialize-links (binds)
   "Return a list of serializations of the links between objects in BINDS."
   (let (result)
     (wg-dohash (obj id binds result)
       (wg-awhen (wg-pickel-link-serializer obj)
         (setq result (nconc (funcall it obj binds) result))))))
 ;;; object deserialization
 (defun wg-pickel-deserialize-uninterned-symbol (name)
   "Return a new uninterned symbol from NAME."
   (make-symbol name))
 (defun wg-pickel-deserialize-cons ()
   "Return a new cons cell initialized to nil."
   (cons nil nil))
 (defun wg-pickel-deserialize-vector (length)
   "Return a new vector of length LENGTH."
   (make-vector length nil))
 (defun wg-pickel-deserialize-hash-table (test size rsize rthresh weakness)
   "Return a new hash-table with the specified properties."
   (make-hash-table :test test :size size :rehash-size rsize
                    :rehash-threshold rthresh :weakness weakness))
 (defun wg-pickel-deserialize-objects (serial-objects)
   "Return a hash-table of objects deserialized from SERIAL-OBJECTS."
   (let ((binds (make-hash-table)))
     (wg-destructuring-dolist ((id obj . rest) serial-objects binds)
       (puthash id
                (if (atom obj) obj
                  (wg-dbind (key . data) obj
                    (apply (wg-pickel-object-deserializer key) data)))
                binds))))
 ;;; link deserialization
 (defun wg-pickel-cons-link-deserializer (cons-id car-id cdr-id binds)
   "Relink a cons cell with its car and cdr in BINDS."
   (let ((cons (gethash cons-id binds)))
     (setcar cons (gethash car-id binds))
     (setcdr cons (gethash cdr-id binds))))
 (defun wg-pickel-vector-link-deserializer (vector-id index value-id binds)
   "Relink a vector with its elements in BINDS."
   (aset (gethash vector-id binds) index (gethash value-id binds)))
 (defun wg-pickel-hash-table-link-deserializer (key-id value-id table-id binds)
   "Relink a hash-table with its keys and values in BINDS."
   (puthash (gethash key-id binds)
            (gethash value-id binds)
            (gethash table-id binds)))
 (defun wg-pickel-deserialize-links (serial-links binds)
   "Return BINDS after relinking all its objects according to SERIAL-LINKS."
   (wg-destructuring-dolist ((key arg1 arg2 arg3 . rest) serial-links binds)
     (funcall (wg-pickel-link-deserializer key) arg1 arg2 arg3 binds)))
 ;;; pickeling
 (defun wg-pickel (obj)
   "Return the serialization of OBJ."
   (wg-pickelable-or-error obj)
   (let ((binds (wg-pickel-make-bindings-table obj)))
     (list wg-pickel-identifier
           (wg-pickel-serialize-objects binds)
           (wg-pickel-serialize-links binds)
           (gethash obj binds))))
 (defun wg-pickel-to-string (obj)
   "Serialize OBJ to a string and return the string."
   (format "%S" (wg-pickel obj)))
 (defun wg-pickel-to-file (file obj)
   "Serialize OBJ to FILE."
   (wg-write-sexp-to-file (wg-pickel obj) file))
 ;;; unpickeling
 (defun wg-unpickel (pickel)
   "Return the deserialization of PICKEL."
   (unless (wg-pickel-p pickel)
     (error "Attempt to unpickel a non-pickel."))
   (wg-dbind (id serial-objects serial-links result) pickel
     (gethash
      result
      (wg-pickel-deserialize-links
       serial-links
       (wg-pickel-deserialize-objects serial-objects)))))
 (defun wg-unpickel-file (file)
   "`unpickel' an object directly from FILE."
   (wg-unpickel (wg-lisp-object-from-file file)))
 (defun wg-unpickel-string (str)
   "`unpickel' and object directly from STR."
   (wg-unpickel (read str)))
 ;;; parameter pickeling
   (defun wg-pickel-workgroup-parameters (workgroup)
     "If WORKGROUP's parameters are non-nil, return a copy of
 WORKGROUP after pickeling its parameters. Otherwise return
 WORKGROUP."
     (if (not (wg-workgroup-parameters workgroup)) workgroup
       (let ((copy (wg-copy-workgroup workgroup)))
         (wg-asetf (wg-workgroup-parameters copy) (wg-pickel copy))
         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 copy))
         copy)))
   (defun wg-pickel-all-session-parameters (session)
     "Return a copy of SESSION after pickeling its
 parameters and the parameters of all its workgroups."
     (let ((copy (wg-copy-session session)))
       (when (wg-session-parameters copy)
         (wg-asetf (wg-session-parameters copy) (wg-pickel copy)))
       (wg-asetf (wg-session-workgroup-list copy)
                 (cl-mapcar 'wg-pickel-workgroup-parameters it))
       copy))
   (defun wg-unpickel-session-parameters (session)
     "Return a copy of SESSION after unpickeling its
 parameters and the parameters of all its workgroups."
     (let ((copy (wg-copy-session session)))
       (when (wg-session-parameters copy)
         (wg-asetf (wg-session-parameters copy) (wg-unpickel copy)))
       (wg-asetf (wg-session-workgroup-list copy)
                 (cl-mapcar 'wg-unpickel-workgroup-parameters it))
       copy))
 (provide 'workgroups-pickel)
 ;;; workgroups-pickel.el ends here

src/workgroups-specialbufs.el

➞

Show inline comments

 ;;; workgroups-specialbufs --- special buffers serialization
 ;;; Commentary:
 ;;
 ;; TODO:
 ;;  1. Add more special buffers support (that you use)
 ;;  2. Improve existing
 ;;
 ;;; Code:
 (require 'workgroups-compat)
 (require 'workgroups-variables)
 (require 'workgroups-support-macro)
 ;; Dired
 (wg-support 'dired-mode 'dired
             `((deserialize . ,(lambda (buffer vars)
                                 (if (or wg-restore-remote-buffers
                                         (not (file-remote-p default-directory)))
                                     ;; TODO: try to restore parent dir if not exist
                                     (if (file-directory-p default-directory)
                                         (dired default-directory)))))))
 ;; Info-mode
 (wg-support 'Info-mode 'info
             `((save . (Info-current-file Info-current-node))
               (deserialize . ,(lambda (buffer vars)
                                 (wg-aif vars
                                     (if (fboundp 'Info-find-node)
                                         (apply #'Info-find-node it))
                                   (info))))))
 ;; help-mode
 (wg-support 'help-mode 'help-mode
             `((save . (help-xref-stack-item help-xref-stack help-xref-forward-stack))
               (deserialize . ,(lambda (buffer vars)
                                (wg-dbind (item stack forward-stack) vars
                                  (condition-case err
                                      (apply (car item) (cdr item))
                                    (error (message "%s" err)))
                                  (wg-awhen (get-buffer "*Help*")
                                    (set-buffer it)
                                    (wg-when-boundp (help-xref-stack help-xref-forward-stack)
                                      (setq help-xref-stack stack
                                            help-xref-forward-stack forward-stack))))))))
 ;; ielm
 (wg-support 'inferior-emacs-lisp-mode 'ielm
             `((deserialize . ,(lambda (buffer vars) (ielm)))))
 ;; Magit status
 (wg-support 'magit-status-mode 'magit
             `((deserialize . ,(lambda (buffer vars)
                                 (when (file-directory-p default-directory)
                                   (magit-status default-directory))))))
 ;; Shell
 (wg-support 'shell-mode 'shell
             `((deserialize . ,(lambda (buffer vars)
                                 (shell (wg-buf-name buffer))))))
 ;; org-agenda buffer
 (defun wg-get-org-agenda-view-commands ()
   "Return commands to restore the state of Agenda buffer.
 Can be restored using \"(eval commands)\"."
   (interactive)
   (when (boundp 'org-agenda-buffer-name)
     (if (get-buffer org-agenda-buffer-name)
         (with-current-buffer org-agenda-buffer-name
           (let* ((p (or (and (looking-at "\\'") (1- (point))) (point)))
                  (series-redo-cmd (get-text-property p 'org-series-redo-cmd)))
             (if series-redo-cmd
                 (get-text-property p 'org-series-redo-cmd)
               (get-text-property p 'org-redo-cmd)))))))
 (defun wg-run-agenda-cmd (f)
   "Run commands F in Agenda buffer.
 You can get these commands using `wg-get-org-agenda-view-commands'."
   (when (and (boundp 'org-agenda-buffer-name)
              (fboundp 'org-current-line)
              (fboundp 'org-goto-line))
     (if (get-buffer org-agenda-buffer-name)
         (save-window-excursion
           (with-current-buffer org-agenda-buffer-name
             (let* ((line (org-current-line)))
               (if f (eval f))
               (org-goto-line line)))))))
 (wg-support 'org-agenda-mode 'org-agenda
             '((serialize . (lambda (buffer)
                              (wg-get-org-agenda-view-commands)))
               (deserialize . (lambda (buffer vars)
                                (org-agenda-list)
                                (wg-awhen (get-buffer org-agenda-buffer-name)
                                  (set-buffer it)
                                  (wg-run-agenda-cmd vars))
                                ))))
 ;; eshell
 (wg-support 'eshell-mode 'esh-mode
             '((deserialize . (lambda (buffer vars)
                                (prog1 (eshell t)
                                  (rename-buffer (wg-buf-name buffer) t))))))
 ;; term-mode
 ;;
 ;; This should work for `ansi-term's, too, as there doesn't seem to
 ;; be any difference between the two except how the name of the
 ;; buffer is generated.
 ;;
 (wg-support 'term-mode 'term
             `((serialize . ,(lambda (buffer)
                               (if (get-buffer-process buffer)
                                   (wg-last1 (process-command (get-buffer-process buffer)))
                                 "/bin/bash")))
               (deserialize . ,(lambda (buffer vars)
                                 (dflet ((term-window-width () 80)
                                         (window-height () 24))
                                 (cl-flet ((term-window-width () 80)
                                           (window-height () 24))
                                   (prog1 (term vars)
                                     (rename-buffer (wg-buf-name buffer) t)))))))
 ;; Python
 (wg-support 'inferior-python-mode 'python
             `((save . (python-shell-interpreter python-shell-interpreter-args))
               (deserialize . ,(lambda (buffer vars)
                                 (wg-dbind (pythoncmd pythonargs) vars
                                   (save-window-excursion
                                     (run-python (concat pythoncmd " " pythonargs)))
                                   (wg-awhen (get-buffer (process-buffer (python-shell-get-or-create-process)))
                                     (set-buffer it)
                                     (switch-to-buffer (process-buffer (python-shell-get-or-create-process)))
                                     (goto-char (point-max)))
                                   )))))
 ;; Sage shell
 (wg-support 'inferior-sage-mode 'sage-mode
             `((deserialize . ,(lambda (buffer vars)
                                 (save-window-excursion
                                   (if (boundp' sage-command)
                                       (run-sage t sage-command t)))
                                 (if (boundp 'sage-buffer)
                                     (wg-awhen (and
                                                sage-buffer)
                                       (set-buffer it)
                                       (switch-to-buffer sage-buffer)
                                       (goto-char (point-max))))))))
 ;; inferior-ess-mode   (ess-inf.el)
 ;; R shell, M-x R
 (wg-support 'inferior-ess-mode 'ess-inf
             `((save . (inferior-ess-program))
               (deserialize . ,(lambda (buffer vars)
                                 (wg-dbind (cmd) vars
                                   (let ((ess-ask-about-transfile nil)
                                         (ess-ask-for-ess-directory nil)
                                         (ess-history-file nil))
                                     (R)))))))
 ;; inferior-octave-mode
 (wg-support 'inferior-octave-mode 'octave
             `((deserialize . ,(lambda (buffer vars)
                                 (prog1 (run-octave)
                                   (rename-buffer (wg-buf-name buffer) t))))))
 ;; Prolog shell
 (wg-support 'prolog-inferior-mode 'prolog
             `((deserialize . ,(lambda (buffer vars)
                                 (save-window-excursion
                                   (run-prolog nil))
                                 (switch-to-buffer "*prolog*")
                                 (goto-char (point-max))))))
 ;; compilation-mode
 ;;
 ;; I think it's not a good idea to compile a program just to switch
 ;; workgroups. So just restoring a buffer name.
 (wg-support 'compilation-mode 'compile
             `((serialize . ,(lambda (buffer)
                               (if (boundp' compilation-arguments) compilation-arguments)))
               (deserialize . ,(lambda (buffer vars)
                                 (save-window-excursion
                                   (get-buffer-create (wg-buf-name buffer)))
                                 (with-current-buffer (wg-buf-name buffer)
                                   (when (boundp' compilation-arguments)
                                     (make-local-variable 'compilation-arguments)
                                     (setq compilation-arguments vars)))
                                 (switch-to-buffer (wg-buf-name buffer))
                                 (goto-char (point-max))))))
 ;; grep-mode
 ;; see grep.el - `compilation-start' - it is just a compilation buffer
 ;; local variables:
 ;; `compilation-arguments' == (cmd mode nil nil)
 (wg-support 'grep-mode 'grep
             `((serialize . ,(lambda (buffer)
                               (if (boundp' compilation-arguments) compilation-arguments)))
               (deserialize . ,(lambda (buffer vars)
                                 (compilation-start (car vars) (nth 1 vars))
                                 (switch-to-buffer "*grep*")))))
 ;; speedbar-mode
 (defun wg-deserialize-speedbar-buffer (buf)
   "Deserialize speedbar-buffer BUF."
   (when (and (require 'speedbar nil 'noerror)
              (require 'dframe nil 'noerror))
     (wg-dbind (this-function args) (wg-buf-special-data buf)
       (let ((default-directory (car args))
             bufname)
         (if (boundp 'sr-speedbar-buffer-name)
             (setq bufname sr-speedbar-buffer-name)
           (setq bufname "*SPEEDBAR*"))
         (when (and (fboundp 'speedbar-mode)
                    (fboundp 'speedbar-reconfigure-keymaps)
                    (fboundp 'speedbar-update-contents)
                    (fboundp 'speedbar-set-timer))
           (with-no-warnings
             (setq speedbar-buffer (get-buffer-create bufname))
             (setq speedbar-frame (selected-frame)
                   dframe-attached-frame (selected-frame)
                   speedbar-select-frame-method 'attached
                   speedbar-verbosity-level 0
                   speedbar-last-selected-file nil)
             (set-buffer speedbar-buffer)
             (speedbar-mode)
             (speedbar-reconfigure-keymaps)
             (speedbar-update-contents)
             (speedbar-set-timer 1)
             (set-window-dedicated-p (get-buffer-window bufname) t)
             (switch-to-buffer bufname)))
         (current-buffer)
         ))))
 (defun wg-serialize-speedbar-buffer (buffer)
   "Serialize speedbar BUFFER."
   (with-current-buffer buffer
     (if (fboundp 'speedbar-mode)
         (when (eq major-mode 'speedbar-mode)
           (list 'wg-deserialize-speedbar-buffer
                 (wg-take-until-unreadable (list default-directory))
                 )))))
 (defun wg-deserialize-slime-buffer (buf)
   "Deserialize `slime' buffer BUF."
   (when (require 'slime nil 'noerror)
     (wg-dbind (this-function args) (wg-buf-special-data buf)
       (let ((default-directory (car args))
             (arguments (nth 1 args)))
         (when (and (fboundp 'slime-start*)
                    (fboundp 'slime-process))
           (save-window-excursion
             (slime-start* arguments))
           (switch-to-buffer (process-buffer (slime-process)))
           (current-buffer))))))
 ;; `comint-mode'  (general mode for all shells)
 ;;
 ;; It may have different shells. So we need to determine which shell is
 ;; now in `comint-mode' and how to restore it.
 ;;
 ;; Just executing `comint-exec' may be not enough because we can miss
 ;; some hooks or any other stuff that is executed when you run a
 ;; specific shell.
 (defun wg-serialize-comint-buffer (buffer)
   "Serialize comint BUFFER."
   (with-current-buffer buffer
     (if (fboundp 'comint-mode)
         (when (eq major-mode 'comint-mode)
           ;; `slime-inferior-lisp-args' var is used when in `slime'
           (when (and (boundp 'slime-inferior-lisp-args)
                      slime-inferior-lisp-args)
             (list 'wg-deserialize-slime-buffer
                   (wg-take-until-unreadable (list default-directory
                                                   slime-inferior-lisp-args))
                 ))))))
 ;; inf-mongo
 ;; https://github.com/tobiassvn/inf-mongo
 ;; `mongo-command' - command used to start inferior mongo
 (wg-support 'inf-mongo-mode 'inf-mongo
             `((serialize . ,(lambda (buffer)
                               (if (boundp 'inf-mongo-command) inf-mongo-command)))
               (deserialize . ,(lambda (buffer vars)
                                 (save-window-excursion
                                   (when (fboundp 'inf-mongo)
                                     (inf-mongo vars)))
                                 (when (get-buffer "*mongo*")
                                   (switch-to-buffer "*mongo*")
                                   (goto-char (point-max)))))))
 (defun wg-temporarily-rename-buffer-if-exists (buffer)
   "Rename BUFFER if it exists."
   (when (get-buffer buffer)
     (with-current-buffer buffer
       (rename-buffer "*wg--temp-buffer*" t))))
 ;; SML shell
 ;; Functions to serialize deserialize inferior sml buffer
 ;; `inf-sml-program' is the program run as inferior sml, is the
 ;; `inf-sml-args' are the extra parameters passed, `inf-sml-host'
 ;; is the host on which sml was running when serialized
 (wg-support 'inferior-sml-mode 'sml-mode
             `((serialize . ,(lambda (buffer)
                               (list (if (boundp 'sml-program-name) sml-program-name)
                                     (if (boundp 'sml-default-arg) sml-default-arg)
                                     (if (boundp 'sml-host-name) sml-host-name))))
               (deserialize . ,(lambda (buffer vars)
                                 (wg-dbind (program args host) vars
                                   (save-window-excursion
                                     ;; If a inf-sml buffer already exists rename it temporarily
                                     ;; otherwise `run-sml' will simply switch to the existing
                                     ;; buffer, however we want to create a separate buffer with
                                     ;; the serialized name
                                     (let* ((inf-sml-buffer-name (concat "*"
                                                                         (file-name-nondirectory program)
                                                                         "*"))
                                            (existing-sml-buf (wg-temporarily-rename-buffer-if-exists
                                                               inf-sml-buffer-name)))
                                       (with-current-buffer (run-sml program args host)
                                         ;; Rename the buffer
                                         (rename-buffer (wg-buf-name buffer) t)
                                         ;; Now we can re-rename the previously renamed buffer
                                         (when existing-sml-buf
                                           (with-current-buffer existing-sml-buf
                                             (rename-buffer inf-sml-buffer-name t))))))
                                   (switch-to-buffer (wg-buf-name buffer))
                                   (goto-char (point-max)))))))
 ;; Geiser repls
 ;; http://www.nongnu.org/geiser/
 (wg-support 'geiser-repl-mode 'geiser
             `((save . (geiser-impl--implementation))
               (deserialize . ,(lambda (buffer vars)
                                 (save-window-excursion
                                   (when (fboundp 'run-geiser)
                                     (wg-dbind (impl) vars
                                       (run-geiser impl)
                                       (goto-char (point-max)))))
                                 (switch-to-buffer (wg-buf-name buffer))))))
 ;; w3m-mode
 (wg-support 'w3m-mode 'w3m
             `((save . (w3m-current-url))
               (deserialize . ,(lambda (buffer vars)
                                 (wg-dbind (url) vars
                                   (w3m-goto-url url))))))
 ;; Wanderlust modes:
 ;; WL - folders
 ;;(defun wg-deserialize-wl-folders-buffer (buf)
 ;;  ""
 ;;  (if (fboundp 'wl)
 ;;      (wg-dbind (this-function) (wg-buf-special-data buf)
 ;;        ;;(when (not (eq major-mode 'wl-folder-mode))
 ;;        (wl)
 ;;        (goto-char (point-max))
 ;;        (current-buffer)
 ;;        )))
 ;;
 ;;(defun wg-serialize-wl-folders-buffer (buffer)
 ;;  ""
 ;;  (if (fboundp 'wl)
 ;;      (with-current-buffer buffer
 ;;        (when (eq major-mode 'wl-folder-mode)
 ;;          (list 'wg-deserialize-wl-folders-buffer
 ;;                )))))
 ;; WL - summary mode (list of mails)
 ;;(defun wg-deserialize-wl-summary-buffer (buf)
 ;;  ""
 ;;  (interactive)
 ;;  (if (fboundp 'wl)
 ;;      (wg-dbind (this-function param-list) (wg-buf-special-data buf)
 ;;        (when (not (eq major-mode 'wl-summary-mode))
 ;;          (let ((fld-name (car param-list)))
 ;;            ;;(switch-to-buffer "*scratch*")
 ;;            ;;(wl)
 ;;            ;;(wl-folder-jump-folder fld-name)
 ;;            ;;(message fld-name)
 ;;            ;;(goto-char (point-max))
 ;;            ;;(insert fld-name)
 ;;            (current-buffer)
 ;;          )))))
 ;;
 ;;(defun wg-serialize-wl-summary-buffer (buffer)
 ;;  ""
 ;;  (if (fboundp 'wl)
 ;;      (with-current-buffer buffer
 ;;        (when (eq major-mode 'wl-summary-mode)
 ;;          (list 'wg-deserialize-wl-summary-buffer
 ;;                (wg-take-until-unreadable (list wl-summary-buffer-folder-name))
 ;;                )))))
 ;;
 ;;
 ;;;; mime-view-mode
 ;;
 ;;(defun wg-deserialize-mime-view-buffer (buf)
 ;;  ""
 ;;  (wg-dbind (this-function) (wg-buf-special-data buf)
 ;;    (when (not (eq major-mode 'mime-view-mode))
 ;;      ;;(wl-summary-enter-handler 3570)     ; only in wl-summary-mode
 ;;      ;;(wl-summary-enter-handler)     ; only in wl-summary-mode
 ;;      (current-buffer)
 ;;      )))
 ;;
 ;;(defun wg-serialize-mime-view-buffer (buffer)
 ;;  ""
 ;;  (with-current-buffer buffer
 ;;    (when (eq major-mode 'mime-view-mode)
 ;;      (list 'wg-deserialize-mime-view-buffer
 ;;            ))))
 ;; emms-playlist-mode
 ;;
 ;; Help me on this one:
 ;; 1. How to start emms without any user interaction?
 ;;
 ;;(defun wg-deserialize-emms-buffer (buf)
 ;;  "Deserialize emms-playlist buffer BUF."
 ;;  (when (require 'emms-setup nil 'noerror)
 ;;    (require 'emms-player-mplayer)
 ;;    (emms-standard)
 ;;    (emms-default-players)
 ;;    (if (fboundp 'emms-playlist-mode)
 ;;        (wg-dbind (this-function args) (wg-buf-special-data buf)
 ;;          (let ((default-directory (car args)))
 ;;            (save-window-excursion
 ;;              ;;(emms)
 ;;              (if (or (null emms-playlist-buffer)
 ;;                      (not (buffer-live-p emms-playlist-buffer)))
 ;;                  ;;(call-interactively 'emms-add-file)
 ;;                  (emms-source-directory "/usr/data/disk_3/Music/SORT/")
 ;;                ))
 ;;            ;; (emms)
 ;;            ;;(with-current-buffer emms-playlist-buffer-name
 ;;            ;;(emms-source-playlist-directory-tree "/usr/data/disk_3/Music/SORT/")
 ;;            ;;(emms-source-directory "/usr/data/disk_3/Music/SORT")
 ;;            ;;(switch-to-buffer emms-playlist-buffer-name)
 ;;            (emms-playlist-mode-go)
 ;;            (current-buffer)
 ;;            )))))
 ;;
 ;;(defun wg-serialize-emms-buffer (buffer)
 ;;  "Serialize emms BUFFER."
 ;;  (with-current-buffer buffer
 ;;    (if (fboundp 'emms-playlist-mode)
 ;;        (when (eq major-mode 'emms-playlist-mode)
 ;;          (list 'wg-deserialize-emms-buffer
 ;;                (wg-take-until-unreadable (list default-directory))
 ;;                )))))
 ;;; buffer-local variable serdes
 (defun wg-serialize-buffer-mark-ring ()
   "Return a new list of the positions of the marks in `mark-ring'."
   (mapcar 'marker-position mark-ring))
 (defun wg-deserialize-buffer-mark-ring (positions)
   "Set `mark-ring' to a new list of markers created from POSITIONS."
   (setq mark-ring
         (mapcar (lambda (pos) (set-marker (make-marker) pos))
                 positions)))
 (defun wg-deserialize-buffer-major-mode (major-mode-symbol)
   "Conditionally retore MAJOR-MODE-SYMBOL in `current-buffer'."
   (and (fboundp major-mode-symbol)
        (not (eq major-mode-symbol major-mode))
        (funcall major-mode-symbol)))
 (defun wg-deserialize-buffer-local-variables (buf)
   "Restore BUF's buffer local variables in `current-buffer'."
   (cl-loop for ((var . val) . rest) on (wg-buf-local-vars buf)
            do (wg-awhen (assq var wg-buffer-local-variables-alist)
                 (wg-dbind (var ser des) it
                   (if des (funcall des val)
                     (set var val))))))
 (provide 'workgroups-specialbufs)
 ;;; workgroups-specialbufs.el ends here

src/workgroups-utils-basic.el

➞

Show inline comments

 ;;; workgroups-utils.el --- Utilities used by Workgroups
 ;;
 ;; Copyright (C) 2010, 2011 tlh
 ;;
 ;; Author: tlh <thunkout at gmail dot com>
 ;; Keywords: session management window-configuration persistence
 ;; Homepage: https://github.com/tlh/workgroups.el
 ;; Version   1.0.0
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU General Public License as
 ;; published by the Free Software Foundation; either version 2 of
 ;; the License, or (at your option) any later version.
 ;; This program is distributed in the hope that it will be
 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
 ;; PURPOSE.  See the GNU General Public License for more details.
 ;; You should have received a copy of the GNU General Public
 ;; License along with this program; if not, write to the Free
 ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
 ;; MA 02111-1307 USA
 ;;; Commentary:
 ;;
 ;; A bunch of general purpose-ish utilities used by Workgroups.
 ;;
 ;;; Code:
 (require 'workgroups-compat)
 ;;; utils used in macros
 (defmacro wg-with-gensyms (syms &rest body)
   "Bind all symbols in SYMS to `gensym's, and eval BODY."
   (declare (indent 1))
   `(let (,@(mapcar (lambda (sym) `(,sym (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)
   "Return list of N-length sublists of LIST, offset by STEP.
 N defaults to 2, and STEP defaults to N.
 Iterative to prevent stack overflow."
   (let* ((n (or n 2)) (step (or step n)) acc)
     (while list
       (push (wg-take list n) acc)
       (setq list (nthcdr step list)))
     (nreverse acc)))
 ;;; bindings
 (defmacro wg-if-let (cond-form then &rest else)
   "Bind VAR to the return value of COND.  If VAR is non-nil, do THEN.
 Else do ELSE...
 \(fn ((VAR COND) THEN ELSE...)"
   (declare (indent 2))
   `(let (,cond-form)
      (if ,(car cond-form) ,then ,@else)))
 (defmacro wg-when-let (binds &rest body)
   "Like `let*' but when all BINDS are non-nil - eval BODY."
   (declare (indent 1))
   (wg-dbind (bind . binds) binds
     (when (consp bind)
       `(let (,bind)
          (when ,(car bind)
            ,(if (not binds) `(progn ,@body)
               `(wg-when-let ,binds ,@body)))))))
 (defmacro wg-when-boundp (symbols &rest body)
   "When all SYMBOLS are bound, `eval' BODY."
   (declare (indent 1))
   `(when (and ,@(mapcar (lambda (sym) `(boundp ',sym)) symbols))
      ,@body))
 ;;; do-style wrappers
 (defmacro wg-docar (spec &rest body)
   "do-style wrapper for `mapcar'.
 \(fn (VAR LIST) BODY...)"
   (declare (indent 1))
   `(mapcar (lambda (,(car spec)) ,@body) ,(cadr spec)))
 (defmacro wg-dohash (spec &rest body)
   "do-style wrapper for `maphash'.
 \(fn (KEY VALUE TABLE [RESULT]) BODY...)"
   (declare (indent 1))
   (wg-dbind (key val table &optional result) spec
     `(progn (maphash (lambda (,key ,val) ,@body) ,table) ,result)))
 (defmacro wg-doconcat (spec &rest body)
   "do-style wrapper for `mapconcat'.
 \(fn (VAR SEQ [SEPARATOR]) BODY...)"
   (declare (indent 1))
   (wg-dbind (elt seq &optional sep) spec
     `(mapconcat (lambda (,elt) ,@body) ,seq (or ,sep ""))))
 ;;; anaphora
 (defmacro wg-aif (test then &rest else)
   "Anaphoric `if'."
   (declare (indent 2))
   `(let ((it ,test)) (if it ,then ,@else)))
 (defmacro wg-awhen (test &rest body)
   "Anaphoric `when'."
   (declare (indent 1))
   `(wg-aif ,test (progn ,@body)))
 (defmacro wg-acond (&rest clauses)
   "Anaphoric `cond'."
   (when clauses
     (wg-dbind ((condition . body) . rest) clauses
       `(wg-aif ,condition (progn ,@body)
          (wg-acond ,@rest)))))
 (defmacro wg-aand (&rest args)
   "Anaphoric `and'."
   (cond ((null args) t)
         ((null (cdr args)) (car args))
         (t `(wg-aif ,(car args) (aand ,@(cdr args))))))
 (defmacro wg-asetf (&rest places-and-values)
   "Anaphoric `setf'."
   `(progn ,@(mapcar (lambda (pv) `(let ((it ,(car pv))) (setf ,@pv)))
                     (wg-partition places-and-values 2))))
 ;;; other control structures
 (defmacro wg-until (test &rest body)
   "`while' not."
   (declare (indent 1))
   `(while (not ,test) ,@body))
 (defmacro wg-destructuring-dolist (spec &rest body)
   "Loop over a list.
 Evaluate BODY, destructuring LIST into SPEC, then evaluate RESULT
 to get a return value, defaulting to nil.  The only hitch is that
 spec must end in dotted style, collecting the rest of the list
 into a var, like so: (a (b c) . rest)
 \(fn (SPEC LIST [RESULT]) BODY...)"
   (declare (indent 1))
   (wg-dbind (loopspec list &optional result) spec
     (let ((rest (cdr (last loopspec))))
       (wg-with-gensyms (list-sym)
         `(let ((,list-sym ,list))
            (while ,list-sym
              (wg-dbind ,loopspec ,list-sym
                ,@body
                (setq ,list-sym ,rest)))
            ,result)))))
 ;;; boolean operators
 (defmacro wg-eager-or (&rest conditions)
   "Evaluate all CONDITIONS.  Return the first non-nil return value."
   (let ((syms (mapcar (lambda (x) (cl-gensym)) conditions)))
     `(let ,(cl-mapcar 'list syms conditions)
        (or ,@syms))))
 (defmacro wg-eager-and (&rest conditions)
   "Evaluate all conditions.  If any return nil, return nil.
 Otherwise return the return value of the last condition."
   (let ((syms (mapcar (lambda (x) (cl-gensym)) conditions)))
     `(let ,(cl-mapcar 'list syms conditions)
        (and ,@syms))))
 ;;; numbers
 (defun wg-step-to (n m step)
   "Increment or decrement N toward M by STEP.
 Return M when the difference between N and M is less than STEP."
   (cond ((= n m) n)
         ((< n m) (min (+ n step) m))
         ((> n m) (max (- n step) m))))
 (defun wg-within (num lo hi &optional hi-inclusive)
   "Return t when NUM is within bounds LO and HI.
 HI-INCLUSIVE non-nil means the HI bound is inclusive."
   (and (>= num lo) (if hi-inclusive (<= num hi) (< num hi))))
 (defun wg-int-to-b36-one-digit (i)
   "Return a character in 0..9 or A..Z from I, and integer 0<=I<32.
 Cribbed from `org-id-int-to-b36-one-digit'."
   (cond ((not (wg-within i 0 36))
          (error "%s out of range" i))
         ((< i 10) (+ ?0 i))
         ((< i 36) (+ ?A i -10))))
 (defun wg-b36-to-int-one-digit (i)
   "Turn a character 0..9, A..Z, a..z into a number 0..61.
 The input I may be a character, or a single-letter string.
 Cribbed from `org-id-b36-to-int-one-digit'."
   (and (stringp i) (setq i (string-to-char i)))
   (cond ((and (>= i ?0) (<= i ?9)) (- i ?0))
         ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10))
         (t (error "Invalid b36 character"))))
 (defun wg-int-to-b36 (i &optional length)
   "Return a base 36 string from I."
   (let ((base 36) b36)
     (dflet ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36)
                       (setq i (/ i base))))
     (cl-flet ((add-digit () (push (wg-int-to-b36-one-digit (mod i base)) b36)
                          (setq i (/ i base))))
       (add-digit)
       (while (> i 0) (add-digit))
       (setq b36 (cl-map 'string 'identity b36))
       (if (not length) b36
         (concat (make-string (max 0 (- length (length b36))) ?0) b36)))))
 (defun wg-b36-to-int (str)
   "Convert STR, a base-36 string, into the corresponding integer.
 Cribbed from `org-id-b36-to-int'."
   (let ((result 0))
     (mapc (lambda (i)
             (setq result (+ (* result 36)
                             (wg-b36-to-int-one-digit i))))
           str)
     result))
 ;;; lists
 (defmacro wg-removef-p (item seq-place &rest keys)
   "If ITEM is a `member*' of SEQ-PLACE, remove it from SEQ-PLACE and return t.
 Otherwise return nil.  KEYS can be any keywords accepted by `remove*'."
   `(> (length ,seq-place)
       (length (setf ,seq-place (cl-remove ,item ,seq-place ,@keys)))))
 (defmacro wg-pushnew-p (item seq-place &rest keys)
   "If ITEM is not a `member' of SEQ-PLACE, push it to SEQ-PLACE and return t.
 Otherwise return nil.  KEYS can be any keyword args accepted by `pushnew'."
   `(< (length ,seq-place)
       (length (cl-pushnew ,item ,seq-place ,@keys))))
 (defun wg-last1 (list)
   "Return the last element of LIST."
   (car (last list)))
 (defun wg-take (list n)
   "Return a list of the first N elts in LIST."
   (butlast list (- (length list) n)))
 (defun wg-leave (list n)
   "Return a list of the last N elts in LIST."
   (nthcdr (- (length list) n) list))
 (defun wg-rnth (n list)
   "Return the Nth element of LIST, counting from the end."
   (nth (- (length list) n 1) list))
 (defun wg-take-until-fail (pred list)
   "Take elements from LIST up to the first element on which PRED fails."
   (let (taken)
     (catch 'result
       (dolist (elt list (nreverse taken))
         (if (funcall pred elt) (push elt taken)
           (throw 'result (nreverse taken)))))))
 (defun wg-range (start end)
   "Return a list of integers from START up to but not including END."
   (let (accum)
     (dotimes (i (- end start) (nreverse accum))
       (push (+ start i) accum))))
 (defun wg-rotate-list (list &optional offset)
   "Rotate LIST by OFFSET.  Positive OFFSET rotates left, negative right."
   (when list
     (let ((split (mod (or offset 1) (length list))))
       (append (nthcdr split list) (wg-take list split)))))
 (defun wg-center-rotate-list (list)
   "Rotate LIST so it's first elt is in the center.  When LIST's
 length is even, the first elt is left nearer the front."
   (wg-rotate-list list (- (/ (1- (length list)) 2))))
 (defun wg-insert-after (elt list index)
   "Insert ELT into LIST after INDEX."
   (let ((new-list (cl-copy-list list)))
     (push elt (cdr (nthcdr index new-list)))
     new-list))
 (defun wg-insert-before (elt list index)
   "Insert ELT into LIST before INDEX."
   (if (zerop index) (cons elt list)
     (wg-insert-after elt list (1- index))))
 (defun wg-move-elt (elt list index &rest keys)
   "Move ELT before INDEX in LIST.
 KEYS is passed to `remove*'."
   (wg-insert-before elt (apply 'cl-remove elt list keys) index))
 (defun wg-cyclic-nth (list n)
   "Return the Nth element of LIST, modded by the length of list."
   (nth (mod n (length list)) list))
 (defun wg-cyclic-offset-elt (elt list n)
   "Cyclically offset ELT's position in LIST by N."
   (wg-when-let ((pos (cl-position elt list)))
     (wg-move-elt elt list (mod (+ n pos) (length list)))))
 (defun wg-cyclic-nth-from-elt (elt list n &rest keys)
   "Return the elt in LIST N places cyclically from ELT.
 If ELT is not present is LIST, return nil.
 KEYS is passed to `position'."
   (wg-when-let ((pos (apply 'cl-position elt list keys)))
     (wg-cyclic-nth list (+ pos n))))
 (defun wg-util-swap (elt1 elt2 list)
   "Return a copy of LIST with ELT1 and ELT2 swapped.
 Return nil when ELT1 and ELT2 aren't both present."
   (wg-when-let ((p1 (cl-position elt1 list))
                 (p2 (cl-position elt2 list)))
     (wg-move-elt elt1 (wg-move-elt elt2 list p1) p2)))
 (defun wg-dups-p (list &rest keys)
   "Return non-nil when LIST contains duplicate elements.
 Keywords supported: :test :key
 \(fn LIST [KEYWORD VALUE]...)"
   (let ((test (or (plist-get keys :test) 'eq))
         (key (or (plist-get keys :key) 'identity)))
     (cl-loop for (elt . rest) on list
              for elt = (funcall key elt)
              when (cl-find elt rest :test test :key key) return elt)))
 (defun wg-string-list-union (&optional list1 list2)
   "Return the `union' of LIST1 and LIST2, using `string=' as the test.
 This only exists to get rid of duplicate lambdas in a few reductions."
   (cl-union list1 list2 :test 'string=))
 ;;; alists
 (defun wg-make-alist (&rest kvps)
   "Return a new alist from KVPS."
   (let (alist)
     (while kvps
       (push (cons (car kvps) (cadr kvps)) alist)
       (setq kvps (cddr kvps)))
     (nreverse alist)))
 (defun wg-aget (alist key &optional default)
   "Return the value of KEY in ALIST. Uses `assq'.
 If PARAM is not found, return DEFAULT which defaults to nil."
   (wg-aif (assq key alist) (cdr it) default))
 (defun wg-acopy (alist)
   "Return a copy of ALIST's toplevel list structure."
   (mapcar (lambda (kvp) (cons (car kvp) (cdr kvp))) alist))
 (defun wg-aput (alist key value)
   "Return a new alist from ALIST with KEY's value set to VALUE."
   (let* ((found nil)
          (new (wg-docar (kvp alist)
                 (if (not (eq key (car kvp))) kvp
                   (setq found (cons key value))))))
     (if found new (cons (cons key value) new))))
 (defun wg-aremove (alist key)
   "`remove' KEY's key-value-pair from ALIST."
   (remove (assoc key alist) alist))
 (defmacro wg-abind (alist binds &rest body)
   "Bind values in ALIST to symbols in BINDS, then eval BODY.
 If an elt of BINDS is a symbol, use it as both the bound variable
 and the key in ALIST.  If it is a cons, use the car as the bound
 variable, and the cadr as the key."
   (declare (indent 2))
   (wg-with-gensyms (asym)
     `(let* ((,asym ,alist)
             ,@(wg-docar (bind binds)
                 (let ((c (consp bind)))
                   `(,(if c (car bind) bind)
                     (wg-aget ,asym ',(if c (cadr bind) bind))))))
        ,@body)))
 ;;; hash-tables
 (defun wg-fill-hash-table (table &rest key-value-pairs)
   "Fill TABLE with KEY-VALUE-PAIRS and return TABLE."
   (while key-value-pairs
     (puthash (car key-value-pairs) (cadr key-value-pairs) table)
     (setq key-value-pairs (cddr key-value-pairs)))
   table)
 ;;; symbols and strings
 (defun wg-toggle (symbol)
   "Toggle SYMBOL's truthiness."
   (set symbol (not (symbol-value symbol))))
 (defun wg-symcat (&rest symbols-and-strings)
   "Return a new interned symbol by concatenating SYMBOLS-AND-STRINGS."
   (intern (mapconcat (lambda (obj) (if (symbolp obj) (symbol-name obj) obj))
                      symbols-and-strings "")))
 (defun wg-make-string (times string &optional separator)
   "Like `make-string', but includes a separator."
   (mapconcat 'identity (make-list times string) (or separator "")))
 ;;; buffers
 (defun wg-get-buffer (buffer-or-name)
   "Return BUFFER-OR-NAME's buffer, or error."
   (or (get-buffer buffer-or-name)
       (error "%S does not identify a buffer" buffer-or-name)))
 (defun wg-buffer-name (buffer-or-name)
   "Return BUFFER-OR-NAME's `buffer-name', or error."
   (buffer-name (wg-get-buffer buffer-or-name)))
 (defun wg-buffer-file-name (buffer-or-name)
   "Return BUFFER-OR-NAME's `buffer-file-name', or error."
   (buffer-file-name (wg-get-buffer buffer-or-name)))
 (defun wg-buffer-major-mode (buffer-or-name)
   "Return BUFFER's major-mode."
   (with-current-buffer buffer-or-name major-mode))
 (defun wg-current-buffer-p (buffer-or-name)
   "Return t if BUFFER-OR-NAME is the current buffer, nil otherwise."
   (eq (wg-get-buffer buffer-or-name) (current-buffer)))
 (defmacro wg-buffer-local-setq (buffer var value)
   "`setq' VAR to VALUE while BUFFER is current.
 Note that this won't make VAR buffer-local if it isn't already."
   `(with-current-buffer ,buffer (setq ,var ,value)))
 (defun wg-interesting-buffers ()
   "Return a list of only the interesting buffers in `buffer-list'."
   (cl-remove-if (lambda (bname) (string-match "^ " bname))
                 (buffer-list) :key 'buffer-name))
 (defun wg-get-first-buffer-matching-regexp (regexp &optional buffer-list)
   "Return the first buffer in BUFFER-LIST with a name matching REGEXP.
 BUFFER-LIST should contain buffer objects and/or buffer names."
   (cl-find regexp (or buffer-list (buffer-list))
            :test 'string-match :key 'wg-buffer-name))
 ;;; files
 (defun wg-write-sexp-to-file (sexp file)
   "Write the printable representation of SEXP to FILE."
   (with-temp-buffer
     (let ((print-level nil)  (print-length nil))
       (insert (format "%S" sexp)))
     (write-file file)))
 (defun wg-read-sexp-from-file (file)
   "Return a Lisp object from FILE."
   (with-temp-buffer
     (insert-file-contents file)
     (goto-char (point-min))
     (read (current-buffer))))
 (defalias 'wg-lisp-object-from-file 'wg-read-sexp-from-file)
 (defun wg-file-under-root-path-p (root-path file-path)
   "Return t when FILE-PATH is under ROOT-PATH, nil otherwise."
   (string-match (concat "^" (regexp-quote (expand-file-name root-path)))
                 (expand-file-name file-path)))
 ;;; frames
 (defun wg-cyclic-nth-from-frame (&optional n frame)
   "Return the frame N places away from FRAME in `frame-list' cyclically.
 N defaults to 1, and FRAME defaults to `selected-frame'."
   (wg-cyclic-nth-from-elt
    (or frame (selected-frame)) (frame-list) (or n 1)))
 ;;; namespace-prefixed defstruct
 (defmacro wg-defstruct (prefix name-form &rest slot-defs)
   "`defstruct' wrapper that namespace-prefixes all generated functions.
 Note: this doesn't yet work with :conc-name, and possibly other
 options."
   (declare (indent 2))
   (let* ((name (if (consp name-form) (car name-form) name-form))
          (prefixed-name (wg-symcat prefix "-" name)))
     (dflet ((rebind (opstr)
                    (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name)))
                      `((fset ',(wg-symcat prefix "-" opstr "-" name)
                              (symbol-function ',oldfnsym))
                        (fmakunbound ',oldfnsym)))))
     (cl-flet ((rebind (opstr)
                       (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name)))
                         `((fset ',(wg-symcat prefix "-" opstr "-" name)
                                 (symbol-function ',oldfnsym))
                           (fmakunbound ',oldfnsym)))))
       ;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not
       ;; known to be defined").  We can accomplish this with `declare-function'
       ;; too, but it annoyingly requires inclusion of the function's arglist,
       ;; which gets ugly.
       `(eval-and-compile
          (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-minibuffer-inactive-p ()
   "Return t when `minibuffer-depth' returns zero, nil otherwise."
   (zerop (minibuffer-depth)))
 (defun wg-minibuffer-active-p ()
   "Return t when `minibuffer-depth' does not return zero, nil otherwise."
   (not (wg-minibuffer-inactive-p)))
 (defun wg-fill-keymap (keymap &rest binds)
   "Return KEYMAP after defining in it all keybindings in BINDS."
   (while binds
     (define-key keymap (car binds) (cadr binds))
     (setq binds (cddr binds)))
   keymap)
 (defun wg-add-or-remove-hooks (remove &rest pairs)
   "Add FUNCTION to or remove it from HOOK, depending on REMOVE."
   (dolist (pair (wg-partition pairs 2))
     (funcall (if remove 'remove-hook 'add-hook)
              (car pair) (cadr pair))))
 (defun wg-read-object (prompt test warning &optional initial-contents keymap
                               read hist default-value inherit-input-method)
   "PROMPT for an object that satisfies TEST, WARNING if necessary.
 ARGS are `read-from-minibuffer's args, after PROMPT."
   (dflet ((read () (read-from-minibuffer
                     prompt initial-contents keymap read hist
                     default-value inherit-input-method)))
   (cl-flet ((read () (read-from-minibuffer
                       prompt initial-contents keymap read hist
                       default-value inherit-input-method)))
     (let ((obj (read)))
       (when (and (equal obj "") default-value) (setq obj default-value))
       (while (not (funcall test obj))
         (message warning)
         (sit-for wg-minibuffer-message-timeout)
         (setq obj (read)))
       obj)))
 (defvar wg-readable-types
   '(integer float cons symbol vector string char-table bool-vector)
   "List of types with readable printed representations.")
 (defun wg-is-readable-p (obj)
   "Return non-nil if OBJ's printed representation is readable."
   (memq (type-of obj) wg-readable-types))
 (defun wg-take-until-unreadable (list)
   "Return a new list of elements of LIST up to the first unreadable element."
   (wg-take-until-fail 'wg-is-readable-p list))
 (defun wg-add-face (facekey string)
   "Return a copy of STRING fontified according to FACEKEY.
 FACEKEY must be a key in `wg-face-abbrevs'."
   (let ((face (wg-aget wg-face-abbrevs facekey))
         (string  (copy-sequence string)))
     (unless face (error "No face with key %s" facekey))
     (if (not wg-use-faces) string
       (put-text-property 0 (length string) 'face face string)
       string)))
 (defmacro wg-fontify (&rest specs)
   "A small fontification DSL.
 The results of all SPECS are `concat'd together.
 If a spec is a cons with a keyword car, apply `wg-add-face' to it.
 Other conses get evaluated, and should produce a strings.
 If a spec is a string it is used unmodified.
 Anything else is formatted with %s to produce a string."
   (declare (indent defun))
   `(concat
     ,@(wg-docar (spec specs)
         (cond ((and (consp spec)
                     (keywordp (car spec)))
                `(wg-add-face ,@spec))
               ;;((listp spec) (cdr (eval spec)))
               ;;((listp spec)
               ;; ;;(prin1-to-string (nth 1 (eval spec)))
               ;; )
               ((consp spec) spec)
               ((stringp spec) spec)
               (t `(format "%s" ,spec))))))
 (defun wg-barf-on-active-minibuffer ()
   "Throw an error when the minibuffer is active."
   (when (wg-minibuffer-active-p)
     (error "Workgroup operations aren't permitted while the \
 minibuffer is active")))
 (defmacro wg-set-parameter (place parameter value)
   "Set PARAMETER to VALUE at PLACE.
 This needs to be a macro to allow specification of a setf'able place."
   (wg-with-gensyms (p v)
     `(let ((,p ,parameter) (,v ,value))
        (wg-pickelable-or-error ,p)
        (wg-pickelable-or-error ,v)
        (setf ,place (wg-aput ,place ,p ,v))
        ,v)))
 ;;; uid utils
 (defun wg-time-to-b36 (&optional time)
   "Convert `current-time' into a b36 string."
   (apply 'concat (wg-docar (time (or time (current-time)))
                    (wg-int-to-b36 time 4))))
 (defun wg-b36-to-time (b36)
   "Parse the time from UID."
   (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)))
 (provide 'workgroups-utils-basic)
 ;;; workgroups-utils-basic.el ends here

0 comments (0 inline, 0 general)