X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgutter-items.el;h=054aa592aa696c74da293ea5f3ef01bf753c0c9a;hb=d8bdbc5aada1ec424d172605017593ffe957b8ed;hp=b1c75dfbb85112eef682965e84588c6302656794;hpb=d8bd7eee3147c839d3c74d1823c139cd54867a75;p=chise%2Fxemacs-chise.git diff --git a/lisp/gutter-items.el b/lisp/gutter-items.el index b1c75df..054aa59 100644 --- a/lisp/gutter-items.el +++ b/lisp/gutter-items.el @@ -47,11 +47,16 @@ This option should be set through the options menu." 'buffers-tab val) (setq gutter-buffers-tab-visible-p val))) +(defcustom gutter-buffers-tab-enabled t + "*Whether to enable support for buffers tab in the gutter. +This is different to `gutter-buffers-tab-visible-p' which still runs hooks +even when the gutter is invisible." + :group 'buffers-tab + :type 'boolean) + (defvar gutter-buffers-tab-orientation 'top "Where the buffers tab currently is. Do not set this.") -(defvar gutter-buffers-tab-extent nil) - (defcustom buffers-tab-max-size 6 "*Maximum number of entries which may appear on the \"Buffers\" tab. If this is 10, then only the ten most-recently-selected buffers will be @@ -72,7 +77,7 @@ a large number or nil will slow down tab responsiveness." (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers "*If non-nil, a function specifying the buffers to omit from the buffers tab. This is passed a buffer and should return non-nil if the buffer should be -omitted. The default value `buffers-tab-omit-invisible-buffers' omits +omitted. The default value `buffers-menu-omit-invisible-buffers' omits buffers that are normally considered \"invisible\" (those whose name begins with a space)." :type '(choice (const :tag "None" nil) @@ -90,6 +95,18 @@ by `buffers-tab-grouping-regexp'." function) :group 'buffers-tab) +(defcustom buffers-tab-filter-functions (list buffers-tab-selection-function) + "*If non-nil, a list of functions specifying the buffers to select +from the buffers tab. +Each function in the list is passed two buffers, the buffer to +potentially select and the context buffer, and should return non-nil +if the first buffer should be selected. The default value groups +buffers by major mode and by `buffers-tab-grouping-regexp'." + + :type '(choice (const :tag "None" nil) + sexp) + :group 'buffers-tab) + (defcustom buffers-tab-sort-function nil "*If non-nil, a function specifying the buffers to select from the buffers tab. This is passed the buffer list and returns the list in the @@ -159,13 +176,14 @@ If this is 0, then the full buffer name will be shown." (select-window (car (windows-of-buffer buffer))) (switch-to-buffer buffer)))) -(defun select-buffers-tab-buffers-by-mode (buf1 buf2) +(defun select-buffers-tab-buffers-by-mode (buffer-to-select buf1) "For use as a value of `buffers-tab-selection-function'. This selects buffers by major mode `buffers-tab-grouping-regexp'." (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1))) - (mode2 (symbol-name (symbol-value-in-buffer 'major-mode buf2))) + (mode2 (symbol-name (symbol-value-in-buffer 'major-mode + buffer-to-select))) (modenm1 (symbol-value-in-buffer 'mode-name buf1)) - (modenm2 (symbol-value-in-buffer 'mode-name buf2))) + (modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select))) (cond ((or (eq mode1 mode2) (eq modenm1 modenm2) (and (string-match "^[^-]+-" mode1) @@ -212,32 +230,25 @@ This just returns the buffer's name, optionally truncated." (when selected (setq selected nil)))) buffers))) -;;; #### SJT I'd really like this function to have just two hooks: (1) the -;;; buffer filter list and (2) a sort function list. Both should be lists -;;; of functions. Each filter takes two arguments: a buffer and a model -;;; buffer. (The model buffer argument allows selecting according to the -;;; mode or directory of that buffer.) The filter returns t if the buffer -;;; should be listed and nil otherwise. Effectively the filter amounts to -;;; the conjuction of the filter list. (Optionally the filter could take a -;;; frame instead of a buffer or generalize to a locale as in a specifier?) -;;; The filtering is done this way to preserve the ordering imposed by -;;; `buffer-list'. In addition, the in-deletion argument will be used the -;;; same way as in the current design. -;;; The list is checked for length and pruned according to least-recently- -;;; selected. (Optionally there could be some kind of sort function here, -;;; too.) -;;; Finally the list is sorted to gutter display order, and the tab data -;;; structure is created and returned. -;;; #### Docstring isn't very well expressed. +;;; #### SJT would like this function to have a sort function list. I +;;; don't see how this could work given that sorting is not +;;; cumulative --andyp. (defun buffers-tab-items (&optional in-deletion frame force-selection) - "This is the tab filter for the top-level buffers \"Buffers\" tab. -It dynamically creates a list of buffers to use as the contents of the tab. -Only the most-recently-used few buffers will be listed on the tab, for -efficiency reasons. You can control how many buffers will be shown by -setting `buffers-tab-max-size'. You can control the text of the tab -items by redefining the function `format-buffers-menu-line'." + "Return a list of tab instantiators based on the current buffers list. +This function is used as the tab filter for the top-level buffers +\"Buffers\" tab. It dynamically creates a list of tab instantiators +to use as the contents of the tab. The contents and order of the list +is controlled by `buffers-tab-filter-functions' which by default +groups buffers according to major mode and removes invisible buffers. +You can control how many buffers will be shown by setting +`buffers-tab-max-size'. You can control the text of the tab items by +redefining the function `format-buffers-menu-line'." (save-match-data - (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame))) + ;; NB it is too late if we run the omit function as part of the + ;; filter functions because we need to know which buffer is the + ;; context buffer before they get run. + (let* ((buffers (delete-if + buffers-tab-omit-function (buffer-list frame))) (first-buf (car buffers))) ;; maybe force the selected window (when (and force-selection @@ -249,16 +260,24 @@ items by redefining the function `format-buffers-menu-line'." (when in-deletion (setq buffers (delq (current-buffer) buffers)) (setq first-buf (car buffers))) - ;; select buffers in group (default is by mode) - (when buffers-tab-selection-function - (delete-if-not #'(lambda (buf) - (funcall buffers-tab-selection-function - first-buf buf)) buffers)) + ;; filter buffers + (when buffers-tab-filter-functions + (setq buffers + (delete-if + #'null + (mapcar #'(lambda (buf) + (let ((tmp-buf buf)) + (mapc #'(lambda (fun) + (unless (funcall fun buf first-buf) + (setq tmp-buf nil))) + buffers-tab-filter-functions) + tmp-buf)) + buffers)))) ;; maybe shorten list of buffers (and (integerp buffers-tab-max-size) (> buffers-tab-max-size 1) (> (length buffers) buffers-tab-max-size) - (setcdr (nthcdr buffers-tab-max-size buffers) nil)) + (setcdr (nthcdr (1- buffers-tab-max-size) buffers) nil)) ;; sort buffers in group (default is most-recently-selected) (when buffers-tab-sort-function (setq buffers (funcall buffers-tab-sort-function buffers))) @@ -269,14 +288,11 @@ items by redefining the function `format-buffers-menu-line'." (defun add-tab-to-gutter () "Put a tab control in the gutter area to hold the most recent buffers." (setq gutter-buffers-tab-orientation (default-gutter-position)) - (let ((gutter-string (copy-sequence "\n"))) - (unless gutter-buffers-tab-extent - (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string))) - (set-extent-begin-glyph - gutter-buffers-tab-extent - (setq gutter-buffers-tab - (make-glyph))) - + (let* ((gutter-string (copy-sequence "\n")) + (gutter-buffers-tab-extent (make-extent 0 1 gutter-string))) + (set-extent-begin-glyph gutter-buffers-tab-extent + (setq gutter-buffers-tab + (make-glyph))) ;; Nuke all existing tabs (remove-gutter-element top-gutter 'buffers-tab) (remove-gutter-element bottom-gutter 'buffers-tab) @@ -298,56 +314,62 @@ items by redefining the function `format-buffers-menu-line'." ((eq gutter-buffers-tab-orientation 'left) (set-specifier left-gutter-border-width 0 'global x) (set-gutter-element left-gutter 'buffers-tab - gutter-string 'global x) - (set-specifier left-gutter-width - (glyph-width gutter-buffers-tab) - 'global x)) + gutter-string 'global x)) ((eq gutter-buffers-tab-orientation 'right) (set-specifier right-gutter-border-width 0 'global x) (set-gutter-element right-gutter 'buffers-tab - gutter-string 'global x) - (set-specifier right-gutter-width - (glyph-width gutter-buffers-tab) - 'global x)) + gutter-string 'global x)) ))) (console-type-list)))) (defun update-tab-in-gutter (frame &optional force-selection) "Update the tab control in the gutter area." ;; dedicated frames don't get tabs - (unless (window-dedicated-p (frame-selected-window frame)) + (unless (or (window-dedicated-p (frame-selected-window frame)) + (frame-property frame 'popup)) (when (specifier-instance default-gutter-visible-p frame) (unless (and gutter-buffers-tab (eq (default-gutter-position) gutter-buffers-tab-orientation)) (add-tab-to-gutter)) (when (valid-image-instantiator-format-p 'tab-control frame) - (set-glyph-image - gutter-buffers-tab - (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face - :orientation gutter-buffers-tab-orientation - (if (or (eq gutter-buffers-tab-orientation 'top) - (eq gutter-buffers-tab-orientation 'bottom)) - :pixel-width :pixel-height) - (if (or (eq gutter-buffers-tab-orientation 'top) - (eq gutter-buffers-tab-orientation 'bottom)) - '(gutter-pixel-width) '(gutter-pixel-height)) - :items (buffers-tab-items nil frame force-selection)) - frame))))) + (let ((items (buffers-tab-items nil frame force-selection))) + (when items + (set-glyph-image + gutter-buffers-tab + (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face + :orientation gutter-buffers-tab-orientation + (if (or (eq gutter-buffers-tab-orientation 'top) + (eq gutter-buffers-tab-orientation 'bottom)) + :pixel-width :pixel-height) + (if (or (eq gutter-buffers-tab-orientation 'top) + (eq gutter-buffers-tab-orientation 'bottom)) + '(gutter-pixel-width) '(gutter-pixel-height)) + :items items) + frame) + ;; set-glyph-image will not make the gutter dirty + (set-gutter-dirty-p gutter-buffers-tab-orientation))))))) ;; A myriad of different update hooks all doing slightly different things -(add-hook 'create-frame-hook - #'(lambda (frame) - (when gutter-buffers-tab (update-tab-in-gutter frame t)))) -(add-hook 'buffer-list-changed-hook 'update-tab-in-gutter) -(add-hook 'default-gutter-position-changed-hook - #'(lambda () - (when gutter-buffers-tab - (mapc #'update-tab-in-gutter (frame-list))))) -(add-hook 'gutter-element-visibility-changed-hook - #'(lambda (prop visible-p) - (when (and (eq prop 'buffers-tab) visible-p) - (mapc #'update-tab-in-gutter (frame-list))))) +(add-one-shot-hook + 'after-init-hook + #'(lambda () + ;; don't add the hooks if the user really doesn't want them + (when gutter-buffers-tab-enabled + (add-hook 'create-frame-hook + #'(lambda (frame) + (when gutter-buffers-tab (update-tab-in-gutter frame t)))) + (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter) + (add-hook 'default-gutter-position-changed-hook + #'(lambda () + (when gutter-buffers-tab + (mapc #'update-tab-in-gutter (frame-list))))) + (add-hook 'gutter-element-visibility-changed-hook + #'(lambda (prop visible-p) + (when (and (eq prop 'buffers-tab) visible-p) + (mapc #'update-tab-in-gutter (frame-list))))) + (update-tab-in-gutter (selected-frame) t)))) + ;; ;; progress display ;; ripped off from message display @@ -401,7 +423,8 @@ side-by-side." ;; 'quit is special and acts "asynchronously". :descriptor "Stop" :callback 'quit] ,progress-text-instantiator)]) - (set-glyph-image progress-layout-glyph progress-layout-instantiator locale)) + (set-glyph-image progress-layout-glyph progress-layout-instantiator + locale)) (t (setq progress-glyph-height 24) (setq progress-layout-instantiator @@ -417,7 +440,20 @@ side-by-side." :descriptor " Stop " ;; 'quit is special and acts "asynchronously". :callback 'quit])])]) - (set-glyph-image progress-layout-glyph progress-layout-instantiator locale)))) + (set-glyph-image progress-layout-glyph progress-layout-instantiator + locale)))) + +(defvar progress-abort-glyph (make-glyph)) + +(defun set-progress-abort-instantiator (&optional locale) + (set-glyph-image progress-abort-glyph + `[layout :orientation vertical :justify left + :items (,progress-text-instantiator + [layout + :margin-width 4 + :pixel-height progress-glyph-height + :orientation horizontal])] + locale)) (defvar progress-stack nil "An alist of label/string pairs representing active progress gauges. @@ -425,15 +461,6 @@ The first element in the list is currently displayed in the gutter area. Do not modify this directly--use the `progress-feedback' or `display-progress-feedback'/`clear-progress-feedback' functions.") -(defvar progress-abort-glyph - (make-glyph - `[layout :orientation vertical :justify left - :items (,progress-text-instantiator - [layout - :margin-width 4 - :pixel-height progress-glyph-height - :orientation horizontal])])) - (defun progress-feedback-displayed-p (&optional return-string frame) "Return a non-nil value if a progress gauge is presently displayed in the gutter area. If optional argument RETURN-STRING is non-nil, @@ -545,8 +572,8 @@ you should just use (progress nil)." ;; fixup the gutter specifiers (set-gutter-element bottom-gutter 'progress gutter-string frame) (set-specifier bottom-gutter-border-width 2 frame) - (set-instantiator-property progress-text-instantiator :datat message) - (set-progress-feedback-instantiator (frame-selected-window frame)) + (set-instantiator-property progress-text-instantiator :data message) + (set-progress-abort-instantiator (frame-selected-window frame)) (set-specifier bottom-gutter-height 'autodetect frame) (set-gutter-element-visible-p bottom-gutter-visible-p 'progress t frame)