emacs/nxhtml/util/vline.el

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