;;; visible-mark.el --- Make marks visible.
+;; Copyright (C) 2014 by Ian Kelling
+
+;; Author: Several people, most recently Ian Kelling <ian@iankelling.org>
+
+;; 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 3 of the License, 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, see <http://www.gnu.org/licenses/>.
+
+
;;; Commentary:
-;; This was hacked together by Jorgen Schäfer
-;; And hacked again by Yann Hodique
-;; Donated to the public domain. Use at your own risk.
+;; Minor mode to display custom overlay faces on mark location(s).
+;; Can display marks from the mark ring in the normal backward direction
+;; in the forward direction.
+;;
+;; Example installation:
+;;
+;; 1. Put this file in Emacs's load-path
+;;
+;; 2. add to init file
+;; (require 'visible-mark)
+;;
+;; ;; example of customizations.
+;; ;; This could be set via M-x customize-group visible-mark
+;; (setq visible-mark-max 2)
+;; (defface my-visible-mark-face-2
+;; `((t (:background "orange" :foreground "black")))
+;; "Face for the mark."
+;; :group 'visible-mark)
+;; (setq visible-mark-faces `(visible-mark-face1 my-visible-mark-face-2))
+;;
+;; (global-visible-mark-mode +1)
+;;
+;;
+;; Additional useful functions like unpoping the mark are listed
+;; http://www.emacswiki.org/emacs/MarkCommands
+;; and http://www.emacswiki.org/emacs/VisibleMark
-;;; History:
+;;; Pre-git history:
+;;
;; 2008-02-21 MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
;;
;; * visible-mark.el: Added function to inhibit trailing overlay.
;; Yann Hodique and Jorgen Schäfer are original authors.
;; Added function to make multiple marks visible.
;;
+;;
+;; Known bugs
+;;
+;; Observed in circe, when the buffer has a right margin, and there
+;; is a mark at the beginning of a line, any text in the margin on that line
+;; gets styled with the mark's face. May also happen for left margins, but
+;; haven't tested yet.
+;;
+;; Patches / pull requests welcome.
;;; Code:
:group 'convenience
:prefix "visible-mark-")
-(defface visible-mark-face
- `((((type tty) (class color))
+(defface visible-mark-active
+ '((((type tty) (class color))
(:background "gray" :foreground "black"))
(((type tty) (class mono))
(:inverse-video t))
(((class color) (background light))
(:background "grey80"))
(t (:background "gray")))
- "Face for the mark."
+ "Face for the active mark."
:group 'visible-mark)
+(defface visible-mark-face1
+ '((((type tty) (class mono)))
+ (t (:background "light salmon")))
+ "Example face which can be customized and added to subsequent face lists."
+ :group 'visible-mark)
+
+(defface visible-mark-face2
+ '((((type tty) (class mono)))
+ (t (:background "light goldenrod")))
+ "Example face which can be customized and added to subsequent face lists."
+ :group 'visible-mark)
+
+(defface visible-mark-forward-face1
+ '((((type tty) (class mono)))
+ (t (:background "pale green")))
+ "Example face which can be customized and added to subsequent face lists."
+ :group 'visible-mark)
+
+(defface visible-mark-forward-face2
+ nil
+ "Placeholder face for customization and addition to subsequent face lists."
+ :group 'visible-mark)
+
+
(defvar visible-mark-overlays nil
"The overlays used in this buffer.")
(make-variable-buffer-local 'visible-mark-overlays)
(defcustom visible-mark-inhibit-trailing-overlay t
- "If non-nil, inhibit trailing overlay with underline face."
+ "If non-nil, inhibit the extension of an overlay at the end of a line
+to the window margin."
:group 'visible-mark
:type 'boolean)
+
(defcustom visible-mark-max 1
- "A number of mark to be visible."
+ "The number of marks in the backward direction to be visible."
+ :group 'visible-mark
+ :type 'integer)
+
+(defcustom visible-mark-forward-max 0
+ "The number of marks in the forward direction to be visible."
:group 'visible-mark
:type 'integer)
(defcustom visible-mark-faces nil
- "A list of mark faces."
+ "A list of mark faces for marks in the backward direction.
+If visible-mark-max is greater than the amount of visible-mark-faces,
+the last defined face will be reused."
+ :group 'visible-mark
+ :type '(repeat face))
+
+(defcustom visible-mark-forward-faces nil
+ "A list of mark faces for marks in the forward direction."
:group 'visible-mark
:type '(repeat face))
(defcustom global-visible-mark-mode-exclude-alist nil
- "A list of buffer names to be excluded"
+ "A list of buffer names to be excluded."
:group 'visible-mark
:type '(repeat regexp))
-
+
(defun visible-mark-initialize-overlays ()
(mapc
(lambda (x)
(delete-overlay x)))
(overlays-in (point-min) (point-max)))
(let (overlays)
- (dotimes (i visible-mark-max)
+ (dotimes (i (+ visible-mark-max visible-mark-forward-max))
(let ((overlay (make-overlay (point-min) (point-min))))
(overlay-put overlay 'category 'visible-mark)
(push overlay overlays)))
found))
(defun visible-mark-move-overlays ()
- "Move the overlay in `visible-mark-overlay' to a new position."
- (mapc (lambda (x) (move-overlay x 0 0))
+ "Update overlays in `visible-mark-overlays'. This is run in the `post-command-hook'"
+ (mapc (lambda (x) (delete-overlay x))
visible-mark-overlays)
(let ((marks (cons (mark-marker) mark-ring))
- (overlays visible-mark-overlays))
+ (overlays visible-mark-overlays)
+ (faces visible-mark-faces)
+ (faces-forward visible-mark-forward-faces))
+ (if mark-active (setq faces (cons 'visible-mark-active (cdr faces))))
(dotimes (i visible-mark-max)
- (let* ((mark (car-safe marks))
- (overlay (car overlays))
- (pos (and mark (marker-position mark))))
- (when pos
- (cond
- ((and visible-mark-inhibit-trailing-overlay
- (save-excursion (goto-char pos) (eolp)))
- (overlay-put overlay 'face nil)
- (if (visible-mark-find-overlay-at pos)
- (progn (overlay-put overlay 'before-string nil)
- (move-overlay overlay 0 0))
- (overlay-put overlay 'before-string
- (propertize
- " "
- 'face (or (nth i visible-mark-faces) 'visible-mark-face)
- 'cursor 0))
- (move-overlay overlay pos (1+ pos))))
- (t
- (overlay-put overlay 'before-string nil)
- (overlay-put overlay 'face
- (or (nth i visible-mark-faces) 'visible-mark-face))
- (move-overlay overlay pos (1+ pos)))))
- (setq marks (cdr marks)))
- (setq overlays (cdr overlays)))))
+ (visible-mark-move-overlay (pop overlays) (pop marks) (car faces))
+ (if (cdr faces) (pop faces)))
+ (dotimes (i visible-mark-forward-max)
+ (visible-mark-move-overlay (pop overlays) (car (last marks (1+ i))) (car faces-forward))
+ (if (cdr faces-forward) (pop faces-forward)))))
+
+(defun visible-mark-move-overlay (overlay mark face)
+ "Set OVERLAY to position of MARK and display of FACE."
+ (let ((pos (and mark (marker-position mark))))
+ (when (and pos (not (equal (point) pos)))
+ (cond
+ ((and
+ visible-mark-inhibit-trailing-overlay
+ (save-excursion (goto-char pos) (eolp)))
+ (overlay-put overlay 'face nil)
+ (if (visible-mark-find-overlay-at pos)
+ (progn (overlay-put overlay 'before-string nil))
+ (overlay-put overlay 'before-string
+ (propertize
+ " "
+ 'face face))
+ (move-overlay overlay pos (1+ pos))))
+ (t
+ (overlay-put overlay 'before-string nil)
+ (overlay-put overlay 'face face)
+ (move-overlay overlay pos (1+ pos)))))))
(require 'easy-mmode)
-
(defun visible-mark-mode-maybe ()
(when (cond
((minibufferp (current-buffer)) nil)
- ((flet ((fun (arg)
- (if (null arg) nil
- (or (string-match (car arg) (buffer-name))
- (fun (cdr arg))))))
+ ((cl-flet ((fun (arg)
+ (if (null arg) nil
+ (or (string-match (car arg) (buffer-name))
+ (fun (cdr arg))))))
(fun global-visible-mark-mode-exclude-alist)) nil)
(t t))
(visible-mark-mode t)))
iankelling.org / git / visible-mark / blobdiff