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