auto-install/vline.el

   1 ;;; vline.el --- show vertical line (column highlighting) mode.
   2
   3 ;; Copyright (C) 2002, 2008, 2009, 2010 by Taiki SUGAWARA <buzz.taiki@gmail.com>
   4
   5 ;; Author: Taiki SUGAWARA <buzz.taiki@gmail.com>
   6 ;; Keywords: faces, editing, emulating
   7 ;; Version: 1.10
   8 ;; Time-stamp: <2010-02-02 19:37:18 UTC taiki>
   9 ;; URL: http://www.emacswiki.org/cgi-bin/wiki/vline.el
  10 ;; URL: http://bitbucket.org/buzztaiki/elisp/src/tip/vline.el
  11
  12 ;; This file is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; This file is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  24 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Usage
  28 ;; put followings your .emacs
  29 ;;   (require 'vline)
  30 ;;
  31 ;; if you display a vertical line, type M-x vline-mode. `vline-mode' doesn't
  32 ;; effect other buffers, because it is a buffer local minor mode. if you hide
  33 ;; a vertical line, type M-x vline-mode again.
  34 ;;
  35 ;; if you display a vertical line in all buffers, type M-x vline-global-mode.
  36 ;;
  37 ;; `vline-style' provides a display style of vertical line. see
  38 ;; `vline-style' docstring.
  39 ;;
  40 ;; if you don't want to visual line highlighting (ex. for performance
  41 ;; issue), please to set `vline-visual' to nil.
  42 ;;
  43 ;; if you don't want to use timer (ex. you want to highlight column
  44 ;; during moving cursors), please to set `vline-use-timer' to nil.
  45
  46 ;;; Changes
  47 ;; 2010-02-02 taiki
  48 ;; improve performance.
  49
  50 ;; 2009-08-26 taiki
  51 ;; support org-mode, outline-mode
  52
  53 ;; 2009-08-18 taiki
  54 ;; add autoload cookies.
  55
  56 ;; 2009-08-18 taiki
  57 ;; fix last line highlighting probrem.
  58
  59 ;; 2009-08-18 taiki
  60 ;; support visual line highlighting.
  61 ;; - Added face vline-visual.
  62 ;; - Added defcustom vline-visual-face.
  63 ;; - Added defcustom vline-visual.
  64 ;;
  65 ;; 2009-08-17 taiki
  66 ;; fix continuas line problem.
  67 ;; - Don't display vline when cursor into fringe
  68 ;; - Don't expand eol more than window width.
  69 ;;
  70 ;; 2008-10-22 taiki
  71 ;; fix coding-system problem.
  72 ;; - Added vline-multiwidth-space-list
  73 ;; - Use ucs code-point for japanese fullwidth space.
  74 ;;
  75 ;; 2008-01-22 taiki
  76 ;; applied patch from Lennart Borgman
  77 ;; - Added :group 'vline
  78 ;; - Added defcustom vline-current-window-only
  79 ;; - Added header items to simplify for users
  80
  81 ;;; TODO:
  82 ;; - track window-scroll-functions, window-size-change-functions.
  83 ;; - consider other minor modes (using {after,before}-string overlay).
  84 ;; - don't use {post,after}-command-hook for performance??
  85
  86 ;;; Code:
  87
  88 (defvar vline-overlay-table-size 200)
  89 (defvar vline-overlay-table (make-vector vline-overlay-table-size nil))
  90 (defvar vline-line-char ?|)
  91 (defvar vline-multiwidth-space-list
  92   (list
  93    ?\t
  94    (decode-char 'ucs #x3000)            ; japanese fullwidth space
  95    ))
  96 (defvar vline-timer nil)
  97
  98 (defcustom vline-style 'face
  99   "This variable holds vertical line display style.
 100 Available values are followings:
 101 `face'      : use face.
 102 `compose'   : use composit char.
 103 `mixed'     : use face and composit char."
 104   :type '(radio
 105           (const face)
 106           (const compose)
 107           (const mixed))
 108   :group 'vline)
 109
 110
 111 (defface vline
 112   '((t (:background "light steel blue")))
 113   "A default face for vertical line highlighting."
 114   :group 'vline)
 115
 116 (defface vline-visual
 117   '((t (:background "gray90")))
 118   "A default face for vertical line highlighting in visual lines."
 119   :group 'vline)
 120
 121 (defcustom vline-face 'vline
 122   "A face for vertical line highlighting."
 123   :type 'face
 124   :group 'vline)
 125
 126 (defcustom vline-visual-face 'vline-visual
 127   "A face for vertical line highlighting in visual lines."
 128   :type 'face
 129   :group 'vline)
 130
 131 (defcustom vline-current-window-only nil
 132   "If non-nil then highlight column in current window only.
 133 If the buffer is shown in several windows then highlight column only
 134 in the currently selected window."
 135   :type 'boolean
 136   :group 'vline)
 137
 138 (defcustom vline-visual t
 139   "If non-nil then highlight column in visual lines.
 140 If you specified `force' then use force visual line highlighting even
 141 if `truncate-lines' is non-nil."
 142   :type '(radio
 143           (const nil)
 144           (const t)
 145           (const force))
 146   :group 'vline)
 147
 148 (defcustom vline-use-timer t
 149   "If non-nil then vline use idle timer instead
 150 of (post|after)-command-hook."
 151   :type 'boolean
 152   :group 'vline)
 153
 154 (defcustom vline-idle-time 0.02
 155   "Idle time for highlighting column."
 156   :type 'number
 157   :group 'vline)
 158
 159 ;;;###autoload
 160 (define-minor-mode vline-mode
 161   "Display vertical line mode."
 162   :global nil
 163   :lighter " VL"
 164   :group 'vline
 165   (if vline-mode
 166       (progn
 167         (add-hook 'pre-command-hook 'vline-pre-command-hook nil t)
 168         (if vline-use-timer
 169             (vline-set-timer)
 170           (add-hook 'post-command-hook 'vline-post-command-hook nil t)))
 171     (vline-cancel-timer)
 172     (vline-clear)
 173     (remove-hook 'pre-command-hook 'vline-pre-command-hook t)
 174     (remove-hook 'post-command-hook 'vline-post-command-hook t)))
 175
 176 ;;;###autoload
 177 (define-global-minor-mode vline-global-mode
 178   vline-mode
 179   (lambda ()
 180     (unless (minibufferp)
 181       (vline-mode 1)))
 182   :group 'vline)
 183
 184 (defun vline-pre-command-hook ()
 185   (when (and vline-mode (not (minibufferp)))
 186     (vline-clear)))
 187
 188 (defun vline-post-command-hook ()
 189   (when (and vline-mode (not (minibufferp)))
 190     (vline-show)))
 191
 192 (defun vline-set-timer ()
 193   (setq vline-timer
 194         (run-with-idle-timer
 195          vline-idle-time t 'vline-timer-callback)))
 196
 197 (defun vline-cancel-timer ()
 198   (when (timerp vline-timer)
 199     (cancel-timer vline-timer)))
 200
 201 (defun vline-timer-callback ()
 202   (when (and vline-mode (not (minibufferp)))
 203     (vline-show)))
 204
 205 (defun vline-clear ()
 206   (mapcar (lambda (ovr)
 207             (and ovr (delete-overlay ovr)))
 208           vline-overlay-table))
 209
 210 (defsubst vline-into-fringe-p ()
 211   (eq (nth 1 (posn-at-point)) 'right-fringe))
 212
 213 (defsubst vline-visual-p ()
 214   (or (eq vline-visual 'force)
 215       (and (not truncate-lines)
 216            vline-visual)))
 217
 218 (defsubst vline-current-column ()
 219   (if (or (not (vline-visual-p))
 220           ;; margin for full-width char
 221           (< (1+ (current-column)) (window-width)))
 222       (current-column)
 223     ;; hmm.. posn-at-point is not consider tab width.
 224     (- (current-column)
 225        (save-excursion
 226          (vertical-motion 0)
 227          (current-column)))))
 228
 229 (defsubst vline-move-to-column (col &optional bol-p)
 230   (if (or (not (vline-visual-p))
 231           ;; margin for full-width char
 232           (< (1+ (current-column)) (window-width)))
 233       (move-to-column col)
 234     (unless bol-p
 235       (vertical-motion 0))
 236     (let ((bol-col (current-column)))
 237       (- (move-to-column (+ bol-col col))
 238          bol-col))))
 239
 240 (defsubst vline-invisible-p (pos)
 241   (let ((inv (get-char-property pos 'invisible)))
 242     (and inv
 243          (or (eq buffer-invisibility-spec t)
 244              (memq inv buffer-invisibility-spec)
 245              (assq inv buffer-invisibility-spec)))))
 246
 247 (defsubst vline-forward (n)
 248   (unless (memq n '(-1 0 1))
 249     (error "n(%s) must be 0 or 1" n))
 250   (if (not (vline-visual-p))
 251       (progn
 252         (forward-line n)
 253         ;; take care of org-mode, outline-mode
 254         (when (and (not (bobp))
 255                    (vline-invisible-p (1- (point))))
 256           (goto-char (1- (point))))
 257         (when (vline-invisible-p (point))
 258           (if (< n 0)
 259               (while (and (not (bobp)) (vline-invisible-p (point)))
 260                 (goto-char (previous-char-property-change (point))))
 261             (while (and (not (bobp)) (vline-invisible-p (point)))
 262               (goto-char (next-char-property-change (point))))
 263             (forward-line 1))))
 264     (vertical-motion n)))
 265
 266 (defun vline-face (visual-p)
 267   (if visual-p
 268       vline-visual-face
 269     vline-face))
 270
 271 (defun vline-show (&optional point)
 272   (vline-clear)
 273   (save-window-excursion
 274     (save-excursion
 275       (if point
 276           (goto-char point)
 277         (setq point (point)))
 278       (let* ((column (vline-current-column))
 279              (lcolumn (current-column))
 280              (i 0)
 281              (compose-p (memq vline-style '(compose mixed)))
 282              (face-p (memq vline-style '(face mixed)))
 283              (line-char (if compose-p vline-line-char ? ))
 284              (line-str (make-string 1 line-char))
 285              (visual-line-str line-str)
 286              (in-fringe-p (vline-into-fringe-p)))
 287         (when face-p
 288           (setq line-str (propertize line-str 'face (vline-face nil)))
 289           (setq visual-line-str (propertize visual-line-str 'face (vline-face t))))
 290         (goto-char (window-end nil t))
 291         (vline-forward 0)
 292         (while (and (not in-fringe-p)
 293                     (< i (window-height))
 294                     (< i (length vline-overlay-table))
 295                     (not (bobp)))
 296           (let ((cur-column (vline-move-to-column column t))
 297                 (cur-lcolumn (current-column)))
 298             ;; non-cursor line only (workaround of eol probrem.
 299             (unless (= (point) point)
 300               ;; if column over the cursor's column (when tab or wide char is appered.
 301               (when (> cur-column column)
 302                 (let ((lcol (current-column)))
 303                   (backward-char)
 304                   (setq cur-column (- cur-column (- lcol (current-column))))))
 305               (let* ((ovr (aref vline-overlay-table i))
 306                      (visual-p (or (< lcolumn (current-column))
 307                                    (> lcolumn (+ (current-column)
 308                                                  (- column cur-column)))))
 309                      ;; consider a newline, tab and wide char.
 310                      (str (concat (make-string (- column cur-column) ? )
 311                                   (if visual-p visual-line-str line-str)))
 312                      (char (char-after)))
 313                 ;; create overlay if not found.
 314                 (unless ovr
 315                   (setq ovr (make-overlay 0 0))
 316                   (overlay-put ovr 'rear-nonsticky t)
 317                   (aset vline-overlay-table i ovr))
 318
 319                 ;; initialize overlay.
 320                 (overlay-put ovr 'face nil)
 321                 (overlay-put ovr 'before-string nil)
 322                 (overlay-put ovr 'after-string nil)
 323                 (overlay-put ovr 'invisible nil)
 324                 (overlay-put ovr 'window
 325                              (if vline-current-window-only
 326                                  (selected-window)
 327                                nil))
 328
 329                 (cond
 330                  ;; multiwidth space
 331                  ((memq char vline-multiwidth-space-list)
 332                   (setq str
 333                         (concat str
 334                                 (make-string (- (save-excursion (forward-char)
 335                                                                 (current-column))
 336                                                 (current-column)
 337                                                 (string-width str))
 338                                              ? )))
 339                   (move-overlay ovr (point) (1+ (point)))
 340                   (overlay-put ovr 'invisible t)
 341                   (overlay-put ovr 'after-string str))
 342                  ;; eol
 343                  ((eolp)
 344                   (move-overlay ovr (point) (point))
 345                   (overlay-put ovr 'after-string str)
 346                   ;; don't expand eol more than window width
 347                   (when (and (not truncate-lines)
 348                              (>= (1+ column) (window-width))
 349                              (>= column (vline-current-column))
 350                              (not (vline-into-fringe-p)))
 351                     (delete-overlay ovr)))
 352                  (t
 353                   (cond
 354                    (compose-p
 355                     (let (str)
 356                       (when char
 357                         (setq str (compose-chars
 358                                    char
 359                                    (cond ((= (char-width char) 1)
 360                                           '(tc . tc))
 361                                          ((= cur-column column)
 362                                           '(tc . tr))
 363                                          (t
 364                                           '(tc . tl)))
 365                                    line-char))
 366                         (when face-p
 367                           (setq str (propertize str 'face (vline-face visual-p))))
 368                         (move-overlay ovr (point) (1+ (point)))
 369                         (overlay-put ovr 'invisible t)
 370                         (overlay-put ovr 'after-string str))))
 371                    (face-p
 372                     (move-overlay ovr (point) (1+ (point)))
 373                     (overlay-put ovr 'face (vline-face visual-p))))))))
 374             (setq i (1+ i))
 375             (vline-forward -1)))))))
 376
 377 (provide 'vline)
 378
 379 ;;; vline.el ends here