diff options
Diffstat (limited to 'emacs/guix-buffer.el')
| -rw-r--r-- | emacs/guix-buffer.el | 566 |
1 files changed, 566 insertions, 0 deletions
diff --git a/emacs/guix-buffer.el b/emacs/guix-buffer.el new file mode 100644 index 0000000000..5687a250aa --- /dev/null +++ b/emacs/guix-buffer.el @@ -0,0 +1,566 @@ +;;; guix-buffer.el --- Buffer interface for displaying data -*- lexical-binding: t -*- + +;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix 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. + +;; GNU Guix 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 'buffer' interface for displaying an +;; arbitrary data. + +;;; Code: + +(require 'cl-lib) +(require 'guix-history) +(require 'guix-utils) + +(defvar guix-buffer-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "l") 'guix-history-back) + (define-key map (kbd "r") 'guix-history-forward) + (define-key map (kbd "g") 'revert-buffer) + (define-key map (kbd "R") 'guix-buffer-redisplay) + map) + "Parent keymap for Guix buffer modes.") + + +;;; Buffer item + +(cl-defstruct (guix-buffer-item + (:constructor nil) + (:constructor guix-buffer-make-item + (entries buffer-type entry-type args)) + (:copier nil)) + entries buffer-type entry-type args) + +(defvar-local guix-buffer-item nil + "Data (structure) for the current Guix buffer. +The structure consists of the following elements: + +- `entries': list of the currently displayed entries. + + Each element of the list is an alist with an entry data of the + following form: + + ((PARAM . VAL) ...) + + PARAM is a name of the entry parameter. + VAL is a value of this parameter. + +- `entry-type': type of the currently displayed entries. + +- `buffer-type': type of the current buffer. + +- `args': search arguments used to get the current entries.") +(put 'guix-buffer-item 'permanent-local t) + +(defmacro guix-buffer-with-item (item &rest body) + "Evaluate BODY using buffer ITEM. +The following local variables are available inside BODY: +`%entries', `%buffer-type', `%entry-type', `%args'. +See `guix-buffer-item' for details." + (declare (indent 1) (debug t)) + (let ((item-var (make-symbol "item"))) + `(let ((,item-var ,item)) + (let ((%entries (guix-buffer-item-entries ,item-var)) + (%buffer-type (guix-buffer-item-buffer-type ,item-var)) + (%entry-type (guix-buffer-item-entry-type ,item-var)) + (%args (guix-buffer-item-args ,item-var))) + ,@body)))) + +(defmacro guix-buffer-with-current-item (&rest body) + "Evaluate BODY using `guix-buffer-item'. +See `guix-buffer-with-item' for details." + (declare (indent 0) (debug t)) + `(guix-buffer-with-item guix-buffer-item + ,@body)) + +(defmacro guix-buffer-define-current-item-accessor (name) + "Define `guix-buffer-current-NAME' function to access NAME +element of `guix-buffer-item' structure. +NAME should be a symbol." + (let* ((name-str (symbol-name name)) + (accessor (intern (concat "guix-buffer-item-" name-str))) + (fun-name (intern (concat "guix-buffer-current-" name-str))) + (doc (format "\ +Return '%s' of the current Guix buffer. +See `guix-buffer-item' for details." + name-str))) + `(defun ,fun-name () + ,doc + (and guix-buffer-item + (,accessor guix-buffer-item))))) + +(defmacro guix-buffer-define-current-item-accessors (&rest names) + "Define `guix-buffer-current-NAME' functions for NAMES. +See `guix-buffer-define-current-item-accessor' for details." + `(progn + ,@(mapcar (lambda (name) + `(guix-buffer-define-current-item-accessor ,name)) + names))) + +(guix-buffer-define-current-item-accessors + entries entry-type buffer-type args) + +(defmacro guix-buffer-define-current-args-accessor (n prefix name) + "Define `PREFIX-NAME' function to access Nth element of 'args' +field of `guix-buffer-item' structure. +PREFIX and NAME should be strings." + (let ((fun-name (intern (concat prefix "-" name))) + (doc (format "\ +Return '%s' of the current Guix buffer. +'%s' is the element number %d in 'args' of `guix-buffer-item'." + name name n))) + `(defun ,fun-name () + ,doc + (nth ,n (guix-buffer-current-args))))) + +(defmacro guix-buffer-define-current-args-accessors (prefix &rest names) + "Define `PREFIX-NAME' functions for NAMES. +See `guix-buffer-define-current-args-accessor' for details." + `(progn + ,@(cl-loop for name in names + for i from 0 + collect `(guix-buffer-define-current-args-accessor + ,i ,prefix ,name)))) + + +;;; Wrappers for defined variables + +(defvar guix-buffer-data nil + "Alist with 'buffer' data. +This alist is filled by `guix-buffer-define-interface' macro.") + +(defun guix-buffer-value (buffer-type entry-type symbol) + "Return SYMBOL's value for BUFFER-TYPE/ENTRY-TYPE from `guix-buffer-data'." + (symbol-value + (guix-assq-value guix-buffer-data buffer-type entry-type symbol))) + +(defun guix-buffer-get-entries (buffer-type entry-type args) + "Return ENTRY-TYPE entries. +Call an appropriate 'get-entries' function from `guix-buffer' +using ARGS as its arguments." + (apply (guix-buffer-value buffer-type entry-type 'get-entries) + args)) + +(defun guix-buffer-mode-enable (buffer-type entry-type) + "Turn on major mode to display ENTRY-TYPE ENTRIES in BUFFER-TYPE buffer." + (funcall (guix-buffer-value buffer-type entry-type 'mode))) + +(defun guix-buffer-mode-initialize (buffer-type entry-type) + "Set up the current BUFFER-TYPE buffer to display ENTRY-TYPE entries." + (let ((fun (guix-buffer-value buffer-type entry-type 'mode-init))) + (when fun + (funcall fun)))) + +(defun guix-buffer-insert-entries (entries buffer-type entry-type) + "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." + (funcall (guix-buffer-value buffer-type entry-type 'insert-entries) + entries)) + +(defun guix-buffer-show-entries-default (entries buffer-type entry-type) + "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." + (let ((inhibit-read-only t)) + (erase-buffer) + (guix-buffer-mode-enable buffer-type entry-type) + (guix-buffer-insert-entries entries buffer-type entry-type) + (goto-char (point-min)))) + +(defun guix-buffer-show-entries (entries buffer-type entry-type) + "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." + (funcall (guix-buffer-value buffer-type entry-type 'show-entries) + entries)) + +(defun guix-buffer-message (entries buffer-type entry-type args) + "Display a message for BUFFER-ITEM after showing entries." + (let ((fun (guix-buffer-value buffer-type entry-type 'message))) + (when fun + (apply fun entries args)))) + +(defun guix-buffer-name (buffer-type entry-type args) + "Return name of BUFFER-TYPE buffer for displaying ENTRY-TYPE entries." + (let ((str-or-fun (guix-buffer-value buffer-type entry-type + 'buffer-name))) + (if (stringp str-or-fun) + str-or-fun + (apply str-or-fun args)))) + +(defun guix-buffer-param-title (buffer-type entry-type param) + "Return PARAM title for BUFFER-TYPE/ENTRY-TYPE." + (or (guix-assq-value (guix-buffer-value buffer-type entry-type 'titles) + param) + ;; Fallback to a title defined in 'info' interface. + (unless (eq buffer-type 'info) + (guix-assq-value (guix-buffer-value 'info entry-type 'titles) + param)) + (guix-symbol-title param))) + +(defun guix-buffer-history-size (buffer-type entry-type) + "Return history size for BUFFER-TYPE/ENTRY-TYPE." + (guix-buffer-value buffer-type entry-type 'history-size)) + +(defun guix-buffer-revert-confirm? (buffer-type entry-type) + "Return 'revert-confirm' value for BUFFER-TYPE/ENTRY-TYPE." + (guix-buffer-value buffer-type entry-type 'revert-confirm)) + + +;;; Displaying entries + +(defun guix-buffer-display (buffer) + "Switch to a Guix BUFFER." + (pop-to-buffer buffer + '((display-buffer-reuse-window + display-buffer-same-window)))) + +(defun guix-buffer-history-item (buffer-item) + "Make and return a history item for displaying BUFFER-ITEM." + (list #'guix-buffer-set buffer-item)) + +(defun guix-buffer-set (buffer-item &optional history) + "Set up the current buffer for displaying BUFFER-ITEM. +HISTORY should be one of the following: + + `nil' - do not save BUFFER-ITEM in history, + + `add' - add it to history, + + `replace' - replace the current history item." + (guix-buffer-with-item buffer-item + (when %entries + (guix-buffer-show-entries %entries %buffer-type %entry-type) + (setq guix-buffer-item buffer-item) + (when history + (funcall (cl-ecase history + (add #'guix-history-add) + (replace #'guix-history-replace)) + (guix-buffer-history-item buffer-item)))) + (guix-buffer-message %entries %buffer-type %entry-type %args))) + +(defun guix-buffer-display-entries-current + (entries buffer-type entry-type args &optional history) + "Show ENTRIES in the current Guix buffer. +See `guix-buffer-item' for the meaning of BUFFER-TYPE, ENTRY-TYPE +and ARGS, and `guix-buffer-set' for the meaning of HISTORY." + (let ((item (guix-buffer-make-item entries buffer-type + entry-type args))) + (guix-buffer-set item history))) + +(defun guix-buffer-get-display-entries-current + (buffer-type entry-type args &optional history) + "Search for entries and show them in the current Guix buffer. +See `guix-buffer-display-entries-current' for details." + (guix-buffer-display-entries-current + (guix-buffer-get-entries buffer-type entry-type args) + buffer-type entry-type args history)) + +(defun guix-buffer-display-entries + (entries buffer-type entry-type args &optional history) + "Show ENTRIES in a BUFFER-TYPE buffer. +See `guix-buffer-display-entries-current' for details." + (let ((buffer (get-buffer-create + (guix-buffer-name buffer-type entry-type args)))) + (with-current-buffer buffer + (guix-buffer-display-entries-current + entries buffer-type entry-type args history)) + (when entries + (guix-buffer-display buffer)))) + +(defun guix-buffer-get-display-entries + (buffer-type entry-type args &optional history) + "Search for entries and show them in a BUFFER-TYPE buffer. +See `guix-buffer-display-entries-current' for details." + (guix-buffer-display-entries + (guix-buffer-get-entries buffer-type entry-type args) + buffer-type entry-type args history)) + +(defun guix-buffer-revert (_ignore-auto noconfirm) + "Update the data in the current Guix buffer. +This function is suitable for `revert-buffer-function'. +See `revert-buffer' for the meaning of NOCONFIRM." + (guix-buffer-with-current-item + (when (or noconfirm + (not (guix-buffer-revert-confirm? %buffer-type %entry-type)) + (y-or-n-p "Update the current buffer? ")) + (guix-buffer-get-display-entries-current + %buffer-type %entry-type %args 'replace)))) + +(defvar guix-buffer-after-redisplay-hook nil + "Hook run by `guix-buffer-redisplay'. +This hook is called before seting up a window position.") + +(defun guix-buffer-redisplay () + "Redisplay the current Guix buffer. +Restore the point and window positions after redisplaying. + +This function does not update the buffer data, use +'\\[revert-buffer]' if you want the full update." + (interactive) + (let* ((old-point (point)) + ;; For simplicity, ignore an unlikely case when multiple + ;; windows display the same buffer. + (window (car (get-buffer-window-list (current-buffer) nil t))) + (window-start (and window (window-start window)))) + (guix-buffer-set guix-buffer-item) + (goto-char old-point) + (run-hooks 'guix-buffer-after-redisplay-hook) + (when window + (set-window-point window (point)) + (set-window-start window window-start)))) + +(defun guix-buffer-redisplay-goto-button () + "Redisplay the current buffer and go to the next button, if needed." + (let ((guix-buffer-after-redisplay-hook + (cons (lambda () + (unless (button-at (point)) + (forward-button 1))) + guix-buffer-after-redisplay-hook))) + (guix-buffer-redisplay))) + + +;;; Interface definer + +(defmacro guix-buffer-define-interface (buffer-type entry-type &rest args) + "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... +In the following description TYPE means ENTRY-TYPE-BUFFER-TYPE. + +Required keywords: + + - `:buffer-name' - default value of the generated + `guix-TYPE-buffer-name' variable. + + - `:get-entries-function' - default value of the generated + `guix-TYPE-get-function' variable. + + - `:show-entries-function' - default value of the generated + `guix-TYPE-show-function' variable. + + Alternatively, if `:show-entries-function' is not specified, a + default `guix-TYPE-show-entries' will be generated, and the + following keyword should be specified instead: + + - `:insert-entries-function' - default value of the generated + `guix-TYPE-insert-function' variable. + +Optional keywords: + + - `:message-function' - default value of the generated + `guix-TYPE-message-function' variable. + + - `:titles' - default value of the generated + `guix-TYPE-titles' variable. + + - `:history-size' - default value of the generated + `guix-TYPE-history-size' variable. + + - `:revert-confirm?' - default value of the generated + `guix-TYPE-revert-confirm' variable. + + - `:mode-name' - name (a string appeared in the mode-line) of + the generated `guix-TYPE-mode'. + + - `:mode-init-function' - default value of the generated + `guix-TYPE-mode-initialize-function' variable. + + - `:reduced?' - if non-nil, generate only group, faces group + and titles variable (if specified); all keywords become + optional." + (declare (indent 2)) + (let* ((entry-type-str (symbol-name entry-type)) + (buffer-type-str (symbol-name buffer-type)) + (prefix (concat "guix-" entry-type-str "-" + buffer-type-str)) + (group (intern prefix)) + (faces-group (intern (concat prefix "-faces"))) + (get-entries-var (intern (concat prefix "-get-function"))) + (show-entries-var (intern (concat prefix "-show-function"))) + (show-entries-fun (intern (concat prefix "-show-entries"))) + (message-var (intern (concat prefix "-message-function"))) + (buffer-name-var (intern (concat prefix "-buffer-name"))) + (titles-var (intern (concat prefix "-titles"))) + (history-size-var (intern (concat prefix "-history-size"))) + (revert-confirm-var (intern (concat prefix "-revert-confirm")))) + (guix-keyword-args-let args + ((get-entries-val :get-entries-function) + (show-entries-val :show-entries-function) + (insert-entries-val :insert-entries-function) + (mode-name :mode-name (capitalize prefix)) + (mode-init-val :mode-init-function) + (message-val :message-function) + (buffer-name-val :buffer-name) + (titles-val :titles) + (history-size-val :history-size 20) + (revert-confirm-val :revert-confirm? t) + (reduced? :reduced?)) + `(progn + (defgroup ,group nil + ,(format "Display '%s' entries in '%s' buffer." + entry-type-str buffer-type-str) + :prefix ,(concat prefix "-") + :group ',(intern (concat "guix-" buffer-type-str))) + + (defgroup ,faces-group nil + ,(format "Faces for displaying '%s' entries in '%s' buffer." + entry-type-str buffer-type-str) + :group ',(intern (concat "guix-" buffer-type-str "-faces"))) + + (defcustom ,titles-var ,titles-val + ,(format "Alist of titles of '%s' parameters." + entry-type-str) + :type '(alist :key-type symbol :value-type string) + :group ',group) + + ,(unless reduced? + `(progn + (defvar ,get-entries-var ,get-entries-val + ,(format "\ +Function used to receive '%s' entries for '%s' buffer." + entry-type-str buffer-type-str)) + + (defvar ,show-entries-var + ,(or show-entries-val `',show-entries-fun) + ,(format "\ +Function used to show '%s' entries in '%s' buffer." + entry-type-str buffer-type-str)) + + (defvar ,message-var ,message-val + ,(format "\ +Function used to display a message after showing '%s' entries. +If nil, do not display messages." + entry-type-str)) + + (defcustom ,buffer-name-var ,buffer-name-val + ,(format "\ +Default name of '%s' buffer for displaying '%s' entries. +May be a string or a function returning a string. The function +is called with the same arguments as `%S'." + buffer-type-str entry-type-str get-entries-var) + :type '(choice string function) + :group ',group) + + (defcustom ,history-size-var ,history-size-val + ,(format "\ +Maximum number of items saved in history of `%S' buffer. +If 0, the history is disabled." + buffer-name-var) + :type 'integer + :group ',group) + + (defcustom ,revert-confirm-var ,revert-confirm-val + ,(format "\ +If non-nil, ask to confirm for reverting `%S' buffer." + buffer-name-var) + :type 'boolean + :group ',group) + + (guix-alist-put! + '((get-entries . ,get-entries-var) + (show-entries . ,show-entries-var) + (message . ,message-var) + (buffer-name . ,buffer-name-var) + (history-size . ,history-size-var) + (revert-confirm . ,revert-confirm-var)) + 'guix-buffer-data ',buffer-type ',entry-type) + + ,(unless show-entries-val + `(defun ,show-entries-fun (entries) + ,(format "\ +Show '%s' ENTRIES in the current '%s' buffer." + entry-type-str buffer-type-str) + (guix-buffer-show-entries-default + entries ',buffer-type ',entry-type))) + + ,(when (or insert-entries-val + (null show-entries-val)) + (let ((insert-entries-var + (intern (concat prefix "-insert-function")))) + `(progn + (defvar ,insert-entries-var ,insert-entries-val + ,(format "\ +Function used to print '%s' entries in '%s' buffer." + entry-type-str buffer-type-str)) + + (guix-alist-put! + ',insert-entries-var 'guix-buffer-data + ',buffer-type ',entry-type + 'insert-entries)))) + + ,(when (or mode-name + mode-init-val + (null show-entries-val)) + (let* ((mode-str (concat prefix "-mode")) + (mode-map-str (concat mode-str "-map")) + (mode (intern mode-str)) + (parent-mode (intern + (concat "guix-" buffer-type-str + "-mode"))) + (mode-var (intern + (concat mode-str "-function"))) + (mode-init-var (intern + (concat mode-str + "-initialize-function")))) + `(progn + (defvar ,mode-var ',mode + ,(format "\ +Major mode for displaying '%s' entries in '%s' buffer." + entry-type-str buffer-type-str)) + + (defvar ,mode-init-var ,mode-init-val + ,(format "\ +Function used to set up '%s' buffer for displaying '%s' entries." + buffer-type-str entry-type-str)) + + (define-derived-mode ,mode ,parent-mode ,mode-name + ,(format "\ +Major mode for displaying '%s' entries in '%s' buffer. + +\\{%s}" + entry-type-str buffer-type-str mode-map-str) + (setq-local revert-buffer-function + 'guix-buffer-revert) + (setq-local guix-history-size + (guix-buffer-history-size + ',buffer-type ',entry-type)) + (guix-buffer-mode-initialize + ',buffer-type ',entry-type)) + + (guix-alist-put! + ',mode-var 'guix-buffer-data + ',buffer-type ',entry-type 'mode) + (guix-alist-put! + ',mode-init-var 'guix-buffer-data + ',buffer-type ',entry-type + 'mode-init)))))) + + (guix-alist-put! + ',titles-var 'guix-buffer-data + ',buffer-type ',entry-type 'titles))))) + + +(defvar guix-buffer-font-lock-keywords + (eval-when-compile + `((,(rx "(" (group (or "guix-buffer-with-item" + "guix-buffer-with-current-item" + "guix-buffer-define-interface")) + symbol-end) + . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode guix-buffer-font-lock-keywords) + +(provide 'guix-buffer) + +;;; guix-buffer.el ends here |