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.

429 lines
16KB

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