(eval-when-compile
(require 'wid-edit))
(require 'scroll-bar)
(require 'fringe)
(defgroup ruler-mode nil
"Display a ruler in the header line."
:version "22.1"
:group 'convenience)
(defcustom ruler-mode-show-tab-stops nil
"*If non-nil the ruler shows tab stop positions.
Also allowing to visually change `tab-stop-list' setting using
<C-down-mouse-1> and <C-down-mouse-3> on the ruler to respectively add
or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or
<C-down-mouse-2> on the ruler toggles showing/editing of tab stops."
:group 'ruler-mode
:type 'boolean)
(defun ruler-mode-character-validate (widget)
"Ensure WIDGET value is a valid character value."
(save-excursion
(let ((value (widget-value widget)))
(if (char-valid-p value)
nil
(widget-put widget :error
(format "Invalid character value: %S" value))
widget))))
(defcustom ruler-mode-fill-column-char (if (char-displayable-p ?¶)
?\¶
?\|)
"*Character used at the `fill-column' location."
:group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
:validate ruler-mode-character-validate)))
(defcustom ruler-mode-comment-column-char ?\#
"*Character used at the `comment-column' location."
:group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
:validate ruler-mode-character-validate)))
(defcustom ruler-mode-goal-column-char ?G
"*Character used at the `goal-column' location."
:group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
:validate ruler-mode-character-validate)))
(defcustom ruler-mode-current-column-char (if (char-displayable-p ?¦)
?\¦
?\@)
"*Character used at the `current-column' location."
:group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
:validate ruler-mode-character-validate)))
(defcustom ruler-mode-tab-stop-char ?\T
"*Character used at `tab-stop-list' locations."
:group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
:validate ruler-mode-character-validate)))
(defcustom ruler-mode-basic-graduation-char ?\.
"*Character used for basic graduations."
:group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
:validate ruler-mode-character-validate)))
(defcustom ruler-mode-inter-graduation-char ?\!
"*Character used for intermediate graduations."
:group 'ruler-mode
:type '(choice
(character :tag "Character")
(integer :tag "Integer char value"
:validate ruler-mode-character-validate)))
(defcustom ruler-mode-set-goal-column-ding-flag t
"*Non-nil means do `ding' when `goal-column' is set."
:group 'ruler-mode
:type 'boolean)
(defface ruler-mode-default
'((((type tty))
(:inherit default
:background "grey64"
:foreground "grey50"
))
(t
(:inherit default
:background "grey76"
:foreground "grey64"
:box (:color "grey76"
:line-width 1
:style released-button)
)))
"Default face used by the ruler."
:group 'ruler-mode)
(defface ruler-mode-pad
'((((type tty))
(:inherit ruler-mode-default
:background "grey50"
))
(t
(:inherit ruler-mode-default
:background "grey64"
)))
"Face used to pad inactive ruler areas."
:group 'ruler-mode)
(defface ruler-mode-margins
'((t
(:inherit ruler-mode-default
:foreground "white"
)))
"Face used to highlight margin areas."
:group 'ruler-mode)
(defface ruler-mode-fringes
'((t
(:inherit ruler-mode-default
:foreground "green"
)))
"Face used to highlight fringes areas."
:group 'ruler-mode)
(defface ruler-mode-column-number
'((t
(:inherit ruler-mode-default
:foreground "black"
)))
"Face used to highlight number graduations."
:group 'ruler-mode)
(defface ruler-mode-fill-column
'((t
(:inherit ruler-mode-default
:foreground "red"
)))
"Face used to highlight the fill column character."
:group 'ruler-mode)
(defface ruler-mode-comment-column
'((t
(:inherit ruler-mode-default
:foreground "red"
)))
"Face used to highlight the comment column character."
:group 'ruler-mode)
(defface ruler-mode-goal-column
'((t
(:inherit ruler-mode-default
:foreground "red"
)))
"Face used to highlight the goal column character."
:group 'ruler-mode)
(defface ruler-mode-tab-stop
'((t
(:inherit ruler-mode-default
:foreground "steelblue"
)))
"Face used to highlight tab stop characters."
:group 'ruler-mode)
(defface ruler-mode-current-column
'((t
(:inherit ruler-mode-default
:weight bold
:foreground "yellow"
)))
"Face used to highlight the `current-column' character."
:group 'ruler-mode)
(defsubst ruler-mode-full-window-width ()
"Return the full width of the selected window."
(let ((edges (window-edges)))
(- (nth 2 edges) (nth 0 edges))))
(defsubst ruler-mode-window-col (n)
"Return a column number relative to the selected window.
N is a column number relative to selected frame."
(- n
(car (window-edges))
(or (car (window-margins)) 0)
(fringe-columns 'left)
(scroll-bar-columns 'left)))
(defun ruler-mode-mouse-set-left-margin (start-event)
"Set left margin end to the graduation where the mouse pointer is on.
START-EVENT is the mouse click event."
(interactive "e")
(let* ((start (event-start start-event))
(end (event-end start-event))
col w lm rm)
(when (eq start end) (save-selected-window
(select-window (posn-window start))
(setq col (- (car (posn-col-row start)) (car (window-edges))
(scroll-bar-columns 'left))
w (- (ruler-mode-full-window-width)
(scroll-bar-columns 'left)
(scroll-bar-columns 'right)))
(when (and (>= col 0) (< col w))
(setq lm (window-margins)
rm (or (cdr lm) 0)
lm (or (car lm) 0))
(message "Left margin set to %d (was %d)" col lm)
(set-window-margins nil col rm))))))
(defun ruler-mode-mouse-set-right-margin (start-event)
"Set right margin beginning to the graduation where the mouse pointer is on.
START-EVENT is the mouse click event."
(interactive "e")
(let* ((start (event-start start-event))
(end (event-end start-event))
col w lm rm)
(when (eq start end) (save-selected-window
(select-window (posn-window start))
(setq col (- (car (posn-col-row start)) (car (window-edges))
(scroll-bar-columns 'left))
w (- (ruler-mode-full-window-width)
(scroll-bar-columns 'left)
(scroll-bar-columns 'right)))
(when (and (>= col 0) (< col w))
(setq lm (window-margins)
rm (or (cdr lm) 0)
lm (or (car lm) 0)
col (- w col 1))
(message "Right margin set to %d (was %d)" col rm)
(set-window-margins nil lm col))))))
(defvar ruler-mode-dragged-symbol nil
"Column symbol dragged in the ruler.
That is `fill-column', `comment-column', `goal-column', or nil when
nothing is dragged.")
(defun ruler-mode-mouse-grab-any-column (start-event)
"Drag a column symbol on the ruler.
Start dragging on mouse down event START-EVENT, and update the column
symbol value with the current value of the ruler graduation while
dragging. See also the variable `ruler-mode-dragged-symbol'."
(interactive "e")
(setq ruler-mode-dragged-symbol nil)
(let* ((start (event-start start-event))
col newc oldc)
(save-selected-window
(select-window (posn-window start))
(setq col (ruler-mode-window-col (car (posn-col-row start)))
newc (+ col (window-hscroll)))
(and
(>= col 0) (< col (window-width))
(cond
((eq newc fill-column)
(setq oldc fill-column
ruler-mode-dragged-symbol 'fill-column)
t)
((eq newc comment-column)
(setq oldc comment-column
ruler-mode-dragged-symbol 'comment-column)
t)
((eq newc goal-column) (setq oldc goal-column
ruler-mode-dragged-symbol 'goal-column)
t)
((null goal-column) (setq oldc goal-column
goal-column newc)
(read-event)
(when ruler-mode-set-goal-column-ding-flag
(ding))
(message "Goal column set to %d (click on %s again to unset it)"
newc
(propertize (char-to-string ruler-mode-goal-column-char)
'face 'ruler-mode-goal-column))
nil) )
(if (eq 'click (ruler-mode-mouse-drag-any-column-iteration
(posn-window start)))
(when (eq 'goal-column ruler-mode-dragged-symbol)
(set-goal-column t))
(message "%s is set to %d (was %d)"
ruler-mode-dragged-symbol
(symbol-value ruler-mode-dragged-symbol)
oldc))))))
(defun ruler-mode-mouse-drag-any-column-iteration (window)
"Update the ruler while dragging the mouse.
WINDOW is the window where occurred the last down-mouse event.
Return the symbol `drag' if the mouse has been dragged, or `click' if
the mouse has been clicked."
(let ((drags 0)
event)
(track-mouse
(while (mouse-movement-p (setq event (read-event)))
(setq drags (1+ drags))
(when (eq window (posn-window (event-end event)))
(ruler-mode-mouse-drag-any-column event)
(force-mode-line-update))))
(if (and (zerop drags) (eq 'click (car (event-modifiers event))))
'click
'drag)))
(defun ruler-mode-mouse-drag-any-column (start-event)
"Update the value of the symbol dragged on the ruler.
Called on each mouse motion event START-EVENT."
(let* ((start (event-start start-event))
(end (event-end start-event))
col newc)
(save-selected-window
(select-window (posn-window start))
(setq col (ruler-mode-window-col (car (posn-col-row end)))
newc (+ col (window-hscroll)))
(when (and (>= col 0) (< col (window-width)))
(set ruler-mode-dragged-symbol newc)))))
(defun ruler-mode-mouse-add-tab-stop (start-event)
"Add a tab stop to the graduation where the mouse pointer is on.
START-EVENT is the mouse click event."
(interactive "e")
(when ruler-mode-show-tab-stops
(let* ((start (event-start start-event))
(end (event-end start-event))
col ts)
(when (eq start end) (save-selected-window
(select-window (posn-window start))
(setq col (ruler-mode-window-col (car (posn-col-row start)))
ts (+ col (window-hscroll)))
(and (>= col 0) (< col (window-width))
(not (member ts tab-stop-list))
(progn
(message "Tab stop set to %d" ts)
(setq tab-stop-list (sort (cons ts tab-stop-list)
#'<)))))))))
(defun ruler-mode-mouse-del-tab-stop (start-event)
"Delete tab stop at the graduation where the mouse pointer is on.
START-EVENT is the mouse click event."
(interactive "e")
(when ruler-mode-show-tab-stops
(let* ((start (event-start start-event))
(end (event-end start-event))
col ts)
(when (eq start end) (save-selected-window
(select-window (posn-window start))
(setq col (ruler-mode-window-col (car (posn-col-row start)))
ts (+ col (window-hscroll)))
(and (>= col 0) (< col (window-width))
(member ts tab-stop-list)
(progn
(message "Tab stop at %d deleted" ts)
(setq tab-stop-list (delete ts tab-stop-list)))))))))
(defun ruler-mode-toggle-show-tab-stops ()
"Toggle showing of tab stops on the ruler."
(interactive)
(setq ruler-mode-show-tab-stops (not ruler-mode-show-tab-stops))
(force-mode-line-update))
(defvar ruler-mode-map
(let ((km (make-sparse-keymap)))
(define-key km [header-line down-mouse-1]
#'ignore)
(define-key km [header-line down-mouse-3]
#'ignore)
(define-key km [header-line down-mouse-2]
#'ruler-mode-mouse-grab-any-column)
(define-key km [header-line (shift down-mouse-1)]
#'ruler-mode-mouse-set-left-margin)
(define-key km [header-line (shift down-mouse-3)]
#'ruler-mode-mouse-set-right-margin)
(define-key km [header-line (control down-mouse-1)]
#'ruler-mode-mouse-add-tab-stop)
(define-key km [header-line (control down-mouse-3)]
#'ruler-mode-mouse-del-tab-stop)
(define-key km [header-line (control down-mouse-2)]
#'ruler-mode-toggle-show-tab-stops)
(define-key km [header-line (shift mouse-1)]
'ignore)
(define-key km [header-line (shift mouse-3)]
'ignore)
(define-key km [header-line (control mouse-1)]
'ignore)
(define-key km [header-line (control mouse-3)]
'ignore)
(define-key km [header-line (control mouse-2)]
'ignore)
km)
"Keymap for ruler minor mode.")
(defvar ruler-mode-header-line-format-old nil
"Hold previous value of `header-line-format'.")
(defvar ruler-mode-ruler-function 'ruler-mode-ruler
"Function to call to return ruler header line format.
This variable is expected to be made buffer-local by modes.")
(defconst ruler-mode-header-line-format
'(:eval (funcall ruler-mode-ruler-function))
"`header-line-format' used in ruler mode.
Call `ruler-mode-ruler-function' to compute the ruler value.")
(define-minor-mode ruler-mode
"Display a ruler in the header line if ARG > 0."
nil nil
ruler-mode-map
:group 'ruler-mode
(if ruler-mode
(progn
(when (local-variable-p 'header-line-format)
(set (make-local-variable 'ruler-mode-header-line-format-old)
header-line-format))
(setq header-line-format ruler-mode-header-line-format)
(add-hook 'post-command-hook 'force-mode-line-update nil t))
(when (eq header-line-format ruler-mode-header-line-format)
(kill-local-variable 'header-line-format)
(when (local-variable-p 'ruler-mode-header-line-format-old)
(setq header-line-format ruler-mode-header-line-format-old)
(kill-local-variable 'ruler-mode-header-line-format-old)))
(remove-hook 'post-command-hook 'force-mode-line-update t)))
(define-key mode-line-mode-menu [ruler-mode]
`(menu-item "Ruler" ruler-mode
:button (:toggle . ruler-mode)))
(defconst ruler-mode-ruler-help-echo
"\
S-mouse-1/3: set L/R margin, \
mouse-2: set goal column, \
C-mouse-2: show tabs"
"Help string shown when mouse is over the ruler.
`ruler-mode-show-tab-stops' is nil.")
(defconst ruler-mode-ruler-help-echo-when-goal-column
"\
S-mouse-1/3: set L/R margin, \
C-mouse-2: show tabs"
"Help string shown when mouse is over the ruler.
`goal-column' is set and `ruler-mode-show-tab-stops' is nil.")
(defconst ruler-mode-ruler-help-echo-when-tab-stops
"\
C-mouse1/3: set/unset tab, \
C-mouse-2: hide tabs"
"Help string shown when mouse is over the ruler.
`ruler-mode-show-tab-stops' is non-nil.")
(defconst ruler-mode-fill-column-help-echo
"drag-mouse-2: set fill column"
"Help string shown when mouse is on the fill column character.")
(defconst ruler-mode-comment-column-help-echo
"drag-mouse-2: set comment column"
"Help string shown when mouse is on the comment column character.")
(defconst ruler-mode-goal-column-help-echo
"\
drag-mouse-2: set goal column, \
mouse-2: unset goal column"
"Help string shown when mouse is on the goal column character.")
(defconst ruler-mode-margin-help-echo
"%s margin %S"
"Help string shown when mouse is over a margin area.")
(defconst ruler-mode-fringe-help-echo
"%s fringe %S"
"Help string shown when mouse is over a fringe area.")
(defsubst ruler-mode-space (width &rest props)
"Return a single space string of WIDTH times the normal character width.
Optional argument PROPS specifies other text properties to apply."
(apply 'propertize " " 'display (list 'space :width width) props))
(defun ruler-mode-ruler ()
"Compute and return a header line ruler."
(let* ((w (window-width))
(m (window-margins))
(f (window-fringes))
(i 0)
(j (window-hscroll))
(lf (ruler-mode-space
'left-fringe
'face 'ruler-mode-fringes
'help-echo (format ruler-mode-fringe-help-echo
"Left" (or (car f) 0))))
(rf (ruler-mode-space
'right-fringe
'face 'ruler-mode-fringes
'help-echo (format ruler-mode-fringe-help-echo
"Right" (or (cadr f) 0))))
(lm (ruler-mode-space
'left-margin
'face 'ruler-mode-margins
'help-echo (format ruler-mode-margin-help-echo
"Left" (or (car m) 0))))
(rm (ruler-mode-space
'right-margin
'face 'ruler-mode-margins
'help-echo (format ruler-mode-margin-help-echo
"Right" (or (cdr m) 0))))
(sb (ruler-mode-space
'scroll-bar
'face 'ruler-mode-pad))
(sbvt (car (window-current-scroll-bars)))
(ruler
(propertize
(make-string w ruler-mode-basic-graduation-char)
'face 'ruler-mode-default
'local-map ruler-mode-map
'help-echo (cond
(ruler-mode-show-tab-stops
ruler-mode-ruler-help-echo-when-tab-stops)
(goal-column
ruler-mode-ruler-help-echo-when-goal-column)
(ruler-mode-ruler-help-echo))))
k c)
(while (< i w)
(cond
((= (mod j 10) 0)
(setq c (number-to-string (/ j 10))
m (length c)
k i)
(put-text-property
i (1+ i) 'face 'ruler-mode-column-number
ruler)
(while (and (> m 0) (>= k 0))
(aset ruler k (aref c (setq m (1- m))))
(setq k (1- k))))
((= (mod j 5) 0)
(aset ruler i ruler-mode-inter-graduation-char)))
(cond
((= j (current-column))
(aset ruler i ruler-mode-current-column-char)
(put-text-property
i (1+ i) 'face 'ruler-mode-current-column
ruler))
((and goal-column (= j goal-column))
(aset ruler i ruler-mode-goal-column-char)
(put-text-property
i (1+ i) 'face 'ruler-mode-goal-column
ruler)
(put-text-property
i (1+ i) 'mouse-face 'mode-line-highlight
ruler)
(put-text-property
i (1+ i) 'help-echo ruler-mode-goal-column-help-echo
ruler))
((= j comment-column)
(aset ruler i ruler-mode-comment-column-char)
(put-text-property
i (1+ i) 'face 'ruler-mode-comment-column
ruler)
(put-text-property
i (1+ i) 'mouse-face 'mode-line-highlight
ruler)
(put-text-property
i (1+ i) 'help-echo ruler-mode-comment-column-help-echo
ruler))
((= j fill-column)
(aset ruler i ruler-mode-fill-column-char)
(put-text-property
i (1+ i) 'face 'ruler-mode-fill-column
ruler)
(put-text-property
i (1+ i) 'mouse-face 'mode-line-highlight
ruler)
(put-text-property
i (1+ i) 'help-echo ruler-mode-fill-column-help-echo
ruler))
((and ruler-mode-show-tab-stops (member j tab-stop-list))
(aset ruler i ruler-mode-tab-stop-char)
(put-text-property
i (1+ i) 'face 'ruler-mode-tab-stop
ruler)))
(setq i (1+ i)
j (1+ j)))
(if (nth 2 (window-fringes))
(list "" (and (eq 'left sbvt) sb) lf lm
ruler rm rf (and (eq 'right sbvt) sb))
(list "" (and (eq 'left sbvt) sb) lm lf
ruler rf rm (and (eq 'right sbvt) sb)))))
(provide 'ruler-mode)