タブをカラフルにする（tabbar.el）

tabbar.el (ver 1.3) の改造，まさかの三日目です．上手くいくとこんな感じになります．

以下はバッファ名が*hoge*，hoge.el，hoge.texとなるとき，あるいはdired-modeのときに色を変える例です．

Faces

faceは条件ごとにunselected，selectedの２つが必要になります，面倒なのでマクロを組んで定義します．

(defmacro my-tabbar-define-unselected-face (name &rest attributes)
  "Utility function to create the face `my-tabbar-unselected-NAME-face'."
  (declare (indent 1))
  `(defface ,(intern (format "my-tabbar-unselected-%s-face" name))
     '((t (:inherit tabbar-unselected-face ,@attributes)))
     nil :group 'tabbar))

(defmacro my-tabbar-define-selected-face (name &rest attributes)
  "Utility function to create the face `my-tabbar-selected-NAME-face'."
  (declare (indent 1))
  `(defface ,(intern (format "my-tabbar-selected-%s-face" name))
     '((t (:inherit tabbar-selected-face ,@attributes)))
     nil :group 'tabbar))

(my-tabbar-define-unselected-face buffer
  :background "navy"
  :foreground "gray")

(my-tabbar-define-selected-face buffer
  :background "navy"
  :foreground "gold")

(my-tabbar-define-unselected-face elisp
  :background "firebrick"
  :foreground "gray")

(my-tabbar-define-selected-face elisp
  :background "firebrick"
  :foreground "gold")

(my-tabbar-define-unselected-face tex
  :background "darkgreen"
  :foreground "gray")

(my-tabbar-define-selected-face tex
  :background "darkgreen"
  :foreground "gold")

(my-tabbar-define-unselected-face dired
  :background "purple"
  :foreground "gray")

(my-tabbar-define-selected-face dired
  :background "purple"
  :foreground "gold")

Conditions

タブを受け取り，判別式を通してfaceを返します．一番下が本体の判別式です．

;; tab => conditions => face

(require 'cl)

(defun buffer-local-value-safe (variable &optional buffer-or-name)
  "Return the value of VARIABLE in a current buffer (or in the buffer
BUFFER-OR-NAME). Or else, return nil."
  (when (and (symbolp variable)
             (boundp variable))
    (let ((buf (cond ((null buffer-or-name)
                      (current-buffer))
                     ((stringp buffer-or-name)
                      (get-buffer buffer-or-name))
                     ((member buffer-or-name (buffer-list))
                      buffer-or-name)
                     (t
                      nil))))
      (when buf
        (buffer-local-value variable buf)))))

(defun get-major-mode (&optional buffer-or-name)
  "Return a major-mode of current buffer (or the buffer BUFFER-OR-NAME)."
  (buffer-local-value-safe 'major-mode buffer-or-name))

(defun dired-mode-p (&optional buffer-or-name)
  "Return non-nil if a current buffer (or the buffer BUFFER-OR-NAME) is
opened as `dired-mode'. Otherwise, return nil."
  (if (eq (get-major-mode buffer-or-name) 'dired-mode) t nil))

(defvar my-tabbar-facesets
  '((buffer my-tabbar-selected-buffer-face my-tabbar-unselected-buffer-face)
    (elisp  my-tabbar-selected-elisp-face  my-tabbar-unselected-elisp-face)
    (tex    my-tabbar-selected-tex-face    my-tabbar-unselected-tex-face)
    (dired  my-tabbar-selected-dired-face  my-tabbar-unselected-dired-face)
    (etc    tabbar-selected-face           tabbar-unselected-face))
  "AList of symbols for `tabbar-mode'. Each list must be the form
\(KEY SELECTED-FACE UNSELECTED-FACE).")

(defun my-tabbar-select-face-fn (tab tabset)
  "Select face by buffer name or major-mode, then return selected one."
  (let ((name (car tab))
        suffix faceset)
    (labels ((whichface (key)
                        (setq faceset (cdr (assq key my-tabbar-facesets)))
                        (if (tabbar-selected-p tab tabset)
                            (car faceset)
                          (cadr faceset)))
             (dired-etc ()
                        (if (dired-mode-p name)
                            (whichface 'dired)
                          (whichface 'etc))))
      (cond
       ((string-match "^\\*.*\\*$" name)
        (whichface 'buffer))
       ((string-match "\\.\\([^.]+\\)$" name)
        (setq suffix (match-string-no-properties 1 name))
          (cond ((string= suffix "el")
                 (whichface 'elisp))
                ((string= suffix "tex")
                 (whichface 'tex))
                (t
                 (dired-etc))))
       (t
        (dired-etc))))))

;;; 2010/11/29 Bug Fix
;;; 上のコードだとメンテが面倒なのでmy-tabbar-facesetsとmy-tabbar-select-face-fnを次のように変えてください．
;;; my-tabbar-facesetsを編集するだけで設定可能になります．
;;;
;;; ちなみに設定の仕方はこんな感じ：
;;;
;;; (push '(foo-mode nil my-tabbar-selected-foo-face my-tabbar-unselected-foo-face) my-tabbar-facesets)
;;;

(defvar my-tabbar-facesets
  '((nil             "^\\*.*\\*$" my-tabbar-selected-buffer-face my-tabbar-unselected-buffer-face) ; *foo*
    (emacs-lisp-mode nil          my-tabbar-selected-elisp-face  my-tabbar-unselected-elisp-face)
    (latex-mode      nil          my-tabbar-selected-tex-face    my-tabbar-unselected-tex-face)
    (dired-mode      nil          my-tabbar-selected-dired-face  my-tabbar-unselected-dired-face))
  "AList for `tabbar-mode'. Each list must be the form
\(MAJOR-MODE BUFFER-NAME-RE SELECTED-FACE UNSELECTED-FACE).")

(defun my-tabbar-select-face-fn (tab tabset)
  "Select face by `my-tabbar-facesets', then return selected one."
  (let* ((name (car tab))
         (mode (get-major-mode name))
         (facesets my-tabbar-facesets)
         (defaults '(tabbar-selected-face tabbar-unselected-face))
         (faceset (if (eq mode 'dired-mode)
                      (or (cddr (assq 'dired-mode facesets)) defaults)
                    (loop for (m re f1 f2) in facesets
                          when (or (eq mode m)
                                   (and (stringp re)
                                        (string-match re name)))
                          return (list f1 f2)
                          finally return defaults))))

    (if (tabbar-selected-p tab tabset)
        (car faceset)
      (cadr faceset))))

Overwriting

最後に今作った判別式をheader-line-formatを返す関数に噛ませるわけですが，そういったオプションが用意されていないようなので，tabbar-line-elementという関数を上書きしてしまいます．defaliasの行をコメントアウトするともとに戻ります．

(defun my-tabbar-line-element (tab)
  "Redefined `tabbar-line-element' for using the function
`my-tabbar-select-face-fn'. Original docstring is below.\n
Return an `header-line-format' template element from TAB.
Call `tabbar-tab-label-function' to obtain a label for TAB."
  (let* ((keymap (make-sparse-keymap))
         (qtab   (list 'quote tab))
         (select (tabbar-make-select-tab-command qtab))
         (help   (tabbar-make-help-on-tab-function qtab))
         (label  (if tabbar-tab-label-function
                     (funcall tabbar-tab-label-function tab)
                   tab)))
    ;; Call `tabbar-select-tab-function' on mouse events.
    (define-key keymap [header-line down-mouse-1] 'ignore)
    (define-key keymap [header-line mouse-1] select)
    (define-key keymap [header-line down-mouse-2] 'ignore)
    (define-key keymap [header-line mouse-2] select)
    (define-key keymap [header-line down-mouse-3] 'ignore)
    (define-key keymap [header-line mouse-3] select)
    ;; Return the tab followed by a separator.
    (list (propertize label 'local-map keymap 'help-echo help
                      'face (my-tabbar-select-face-fn ; <= modified
                             tab (tabbar-current-tabset)))
          tabbar-separator-value)))

(defalias 'tabbar-line-element 'my-tabbar-line-element)

以上です．

Memo

ソースはだいたいこんな感じになってる．

(let* ((tabset (tabbar-current-tabset t))    ; => Buffers
       (tab    (tabbar-selected-tab tabset)) ; => ("*scratch*" . Buffers)
       (label  (if tabbar-tab-label-function
                   (funcall tabbar-tab-label-function tab)
                 tab)))
  (insert label))                       ; => " *scratch* "