;;; 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:

;; 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

;;; Pre-git history:
;;
;; 2008-02-21  MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
;;
;;      * visible-mark.el: Added function to inhibit trailing overlay.
;;
;; 2008-01-31  MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
;;
;;      * visible-mark.el: Create formal emacs lisp file from
;;        http://www.emacswiki.org/cgi-bin/wiki/VisibleMark.
;;        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:

(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."
  :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 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
  "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))

(defcustom global-visible-mark-mode-exclude-alist nil
  "A list of buffer names to be excluded."
  :group 'visible-mark
  :type '(repeat regexp))

(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)))

(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)))

(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