Klimi's new dotfiles with stow.
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.

462 lines
18 KiB

преди 4 години
  1. ;;; sesman-browser.el --- Interactive Browser for Sesman -*- lexical-binding: t -*-
  2. ;;
  3. ;; Copyright (C) 2018, Vitalie Spinu
  4. ;; Author: Vitalie Spinu
  5. ;; URL: https://github.com/vspinu/sesman
  6. ;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;
  9. ;; This file is *NOT* part of GNU Emacs.
  10. ;;
  11. ;; This program is free software; you can redistribute it and/or
  12. ;; modify it under the terms of the GNU General Public License as
  13. ;; published by the Free Software Foundation; either version 3, or
  14. ;; (at your option) any later version.
  15. ;;
  16. ;; This program is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  19. ;; General Public License for more details.
  20. ;;
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with this program; see the file COPYING. If not, write to
  23. ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  24. ;; Floor, Boston, MA 02110-1301, USA.
  25. ;;
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. ;;
  28. ;;; Commentary:
  29. ;;
  30. ;; Interactive session browser.
  31. ;;
  32. ;;; Code:
  33. (require 'seq)
  34. (require 'sesman)
  35. (defgroup sesman-browser nil
  36. "Browser for Sesman."
  37. :prefix "sesman-browser-"
  38. :group 'sesman
  39. :link '(url-link :tag "GitHub" "https://github.com/vspinu/sesman"))
  40. (defface sesman-browser-highligh-face
  41. '((default (:inherit highlight :weight bold)))
  42. "Face used to highlight currently selected button."
  43. :group 'sesman-browser)
  44. (defface sesman-browser-button-face
  45. '((default (:inherit button :slant italic)))
  46. "Face used to highlight currently selected object."
  47. :group 'sesman-browser)
  48. (defvar-local sesman-browser--sort-types '(name relevance))
  49. (defcustom sesman-browser-sort-type 'name
  50. "Default sorting type in sesman browser buffers.
  51. Currently can be either 'name or 'relevance."
  52. :type '(choice (const name) (const relevance))
  53. :group 'sesman-browser)
  54. (defvar sesman-browser-map
  55. (let (sesman-browser-map)
  56. (define-prefix-command 'sesman-browser-map)
  57. (define-key sesman-browser-map (kbd "r") #'sesman-browser-restart-session)
  58. (define-key sesman-browser-map (kbd "q") #'sesman-browser-quit-session)
  59. (define-key sesman-browser-map (kbd "b") #'sesman-browser-link-with-buffer)
  60. (define-key sesman-browser-map (kbd "d") #'sesman-browser-link-with-directory)
  61. (define-key sesman-browser-map (kbd "p") #'sesman-browser-link-with-project)
  62. (define-key sesman-browser-map (kbd "u") #'sesman-browser-unlink)
  63. sesman-browser-map)
  64. "Prefix keymap for sesman commands from sesman browser.")
  65. (defvar sesman-browser-mode-map
  66. (let ((sesman-browser-mode-map (make-sparse-keymap)))
  67. (define-key sesman-browser-mode-map (kbd "n") #'sesman-browser-vertical-next)
  68. (define-key sesman-browser-mode-map (kbd "p") #'sesman-browser-vertical-prev)
  69. (define-key sesman-browser-mode-map (kbd "f") #'sesman-browser-forward)
  70. (define-key sesman-browser-mode-map (kbd "b") #'sesman-browser-backward)
  71. (define-key sesman-browser-mode-map [remap forward-paragraph] #'sesman-browser-session-next)
  72. (define-key sesman-browser-mode-map [remap backward-paragraph] #'sesman-browser-session-prev)
  73. (define-key sesman-browser-mode-map (kbd "C-M-n") #'sesman-browser-session-next)
  74. (define-key sesman-browser-mode-map (kbd "C-M-p") #'sesman-browser-session-prev)
  75. (define-key sesman-browser-mode-map (kbd "<tab>") #'sesman-browser-forward)
  76. (define-key sesman-browser-mode-map (kbd "<backtab>") #'sesman-browser-backward)
  77. (define-key sesman-browser-mode-map (kbd "<RET>") #'sesman-goto)
  78. (define-key sesman-browser-mode-map (kbd "o") #'sesman-show)
  79. (define-key sesman-browser-mode-map (kbd "t") #'sesman-browser-toggle-sort)
  80. (define-key sesman-browser-mode-map (kbd "S") #'sesman-browser-toggle-sort)
  81. (define-key sesman-browser-mode-map (kbd "l b") #'sesman-browser-link-with-buffer)
  82. (define-key sesman-browser-mode-map (kbd "l d") #'sesman-browser-link-with-directory)
  83. (define-key sesman-browser-mode-map (kbd "l p") #'sesman-browser-link-with-project)
  84. (define-key sesman-browser-mode-map (kbd "u") #'sesman-browser-unlink)
  85. (define-key sesman-browser-mode-map (kbd "s") 'sesman-browser-map)
  86. (define-key sesman-browser-mode-map (kbd "C-c C-s") 'sesman-browser-map)
  87. sesman-browser-mode-map)
  88. "Local keymap in `sesman-browser-mode'.")
  89. ;;; Utilities
  90. (defun sesman-browser--closeby-pos (prop lax)
  91. (or (when (get-text-property (point) prop)
  92. (point))
  93. (when (and (not (bobp))
  94. (get-text-property (1- (point)) prop))
  95. (1- (point)))
  96. (when lax
  97. (let ((next (save-excursion
  98. (and
  99. (goto-char (next-single-char-property-change (point) prop))
  100. (get-text-property (point) prop)
  101. (point))))
  102. (prev (save-excursion
  103. (and
  104. (goto-char (previous-single-char-property-change (point) prop))
  105. (not (bobp))
  106. (get-text-property (1- (point)) prop)
  107. (1- (point))))))
  108. (if next
  109. (if prev
  110. (if (< (- (point) prev) (- next (point)))
  111. prev
  112. next)
  113. next)
  114. prev)))))
  115. (defun sesman-browser--closeby-value (prop lax)
  116. (when-let ((pos (sesman-browser--closeby-pos prop lax)))
  117. (get-text-property pos prop)))
  118. (defun sesman-browser-get (what &optional no-error lax)
  119. "Get value of the property WHAT at point.
  120. If NO-ERROR is non-nil, don't throw an error if no value has been found and
  121. return nil. If LAX is non-nil, search nearby and return the closest value."
  122. (when (derived-mode-p 'sesman-browser-mode)
  123. (or (let ((prop (pcase what
  124. ('session :sesman-session)
  125. ('link :sesman-link)
  126. ('object :sesman-object)
  127. (_ what))))
  128. (sesman-browser--closeby-value prop 'lax))
  129. (unless no-error
  130. (user-error "No %s %s" what (if lax "nearby" "at point"))))))
  131. ;;; Navigation
  132. (defvar-local sesman-browser--section-overlay nil)
  133. (defvar-local sesman-browser--stop-overlay nil)
  134. (when (fboundp 'define-fringe-bitmap)
  135. (define-fringe-bitmap 'sesman-left-bar
  136. [#b00001100] nil nil '(top t)))
  137. (defun sesman-browser--next (prop)
  138. (let ((pos (point)))
  139. (goto-char (previous-single-char-property-change (point) prop))
  140. (unless (get-text-property (point) prop)
  141. (goto-char (previous-single-char-property-change (point) prop)))
  142. (when (bobp)
  143. (goto-char pos))))
  144. (defun sesman-browser--prev (prop)
  145. (let ((pos (point)))
  146. (goto-char (next-single-char-property-change (point) prop))
  147. (unless (get-text-property (point) prop)
  148. (goto-char (next-single-char-property-change (point) prop)))
  149. (when (eobp)
  150. (goto-char pos))))
  151. (defun sesman-browser-forward ()
  152. "Go to next button."
  153. (interactive)
  154. (sesman-browser--prev :sesman-stop))
  155. (defun sesman-browser-backward ()
  156. "Go to previous button."
  157. (interactive)
  158. (sesman-browser--next :sesman-stop))
  159. (defun sesman-browser-vertical-next ()
  160. "Go to next button section or row."
  161. (interactive)
  162. (sesman-browser--prev :sesman-vertical-stop))
  163. (defun sesman-browser-vertical-prev ()
  164. "Go to previous button section or row."
  165. (interactive)
  166. (sesman-browser--next :sesman-vertical-stop))
  167. (defun sesman-browser-session-next ()
  168. "Go to next session."
  169. (interactive)
  170. (sesman-browser--prev :sesman-session-stop))
  171. (defun sesman-browser-session-prev ()
  172. "Go to previous session."
  173. (interactive)
  174. (sesman-browser--next :sesman-session-stop))
  175. ;;; Display
  176. (defun sesman-goto (&optional no-switch)
  177. "Go to most relevant buffer for session at point.
  178. If NO-SWITCH is non-nil, only display the buffer."
  179. (interactive "P")
  180. (let ((object (get-text-property (point) :sesman-object)))
  181. (if (and object (bufferp object))
  182. (if no-switch
  183. (display-buffer object)
  184. (pop-to-buffer object))
  185. (let* ((session (sesman-browser-get 'session))
  186. (info (sesman-session-info (sesman--system) session))
  187. (buffers (or (plist-get info :buffers)
  188. (let ((objects (plist-get info :objects)))
  189. (seq-filter #'bufferp objects)))))
  190. (if buffers
  191. (let ((most-recent-buf (seq-find (lambda (b)
  192. (member b buffers))
  193. (buffer-list))))
  194. (if no-switch
  195. (display-buffer most-recent-buf)
  196. (pop-to-buffer most-recent-buf)))
  197. (user-error "Cannot jump to session %s; it doesn't contain any buffers" (car session)))))))
  198. (defun sesman-show ()
  199. "Show the most relevant buffer for the session at point."
  200. (interactive)
  201. (sesman-goto 'no-switch))
  202. (defun sesman-browser--sensor-function (&rest _ignore)
  203. (let ((beg (or (when (get-text-property (point) :sesman-stop)
  204. (if (get-text-property (1- (point)) :sesman-stop)
  205. (previous-single-char-property-change (point) :sesman-stop)
  206. (point)))
  207. (next-single-char-property-change (point) :sesman-stop)))
  208. (end (next-single-char-property-change (point) :sesman-stop)))
  209. (move-overlay sesman-browser--stop-overlay beg end)
  210. (when window-system
  211. (let ((beg (get-text-property (point) :sesman-fragment-beg))
  212. (end (get-text-property (point) :sesman-fragment-end)))
  213. (when (and beg end)
  214. (move-overlay sesman-browser--section-overlay beg end))))))
  215. ;;; Sesman UI
  216. (defun sesman-browser-quit-session ()
  217. "Quite session at point."
  218. (interactive)
  219. (sesman-quit (sesman-browser-get 'session)))
  220. (defun sesman-browser-restart-session ()
  221. "Restart session at point."
  222. (interactive)
  223. (sesman-restart (sesman-browser-get 'session)))
  224. (defun sesman-browser-link-with-buffer ()
  225. "Ask for buffer to link session at point to."
  226. (interactive)
  227. (let ((session (sesman-browser-get 'session)))
  228. (sesman-link-with-buffer 'ask session)))
  229. (defun sesman-browser-link-with-directory ()
  230. "Ask for directory to link session at point to."
  231. (interactive)
  232. (let ((session (sesman-browser-get 'session)))
  233. (sesman-link-with-directory 'ask session)))
  234. (defun sesman-browser-link-with-project ()
  235. "Ask for project to link session at point to."
  236. (interactive)
  237. (let ((session (sesman-browser-get 'session)))
  238. (sesman-link-with-project 'ask session)))
  239. (defun sesman-browser-unlink ()
  240. "Unlink the link at point or ask for link to unlink."
  241. (interactive)
  242. (if-let ((link (sesman-browser-get 'link 'no-error)))
  243. (sesman--unlink link)
  244. (if-let ((links (sesman-links (sesman--system)
  245. (sesman-browser-get 'session))))
  246. (mapc #'sesman--unlink
  247. (sesman--ask-for-link "Unlink: " links 'ask-all))
  248. (user-error "No links for session %s" (car (sesman-browser-get 'session)))))
  249. (run-hooks 'sesman-post-command-hook))
  250. ;;; Major Mode
  251. (defun sesman-browser-revert (&rest _ignore)
  252. "Refresh current browser buffer."
  253. (let ((pos (point)))
  254. (sesman-browser)
  255. ;; simple but not particularly reliable or useful
  256. (goto-char (min pos (point-max)))))
  257. (defun sesman-browser-revert-all (system)
  258. "Refresh all Sesman SYSTEM browsers."
  259. (mapc (lambda (b)
  260. (with-current-buffer b
  261. (when (and (derived-mode-p 'sesman-browser-mode)
  262. (eq system (sesman--system)))
  263. (sesman-browser-revert))))
  264. (buffer-list)))
  265. (defun sesman-browser--goto-stop (stop-value)
  266. (let ((search t))
  267. (goto-char (point-min))
  268. (while search
  269. (goto-char (next-single-char-property-change (point) :sesman-stop))
  270. (if (eobp)
  271. (progn (setq search nil)
  272. (goto-char (next-single-char-property-change (point-min) :sesman-stop)))
  273. (when (equal (get-text-property (point) :sesman-stop) stop-value)
  274. (setq search nil))))))
  275. (defun sesman-browser-toggle-sort ()
  276. "Toggle sorting of sessions.
  277. See `sesman-browser-sort-type' for the default sorting type."
  278. (interactive)
  279. (when (eq sesman-browser-sort-type
  280. (car sesman-browser--sort-types))
  281. (pop sesman-browser--sort-types))
  282. (unless sesman-browser--sort-types
  283. (setq-local sesman-browser--sort-types (default-value 'sesman-browser--sort-types)))
  284. (setq sesman-browser-sort-type (pop sesman-browser--sort-types))
  285. (let ((stop (sesman-browser-get :sesman-stop nil 'lax)))
  286. (sesman-browser)
  287. (sesman-browser--goto-stop stop)
  288. (sesman-browser--sensor-function))
  289. (message "Sorted by %s"
  290. (propertize (symbol-name sesman-browser-sort-type) 'face 'bold)))
  291. (define-derived-mode sesman-browser-mode special-mode "SesmanBrowser"
  292. "Interactive view of Sesman sessions.
  293. When applicable, system specific commands are locally bound to j when point is
  294. on a session object."
  295. ;; ensure there is a sesman-system here
  296. (sesman--system)
  297. (delete-all-overlays)
  298. (setq-local sesman-browser--stop-overlay (make-overlay (point) (point)))
  299. (overlay-put sesman-browser--stop-overlay 'face 'sesman-browser-highligh-face)
  300. (setq-local sesman-browser--section-overlay (make-overlay (point) (point)))
  301. (when window-system
  302. (let* ((fringe-spec '(left-fringe sesman-left-bar sesman-browser-highligh-face))
  303. (dummy-string (propertize "|" 'display fringe-spec)))
  304. (overlay-put sesman-browser--section-overlay 'line-prefix dummy-string)))
  305. (add-hook 'sesman-post-command-hook 'sesman-browser-revert nil t)
  306. (setq-local display-buffer-base-action '(nil . ((inhibit-same-window . t))))
  307. (setq-local sesman-browser--sort-types (default-value 'sesman-browser--sort-types))
  308. (setq-local revert-buffer-function #'sesman-browser-revert))
  309. (defun sesman-browser--insert-session (system ses i)
  310. (let ((ses-name (car ses))
  311. (head-template "%17s")
  312. beg end)
  313. (setq beg (point))
  314. ;; session header
  315. (insert (format "%3d: " i))
  316. (insert (propertize (car ses)
  317. :sesman-stop ses-name
  318. :sesman-vertical-stop t
  319. :sesman-session-stop t
  320. 'face 'bold
  321. 'cursor-sensor-functions (list #'sesman-browser--sensor-function)
  322. 'mouse-face 'highlight)
  323. "\n")
  324. ;; links
  325. (insert (format head-template "linked-to: "))
  326. (let ((link-groups (sesman-grouped-links system ses))
  327. (vert-stop))
  328. (dolist (grp link-groups)
  329. (let* ((type (car grp)))
  330. (dolist (link (cdr grp))
  331. (when (> (current-column) fill-column)
  332. (insert "\n" (format head-template " "))
  333. (setq vert-stop nil))
  334. (let ((val (sesman--abbrev-path-maybe (sesman--lnk-value link))))
  335. (insert (propertize (sesman--format-context type val 'sesman-browser-button-face)
  336. :sesman-stop (car link)
  337. :sesman-vertical-stop (unless vert-stop (setq vert-stop t))
  338. :sesman-link link
  339. 'cursor-sensor-functions (list #'sesman-browser--sensor-function)
  340. 'mouse-face 'highlight)))
  341. (insert " ")))))
  342. (insert "\n")
  343. ;; objects
  344. (insert (format head-template "objects: "))
  345. (let* ((info (sesman-session-info system ses))
  346. (map (plist-get info :map))
  347. (objects (plist-get info :objects))
  348. (strings (or (plist-get info :strings)
  349. (mapcar (lambda (x) (format "%s" x)) objects)))
  350. (kvals (seq-mapn #'cons objects strings))
  351. (kvals (seq-sort (lambda (a b) (string-lessp (cdr a) (cdr b)))
  352. kvals))
  353. (vert-stop))
  354. (dolist (kv kvals)
  355. (when (> (current-column) fill-column)
  356. (insert "\n" (format head-template " "))
  357. (setq vert-stop nil))
  358. (let ((str (replace-regexp-in-string ses-name "%s" (cdr kv) nil t)))
  359. (insert (propertize str
  360. :sesman-stop str
  361. :sesman-vertical-stop (unless vert-stop (setq vert-stop t))
  362. :sesman-object (car kv)
  363. 'cursor-sensor-functions (list #'sesman-browser--sensor-function)
  364. 'face 'sesman-browser-button-face
  365. 'mouse-face 'highlight
  366. 'help-echo "mouse-2: visit in other window"
  367. 'keymap map)
  368. " "))))
  369. ;; session properties
  370. (setq end (point))
  371. (put-text-property beg end :sesman-session ses)
  372. (put-text-property beg end :sesman-session-name ses-name)
  373. (put-text-property beg end :sesman-fragment-beg beg)
  374. (put-text-property beg end :sesman-fragment-end end)
  375. (insert "\n\n")))
  376. ;;;###autoload
  377. (defun sesman-browser ()
  378. "Display an interactive session browser.
  379. See `sesman-browser-mode' for more details."
  380. (interactive)
  381. (let* ((system (sesman--system))
  382. (pop-to (called-interactively-p 'any))
  383. (sessions (sesman-sessions system))
  384. (cur-session (when pop-to
  385. (sesman-current-session 'CIDER)))
  386. (buff (get-buffer-create (format "*sesman %s browser*" system))))
  387. (with-current-buffer buff
  388. (setq-local sesman-system system)
  389. (sesman-browser-mode)
  390. (cursor-sensor-mode 1)
  391. (let ((inhibit-read-only t)
  392. (sessions (pcase sesman-browser-sort-type
  393. ('name (seq-sort (lambda (a b) (string-greaterp (car b) (car a)))
  394. sessions))
  395. ('relevance (sesman--sort-sessions system sessions))
  396. (_ (error "Invalid `sesman-browser-sort-type'"))))
  397. (i 0))
  398. (erase-buffer)
  399. (insert "\n ")
  400. (insert (propertize (format "%s Sessions:" system)
  401. 'face '(bold font-lock-keyword-face)))
  402. (insert "\n\n")
  403. (dolist (ses sessions)
  404. (setq i (1+ i))
  405. (sesman-browser--insert-session system ses i))
  406. (when pop-to
  407. (pop-to-buffer buff)
  408. (sesman-browser--goto-stop (car cur-session)))
  409. (sesman-browser--sensor-function)))))
  410. (provide 'sesman-browser)
  411. ;;; sesman-browser.el ends here