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.

486 lines
18KB

  1. ;;; navigel.el --- Facilitate the creation of tabulated-list based UIs -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2019 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 'bookmark)
  34. ;; Customization
  35. (defgroup navigel nil
  36. "Navigel."
  37. :group 'magit-extensions)
  38. (defcustom navigel-changed-hook nil
  39. "Normal hook run after a navigel's tablist buffer has been refreshed or populated."
  40. :type 'hook)
  41. (defcustom navigel-init-done-hook nil
  42. "Normal hook run after a navigel's tablist buffer has been initially populated."
  43. :type 'hook)
  44. (defcustom navigel-display-messages t
  45. "Whether to display navigel's informative messages in the echo area."
  46. :type 'boolean)
  47. ;; Private variables
  48. (defvar navigel-entity nil
  49. "Specify the entity that was used to generate the buffer.")
  50. (defvar navigel-app nil
  51. "Specify the application that was used to generate the buffer.")
  52. ;; Private functions
  53. (defun navigel--tablist-operation-function (operation &rest args)
  54. "Setup `tablist' operations in current buffer.
  55. OPERATION and ARGS are defined by `tablist-operations-function'."
  56. (cl-case operation
  57. (supported-operations '(find-entry delete))
  58. (find-entry (navigel-open (car args) nil))
  59. (delete (navigel-delete (car args) #'navigel--revert-buffer))))
  60. (defun navigel--imenu-extract-index-name ()
  61. "Return the name of entity at point for `imenu'.
  62. This function is used as a value for
  63. `imenu-extract-index-name-function'. Point should be at the
  64. beginning of the line."
  65. (navigel-imenu-name (tabulated-list-get-id)))
  66. (defun navigel--imenu-prev-index-position ()
  67. "Move point to previous line in current buffer.
  68. This function is used as a value for
  69. `imenu-prev-index-position-function'."
  70. (unless (bobp)
  71. (forward-line -1)))
  72. (defun navigel-go-to-entity (entity)
  73. "Move point to ENTITY.
  74. Return non-nil if ENTITY is found, nil otherwise."
  75. (goto-char (point-min))
  76. (while (and (not (= (point) (point-max)))
  77. (not (navigel-equal (navigel-entity-at-point) entity)))
  78. (forward-line 1))
  79. (not (= (point) (point-max))))
  80. ;; CL Context rewriter: this lets users write "&context (navigel-app
  81. ;; something)" instead of "&context (navigel-app (eql something))"
  82. (cl-generic-define-context-rewriter navigel-app (app)
  83. `(navigel-app (eql ,app)))
  84. (defun navigel--bookmark-jump (bookmark)
  85. "Open a navigel buffer showing BOOKMARK."
  86. (let ((entity (bookmark-prop-get bookmark 'navigel-entity))
  87. (target (bookmark-prop-get bookmark 'navigel-target))
  88. (navigel-app (bookmark-prop-get bookmark 'navigel-app)))
  89. (navigel-open entity target)
  90. (message "Current buffer at the end of navigel--bookmark-jump: %s" (current-buffer))))
  91. (defun navigel--message (&rest args)
  92. "Display a message in the echo area.
  93. This function only has an effect when `navigel-display-messages'
  94. is true. ARGS are the message format followed by any arguments
  95. it takes."
  96. (when navigel-display-messages
  97. (apply #'message args)))
  98. ;; Generic methods: Those methods are the one you may override.
  99. (cl-defgeneric navigel-name (entity)
  100. "Return a short string describing ENTITY.
  101. The returned value is the default for `navigel-buffer-name',
  102. `navigel-tablist-name' and `navigel-imenu-name'. Those can be
  103. overridden separately if necessary."
  104. (format "%s" entity))
  105. (cl-defgeneric navigel-buffer-name (entity)
  106. "Return a string representing ENTITY in the buffer's name."
  107. (navigel-name entity))
  108. (cl-defgeneric navigel-tablist-name (entity)
  109. "Return a string representing ENTITY in tablist columns."
  110. (navigel-name entity))
  111. (cl-defgeneric navigel-imenu-name (entity)
  112. "Return a string representing ENTITY for `imenu'."
  113. (navigel-name entity))
  114. (cl-defgeneric navigel-bookmark-name (entity)
  115. "Return a string representing ENTITY for `bookmark'."
  116. (navigel-name entity))
  117. (cl-defgeneric navigel-children (entity callback)
  118. "Execute CALLBACK with the list of ENTITY's children as argument.
  119. This method must be overridden for any tablist view to work.")
  120. (cl-defmethod navigel-children ((entities list) callback)
  121. "Execute CALLBACK with the children of ENTITIES as argument."
  122. (navigel-async-mapcar #'navigel-children entities callback))
  123. (cl-defgeneric navigel-parent (_entity)
  124. "Return the parent of ENTITY if possible, nil if not."
  125. nil)
  126. (cl-defgeneric navigel-equal (entity1 entity2)
  127. "Return non-nil if ENTITY1 and ENTITY2 represent the same entity."
  128. (equal entity1 entity2))
  129. (cl-defgeneric navigel-entity-at-point ()
  130. "Return the entity at point or nil if none.")
  131. (cl-defmethod navigel-entity-at-point (&context (major-mode (derived-mode navigel-tablist-mode)))
  132. "Return the entity at point in the context of a mode derived from MAJOR-MODE."
  133. (or (tabulated-list-get-id) navigel-entity))
  134. (cl-defgeneric navigel-marked-entities (&optional _at-point-if-empty)
  135. "Return a list of entities that are selected.
  136. If no entity is selected and AT-POINT-IF-EMPTY is non-nil, return
  137. a list with just the entity at point."
  138. nil)
  139. (cl-defmethod navigel-marked-entities (&context (major-mode (derived-mode navigel-tablist-mode))
  140. &optional at-point-if-empty)
  141. "Return a list with marked entities for MAJOR-MODE derived from a tablist.
  142. AT-POINT-IF-EMPTY indicates whether to return the entity at point if none
  143. is marked."
  144. ;; `tablist-get-marked-items' automatically includes the entity at
  145. ;; point if no entity is marked. We have to remove it unless
  146. ;; `at-point-if-empty' is non-nil.
  147. (let ((entities (mapcar #'car (tablist-get-marked-items))))
  148. (if (or (> (length entities) 1)
  149. (save-excursion ;; check if the entity is really marked
  150. (navigel-go-to-entity (car entities))
  151. (tablist-get-mark-state))
  152. at-point-if-empty)
  153. entities
  154. (list))))
  155. (cl-defgeneric navigel-entity-buffer (entity)
  156. "Return a buffer name for ENTITY.
  157. The default name is based on `navigel-app' and `navigel-buffer-name'."
  158. (format "*%s-%s*" navigel-app (navigel-buffer-name entity)))
  159. (cl-defgeneric navigel-entity-tablist-mode (_entity)
  160. "Enable the `major-mode' most suited to display children of ENTITY."
  161. (navigel-tablist-mode))
  162. (cl-defgeneric navigel-tablist-format (_entity)
  163. "Return a vector specifying columns to display ENTITY's children.
  164. The return value is set as `tabulated-list-format'."
  165. (vector (list "Name" 0 t)))
  166. (cl-defgeneric navigel-tablist-format-children (_entity &optional _children)
  167. "Return a vector specifying columns to display ENTITY's CHILDREN.
  168. The return value is set as `tabulated-list-format' after the list
  169. of children has been retrieved, unless this call returns nil."
  170. nil)
  171. (cl-defgeneric navigel-entity-to-columns (entity)
  172. "Return the column descriptors to display ENTITY in a tabulated list.
  173. The return value is a vector for `tabulated-list-entries'.
  174. The vector should be compatible to the one defined with
  175. `navigel-tablist-format'."
  176. (vector (navigel-tablist-name entity)))
  177. (cl-defgeneric navigel-open (entity target)
  178. "Open a buffer displaying ENTITY.
  179. If TARGET is non-nil and is in buffer, move point to it.
  180. By default, list ENTITY's children in a tabulated list."
  181. (navigel--list-children entity target))
  182. (cl-defgeneric navigel-parent-to-open (entity)
  183. "Return an indication of what to open if asked to open the parent of ENTITY.
  184. Return nil if there is no parent to open.
  185. The return value is (PARENT . ENTITY), where PARENT is the entity
  186. to open and ENTITY is the entity to move point to."
  187. (cons (navigel-parent entity) entity))
  188. (cl-defmethod navigel-parent-to-open (entity &context (major-mode navigel-tablist-mode))
  189. "Parent or ENTITY to open in the context of MAJOR-MODE derived from tablist."
  190. ;; Override default implementation because, in navigel-tablist-mode,
  191. ;; opening the parent of the entity at point would usually result in
  192. ;; opening the current buffer again. This is because the current
  193. ;; buffer typically already displays the parent of the entity at
  194. ;; point.
  195. (let* ((parent (navigel-parent entity))
  196. (ancestor (and parent (navigel-parent parent))))
  197. (cond ((and ancestor (navigel-equal parent navigel-entity))
  198. (cons ancestor parent))
  199. ((and parent (not (navigel-equal parent navigel-entity)))
  200. (cons parent entity))
  201. (t nil))))
  202. (cl-defgeneric navigel-delete (_entity &optional _callback)
  203. "Remove ENTITY from its parent.
  204. If non-nil, call CALLBACK with no parameter when done."
  205. (user-error "This operation is not supported in this context"))
  206. (cl-defmethod navigel-delete ((entities list) &optional callback)
  207. "Remove each item of ENTITIES from its parent.
  208. If non-nil, call CALLBACK with no parameter when done."
  209. (navigel-async-mapc #'navigel-delete entities callback))
  210. (cl-defmethod navigel-make-bookmark ()
  211. "Return a record to bookmark the current buffer.
  212. This function is to be used as value for
  213. `bookmark-make-record-function' in navigel buffers."
  214. `(
  215. ,(navigel-bookmark-name navigel-entity)
  216. ((handler . ,#'navigel--bookmark-jump)
  217. (navigel-entity . ,navigel-entity)
  218. (navigel-target . ,(navigel-entity-at-point))
  219. (navigel-app . ,navigel-app))))
  220. ;;; Public functions
  221. (defun navigel-async-mapcar (mapfn list callback)
  222. "Apply MAPFN to each element of LIST and pass result to CALLBACK.
  223. MAPFN is a function taking 2 arguments: the element to map and a
  224. callback to call when the mapping is done."
  225. (if (not list)
  226. (funcall callback nil)
  227. (let ((result (make-vector (length list) nil))
  228. (count 0))
  229. (cl-loop for index below (length list)
  230. for item in list
  231. do (let ((index index) (item item))
  232. (funcall
  233. mapfn
  234. item
  235. (lambda (item-result)
  236. (setf (seq-elt result index) item-result)
  237. (cl-incf count)
  238. (when (eq count (length list))
  239. ;; use `run-at-time' to ensure that CALLBACK is
  240. ;; consistently called asynchronously even if MAPFN is
  241. ;; synchronous:
  242. (run-at-time
  243. 0 nil
  244. callback
  245. (seq-concatenate 'list result))))))))))
  246. (defun navigel-async-mapc (mapfn list callback)
  247. "Same as `navigel-async-mapcar' but for side-effects only.
  248. MAPFN is a function taking 2 arguments: an element of LIST and a
  249. callback. MAPFN should call the callback with no argument when
  250. done computing.
  251. CALLBACK is a function of no argument that is called when done
  252. computing for the all elements of LIST."
  253. (navigel-async-mapcar
  254. (lambda (item callback) (funcall mapfn item (lambda () (funcall callback nil))))
  255. list
  256. (lambda (_result) (funcall callback))))
  257. (defun navigel-open-parent (&optional entity)
  258. "Open in a new buffer the parent of ENTITY, entity at point if nil."
  259. (interactive (list (navigel-entity-at-point)))
  260. (when entity
  261. (pcase (navigel-parent-to-open entity)
  262. (`(,parent . ,entity) (navigel-open parent entity))
  263. (_ (message "No parent to go to")))))
  264. (defun navigel-refresh (&optional target callback)
  265. "Compute `navigel-entity' children and list those in the current buffer.
  266. If TARGET is non-nil and is in buffer, move point to it.
  267. If CALLBACK is non nil, execute it when the buffer has been
  268. refreshed."
  269. (let ((entity navigel-entity)
  270. ;; save navigel-app so we can rebind below
  271. (app navigel-app))
  272. (navigel--message (if (equal (point-min) (point-max))
  273. "Populating…"
  274. "Refreshing…"))
  275. (navigel-children
  276. entity
  277. (lambda (children)
  278. (let ((new-format (navigel-tablist-format-children entity children)))
  279. (when new-format
  280. (setq-local tabulated-list-format new-format)
  281. (tabulated-list-init-header)))
  282. ;; restore navigel-app
  283. (let ((navigel-app app) state)
  284. (with-current-buffer (get-buffer-create (navigel-entity-buffer entity))
  285. (setq state (navigel--save-state))
  286. (setq-local tabulated-list-entries
  287. (mapcar
  288. (lambda (child) (list child (navigel-entity-to-columns child)))
  289. children))
  290. (tabulated-list-print)
  291. (navigel--restore-state state)
  292. (when target
  293. (navigel-go-to-entity target))
  294. (run-hooks 'navigel-changed-hook)
  295. (when callback
  296. (funcall callback))
  297. (navigel--message "Ready!")))))))
  298. (defmacro navigel-method (app name args &rest body)
  299. "Define a method NAME with ARGS and BODY.
  300. This method will only be active if `navigel-app' equals APP."
  301. (declare (indent 3))
  302. `(cl-defmethod ,name ,(navigel--insert-context-in-args app args)
  303. ,@body))
  304. ;;; Private functions
  305. (defvar bookmark-make-record-function)
  306. (defun navigel--list-children (entity &optional target)
  307. "Open a new buffer showing ENTITY's children.
  308. If TARGET is non-nil and is in buffer, move point to it.
  309. Interactively, ENTITY is either the element at point or the user
  310. is asked for a top level ENTITY."
  311. ;; save navigel-app because (navigel-tablist-mode) will reset it
  312. (let ((app navigel-app)
  313. (buffer (get-buffer-create (navigel-entity-buffer entity))))
  314. (with-current-buffer buffer
  315. ;; set navigel-app first because it is used on the line below to
  316. ;; select the appropriate mode:
  317. (setq-local navigel-app app)
  318. (navigel-entity-tablist-mode entity)
  319. ;; restore navigel-app because is got erased by activating the major mode:
  320. (setq-local navigel-app app)
  321. (setq-local tabulated-list-padding 2) ; for `tablist'
  322. (setq-local navigel-entity entity)
  323. (setq-local tablist-operations-function #'navigel--tablist-operation-function)
  324. (setq-local revert-buffer-function #'navigel--revert-buffer)
  325. (setq-local imenu-prev-index-position-function
  326. #'navigel--imenu-prev-index-position)
  327. (setq-local imenu-extract-index-name-function
  328. #'navigel--imenu-extract-index-name)
  329. (setq-local tabulated-list-format (navigel-tablist-format entity))
  330. (setq-local bookmark-make-record-function #'navigel-make-bookmark)
  331. (tabulated-list-init-header)
  332. (navigel-refresh
  333. target
  334. (lambda ()
  335. (with-current-buffer buffer
  336. (run-hooks 'navigel-init-done-hook)))))
  337. (switch-to-buffer buffer)))
  338. (defun navigel--save-state ()
  339. "Return an object representing the state of the current buffer.
  340. This should be restored with `navigel--restore-state'.
  341. The state contains the entity at point, the column of point, and the marked entities."
  342. `(
  343. (entity-at-point . ,(navigel-entity-at-point))
  344. (column . ,(current-column))
  345. (marked-entities . ,(navigel-marked-entities))))
  346. (defun navigel--restore-state (state)
  347. "Restore STATE. This was saved with `navigel--save-state'."
  348. (let-alist state
  349. (if .entity-at-point
  350. (navigel-go-to-entity .entity-at-point)
  351. (setf (point) (point-min)))
  352. (when .column
  353. (setf (point) (line-beginning-position))
  354. (forward-char .column))
  355. (when .marked-entities
  356. (save-excursion
  357. (dolist (entity .marked-entities)
  358. (when (navigel-go-to-entity entity)
  359. (tablist-put-mark)))))))
  360. (defun navigel--revert-buffer (&rest _args)
  361. "Compute `navigel-entity' children and list those in the current buffer."
  362. (navigel-refresh))
  363. (defun navigel--insert-context-in-args (app args)
  364. "Return an argument list with a &context specializer for APP within ARGS."
  365. (let ((result (list))
  366. (rest-args args))
  367. (catch 'found-special-arg
  368. (while rest-args
  369. (let ((arg (car rest-args)))
  370. (when (symbolp arg)
  371. (when (eq arg '&context)
  372. (throw 'found-special-arg
  373. (append (nreverse result)
  374. `(&context (navigel-app ,app))
  375. (cdr rest-args))))
  376. (when (string= "&" (substring-no-properties (symbol-name arg) 0 1))
  377. (throw 'found-special-arg
  378. (append (nreverse result)
  379. `(&context (navigel-app ,app))
  380. rest-args))))
  381. (setq result (cons arg result))
  382. (setq rest-args (cdr rest-args))))
  383. (append (nreverse result) `(&context (navigel-app ,app))))))
  384. ;;; Major mode
  385. (defvar navigel-tablist-mode-map
  386. (let ((map (make-sparse-keymap)))
  387. (define-key map (kbd "^") #'navigel-open-parent)
  388. map)
  389. "Keymap for `navigel-tablist-mode'.")
  390. (define-derived-mode navigel-tablist-mode tablist-mode "navigel-tablist"
  391. "Major mode for all elcouch listing modes.")
  392. (provide 'navigel)
  393. ;;; navigel.el ends here
  394. ;;; LocalWords: navigel tablist tablists keymap