Changeset - ec2a94810d3b
[Not reviewed]
0 2 0
Sergey Pashinin - 12 years ago 2014-03-11 21:53:12
sergey@pashinin.com
Hints to test workgroup parameters set/get
2 files changed with 6 insertions and 1 deletions:
0 comments (0 inline, 0 general)
src/workgroups-functions.el
Show inline comments
 
@@ -460,385 +460,389 @@ new wlist, return it instead of a new wtree."
 
               (max (- hb1 1 min-size))
 
               (lastw (wg-last1 wlist)))
 
          (cl-labels
 
              ((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."
 
  (cl-labels
 
      ((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."
 
  (cl-labels
 
      ((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."
 
  (cl-labels
 
      ((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
 

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

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

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

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

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

	
 

	
 
;;; workgroup 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)))
src/workgroups-structs.el
Show inline comments
 
;;; workgroups-structs.el --- Data structures for WG
 
;;; Commentary:
 
;;
 
;; Copyright (C) Sergey Pashinin
 
;; Author: Sergey Pashinin <sergey@pashinin.com>
 
;;
 
;; `wg-defstruct'
 
;;
 
;; It creates some functions named like "wg-buf-...", "wg-session-..."
 
;;
 
;; To get a value you can use:
 
;; (wg-session-... (wg-current-session))
 
;; Like:
 
;; (wg-session-file-name (wg-current-session))
 
;; (wg-workgroup-parameters (wg-current-workgroup))
 
;;
 
;; To set a value (in `wg-write-session-file'):
 
;;
 
;; (setf (wg-session-file-name (wg-current-session)) filename)
 
;;
 
;;; Code:
 

	
 
(require 'workgroups-utils-basic)
 

	
 
(wg-defstruct wg buf
 
  (uid (wg-generate-uid))
 
  (name)
 
  (file-name)
 
  (point)
 
  (mark)
 
  (local-vars)
 
  (special-data)
 
  ;; This may be used later:
 
  (gc))
 

	
 
(wg-defstruct wg win
 
  (uid)
 
  (parameters)
 
  (edges)
 
  (point)
 
  (start)
 
  (hscroll)
 
  (dedicated)
 
  (selected)
 
  (minibuffer-scroll)
 
  (buf-uid))
 

	
 
(wg-defstruct wg wtree
 
  (uid)
 
  (dir)
 
  (edges)
 
  (wlist))
 

	
 
(wg-defstruct wg wconfig
 
  (uid (wg-generate-uid))
 
  (name)
 
  (parameters)
 
  (left)
 
  (top)
 
  (width)
 
  (height)
 
  (vertical-scroll-bars)
 
  (scroll-bar-width)
 
  (wtree)
 
  ;;(fullscreen)
 
  )
 
;; wg-wconfig
 

	
 
(wg-defstruct wg workgroup
 
  (uid (wg-generate-uid))
 
  (name)
 
  (modified)
 
  (parameters)
 
  (base-wconfig)
 
  (selected-frame-wconfig)
 
  (saved-wconfigs)
 
  (strong-buf-uids)
 
  (weak-buf-uids))
 

	
 
(wg-defstruct wg session
 
  (uid (wg-generate-uid))
 
  (name)
 
  (modified)
 
  (parameters)
 
  (file-name)
 
  (version wg-version)
 
  (workgroup-list)
 
  (buf-list))
 

	
 
(wg-defstruct wg workgroup-state
 
  (undo-pointer)
 
  (undo-list))
 

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