.
675 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | ELPA_DEPENDENCIES=package-lint tablist let-alist
2 |
3 | ELPA_ARCHIVES=melpa gnu
4 |
5 | TEST_ERT_FILES=$(wildcard test/*.el)
6 | LINT_CHECKDOC_FILES=$(wildcard *.el) $(wildcard test/*.el)
7 | LINT_PACKAGE_LINT_FILES=$(wildcard *.el)
8 | LINT_COMPILE_FILES=$(wildcard *.el) $(wildcard test/*.el)
9 |
10 | LINT_CHECKDOC_OPTIONS=--eval "(setq checkdoc-arguments-in-order-flag nil)"
11 |
12 | makel.mk:
13 | # Download makel
14 | @if [ -f ../makel/makel.mk ]; then \
15 | ln -s ../makel/makel.mk .; \
16 | else \
17 | curl \
18 | --fail --silent --show-error --insecure --location \
19 | --retry 9 --retry-delay 9 \
20 | -O https://github.com/DamienCassou/makel/raw/v0.5.3/makel.mk; \
21 | fi
22 |
23 | # Include makel.mk if present
24 | -include makel.mk
25 |
--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
1 | * navigel
2 |
3 | #+BEGIN_HTML
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 | #+END_HTML
18 |
19 |
20 | ** Summary
21 |
22 | The navigel package is a library that makes it simpler for Emacs Lisp
23 | developers to define user-interfaces based on tablists (also known as
24 | tabulated-lists). Overriding a few (CL) methods and calling
25 | `navigel-open' is all that's required to get a nice UI to navigate
26 | your domain objects (files, music library, database, etc.).
27 |
28 | Navigel displays "entities" in a tablist. An "entity" is whatever you
29 | want that has a name. If an entity defines some "children", then
30 | pressing ~RET~ on the entity will list its children in another
31 | tablist.
32 |
33 | Some features of navigel include:
34 |
35 | - pressing ~RET~ on an entity lists the entity's children in another
36 | tablist;
37 | - pressing ~^~ opens the parent of the current entity;
38 | - pressing ~m~ marks the entity at point;
39 | - pressing ~d~ deletes the marked entities.
40 |
41 | Navigel automatically adds support for [[https://www.gnu.org/software/emacs/manual/html_node/emacs/Bookmarks.html#Bookmarks][bookmarks]] and [[https://www.gnu.org/software/emacs/manual/html_node/emacs/Imenu.html#Imenu][imenu]].
42 |
43 | This package depends on [[https://github.com/politza/tablist][tablist]] to get support for marking, deletion
44 | and more. On top of the tablist package, navigel provides an easy way
45 | to specify the content of your tabulated lists: through entities
46 | specified with method overrides. This makes it a breath to have
47 | tablist-based navigation within domain objects.
48 |
49 | ** Usage
50 |
51 | This code is a library and is meant for Emacs Lisp developers. The
52 | source code is well documented and organized in sections. Please have
53 | a look at it.
54 |
55 | Please have a look at the [[file:examples/navigel-ex-fs.el][examples/navigel-ex-fs.el]] file for an
56 | example on how to use the library. This file guides the reader through
57 | an implementation of a tablist-based directory navigator with support
58 | for marking and deleting:
59 |
60 | [[file:media/files.png]]
61 |
62 | ** License
63 |
64 | See [[file:COPYING][COPYING]]. Copyright (c) 2019-2023 Damien Cassou.
65 |
66 | #+BEGIN_HTML
67 |
68 |
69 |
70 | #+END_HTML
71 |
72 | # LocalWords: navigel tablist tablists
73 |
--------------------------------------------------------------------------------
/examples/navigel-ex-fs.el:
--------------------------------------------------------------------------------
1 | ;;; navigel-ex-fs.el --- Example of navigel to navigate the filesystem -*- lexical-binding: t; -*-
2 |
3 | ;; Copyright (C) 2019-2023 Damien Cassou
4 |
5 | ;; Author: Damien Cassou
6 |
7 | ;; This program is free software; you can redistribute it and/or modify
8 | ;; it under the terms of the GNU General Public License as published by
9 | ;; the Free Software Foundation, either version 3 of the License, or
10 | ;; (at your option) any later version.
11 |
12 | ;; This program is distributed in the hope that it will be useful,
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 | ;; GNU General Public License for more details.
16 |
17 | ;; You should have received a copy of the GNU General Public License
18 | ;; along with this program. If not, see .
19 |
20 | ;;; Commentary:
21 |
22 | ;; This file is an example usage of navigel. It guides the reader
23 | ;; through an implementation of a tablist-based directory navigator.
24 |
25 | ;; In this example, we will implement a tablist-based UI to navigate
26 | ;; the folders of your computer. As in dired, we want one file or
27 | ;; directory per line. Pressing `RET' on a line should open the file
28 | ;; or directory at point. Pressing `m' should mark the file at point
29 | ;; while `d' should delete all marked files.
30 |
31 | ;;; Code:
32 |
33 | (require 'f)
34 |
35 | (require 'navigel)
36 |
37 | ;; Navigel is based on the notion of "entity". In our example of a
38 | ;; directory navigator, the entities will be absolute filenames.
39 |
40 | ;; Navigel requires the developer to implement a command that calls
41 | ;; `navigel-open' on the initial entity. Navigel also requires an
42 | ;; application name dynamically bound in the variable `navigel-app'.
43 | ;; This name is meant to disambiguate method definitions and is *not*
44 | ;; visible to the user. In this example, we use `navigel-ex-fs'
45 | ;; as name. The code below defines the command:
46 |
47 | (defun navigel-ex-fs-list-files (&optional directory)
48 | "List files of DIRECTORY, home directory if nil."
49 | (interactive (list (getenv "HOME")))
50 | (let ((navigel-app 'navigel-ex-fs))
51 | (navigel-open (f-expand directory) nil)))
52 |
53 | ;; For this command to display the files in the home directory (i.e.,
54 | ;; "~/"), navigel needs a way to get the children of a file entity.
55 | ;; Specifying behavior with navigel is done through method overriding.
56 | ;; How to get the children of an entity should be specified by
57 | ;; overriding the method `navigel-children':
58 |
59 | (navigel-method navigel-ex-fs navigel-children (directory callback)
60 | "Call CALLBACK with the files in DIRECTORY as parameter."
61 | (funcall callback (f-entries directory)))
62 |
63 | ;; `navigel-method' (which is syntactic sugar around `cl-defmethod')
64 | ;; is used to override the methods of navigel. To distinguish this
65 | ;; override of `navigel-children' from other overrides made by other
66 | ;; navigel clients, the first parameter to `navigel-method' must be
67 | ;; the name of the application saved in `navigel-app' in the command
68 | ;; above.
69 |
70 | ;; At this point, you should be able to type `M-x
71 | ;; navigel-ex-fs-list-files RET' to get a buffer showing all
72 | ;; files and folders in your home directory. If you move the point to
73 | ;; a folder and press `RET', a new buffer should open listing its
74 | ;; files and folders. If you type `M-x imenu RET', you can select one
75 | ;; entity of the buffer using completion: I recommend binding this
76 | ;; command or `counsel-imenu' to a key (e.g., to `M-i') because this
77 | ;; can be useful in many kinds of buffers.
78 |
79 | ;; A problem though: the absolute filenames (e.g., "/home/me/.bashrc")
80 | ;; are shown whereas a user probably expects to see basenames (e.g.,
81 | ;; ".bashrc") as in all file browsers. We can easily change that by
82 | ;; overriding the `navigel-name' method:
83 |
84 | (navigel-method navigel-ex-fs navigel-name (file)
85 | (f-filename file))
86 |
87 | ;; This is much better. With `RET', we can easily navigate from a
88 | ;; folder to its sub-folders. Nevertheless, we have no way yet to
89 | ;; navigate back, i.e., from a folder to its parent. To do that, we
90 | ;; need to override the `navigel-parent' method whose responsibility
91 | ;; is to return the parent entity of the entity passed as parameter:
92 |
93 | (navigel-method navigel-ex-fs navigel-parent (file)
94 | (f-dirname file))
95 |
96 | ;; You should now be able to press `^' to go to the parent directory
97 | ;; of the current one.
98 |
99 | ;; Pressing `RET' on a folder correctly opens the folder in another
100 | ;; navigel buffer. But, just like in `dired', you might want that
101 | ;; pressing `RET' on a file opens the file itself. This can be done
102 | ;; by overriding `navigel-open':
103 |
104 | (navigel-method navigel-ex-fs navigel-open (file _target)
105 | (if (f-file-p file)
106 | (find-file file)
107 | (cl-call-next-method)))
108 |
109 | ;; The `cl-call-next-method' call is used to express that we don't
110 | ;; have anything specific to do for a non-file first parameter and
111 | ;; that we want the default behavior. This works perfectly fine!
112 |
113 | ;; We can improve the list of files a bit by adding some more
114 | ;; information about each file. For example, we could have a first
115 | ;; column representing the size of each file. We start by
116 | ;; implementing a function returning the size of its file argument:
117 |
118 | (defun navigel-ex-fs-size (file)
119 | "Return FILE size as number of bytes."
120 | (nth 7 (file-attributes file)))
121 |
122 | ;; We now specify the column values for each file by overriding
123 | ;; `navigel-entity-to-columns':
124 |
125 | (navigel-method navigel-ex-fs navigel-entity-to-columns (file)
126 | (vector (number-to-string (navigel-ex-fs-size file))
127 | (navigel-name file)))
128 |
129 | ;; The code above specifies that the first column of a file line will
130 | ;; contain the file size and the second will contain the filename. We
131 | ;; aren't exactly done yet as we also need to specify what each column
132 | ;; should look like. This is done by overriding
133 | ;; `navigel-tablist-format':
134 |
135 | (navigel-method navigel-ex-fs navigel-tablist-format (_entity)
136 | (vector (list "Size (B)" 10 nil :right-align t)
137 | (list "Name" 0 t)))
138 |
139 | ;; This code defines the format of columns. The first column will have
140 | ;; "Size (B)" as title to indicate that the displayed numbers
141 | ;; represent the size in bytes. The first column will be 10
142 | ;; characters wide and the numbers will be right aligned. The second
143 | ;; column will have "Name as title and will take the rest of the
144 | ;; buffer width. Read the documentation of `tabulated-list-format' to
145 | ;; get more information about the column format specification.
146 |
147 | ;; By default, navigel first sets the header information and then
148 | ;; proceeds to read the children of the current entity to display
149 | ;; them. If you need to use the list of children to decide the format
150 | ;; of the header, you can override `navigel-tablist-format-children',
151 | ;; which is called _after_ the entities returned by `navigel-children'
152 | ;; are available.
153 |
154 | ;; As a final step, we might want to be able to delete files from the
155 | ;; file system. This can be done by overriding `navigel-delete':
156 |
157 | (navigel-method navigel-ex-fs navigel-delete (file &optional callback)
158 | (f-delete file)
159 | (funcall callback))
160 |
161 | ;; The `funcall' is here to tell navigel that deletion is
162 | ;; finished. You can now mark files with `m' and delete them with `D'.
163 |
164 | ;; By default, all entities of the new application will be displayed
165 | ;; in their own buffers, named using the generic function
166 | ;; `navigel-name'. Users of your application can ask navigel to reuse
167 | ;; the same buffer for all entities in the app by customizing the
168 | ;; variable `navigel-single-buffer-apps'. The name of this single
169 | ;; buffer when it is displaying a given entity is constructed using
170 | ;; the generic function `navigel-single-buffer-name'.
171 |
172 | (provide 'navigel-ex-fs)
173 | ;;; navigel-ex-fs.el ends here
174 |
--------------------------------------------------------------------------------
/media/files.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/DamienCassou/navigel/5f2f2ecfbd91c35bfbe4946915462872acf58310/media/files.png
--------------------------------------------------------------------------------
/navigel.el:
--------------------------------------------------------------------------------
1 | ;;; navigel.el --- Facilitate the creation of tabulated-list based UIs -*- lexical-binding: t; -*-
2 |
3 | ;; Copyright (C) 2019-2023 Damien Cassou
4 |
5 | ;; Author: Damien Cassou
6 | ;; Url: https://github.com/DamienCassou/navigel
7 | ;; Package-requires: ((emacs "25.1") (tablist "1.0"))
8 | ;; Version: 1.0.0
9 |
10 | ;; This program is free software; you can redistribute it and/or modify
11 | ;; it under the terms of the GNU General Public License as published by
12 | ;; the Free Software Foundation, either version 3 of the License, or
13 | ;; (at your option) any later version.
14 |
15 | ;; This program is distributed in the hope that it will be useful,
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 | ;; GNU General Public License for more details.
19 |
20 | ;; You should have received a copy of the GNU General Public License
21 | ;; along with this program. If not, see .
22 |
23 | ;;; Commentary:
24 |
25 | ;; This library makes it simpler for Emacs Lisp developers to define
26 | ;; user-interfaces based on tablists (also known as tabulated-lists).
27 | ;; Overriding a few (CL) methods and calling `navigel-open' is all
28 | ;; that's required to get a nice UI to navigate your domain objects
29 | ;; (e.g., files, music library, database).
30 | ;;
31 | ;; Features include :
32 | ;;
33 | ;; - pressing RET to open the entity at point in another buffer;
34 | ;; - pressing ^ to open the current entity's parent;
35 | ;; - marking entities for bulk operations (e.g., delete);
36 | ;; - `imenu' support for quick navigation;
37 |
38 | ;;; Code:
39 |
40 | (require 'tablist)
41 | (require 'seq)
42 | (require 'map)
43 | (require 'bookmark)
44 |
45 |
46 | ;; Customization
47 |
48 | (defgroup navigel nil
49 | "Navigel."
50 | :group 'magit-extensions)
51 |
52 | (defcustom navigel-changed-hook nil
53 | "Normal hook run after a navigel's tablist buffer changed."
54 | :type 'hook)
55 |
56 | (defcustom navigel-init-done-hook nil
57 | "Normal hook run after a navigel's tablist buffer has been initially populated."
58 | :type 'hook)
59 |
60 | (defcustom navigel-display-messages t
61 | "Whether to display navigel's informative messages in the echo area."
62 | :type 'boolean)
63 |
64 | (defcustom navigel-single-buffer-apps nil
65 | "Applications using a single buffer to display all entities.
66 |
67 | Either a list of symbols denoting applications, t for all
68 | applications or nil, the default, for none."
69 | :type '(choice (const :tag "None" nil)
70 | (const :tag "All applications" t)
71 | (repeat (symbol :tag "Application"))))
72 |
73 |
74 | ;; Private variables
75 |
76 | (defvar navigel-entity nil
77 | "Specify the entity that was used to generate the buffer.")
78 |
79 | (defvar navigel-app nil
80 | "Specify the application that was used to generate the buffer.")
81 |
82 | (defvar navigel-single-buffers nil
83 | "An alist of (APP . BUFFER) associating app symbols with their buffer name.
84 |
85 | This name is used only for applications that are working in single-buffer mode.")
86 |
87 | (defvar-local navigel--state-cache nil
88 | "Cache of entity states for single-buffer applications.
89 |
90 | This cache is an alist of (APP . STATE) pairs, where in turn
91 | STATE is an alist of (ENTITY-ID . ENTITY-STATE) pairs,
92 | associating to each entity that has been displayed by APP in this
93 | buffer its last state (as returned by `navigel--save-state').")
94 |
95 |
96 | ;; Private functions
97 |
98 | (defun navigel--tablist-operation-function (operation &rest args)
99 | "Setup `tablist' operations in current buffer.
100 |
101 | OPERATION and ARGS are defined by `tablist-operations-function'."
102 | (cl-case operation
103 | (supported-operations '(find-entry delete))
104 | (find-entry (navigel-open (car args) nil))
105 | (delete (navigel-delete (car args) #'navigel--revert-buffer))))
106 |
107 | (defun navigel--imenu-extract-index-name ()
108 | "Return the name of entity at point for `imenu'.
109 | This function is used as a value for
110 | `imenu-extract-index-name-function'. Point should be at the
111 | beginning of the line."
112 | (navigel-imenu-name (tabulated-list-get-id)))
113 |
114 | (defun navigel--imenu-prev-index-position ()
115 | "Move point to previous line in current buffer.
116 | This function is used as a value for
117 | `imenu-prev-index-position-function'."
118 | (unless (bobp)
119 | (forward-line -1)))
120 |
121 | (defun navigel-go-to-entity (entity)
122 | "Move point to ENTITY.
123 | Return non-nil if ENTITY is found, nil otherwise."
124 | (goto-char (point-min))
125 | (while (and (not (= (point) (point-max)))
126 | (not (navigel-equal (navigel-entity-at-point) entity)))
127 | (forward-line 1))
128 | (not (= (point) (point-max))))
129 |
130 | ;; CL Context rewriter: this lets users write "&context (navigel-app
131 | ;; something)" instead of "&context (navigel-app (eql something))"
132 | (cl-generic-define-context-rewriter navigel-app (app)
133 | `(navigel-app (eql ,app)))
134 |
135 | (defun navigel--bookmark-jump (bookmark)
136 | "Open a navigel buffer showing BOOKMARK."
137 | (let ((entity (bookmark-prop-get bookmark 'navigel-entity))
138 | (target (bookmark-prop-get bookmark 'navigel-target))
139 | (navigel-app (bookmark-prop-get bookmark 'navigel-app)))
140 | (navigel-open entity target)
141 | (message "Current buffer at the end of navigel--bookmark-jump: %s" (current-buffer))))
142 |
143 | (defun navigel--message (&rest args)
144 | "Display a message in the echo area.
145 | This function only has an effect when `navigel-display-messages'
146 | is true. ARGS are the message format followed by any arguments
147 | it takes."
148 | (when navigel-display-messages
149 | (apply #'message args)))
150 |
151 |
152 | ;; Generic methods: Those methods are the one you may override.
153 |
154 | (cl-defgeneric navigel-name (entity)
155 | "Return a short string describing ENTITY.
156 |
157 | The returned value is the default for `navigel-buffer-name',
158 | `navigel-tablist-name' and `navigel-imenu-name'. Those can be
159 | overridden separately if necessary."
160 | (format "%s" entity))
161 |
162 | (cl-defgeneric navigel-entity-id (entity)
163 | "Return a possibly unique identifier for the given ENTITY.
164 |
165 | Under some circumstances, Navigel will cache information about
166 | displayed entities, using its id as key. By default, this
167 | function calls `navigel-name', which should be good enough in the
168 | majority of cases."
169 | (navigel-name entity))
170 |
171 | (cl-defgeneric navigel-buffer-name (entity)
172 | "Return a string representing ENTITY in the buffer's name."
173 | (navigel-name entity))
174 |
175 | (cl-defgeneric navigel-single-buffer-name (app entity)
176 | "Return a string representing ENTITY in the buffer's name, for single-buffer APP."
177 | (let ((app (or app navigel-app 'navigel))
178 | (suffix (if entity (format " - %s" (navigel-buffer-name entity)) "")))
179 | (format "*%s%s*" app suffix)))
180 |
181 | (cl-defgeneric navigel-tablist-name (entity)
182 | "Return a string representing ENTITY in tablist columns."
183 | (navigel-name entity))
184 |
185 | (cl-defgeneric navigel-imenu-name (entity)
186 | "Return a string representing ENTITY for `imenu'."
187 | (navigel-name entity))
188 |
189 | (cl-defgeneric navigel-bookmark-name (entity)
190 | "Return a string representing ENTITY for `bookmark'."
191 | (navigel-name entity))
192 |
193 | (cl-defgeneric navigel-children (entity callback)
194 | "Execute CALLBACK with the list of ENTITY's children as argument.
195 | This method must be overridden for any tablist view to work.")
196 |
197 | (cl-defmethod navigel-children ((entities list) callback)
198 | "Execute CALLBACK with the children of ENTITIES as argument."
199 | (navigel-async-mapcar #'navigel-children entities callback))
200 |
201 | (cl-defgeneric navigel-parent (_entity)
202 | "Return the parent of ENTITY if possible, nil if not."
203 | nil)
204 |
205 | (cl-defgeneric navigel-equal (entity1 entity2)
206 | "Return non-nil if ENTITY1 and ENTITY2 represent the same entity."
207 | (equal entity1 entity2))
208 |
209 | (cl-defgeneric navigel-entity-at-point ()
210 | "Return the entity at point or nil if none.")
211 |
212 | (cl-defmethod navigel-entity-at-point (&context (major-mode (derived-mode navigel-tablist-mode)))
213 | "Return the entity at point in the context of a mode derived from MAJOR-MODE."
214 | (or (tabulated-list-get-id) navigel-entity))
215 |
216 | (cl-defgeneric navigel-marked-entities (&optional _at-point-if-empty)
217 | "Return a list of entities that are selected.
218 | If no entity is selected and AT-POINT-IF-EMPTY is non-nil, return
219 | a list with just the entity at point."
220 | nil)
221 |
222 | (cl-defmethod navigel-marked-entities (&context (major-mode (derived-mode navigel-tablist-mode))
223 | &optional at-point-if-empty)
224 | "Return a list with marked entities for MAJOR-MODE derived from a tablist.
225 |
226 | AT-POINT-IF-EMPTY indicates whether to return the entity at point if none
227 | is marked."
228 | ;; `tablist-get-marked-items' automatically includes the entity at
229 | ;; point if no entity is marked. We have to remove it unless
230 | ;; `at-point-if-empty' is non-nil.
231 | (let ((entities (mapcar #'car (tablist-get-marked-items))))
232 | (if (or (> (length entities) 1)
233 | (save-excursion ;; check if the entity is really marked
234 | (navigel-go-to-entity (car entities))
235 | (tablist-get-mark-state))
236 | at-point-if-empty)
237 | entities
238 | (list))))
239 |
240 | (cl-defgeneric navigel-entity-buffer (entity)
241 | "Return a buffer name for ENTITY.
242 | The default name is based on `navigel-app' and `navigel-buffer-name'."
243 | (format "*%s-%s*" navigel-app (navigel-buffer-name entity)))
244 |
245 | (cl-defgeneric navigel-entity-tablist-mode (_entity)
246 | "Enable the `major-mode' most suited to display children of ENTITY."
247 | (navigel-tablist-mode))
248 |
249 | (cl-defgeneric navigel-tablist-format (_entity)
250 | "Return a vector specifying columns to display ENTITY's children.
251 | The return value is set as `tabulated-list-format'."
252 | (vector (list "Name" 0 t)))
253 |
254 | (cl-defgeneric navigel-tablist-format-children (_entity &optional _children)
255 | "Return a vector specifying columns to display ENTITY's CHILDREN.
256 | The return value is set as `tabulated-list-format' after the list
257 | of children has been retrieved, unless this call returns nil."
258 | nil)
259 |
260 | (cl-defgeneric navigel-entity-to-columns (entity)
261 | "Return the column descriptors to display ENTITY in a tabulated list.
262 | The return value is a vector for `tabulated-list-entries'.
263 |
264 | The vector should be compatible to the one defined with
265 | `navigel-tablist-format'."
266 | (vector (navigel-tablist-name entity)))
267 |
268 | (cl-defgeneric navigel-open (entity target)
269 | "Open a buffer displaying ENTITY.
270 | If TARGET is non-nil and is in buffer, move point to it.
271 |
272 | By default, list ENTITY's children in a tabulated list."
273 | (navigel--list-children entity target))
274 |
275 | (cl-defgeneric navigel-parent-to-open (entity)
276 | "Return an indication of what to open if asked to open the parent of ENTITY.
277 | Return nil if there is no parent to open.
278 |
279 | The return value is (PARENT . ENTITY), where PARENT is the entity
280 | to open and ENTITY is the entity to move point to."
281 | (cons (navigel-parent entity) entity))
282 |
283 | (cl-defmethod navigel-parent-to-open (entity &context (major-mode navigel-tablist-mode))
284 | "Parent or ENTITY to open in the context of MAJOR-MODE derived from tablist."
285 | ;; Override default implementation because, in navigel-tablist-mode,
286 | ;; opening the parent of the entity at point would usually result in
287 | ;; opening the current buffer again. This is because the current
288 | ;; buffer typically already displays the parent of the entity at
289 | ;; point.
290 | (let* ((parent (navigel-parent entity))
291 | (ancestor (and parent (navigel-parent parent))))
292 | (cond ((and ancestor (navigel-equal parent navigel-entity))
293 | (cons ancestor parent))
294 | ((and parent (not (navigel-equal parent navigel-entity)))
295 | (cons parent entity))
296 | (t nil))))
297 |
298 | (cl-defgeneric navigel-delete (_entity &optional _callback)
299 | "Remove ENTITY from its parent.
300 | If non-nil, call CALLBACK with no parameter when done."
301 | (user-error "This operation is not supported in this context"))
302 |
303 | (cl-defmethod navigel-delete ((entities list) &optional callback)
304 | "Remove each item of ENTITIES from its parent.
305 | If non-nil, call CALLBACK with no parameter when done."
306 | (navigel-async-mapc #'navigel-delete entities callback))
307 |
308 | (cl-defmethod navigel-make-bookmark ()
309 | "Return a record to bookmark the current buffer.
310 |
311 | This function is to be used as value for
312 | `bookmark-make-record-function' in navigel buffers."
313 | `(
314 | ,(navigel-bookmark-name navigel-entity)
315 | ((handler . ,#'navigel--bookmark-jump)
316 | (navigel-entity . ,navigel-entity)
317 | (navigel-target . ,(navigel-entity-at-point))
318 | (navigel-app . ,navigel-app))))
319 |
320 |
321 | ;;; Public functions
322 |
323 | (defun navigel-single-buffer-app-p (app)
324 | "Check whether APP is registered as a single-buffer application.
325 |
326 | See also `navigel-single-buffer-apps'."
327 | (or (eq t navigel-single-buffer-apps)
328 | (memq app navigel-single-buffer-apps)))
329 |
330 | (defun navigel-register-single-buffer-app (app)
331 | "Register APP as a single buffer application."
332 | (or (navigel-single-buffer-app-p app)
333 | (add-to-list 'navigel-single-buffer-apps app)))
334 |
335 | (defun navigel-app-buffer (app)
336 | "If APP is a single-buffer application, return its buffer."
337 | (navigel--app-buffer app t))
338 |
339 | (defun navigel-async-mapcar (mapfn list callback)
340 | "Apply MAPFN to each element of LIST and pass result to CALLBACK.
341 |
342 | MAPFN is a function taking 2 arguments: the element to map and a
343 | callback to call when the mapping is done."
344 | (if (not list)
345 | (funcall callback nil)
346 | (let ((result (make-vector (length list) nil))
347 | (count 0))
348 | (cl-loop for index below (length list)
349 | for item in list
350 | do (let ((index index) (item item))
351 | (funcall
352 | mapfn
353 | item
354 | (lambda (item-result)
355 | (setf (seq-elt result index) item-result)
356 | (cl-incf count)
357 | (when (eq count (length list))
358 | ;; use `run-at-time' to ensure that CALLBACK is
359 | ;; consistently called asynchronously even if MAPFN is
360 | ;; synchronous:
361 | (run-at-time
362 | 0 nil
363 | callback
364 | (seq-concatenate 'list result))))))))))
365 |
366 | (defun navigel-async-mapc (mapfn list callback)
367 | "Same as `navigel-async-mapcar' but for side-effects only.
368 |
369 | MAPFN is a function taking 2 arguments: an element of LIST and a
370 | callback. MAPFN should call the callback with no argument when
371 | done computing.
372 |
373 | CALLBACK is a function of no argument that is called when done
374 | computing for the all elements of LIST."
375 | (navigel-async-mapcar
376 | (lambda (item callback) (funcall mapfn item (lambda () (funcall callback nil))))
377 | list
378 | (lambda (_result) (funcall callback))))
379 |
380 | (defun navigel-open-parent (&optional entity)
381 | "Open in a new buffer the parent of ENTITY, entity at point if nil."
382 | (interactive (list (navigel-entity-at-point)))
383 | (when entity
384 | (pcase (navigel-parent-to-open entity)
385 | (`(,parent . ,entity) (navigel-open parent entity))
386 | (_ (message "No parent to go to")))))
387 |
388 | (defun navigel-refresh (&optional target callback)
389 | "Compute `navigel-entity' children and list those in the current buffer.
390 |
391 | If TARGET is non-nil and is in buffer, move point to it.
392 |
393 | If CALLBACK is non nil, execute it when the buffer has been
394 | refreshed."
395 | (let ((entity navigel-entity)
396 | ;; save navigel-app so we can rebind below
397 | (app navigel-app))
398 | (navigel--message (if (equal (point-min) (point-max))
399 | "Populating…"
400 | "Refreshing…"))
401 | (navigel-children
402 | entity
403 | (lambda (children)
404 | ;; restore navigel-app
405 | (let ((navigel-app app) state)
406 | (with-current-buffer (navigel--entity-buffer app entity)
407 | (let ((fmt (navigel-tablist-format-children entity children)))
408 | (when fmt
409 | (setq-local tabulated-list-format fmt)
410 | (tabulated-list-init-header)))
411 | (setq state (navigel--save-state))
412 | (setq-local tabulated-list-entries
413 | (mapcar (lambda (child)
414 | (list child (navigel-entity-to-columns child)))
415 | children))
416 | (tabulated-list-print)
417 | (when (not (navigel-single-buffer-app-p app))
418 | (navigel--restore-state state))
419 | (when target
420 | (navigel-go-to-entity target))
421 | (run-hooks 'navigel-changed-hook)
422 | (when callback
423 | (funcall callback))
424 | (navigel--message "Ready!")))))))
425 |
426 | (defmacro navigel-method (app name args &rest body)
427 | "Define a method NAME with ARGS and BODY.
428 | This method will only be active if `navigel-app' equals APP."
429 | (declare (indent 3))
430 | `(cl-defmethod ,name ,(navigel--insert-context-in-args app args)
431 | ,@body))
432 |
433 |
434 | ;;; Private functions
435 |
436 | (defvar bookmark-make-record-function)
437 |
438 | (defun navigel--list-children (entity &optional target)
439 | "Open a new buffer showing ENTITY's children.
440 |
441 | If TARGET is non-nil and is in buffer, move point to it.
442 |
443 | Interactively, ENTITY is either the element at point or the user
444 | is asked for a top level ENTITY."
445 | ;; save navigel-app because (navigel-tablist-mode) will reset it
446 | (let ((app navigel-app)
447 | (prev-entity navigel-entity)
448 | (single (navigel-single-buffer-app-p navigel-app))
449 | (buffer (navigel--entity-buffer navigel-app entity))
450 | cache)
451 | (with-current-buffer buffer
452 | ;; set navigel-app first because it is used on the line below to
453 | ;; select the appropriate mode:
454 | (setq-local navigel-app app)
455 | (when single
456 | (when prev-entity (navigel--cache-state prev-entity))
457 | (setq cache navigel--state-cache))
458 | (navigel-entity-tablist-mode entity)
459 | ;; restore navigel-app because is got erased by activating the major mode:
460 | (setq-local navigel-app app)
461 | (setq-local tabulated-list-padding 2) ; for `tablist'
462 | (setq-local navigel-entity entity)
463 | (when single
464 | (setq-local navigel--state-cache cache)
465 | (rename-buffer (navigel-single-buffer-name app entity) t))
466 | (setq-local tablist-operations-function #'navigel--tablist-operation-function)
467 | (setq-local revert-buffer-function #'navigel--revert-buffer)
468 | (setq-local imenu-prev-index-position-function
469 | #'navigel--imenu-prev-index-position)
470 | (setq-local imenu-extract-index-name-function
471 | #'navigel--imenu-extract-index-name)
472 | (setq-local tabulated-list-format (navigel-tablist-format entity))
473 | (setq-local bookmark-make-record-function #'navigel-make-bookmark)
474 | (tabulated-list-init-header)
475 | (navigel-refresh
476 | nil
477 | (lambda ()
478 | (with-current-buffer buffer
479 | (when (and single entity)
480 | (navigel--restore-state (navigel--cached-state entity)))
481 | (if target (navigel-go-to-entity target) (goto-char (point-min)))
482 | (run-hooks 'navigel-init-done-hook)))))
483 | (switch-to-buffer buffer)))
484 |
485 | (defun navigel--save-state ()
486 | "Return an object representing the state of the current buffer.
487 | This should be restored with `navigel--restore-state'.
488 |
489 | The state contains the entity at point, the column of point, and
490 | the marked entities."
491 | `(
492 | (entity-at-point . ,(navigel-entity-at-point))
493 | (column . ,(current-column))
494 | (marked-entities . ,(navigel-marked-entities))))
495 |
496 | (defun navigel--restore-state (state)
497 | "Restore STATE. This was saved with `navigel--save-state'."
498 | (let-alist state
499 | (if .entity-at-point
500 | (navigel-go-to-entity .entity-at-point)
501 | (goto-char (point-min)))
502 | (when .column
503 | (goto-char (line-beginning-position))
504 | (forward-char .column))
505 | (when .marked-entities
506 | (save-excursion
507 | (dolist (entity .marked-entities)
508 | (when (navigel-go-to-entity entity)
509 | (tablist-put-mark)))))))
510 |
511 | (defun navigel--forget-single-buffer ()
512 | "Remove the entry for the current buffer in `navigel-single-buffers."
513 | (map-delete navigel-single-buffers navigel-app))
514 |
515 | (defun navigel--single-app-buffer-create (app)
516 | "Create and return a buffer for the given APP, setting it up for single mode."
517 | (let ((buffer (get-buffer-create (navigel-single-buffer-name app nil))))
518 | (setf (alist-get app navigel-single-buffers) buffer)
519 | (with-current-buffer buffer
520 | (add-hook 'kill-buffer-hook #'navigel--forget-single-buffer nil t)
521 | (setq-local navigel-app app))
522 | buffer))
523 |
524 | (defun navigel--app-buffer (app &optional no-create)
525 | "If APP is a single-buffer application, find or create its buffer.
526 |
527 | If NO-CREATE is not nil, do not create a fresh buffer if one does
528 | not already exist."
529 | (when (navigel-single-buffer-app-p app)
530 | (let ((buffer (alist-get app navigel-single-buffers)))
531 | (when (and (not (buffer-live-p buffer)) (not no-create))
532 | (setq buffer (navigel--single-app-buffer-create app)))
533 | buffer)))
534 |
535 | (defun navigel--entity-buffer (app entity)
536 | "Return the buffer that APP should use for the given ENTITY."
537 | (or (navigel--app-buffer app)
538 | (get-buffer-create (navigel-entity-buffer entity))))
539 |
540 | (defun navigel--cache-state (entity)
541 | "Save in the local cache the state of ENTITY, as displayed in the current buffer."
542 | (let ((id (when entity (navigel-entity-id entity))))
543 | (when id
544 | (when (not navigel--state-cache)
545 | (setq-local navigel--state-cache ()))
546 | (setf (alist-get id navigel--state-cache nil nil #'equal)
547 | (navigel--save-state)))))
548 |
549 | (defun navigel--cached-state (&optional entity app)
550 | "Return the cached state of the given ENTITY, in application APP.
551 |
552 | ENTITY and APP default to the local values of `navigel-entity' and
553 | `navigel-app'."
554 | (let ((entity (or entity navigel-entity)))
555 | (when entity
556 | (let ((app-buffer (navigel--app-buffer (or app navigel-app))))
557 | (when app-buffer
558 | (cdr (assoc (navigel-entity-id entity)
559 | (buffer-local-value 'navigel--state-cache app-buffer))))))))
560 |
561 | (defun navigel--revert-buffer (&rest _args)
562 | "Compute `navigel-entity' children and list those in the current buffer."
563 | (navigel-refresh))
564 |
565 | (defun navigel--insert-context-in-args (app args)
566 | "Return an argument list with a &context specializer for APP within ARGS."
567 | (let ((result (list))
568 | (rest-args args))
569 | (catch 'found-special-arg
570 | (while rest-args
571 | (let ((arg (car rest-args)))
572 | (when (symbolp arg)
573 | (when (eq arg '&context)
574 | (throw 'found-special-arg
575 | (append (nreverse result)
576 | `(&context (navigel-app ,app))
577 | (cdr rest-args))))
578 | (when (string= "&" (substring-no-properties (symbol-name arg) 0 1))
579 | (throw 'found-special-arg
580 | (append (nreverse result)
581 | `(&context (navigel-app ,app))
582 | rest-args))))
583 | (setq result (cons arg result))
584 | (setq rest-args (cdr rest-args))))
585 | (append (nreverse result) `(&context (navigel-app ,app))))))
586 |
587 |
588 | ;;; Major mode
589 |
590 | (defvar navigel-tablist-mode-map
591 | (let ((map (make-sparse-keymap)))
592 | (define-key map (kbd "^") #'navigel-open-parent)
593 | map)
594 | "Keymap for `navigel-tablist-mode'.")
595 |
596 | (define-derived-mode navigel-tablist-mode tablist-mode "navigel-tablist"
597 | "Major mode for all elcouch listing modes.")
598 |
599 | (provide 'navigel)
600 | ;;; navigel.el ends here
601 |
602 | ;;; LocalWords: navigel tablist tablists keymap
603 |
--------------------------------------------------------------------------------
/test/navigel-test.el:
--------------------------------------------------------------------------------
1 | ;;; navigel-test.el --- Tests for navigel.el -*- lexical-binding: t; -*-
2 |
3 | ;; Copyright (C) 2019-2023 Damien Cassou
4 |
5 | ;; Author: Damien Cassou
6 |
7 | ;; This program is free software; you can redistribute it and/or modify
8 | ;; it under the terms of the GNU General Public License as published by
9 | ;; the Free Software Foundation, either version 3 of the License, or
10 | ;; (at your option) any later version.
11 |
12 | ;; This program is distributed in the hope that it will be useful,
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 | ;; GNU General Public License for more details.
16 |
17 | ;; You should have received a copy of the GNU General Public License
18 | ;; along with this program. If not, see .
19 |
20 | ;;; Commentary:
21 |
22 | ;; Tests for navigel.el.
23 |
24 | ;;; Code:
25 |
26 | (require 'navigel)
27 |
28 | (require 'ert)
29 |
30 | (require 'cl-lib)
31 |
32 | (ert-deftest navigel-insert-context-in-args ()
33 | (progn
34 | ;; no arguments:
35 | (should (equal
36 | (navigel--insert-context-in-args 'foo '())
37 | '(&context (navigel-app foo))))
38 | ;; only mandatory arguments:
39 | (should (equal
40 | (navigel--insert-context-in-args 'foo '(a))
41 | '(a &context (navigel-app foo))))
42 | ;; special argument:
43 | (should (equal
44 | (navigel--insert-context-in-args 'foo '(a &optional b))
45 | '(a &context (navigel-app foo) &optional b)))
46 | ;; context argument:
47 | (should (equal
48 | (navigel--insert-context-in-args 'foo '(a &context (a b)))
49 | '(a &context (navigel-app foo) (a b))))
50 | ;; special + context argument:
51 | (should (equal
52 | (navigel--insert-context-in-args 'foo '(a &context (a b) &optional b))
53 | '(a &context (navigel-app foo) (a b) &optional b)))))
54 |
55 | (provide 'navigel-test)
56 | ;;; navigel-test.el ends here
57 |
--------------------------------------------------------------------------------