Emacs library to facilitate the creation of tabulated-list based UIs
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

601 lines
23KB

  1. ;;; navigel.el --- Facilitate the creation of tabulated-list based UIs -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2019, 2020 Damien Cassou
  3. ;; Author: Damien Cassou <damien@cassou.me>
  4. ;; Url: https://gitlab.petton.fr/DamienCassou/navigel
  5. ;; Package-requires: ((emacs "25.1") (tablist "1.0"))
  6. ;; Version: 0.7.0
  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. ;; This program is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;; GNU General Public License for more details.
  15. ;; You should have received a copy of the GNU General Public License
  16. ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
  17. ;;; Commentary:
  18. ;; This library makes it simpler for Emacs Lisp developers to define
  19. ;; user-interfaces based on tablists (also known as tabulated-lists).
  20. ;; Overriding a few (CL) methods and calling `navigel-open' is all
  21. ;; that's required to get a nice UI to navigate your domain objects
  22. ;; (e.g., files, music library, database).
  23. ;;
  24. ;; Features include :
  25. ;;
  26. ;; - pressing RET to open the entity at point in another buffer;
  27. ;; - pressing ^ to open the current entity's parent;
  28. ;; - marking entities for bulk operations (e.g., delete);
  29. ;; - `imenu' support for quick navigation;
  30. ;;; Code:
  31. (require 'tablist)
  32. (require 'seq)
  33. (require 'map)
  34. (require 'bookmark)
  35. ;; Customization
  36. (defgroup navigel nil
  37. "Navigel."
  38. :group 'magit-extensions)
  39. (defcustom navigel-changed-hook nil
  40. "Normal hook run after a navigel's tablist buffer has been refreshed or populated."
  41. :type 'hook)
  42. (defcustom navigel-init-done-hook nil
  43. "Normal hook run after a navigel's tablist buffer has been initially populated."
  44. :type 'hook)
  45. (defcustom navigel-display-messages t
  46. "Whether to display navigel's informative messages in the echo area."
  47. :type 'boolean)
  48. (defcustom navigel-single-buffer-apps nil
  49. "Applications using a single buffer to display all entities.
  50. Either a list of symbols denoting applications, t for all
  51. applications or nil, the default, for none."
  52. :type '(choice (const :tag "None" nil)
  53. (const :tag "All applications" t)
  54. (repeat (symbol :tag "Application"))))
  55. ;; Private variables
  56. (defvar navigel-entity nil
  57. "Specify the entity that was used to generate the buffer.")
  58. (defvar navigel-app nil
  59. "Specify the application that was used to generate the buffer.")
  60. (defvar navigel-single-buffers nil
  61. "An alist of (APP . BUFFER) associating app symbols with their buffer name.
  62. This name is used only for applications that are working in single-buffer mode.")
  63. (defvar-local navigel--state-cache nil
  64. "Cache of entity states for single-buffer applications.
  65. This cache is an alist of (APP . STATE) pairs, where in turn
  66. STATE is an alist of (ENTITY-ID . ENTITY-STATE) pairs,
  67. associating to each entity that has been displayed by APP in this
  68. buffer its last state (as returned by `navigel--save-state').")
  69. ;; Private functions
  70. (defun navigel--tablist-operation-function (operation &rest args)
  71. "Setup `tablist' operations in current buffer.
  72. OPERATION and ARGS are defined by `tablist-operations-function'."
  73. (cl-case operation
  74. (supported-operations '(find-entry delete))
  75. (find-entry (navigel-open (car args) nil))
  76. (delete (navigel-delete (car args) #'navigel--revert-buffer))))
  77. (defun navigel--imenu-extract-index-name ()
  78. "Return the name of entity at point for `imenu'.
  79. This function is used as a value for
  80. `imenu-extract-index-name-function'. Point should be at the
  81. beginning of the line."
  82. (navigel-imenu-name (tabulated-list-get-id)))
  83. (defun navigel--imenu-prev-index-position ()
  84. "Move point to previous line in current buffer.
  85. This function is used as a value for
  86. `imenu-prev-index-position-function'."
  87. (unless (bobp)
  88. (forward-line -1)))
  89. (defun navigel-go-to-entity (entity)
  90. "Move point to ENTITY.
  91. Return non-nil if ENTITY is found, nil otherwise."
  92. (goto-char (point-min))
  93. (while (and (not (= (point) (point-max)))
  94. (not (navigel-equal (navigel-entity-at-point) entity)))
  95. (forward-line 1))
  96. (not (= (point) (point-max))))
  97. ;; CL Context rewriter: this lets users write "&context (navigel-app
  98. ;; something)" instead of "&context (navigel-app (eql something))"
  99. (cl-generic-define-context-rewriter navigel-app (app)
  100. `(navigel-app (eql ,app)))
  101. (defun navigel--bookmark-jump (bookmark)
  102. "Open a navigel buffer showing BOOKMARK."
  103. (let ((entity (bookmark-prop-get bookmark 'navigel-entity))
  104. (target (bookmark-prop-get bookmark 'navigel-target))
  105. (navigel-app (bookmark-prop-get bookmark 'navigel-app)))
  106. (navigel-open entity target)
  107. (message "Current buffer at the end of navigel--bookmark-jump: %s" (current-buffer))))
  108. (defun navigel--message (&rest args)
  109. "Display a message in the echo area.
  110. This function only has an effect when `navigel-display-messages'
  111. is true. ARGS are the message format followed by any arguments
  112. it takes."
  113. (when navigel-display-messages
  114. (apply #'message args)))
  115. ;; Generic methods: Those methods are the one you may override.
  116. (cl-defgeneric navigel-name (entity)
  117. "Return a short string describing ENTITY.
  118. The returned value is the default for `navigel-buffer-name',
  119. `navigel-tablist-name' and `navigel-imenu-name'. Those can be
  120. overridden separately if necessary."
  121. (format "%s" entity))
  122. (cl-defgeneric navigel-entity-id (entity)
  123. "Return a possibly unique identifier for the given ENTITY.
  124. Under some circumstances, Navigel will cache information about
  125. displayed entities, using its id as key. By default, this
  126. function calls `navigel-name', which should be good enough in the
  127. majority of cases."
  128. (navigel-name entity))
  129. (cl-defgeneric navigel-buffer-name (entity)
  130. "Return a string representing ENTITY in the buffer's name."
  131. (navigel-name entity))
  132. (cl-defgeneric navigel-single-buffer-name (app entity)
  133. "Return a string representing ENTITY in the buffer's name, for single-buffer APP."
  134. (let ((app (or app navigel-app 'navigel))
  135. (suffix (if entity (format " - %s" (navigel-buffer-name entity)) "")))
  136. (format "*%s%s*" app suffix)))
  137. (cl-defgeneric navigel-tablist-name (entity)
  138. "Return a string representing ENTITY in tablist columns."
  139. (navigel-name entity))
  140. (cl-defgeneric navigel-imenu-name (entity)
  141. "Return a string representing ENTITY for `imenu'."
  142. (navigel-name entity))
  143. (cl-defgeneric navigel-bookmark-name (entity)
  144. "Return a string representing ENTITY for `bookmark'."
  145. (navigel-name entity))
  146. (cl-defgeneric navigel-children (entity callback)
  147. "Execute CALLBACK with the list of ENTITY's children as argument.
  148. This method must be overridden for any tablist view to work.")
  149. (cl-defmethod navigel-children ((entities list) callback)
  150. "Execute CALLBACK with the children of ENTITIES as argument."
  151. (navigel-async-mapcar #'navigel-children entities callback))
  152. (cl-defgeneric navigel-parent (_entity)
  153. "Return the parent of ENTITY if possible, nil if not."
  154. nil)
  155. (cl-defgeneric navigel-equal (entity1 entity2)
  156. "Return non-nil if ENTITY1 and ENTITY2 represent the same entity."
  157. (equal entity1 entity2))
  158. (cl-defgeneric navigel-entity-at-point ()
  159. "Return the entity at point or nil if none.")
  160. (cl-defmethod navigel-entity-at-point (&context (major-mode (derived-mode navigel-tablist-mode)))
  161. "Return the entity at point in the context of a mode derived from MAJOR-MODE."
  162. (or (tabulated-list-get-id) navigel-entity))
  163. (cl-defgeneric navigel-marked-entities (&optional _at-point-if-empty)
  164. "Return a list of entities that are selected.
  165. If no entity is selected and AT-POINT-IF-EMPTY is non-nil, return
  166. a list with just the entity at point."
  167. nil)
  168. (cl-defmethod navigel-marked-entities (&context (major-mode (derived-mode navigel-tablist-mode))
  169. &optional at-point-if-empty)
  170. "Return a list with marked entities for MAJOR-MODE derived from a tablist.
  171. AT-POINT-IF-EMPTY indicates whether to return the entity at point if none
  172. is marked."
  173. ;; `tablist-get-marked-items' automatically includes the entity at
  174. ;; point if no entity is marked. We have to remove it unless
  175. ;; `at-point-if-empty' is non-nil.
  176. (let ((entities (mapcar #'car (tablist-get-marked-items))))
  177. (if (or (> (length entities) 1)
  178. (save-excursion ;; check if the entity is really marked
  179. (navigel-go-to-entity (car entities))
  180. (tablist-get-mark-state))
  181. at-point-if-empty)
  182. entities
  183. (list))))
  184. (cl-defgeneric navigel-entity-buffer (entity)
  185. "Return a buffer name for ENTITY.
  186. The default name is based on `navigel-app' and `navigel-buffer-name'."
  187. (format "*%s-%s*" navigel-app (navigel-buffer-name entity)))
  188. (cl-defgeneric navigel-entity-tablist-mode (_entity)
  189. "Enable the `major-mode' most suited to display children of ENTITY."
  190. (navigel-tablist-mode))
  191. (cl-defgeneric navigel-tablist-format (_entity)
  192. "Return a vector specifying columns to display ENTITY's children.
  193. The return value is set as `tabulated-list-format'."
  194. (vector (list "Name" 0 t)))
  195. (cl-defgeneric navigel-tablist-format-children (_entity &optional _children)
  196. "Return a vector specifying columns to display ENTITY's CHILDREN.
  197. The return value is set as `tabulated-list-format' after the list
  198. of children has been retrieved, unless this call returns nil."
  199. nil)
  200. (cl-defgeneric navigel-entity-to-columns (entity)
  201. "Return the column descriptors to display ENTITY in a tabulated list.
  202. The return value is a vector for `tabulated-list-entries'.
  203. The vector should be compatible to the one defined with
  204. `navigel-tablist-format'."
  205. (vector (navigel-tablist-name entity)))
  206. (cl-defgeneric navigel-open (entity target)
  207. "Open a buffer displaying ENTITY.
  208. If TARGET is non-nil and is in buffer, move point to it.
  209. By default, list ENTITY's children in a tabulated list."
  210. (navigel--list-children entity target))
  211. (cl-defgeneric navigel-parent-to-open (entity)
  212. "Return an indication of what to open if asked to open the parent of ENTITY.
  213. Return nil if there is no parent to open.
  214. The return value is (PARENT . ENTITY), where PARENT is the entity
  215. to open and ENTITY is the entity to move point to."
  216. (cons (navigel-parent entity) entity))
  217. (cl-defmethod navigel-parent-to-open (entity &context (major-mode navigel-tablist-mode))
  218. "Parent or ENTITY to open in the context of MAJOR-MODE derived from tablist."
  219. ;; Override default implementation because, in navigel-tablist-mode,
  220. ;; opening the parent of the entity at point would usually result in
  221. ;; opening the current buffer again. This is because the current
  222. ;; buffer typically already displays the parent of the entity at
  223. ;; point.
  224. (let* ((parent (navigel-parent entity))
  225. (ancestor (and parent (navigel-parent parent))))
  226. (cond ((and ancestor (navigel-equal parent navigel-entity))
  227. (cons ancestor parent))
  228. ((and parent (not (navigel-equal parent navigel-entity)))
  229. (cons parent entity))
  230. (t nil))))
  231. (cl-defgeneric navigel-delete (_entity &optional _callback)
  232. "Remove ENTITY from its parent.
  233. If non-nil, call CALLBACK with no parameter when done."
  234. (user-error "This operation is not supported in this context"))
  235. (cl-defmethod navigel-delete ((entities list) &optional callback)
  236. "Remove each item of ENTITIES from its parent.
  237. If non-nil, call CALLBACK with no parameter when done."
  238. (navigel-async-mapc #'navigel-delete entities callback))
  239. (cl-defmethod navigel-make-bookmark ()
  240. "Return a record to bookmark the current buffer.
  241. This function is to be used as value for
  242. `bookmark-make-record-function' in navigel buffers."
  243. `(
  244. ,(navigel-bookmark-name navigel-entity)
  245. ((handler . ,#'navigel--bookmark-jump)
  246. (navigel-entity . ,navigel-entity)
  247. (navigel-target . ,(navigel-entity-at-point))
  248. (navigel-app . ,navigel-app))))
  249. ;;; Public functions
  250. (defun navigel-single-buffer-app-p (app)
  251. "Check whether APP is registered as a single-buffer application.
  252. See also `navigel-single-buffer-apps'."
  253. (or (eq t navigel-single-buffer-apps)
  254. (memq app navigel-single-buffer-apps)))
  255. (defun navigel-register-single-buffer-app (app)
  256. "Register APP as a single buffer application."
  257. (or (navigel-single-buffer-app-p app)
  258. (add-to-list 'navigel-single-buffer-apps app)))
  259. (defun navigel-app-buffer (app)
  260. "If APP is a single-buffer application, return its buffer."
  261. (navigel--app-buffer app t))
  262. (defun navigel-async-mapcar (mapfn list callback)
  263. "Apply MAPFN to each element of LIST and pass result to CALLBACK.
  264. MAPFN is a function taking 2 arguments: the element to map and a
  265. callback to call when the mapping is done."
  266. (if (not list)
  267. (funcall callback nil)
  268. (let ((result (make-vector (length list) nil))
  269. (count 0))
  270. (cl-loop for index below (length list)
  271. for item in list
  272. do (let ((index index) (item item))
  273. (funcall
  274. mapfn
  275. item
  276. (lambda (item-result)
  277. (setf (seq-elt result index) item-result)
  278. (cl-incf count)
  279. (when (eq count (length list))
  280. ;; use `run-at-time' to ensure that CALLBACK is
  281. ;; consistently called asynchronously even if MAPFN is
  282. ;; synchronous:
  283. (run-at-time
  284. 0 nil
  285. callback
  286. (seq-concatenate 'list result))))))))))
  287. (defun navigel-async-mapc (mapfn list callback)
  288. "Same as `navigel-async-mapcar' but for side-effects only.
  289. MAPFN is a function taking 2 arguments: an element of LIST and a
  290. callback. MAPFN should call the callback with no argument when
  291. done computing.
  292. CALLBACK is a function of no argument that is called when done
  293. computing for the all elements of LIST."
  294. (navigel-async-mapcar
  295. (lambda (item callback) (funcall mapfn item (lambda () (funcall callback nil))))
  296. list
  297. (lambda (_result) (funcall callback))))
  298. (defun navigel-open-parent (&optional entity)
  299. "Open in a new buffer the parent of ENTITY, entity at point if nil."
  300. (interactive (list (navigel-entity-at-point)))
  301. (when entity
  302. (pcase (navigel-parent-to-open entity)
  303. (`(,parent . ,entity) (navigel-open parent entity))
  304. (_ (message "No parent to go to")))))
  305. (defun navigel-refresh (&optional target callback)
  306. "Compute `navigel-entity' children and list those in the current buffer.
  307. If TARGET is non-nil and is in buffer, move point to it.
  308. If CALLBACK is non nil, execute it when the buffer has been
  309. refreshed."
  310. (let ((entity navigel-entity)
  311. ;; save navigel-app so we can rebind below
  312. (app navigel-app))
  313. (navigel--message (if (equal (point-min) (point-max))
  314. "Populating…"
  315. "Refreshing…"))
  316. (navigel-children
  317. entity
  318. (lambda (children)
  319. ;; restore navigel-app
  320. (let ((navigel-app app) state)
  321. (with-current-buffer (navigel--entity-buffer app entity)
  322. (let ((fmt (navigel-tablist-format-children entity children)))
  323. (when fmt
  324. (setq-local tabulated-list-format fmt)
  325. (tabulated-list-init-header)))
  326. (setq state (navigel--save-state))
  327. (setq-local tabulated-list-entries
  328. (mapcar (lambda (child)
  329. (list child (navigel-entity-to-columns child)))
  330. children))
  331. (tabulated-list-print)
  332. (when (not (navigel-single-buffer-app-p app))
  333. (navigel--restore-state state))
  334. (when target
  335. (navigel-go-to-entity target))
  336. (run-hooks 'navigel-changed-hook)
  337. (when callback
  338. (funcall callback))
  339. (navigel--message "Ready!")))))))
  340. (defmacro navigel-method (app name args &rest body)
  341. "Define a method NAME with ARGS and BODY.
  342. This method will only be active if `navigel-app' equals APP."
  343. (declare (indent 3))
  344. `(cl-defmethod ,name ,(navigel--insert-context-in-args app args)
  345. ,@body))
  346. ;;; Private functions
  347. (defvar bookmark-make-record-function)
  348. (defun navigel--list-children (entity &optional target)
  349. "Open a new buffer showing ENTITY's children.
  350. If TARGET is non-nil and is in buffer, move point to it.
  351. Interactively, ENTITY is either the element at point or the user
  352. is asked for a top level ENTITY."
  353. ;; save navigel-app because (navigel-tablist-mode) will reset it
  354. (let ((app navigel-app)
  355. (prev-entity navigel-entity)
  356. (single (navigel-single-buffer-app-p navigel-app))
  357. (buffer (navigel--entity-buffer navigel-app entity))
  358. cache)
  359. (with-current-buffer buffer
  360. ;; set navigel-app first because it is used on the line below to
  361. ;; select the appropriate mode:
  362. (setq-local navigel-app app)
  363. (when single
  364. (when prev-entity (navigel--cache-state prev-entity))
  365. (setq cache navigel--state-cache))
  366. (navigel-entity-tablist-mode entity)
  367. ;; restore navigel-app because is got erased by activating the major mode:
  368. (setq-local navigel-app app)
  369. (setq-local tabulated-list-padding 2) ; for `tablist'
  370. (setq-local navigel-entity entity)
  371. (when single
  372. (setq-local navigel--state-cache cache)
  373. (rename-buffer (navigel-single-buffer-name app entity) t))
  374. (setq-local tablist-operations-function #'navigel--tablist-operation-function)
  375. (setq-local revert-buffer-function #'navigel--revert-buffer)
  376. (setq-local imenu-prev-index-position-function
  377. #'navigel--imenu-prev-index-position)
  378. (setq-local imenu-extract-index-name-function
  379. #'navigel--imenu-extract-index-name)
  380. (setq-local tabulated-list-format (navigel-tablist-format entity))
  381. (setq-local bookmark-make-record-function #'navigel-make-bookmark)
  382. (tabulated-list-init-header)
  383. (navigel-refresh
  384. nil
  385. (lambda ()
  386. (with-current-buffer buffer
  387. (when (and single entity)
  388. (navigel--restore-state (navigel--cached-state entity)))
  389. (when target (navigel-go-to-entity target))
  390. (run-hooks 'navigel-init-done-hook)))))
  391. (switch-to-buffer buffer)))
  392. (defun navigel--save-state ()
  393. "Return an object representing the state of the current buffer.
  394. This should be restored with `navigel--restore-state'.
  395. The state contains the entity at point, the column of point, and the marked entities."
  396. `(
  397. (entity-at-point . ,(navigel-entity-at-point))
  398. (column . ,(current-column))
  399. (marked-entities . ,(navigel-marked-entities))))
  400. (defun navigel--restore-state (state)
  401. "Restore STATE. This was saved with `navigel--save-state'."
  402. (let-alist state
  403. (if .entity-at-point
  404. (navigel-go-to-entity .entity-at-point)
  405. (setf (point) (point-min)))
  406. (when .column
  407. (setf (point) (line-beginning-position))
  408. (forward-char .column))
  409. (when .marked-entities
  410. (save-excursion
  411. (dolist (entity .marked-entities)
  412. (when (navigel-go-to-entity entity)
  413. (tablist-put-mark)))))))
  414. (defun navigel--forget-single-buffer ()
  415. "Remove the entry for the current buffer in `navigel-single-buffers."
  416. (map-delete navigel-single-buffers navigel-app))
  417. (defun navigel--single-app-buffer-create (app)
  418. "Create and return a buffer for the given APP, setting it up for single mode."
  419. (let ((buffer (get-buffer-create (navigel-single-buffer-name app nil))))
  420. (setf (alist-get app navigel-single-buffers) buffer)
  421. (with-current-buffer buffer
  422. (add-hook 'kill-buffer-hook #'navigel--forget-single-buffer nil t)
  423. (setq-local navigel-app app))
  424. buffer))
  425. (defun navigel--app-buffer (app &optional no-create)
  426. "If APP is a single-buffer application, find or create its buffer.
  427. If NO-CREATE is not nil, do not create a fresh buffer if one does
  428. not already exist."
  429. (when (navigel-single-buffer-app-p app)
  430. (let ((buffer (alist-get app navigel-single-buffers)))
  431. (when (and (not (buffer-live-p buffer)) (not no-create))
  432. (setq buffer (navigel--single-app-buffer-create app)))
  433. buffer)))
  434. (defun navigel--entity-buffer (app entity)
  435. "Return the buffer that APP should use for the given ENTITY."
  436. (or (navigel--app-buffer app)
  437. (get-buffer-create (navigel-entity-buffer entity))))
  438. (defun navigel--cache-state (entity)
  439. "Save in the local cache the state of ENTITY, as displayed in the current buffer."
  440. (let ((id (when entity (navigel-entity-id entity))))
  441. (when id
  442. (when (not navigel--state-cache)
  443. (setq-local navigel--state-cache ()))
  444. (setf (alist-get id navigel--state-cache nil nil #'equal)
  445. (navigel--save-state)))))
  446. (defun navigel--cached-state (&optional entity app)
  447. "Return the cached state of the given ENTITY, in application APP.
  448. ENTITY and APP default to the local values of `navigel-entity' and `navigel-app'."
  449. (let ((entity (or entity navigel-entity)))
  450. (when entity
  451. (let ((app-buffer (navigel--app-buffer (or app navigel-app))))
  452. (when app-buffer
  453. (cdr (assoc (navigel-entity-id entity)
  454. (buffer-local-value 'navigel--state-cache app-buffer))))))))
  455. (defun navigel--revert-buffer (&rest _args)
  456. "Compute `navigel-entity' children and list those in the current buffer."
  457. (navigel-refresh))
  458. (defun navigel--insert-context-in-args (app args)
  459. "Return an argument list with a &context specializer for APP within ARGS."
  460. (let ((result (list))
  461. (rest-args args))
  462. (catch 'found-special-arg
  463. (while rest-args
  464. (let ((arg (car rest-args)))
  465. (when (symbolp arg)
  466. (when (eq arg '&context)
  467. (throw 'found-special-arg
  468. (append (nreverse result)
  469. `(&context (navigel-app ,app))
  470. (cdr rest-args))))
  471. (when (string= "&" (substring-no-properties (symbol-name arg) 0 1))
  472. (throw 'found-special-arg
  473. (append (nreverse result)
  474. `(&context (navigel-app ,app))
  475. rest-args))))
  476. (setq result (cons arg result))
  477. (setq rest-args (cdr rest-args))))
  478. (append (nreverse result) `(&context (navigel-app ,app))))))
  479. ;;; Major mode
  480. (defvar navigel-tablist-mode-map
  481. (let ((map (make-sparse-keymap)))
  482. (define-key map (kbd "^") #'navigel-open-parent)
  483. map)
  484. "Keymap for `navigel-tablist-mode'.")
  485. (define-derived-mode navigel-tablist-mode tablist-mode "navigel-tablist"
  486. "Major mode for all elcouch listing modes.")
  487. (provide 'navigel)
  488. ;;; navigel.el ends here
  489. ;;; LocalWords: navigel tablist tablists keymap