emacs-bui/bui-history.el

;;; bui-history.el --- Buffer history  -*- lexical-binding: t -*-

;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>

;; 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 file provides a general support for buffer history similar to
;; the history of a `help-mode' buffer.

;;; Code:

(require 'cl-lib)
(require 'help-mode)            ; for button labels
(require 'bui-button)
(require 'bui-utils)

(bui-define-groups bui-history
  :group-doc "Settings for BUI buffers history."
  :faces-group-doc "Faces for history buttons.")

(defvar-local bui-history-stack-item nil
  "Current item of the history.
A list of the form (FUNCTION [ARGS ...]).
The item is used by calling (apply FUNCTION ARGS).")
(put 'bui-history-stack-item 'permanent-local t)

(defvar-local bui-history-back-stack nil
  "Stack (list) of visited items.
Each element of the list has a form of `bui-history-stack-item'.")
(put 'bui-history-back-stack 'permanent-local t)

(defvar-local bui-history-forward-stack nil
  "Stack (list) of items visited with `bui-history-back'.
Each element of the list has a form of `bui-history-stack-item'.")
(put 'bui-history-forward-stack 'permanent-local t)

(defcustom bui-history-size 16
  "Maximum number of items saved in history.
If 0, the history is disabled.
If nil, the history is infinite (until Emacs eats all your memory :-))."
  :type '(choice integer (const :tag "Infinite" nil))
  :group 'bui-history)

(defun bui-history-add (item)
  "Add ITEM to history."
  (and bui-history-stack-item
       (push bui-history-stack-item bui-history-back-stack))
  (setq bui-history-forward-stack nil
        bui-history-stack-item item)
  (when (and bui-history-size
             (>= (length bui-history-back-stack)
                 bui-history-size))
    (setq bui-history-back-stack
          (cl-loop for elt in bui-history-back-stack
                   for i from 1 to bui-history-size
                   collect elt))))

(defun bui-history-replace (item)
  "Replace current item in history with ITEM."
  (setq bui-history-stack-item item))

(defun bui-history-goto (item)
  "Go to the ITEM of history.
ITEM should have the form of `bui-history-stack-item'."
  (or (listp item)
      (error "Wrong value of history element"))
  (setq bui-history-stack-item item)
  (apply (car item) (cdr item)))

(defun bui-history-back ()
  "Go back to the previous element of history in the current buffer."
  (interactive)
  (or bui-history-back-stack
      (user-error "No previous element in history"))
  (push bui-history-stack-item bui-history-forward-stack)
  (bui-history-goto (pop bui-history-back-stack)))

(defun bui-history-forward ()
  "Go forward to the next element of history in the current buffer."
  (interactive)
  (or bui-history-forward-stack
      (user-error "No next element in history"))
  (push bui-history-stack-item bui-history-back-stack)
  (bui-history-goto (pop bui-history-forward-stack)))


;;; History buttons

(defface bui-history-button
  '((t :inherit button))
  "Face used for history buttons (back/forward)."
  :group 'bui-history-faces)

(defcustom bui-history-back-label help-back-label
  "Label of a button used to move backward by history."
  :type 'string
  :group 'bui-history)

(defcustom bui-history-forward-label help-forward-label
  "Label of a button used to move forward by history."
  :type 'string
  :group 'bui-history)

(define-button-type 'bui-history
  :supertype 'bui
  'face 'bui-history-button)

(defun bui-history-insert-button (label action &optional message
                                        &rest properties)
  "Insert history button with LABEL at point.
ACTION is a function called without arguments when the button is
pressed.  MESSAGE is a button help message.  See
`insert-text-button' for the meaning of PROPERTIES."
  (apply #'bui-insert-button
         label 'bui-history
         'action (lambda (_btn) (funcall action))
         'help-echo message
         properties))

(defun bui-history-insert-buttons ()
  "Insert back/forward history buttons at point if needed."
  (let ((insert-back?    bui-history-back-stack)
        (insert-forward? bui-history-forward-stack)
        (insert-any?     (or bui-history-back-stack
                             bui-history-forward-stack)))
    (when insert-any? (bui-newline))
    (when insert-back?
      (bui-history-insert-button bui-history-back-label
                                 #'bui-history-back
                                 "Go back to the previous info"))
    (when insert-forward?
      (when insert-back? (insert "\t"))
      (bui-history-insert-button bui-history-forward-label
                                 #'bui-history-forward
                                 "Go forward to the next info"))
    (when insert-any? (bui-newline))))

(provide 'bui-history)

;;; bui-history.el ends here