;;; visible-mark.el --- Make marks visible. ;; Copyright (C) 2014 by Ian Kelling ;; Maintainer: Ian Kelling ;; Mailing list: https://lists.iankelling.org/listinfo/visible-mark ;; Author: Ian Kelling ;; Author: Yann Hodique ;; Author: MATSUYAMA Tomohiro ;; Author: John Foerch ;; Keywords: marking color faces ;; URL: https://gitlab.com/iankelling/visible-mark ;; Created: 2008-02-21 ;;; License: ;; 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 . ;;; Commentary: ;; Emacs minor mode to highlight mark(s). ;; ;; Allows setting the number of marks to display, and the faces to display them. ;; ;; A good blog post was written introducing this package: ;; http://pragmaticemacs.com/emacs/regions-marks-and-visual-mark/ ;; ;; Example installation: ;; ;; 1. Put this file in Emacs's load-path ;; ;; 2. add custom faces to init file ;; (require 'visible-mark) ;; (global-visible-mark-mode 1) ;; or add (visible-mark-mode) to specific hooks ;; ;; 3. Add customizations. The defaults are very minimal. They could also be set ;; via customize. ;; ;; (defface visible-mark-active ;; put this before (require 'visible-mark) ;; '((((type tty) (class mono))) ;; (t (:background "magenta"))) "") ;; (setq visible-mark-max 2) ;; (setq visible-mark-faces `(visible-mark-face1 visible-mark-face2)) ;; ;; ;; Additional useful functions like unpoping the mark are at ;; http://www.emacswiki.org/emacs/MarkCommands ;; and http://www.emacswiki.org/emacs/VisibleMark ;; 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 / feedback welcome. ;;; Code: (eval-when-compile (require 'cl)) (defgroup visible-mark nil "Show the position of your mark." :group 'convenience :prefix "visible-mark-") (defface visible-mark-active '((((type tty) (class color)) (:background "gray" :foreground "black")) (((type tty) (class mono)) (:inverse-video t)) (((class color) (background dark)) (:background "gray" :foreground "black")) (((class color) (background light)) (:background "grey80")) (t (:background "gray"))) "Face for the active mark. To redefine this in your init file, do it before loading/requiring visible-mark." :group 'visible-mark) (defcustom visible-mark-inhibit-trailing-overlay t "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 global-visible-mark-mode-exclude-alist nil "A list of buffer names to be excluded." :group 'visible-mark :type '(repeat regexp)) (defcustom visible-mark-max 1 "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 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)) ;;; example faces (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 for mark faces. Used internally by visible-mark-mode.") (make-variable-buffer-local 'visible-mark-overlays) (defun visible-mark-initialize-overlays () (mapc (lambda (x) (when (eq 'visible-mark (overlay-get x 'category)) (delete-overlay x))) (overlays-in (point-min) (point-max))) (let (overlays) (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))) (setq visible-mark-overlays (nreverse overlays)))) (defun visible-mark-find-overlay-at (pos) (let ((overlays (overlays-at pos)) found) (while (and overlays (not found)) (let ((overlay (car overlays))) (if (eq 'visible-mark (overlay-get overlay 'category)) (setq found overlay))) (setq overlays (cdr overlays))) found)) (defun visible-mark-move-overlays () "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) (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) (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) ((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))) ;;;###autoload (define-minor-mode visible-mark-mode "A mode to make the mark visible." nil nil nil :group 'visible-mark (if visible-mark-mode (progn (visible-mark-initialize-overlays) (add-hook 'post-command-hook 'visible-mark-move-overlays nil t)) (mapc 'delete-overlay visible-mark-overlays) (setq visible-mark-overlays nil) (remove-hook 'post-command-hook 'visible-mark-move-overlays t))) ;;;###autoload (define-global-minor-mode global-visible-mark-mode visible-mark-mode visible-mark-mode-maybe :group 'visible-mark) (provide 'visible-mark) ;;; visible-mark.el ends here