Re: highlight current line when Emacs is idle

[Masatake YAMATO]

(I know we are in pretest stage.)

> A follow-on to that follow-on: Perhaps optionally highlight the current
> column as well.

How about this one?

;;; hl-column.el --- highlight the current column

;; Copyright 2004 2005 Masatake YAMATO
;;
;; Author: Masatake YAMATO<address@hidden>
;; Keywords:
;; X-URL: not distributed yet

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;;  This is the column version of hl-line.el.
;;
;; Put this file into your load-path and the following into your ~/.emacs:
;;   (require 'hl-column)
;; then
;;   M-x hl-column-mode
;;
;; Next key binding is optional.
;;   (define-key global-map "\C-x|" 'hl-column-highlight)
;;
;; TODO
;; - Stocking the overlays

;;; Code:

(provide 'hl-column)
(eval-when-compile
  (require 'cl))


;;;;##########################################################################
;;;;  User Options, Variables
;;;;##########################################################################
(defgroup hl-column nil
  "Highlight the current column."
  :group 'editing)

(defcustom hl-column-face 'highlight
  "Face with which to highlight the current column."
  :type 'face
  :group 'hl-column)

(defcustom hl-column-string nil
  "String to indicate the current column."
  :type '(choice (const  :tag "No overlay string" nil)
                 (const  :tag "Bar"               "|")
                 (string))
  :group 'hl-column)

(defcustom hl-column-accept-tab t
  "Highlight tab character or not.
Generally tab character takes wider area than the other."
  :type 'boolean
  :group 'hl-column)

;;;;##########################################################################
;;;;  Functions
;;;;##########################################################################
        
;; Requirement
;; line-number-at-pos
;; line-move-to-column

(defun hl-column-highlight (&optional column)
  "Highlight the current columns."
  (interactive "P")
  (let* ((start-line (line-number-at-pos (window-start)))
         (end-line   (line-number-at-pos (window-end)))
         (cc    (if column
                    (prefix-numeric-value column)
                  (current-column)))
         (goal-column cc)
         (p (point))
         l overlays overlay)
    (unwind-protect
        (progn
          (save-excursion
            (setq l (line-number-at-pos))
            (while (<= start-line l)
              (when (and
                     ;(not (zerop (current-column)))
                     (or (eq cc (current-column))
                         (and (< cc (current-column))
                              (< 1 (char-width (char-before)))
                              (prog1 t (goto-char (1- (point))))))
                     (or hl-column-accept-tab
                         (not (eq (char-after) ?\t)))
                     (not (eolp)))
                (setq overlay (make-overlay (point) (1+ (point)))
                      overlays (cons overlay overlays))
                (overlay-put overlay 'face hl-column-face)
                (when hl-column-string
                  (overlay-put overlay 'display hl-column-string)))
              (condition-case nil
                  (progn (previous-line 1)
                         (setq l (line-number-at-pos)))
                (error (setq l (1- start-line)))))
            (goto-char p)
            (while (<= (line-number-at-pos) end-line)
              (line-move-to-column cc)
              ;(move-to-column cc t)
              (when (and
                     ;(not (zerop (current-column)))
                     (or (eq cc (current-column))
                         (and (< cc (current-column))
                              (< 1 (char-width (char-before)))
                              (prog1 t (goto-char (1- (point))))))
                     (not (eq (char-after) ?\t))
                     (not (eolp)))
                (setq overlay (make-overlay (point) (1+ (point)))
                      overlays (cons overlay overlays))
                (overlay-put overlay 'face hl-column-face)
                (when hl-column-string
                    (overlay-put overlay 'display hl-column-string)))
              (when (or (< 0 (forward-line 1))
                        (eobp))
                (setq end-line -1))))
          (sit-for 99999))
      (mapc (lambda (o) (delete-overlay o)) overlays))))

(define-minor-mode hl-column-mode
  "Buffer-local minor mode to highlight the column about point."
  nil nil
  nil
  :group 'hl-column-mode
  (if hl-column-mode
      (add-hook 'post-command-hook 'hl-column-highlight nil t)
    (remove-hook 'post-command-hook 'hl-column-highlight t)))

;; arch-tag: 8d30b572-81a8-4b7b-acb5-d2f8a03ae6bf
;;; hl-column.el ends here