├── .dir-locals.el ├── .gitignore ├── .travis.yml ├── Makefile ├── README.md ├── sesman-browser.el ├── sesman-test.el ├── sesman.el └── targets ├── checkdoc.el └── compile.el /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((nil 5 | (sentence-end-double-space) 6 | (checkdoc-arguments-in-order-flag) 7 | (checkdoc-verb-check-experimental-flag) 8 | (checkdoc-force-docstrings-flag) 9 | ;; To use the bug-reference stuff, do: 10 | ;; (add-hook 'text-mode-hook #'bug-reference-mode) 11 | ;; (add-hook 'prog-mode-hook #'bug-reference-prog-mode) 12 | (bug-reference-bug-regexp . "#\\(?2:[[:digit:]]+\\)") 13 | (bug-reference-url-format . "https://github.com/vspinu/sesman/issues/%s")) 14 | (emacs-lisp-mode 15 | (eval . (add-hook 'before-save-hook 'delete-trailing-whitespace nil t)) 16 | (indent-tabs-mode) 17 | (fill-column . 80) 18 | (emacs-lisp-docstring-fill-column . 80))) 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *\#*\# 3 | *.\#* 4 | *.elc 5 | TAGS 6 | .DS_STORE 7 | tmp/ -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: emacs-lisp 2 | env: 3 | - EVM_EMACS=emacs-25.3-travis 4 | - EVM_EMACS=emacs-26.1-travis 5 | - EVM_EMACS=emacs-git-snapshot-travis 6 | 7 | before_install: 8 | - git clone https://github.com/rejeep/evm.git $HOME/.evm 9 | - export PATH=$HOME/.evm/bin:$PATH 10 | - evm config path /tmp 11 | - evm install $EVM_EMACS --use --skip 12 | 13 | script: 14 | - emacs --version 15 | - make all 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | export EMACS ?= emacs 2 | EMACSFLAGS = -L . 3 | VERSION = $(git describe --tags --abbrev=0 | sed 's/^v//') 4 | 5 | ELS = $(wildcard *.el) 6 | OBJECTS = $(ELS:.el=.elc) 7 | 8 | .PHONY: test version compile 9 | 10 | all: compile checkdoc test 11 | 12 | compile: version clean 13 | $(EMACS) --batch --load targets/compile.el 14 | 15 | checkdoc: version 16 | $(EMACS) --batch --load targets/checkdoc.el 17 | 18 | lint: checkdoc 19 | 20 | test: version 21 | $(EMACS) --batch --directory . --load sesman-test.el --funcall ert-run-tests-batch-and-exit 22 | 23 | version: 24 | @echo SESMAN: $(VERSION) 25 | @$(EMACS) --version 26 | 27 | clean: 28 | rm -f $(OBJECTS) 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![License GPL 3][badge-license]](http://www.gnu.org/licenses/gpl-3.0.txt) 2 | [![MELPA](http://melpa.org/packages/sesman-badge.svg)](http://melpa.org/#/sesman) 3 | [![MELPA Stable](http://stable.melpa.org/packages/sesman-badge.svg)](http://stable.melpa.org/#/sesman) 4 | [![Build Status](https://travis-ci.org/vspinu/sesman.svg?branch=master)](https://travis-ci.org/vspinu/sesman) 5 | 6 | ## Generic Session Manager for Emacs 7 | 8 | Sesman provides facilities for session management and interactive session association with the current contexts (e.g. project, directory, buffers). While sesman can be used to manage arbitrary "sessions", it primary targets the Emacs based IDEs ([CIDER][], [ESS][], [Geiser][], [Robe][], [SLIME][] etc.) 9 | 10 | For Emacs based IDEs, session are commonly composed of one or more physical processes (sub-processes, sockets, websockets etc). For example in the current implementation of [CIDER][] a session would be composed of one or more sesman connections (Clojure or ClojureScript). Each [CIDER][] connection consists of user REPL buffer and two sub-processes, one for user eval communication and another for tooling (completion, inspector etc). 11 | 12 | ### Concepts: 13 | 14 | - "session" is a list of the form `(session-name ..other-stuff..)` where `..other-stuff..` is system dependent. 15 | - "system" is generic name used for a tool which uses sesman (e.g. `CIDER`, `ESS` etc) 16 | - "contexts" are Emacs objects which describe current context. For example `current-buffer`, `default-directory` and `project-current` are such contexts. Context objects are used to create associations (links) between the current context and sessions. At any given time the user can link (unlink) sessions to (from) contexts. By default there are three types of contexts - buffer, directory and project, but systems can define their own specialized context types.. 17 | 18 | Sesman is composed of two parts, user interface, available as a sesman map and menu, and system interface consisting of a few generics and API functions. 19 | 20 | ### User Interface 21 | 22 | Consists of 23 | 24 | - lifecycle management commands (`sesman-start`, `sesman-quit` and `sesman-restart`), and 25 | - association management commands (`sesman-link-with-buffer`, `sesman-link-with-directory`, `sesman-link-with-project` and `sesman-unlink`). 26 | 27 | From the user's prospective the work-flow is as follow. Start a session, either with `sesman-start` (`C-c C-s C-s`) or some of the system specific commands (`run-xyz`, `xyz-jack-in` etc). On startup each session is automatically associated with the least specific context (commonly a project). In the most common case the user has only one session open per project. In such case, no ambiguity arises when a system retrieves the current session. If multiple sessions are associated with the current context the ambiguity is automatically resolved through the system specific relevance mechanism. Usually it is the most recently used session. 28 | 29 | By default links with projects and directories are many-to-many in the sense that any session can be linked to multiple context and each context can be associated with multiple sessions. Buffers instead are 1-to-many. One buffer can be associated with only one session and a session can be associated with multiple buffers. This behavior is controlled by a custom `sesman-single-link-context-types`. 30 | 31 | ### System Interface 32 | 33 | Consists of several generics, of which only first three are strictly required: 34 | 35 | - `sesman-start-session` 36 | - `sesman-quit-session` 37 | - `sesman-restart-session` 38 | - `sesman-session-info` 39 | - `sesman-context-types` 40 | - `sesman-more-relevant-p` 41 | 42 | Sesman also provides [a range of utility functions][system api] functions to manipulate sessions, links and session components. Systems can register entire sessions with `sesman-register` or add/remove objects one by one with `sesman-add-object`/`sesman-remove-object`. 43 | 44 | Systems should link sesman map into their key-maps (ideally on `C-c C-s`) and install sesman menu with `sesman-install-menu`. 45 | 46 | ### Implementations 47 | 48 | - [CIDER implementation](https://docs.cider.mx/cider/usage/managing_connections.html) 49 | 50 | 51 | 52 | 53 | [cider]: https://github.com/clojure-emacs/cider 54 | [ess]: https://ess.r-project.org/ 55 | [geiser]: https://github.com/jaor/geiser 56 | [robe]: https://github.com/dgutov/robe 57 | [slime]: https://common-lisp.net/project/slime/ 58 | 59 | [badge-license]: https://img.shields.io/badge/license-GPL_3-green.svg 60 | -------------------------------------------------------------------------------- /sesman-browser.el: -------------------------------------------------------------------------------- 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 ((map (make-sparse-keymap))) 74 | (define-key map (kbd "n") #'sesman-browser-vertical-next) 75 | (define-key map (kbd "p") #'sesman-browser-vertical-prev) 76 | (define-key map (kbd "f") #'sesman-browser-forward) 77 | (define-key map (kbd "b") #'sesman-browser-backward) 78 | (define-key map [remap forward-paragraph] #'sesman-browser-session-next) 79 | (define-key map [remap backward-paragraph] #'sesman-browser-session-prev) 80 | (define-key map (kbd "C-M-n") #'sesman-browser-session-next) 81 | (define-key map (kbd "C-M-p") #'sesman-browser-session-prev) 82 | (define-key map (kbd "") #'sesman-browser-forward) 83 | (define-key map (kbd "") #'sesman-browser-backward) 84 | (define-key map (kbd "") #'sesman-goto) 85 | (define-key map (kbd "o") #'sesman-show) 86 | (define-key map (kbd "t") #'sesman-browser-toggle-sort) 87 | (define-key map (kbd "S") #'sesman-browser-toggle-sort) 88 | (define-key map (kbd "l b") #'sesman-browser-link-with-buffer) 89 | (define-key map (kbd "l d") #'sesman-browser-link-with-directory) 90 | (define-key map (kbd "l p") #'sesman-browser-link-with-project) 91 | (define-key map (kbd "u") #'sesman-browser-unlink) 92 | (define-key map (kbd "s") 'sesman-browser-map) 93 | (define-key map (kbd "C-c C-s") 'sesman-browser-map) 94 | (easy-menu-define sesman-browser-mode-map map 95 | "Sesman Browser" 96 | '("SesmanBrowser" 97 | ["Next row" sesman-browser-vertical-next] 98 | ["Previous row" sesman-browser-vertical-prev] 99 | ["Next button" sesman-browser-forward] 100 | ["Previous button" sesman-browser-backward] 101 | ["Next session" sesman-browser-session-next] 102 | ["Previous session" sesman-browser-session-prev] 103 | "--" 104 | ["Goto buffer" sesman-goto] 105 | ["Show buffer" sesman-show] 106 | "--" 107 | ["Link with Buffer" sesman-browser-link-with-buffer] 108 | ["Link with Directory" sesman-browser-link-with-directory] 109 | ["Link with Project" sesman-browser-link-with-project] 110 | ["Unlink" sesman-browser-unlink] 111 | "--" 112 | ["Toggle sort" sesman-browser-toggle-sort] 113 | ["Refresh View" revert-buffer])) 114 | map) 115 | "Local keymap in `sesman-browser-mode'.") 116 | 117 | 118 | ;;; Utilities 119 | 120 | (defun sesman-browser--closeby-pos (prop lax) 121 | (or (when (get-text-property (point) prop) 122 | (point)) 123 | (when (and (not (bobp)) 124 | (get-text-property (1- (point)) prop)) 125 | (1- (point))) 126 | (when lax 127 | (let ((next (save-excursion 128 | (and 129 | (goto-char (next-single-char-property-change (point) prop)) 130 | (get-text-property (point) prop) 131 | (point)))) 132 | (prev (save-excursion 133 | (and 134 | (goto-char (previous-single-char-property-change (point) prop)) 135 | (not (bobp)) 136 | (get-text-property (1- (point)) prop) 137 | (1- (point)))))) 138 | (if next 139 | (if prev 140 | (if (< (- (point) prev) (- next (point))) 141 | prev 142 | next) 143 | next) 144 | prev))))) 145 | 146 | (defun sesman-browser--closeby-value (prop lax) 147 | (when-let ((pos (sesman-browser--closeby-pos prop lax))) 148 | (get-text-property pos prop))) 149 | 150 | (defun sesman-browser-get (what &optional no-error lax) 151 | "Get value of the property WHAT at point. 152 | If NO-ERROR is non-nil, don't throw an error if no value has been found and 153 | return nil. If LAX is non-nil, search nearby and return the closest value." 154 | (when (derived-mode-p 'sesman-browser-mode) 155 | (or (let ((prop (pcase what 156 | ('session :sesman-session) 157 | ('link :sesman-link) 158 | ('object :sesman-object) 159 | (_ what)))) 160 | (sesman-browser--closeby-value prop 'lax)) 161 | (unless no-error 162 | (user-error "No %s %s" what (if lax "nearby" "at point")))))) 163 | 164 | 165 | ;;; Navigation 166 | 167 | (defvar-local sesman-browser--section-overlay nil) 168 | (defvar-local sesman-browser--stop-overlay nil) 169 | 170 | (when (fboundp 'define-fringe-bitmap) 171 | (define-fringe-bitmap 'sesman-left-bar 172 | [#b00001100] nil nil '(top t))) 173 | 174 | (defun sesman-browser--next (prop) 175 | (let ((pos (point))) 176 | (goto-char (previous-single-char-property-change (point) prop)) 177 | (unless (get-text-property (point) prop) 178 | (goto-char (previous-single-char-property-change (point) prop))) 179 | (when (bobp) 180 | (goto-char pos)))) 181 | 182 | (defun sesman-browser--prev (prop) 183 | (let ((pos (point))) 184 | (goto-char (next-single-char-property-change (point) prop)) 185 | (unless (get-text-property (point) prop) 186 | (goto-char (next-single-char-property-change (point) prop))) 187 | (when (eobp) 188 | (goto-char pos)))) 189 | 190 | (defun sesman-browser-forward () 191 | "Go to next button." 192 | (interactive) 193 | (sesman-browser--prev :sesman-stop)) 194 | 195 | (defun sesman-browser-backward () 196 | "Go to previous button." 197 | (interactive) 198 | (sesman-browser--next :sesman-stop)) 199 | 200 | (defun sesman-browser-vertical-next () 201 | "Go to next button section or row." 202 | (interactive) 203 | (sesman-browser--prev :sesman-vertical-stop)) 204 | 205 | (defun sesman-browser-vertical-prev () 206 | "Go to previous button section or row." 207 | (interactive) 208 | (sesman-browser--next :sesman-vertical-stop)) 209 | 210 | (defun sesman-browser-session-next () 211 | "Go to next session." 212 | (interactive) 213 | (sesman-browser--prev :sesman-session-stop)) 214 | 215 | (defun sesman-browser-session-prev () 216 | "Go to previous session." 217 | (interactive) 218 | (sesman-browser--next :sesman-session-stop)) 219 | 220 | 221 | ;;; Display 222 | 223 | (defun sesman-goto (&optional no-switch) 224 | "Go to most relevant buffer for session at point. 225 | If NO-SWITCH is non-nil, only display the buffer." 226 | (interactive "P") 227 | (let ((object (get-text-property (point) :sesman-object))) 228 | (if (and object (bufferp object)) 229 | (if no-switch 230 | (display-buffer object) 231 | (pop-to-buffer object)) 232 | (let* ((session (sesman-browser-get 'session)) 233 | (info (sesman-session-info (sesman--system) session)) 234 | (buffers (or (plist-get info :buffers) 235 | (let ((objects (plist-get info :objects))) 236 | (seq-filter #'bufferp objects))))) 237 | (if buffers 238 | (let ((most-recent-buf (seq-find (lambda (b) 239 | (member b buffers)) 240 | (buffer-list)))) 241 | (if no-switch 242 | (display-buffer most-recent-buf) 243 | (pop-to-buffer most-recent-buf))) 244 | (user-error "Cannot jump to session %s; it doesn't contain any buffers" (car session))))))) 245 | 246 | (defun sesman-show () 247 | "Show the most relevant buffer for the session at point." 248 | (interactive) 249 | (sesman-goto 'no-switch)) 250 | 251 | (defun sesman-browser--sensor-function (&rest _ignore) 252 | (let ((beg (or (when (get-text-property (point) :sesman-stop) 253 | (if (get-text-property (1- (point)) :sesman-stop) 254 | (previous-single-char-property-change (point) :sesman-stop) 255 | (point))) 256 | (next-single-char-property-change (point) :sesman-stop))) 257 | (end (next-single-char-property-change (point) :sesman-stop))) 258 | (move-overlay sesman-browser--stop-overlay beg end) 259 | (when window-system 260 | (let ((beg (get-text-property (point) :sesman-fragment-beg)) 261 | (end (get-text-property (point) :sesman-fragment-end))) 262 | (when (and beg end) 263 | (move-overlay sesman-browser--section-overlay beg end)))))) 264 | 265 | 266 | ;;; Sesman UI 267 | 268 | (defun sesman-browser-quit-session () 269 | "Quite session at point." 270 | (interactive) 271 | (sesman-quit (sesman-browser-get 'session))) 272 | 273 | (defun sesman-browser-restart-session () 274 | "Restart session at point." 275 | (interactive) 276 | (sesman-restart (sesman-browser-get 'session))) 277 | 278 | (defun sesman-browser-link-with-buffer () 279 | "Ask for buffer to link session at point to." 280 | (interactive) 281 | (let ((session (sesman-browser-get 'session))) 282 | (sesman-link-with-buffer 'ask session))) 283 | 284 | (defun sesman-browser-link-with-directory () 285 | "Ask for directory to link session at point to." 286 | (interactive) 287 | (let ((session (sesman-browser-get 'session))) 288 | (sesman-link-with-directory 'ask session))) 289 | 290 | (defun sesman-browser-link-with-project () 291 | "Ask for project to link session at point to." 292 | (interactive) 293 | (let ((session (sesman-browser-get 'session))) 294 | (sesman-link-with-project 'ask session))) 295 | 296 | (defun sesman-browser-unlink () 297 | "Unlink the link at point or ask for link to unlink." 298 | (interactive) 299 | (if-let ((link (sesman-browser-get 'link 'no-error))) 300 | (sesman--unlink link) 301 | (if-let ((links (sesman-links (sesman--system) 302 | (sesman-browser-get 'session)))) 303 | (mapc #'sesman--unlink 304 | (sesman--ask-for-link "Unlink: " links 'ask-all)) 305 | (user-error "No links for session %s" (car (sesman-browser-get 'session))))) 306 | (run-hooks 'sesman-post-command-hook)) 307 | 308 | 309 | ;;; Major Mode 310 | 311 | (defun sesman-browser-revert (&rest _ignore) 312 | "Refresh current browser buffer." 313 | (let ((pos (point))) 314 | (sesman-browser) 315 | ;; simple but not particularly reliable or useful 316 | (goto-char (min pos (point-max))))) 317 | 318 | (defun sesman-browser-revert-all (system) 319 | "Refresh all Sesman SYSTEM browsers." 320 | (mapc (lambda (b) 321 | (with-current-buffer b 322 | (when (and (derived-mode-p 'sesman-browser-mode) 323 | (eq system (sesman--system))) 324 | (sesman-browser-revert)))) 325 | (buffer-list))) 326 | 327 | (defun sesman-browser--goto-stop (stop-value) 328 | (let ((search t)) 329 | (goto-char (point-min)) 330 | (while search 331 | (goto-char (next-single-char-property-change (point) :sesman-stop)) 332 | (if (eobp) 333 | (progn (setq search nil) 334 | (goto-char (next-single-char-property-change (point-min) :sesman-stop))) 335 | (when (equal (get-text-property (point) :sesman-stop) stop-value) 336 | (setq search nil)))))) 337 | 338 | (defun sesman-browser-toggle-sort () 339 | "Toggle sorting of sessions. 340 | See `sesman-browser-sort-type' for the default sorting type." 341 | (interactive) 342 | (when (eq sesman-browser-sort-type 343 | (car sesman-browser--sort-types)) 344 | (pop sesman-browser--sort-types)) 345 | (unless sesman-browser--sort-types 346 | (setq-local sesman-browser--sort-types (default-value 'sesman-browser--sort-types))) 347 | (setq sesman-browser-sort-type (pop sesman-browser--sort-types)) 348 | (let ((stop (sesman-browser-get :sesman-stop nil 'lax))) 349 | (sesman-browser) 350 | (sesman-browser--goto-stop stop) 351 | (sesman-browser--sensor-function)) 352 | (message "Sorted by %s" 353 | (propertize (symbol-name sesman-browser-sort-type) 'face 'bold))) 354 | 355 | (define-derived-mode sesman-browser-mode special-mode "SesmanBrowser" 356 | "Interactive view of Sesman sessions. 357 | When applicable, system specific commands are locally bound to j when point is 358 | on a session object." 359 | ;; ensure there is a sesman-system here 360 | (sesman--system) 361 | (delete-all-overlays) 362 | (setq-local sesman-browser--stop-overlay (make-overlay (point) (point))) 363 | (overlay-put sesman-browser--stop-overlay 'face 'sesman-browser-highligh-face) 364 | (setq-local sesman-browser--section-overlay (make-overlay (point) (point))) 365 | (when window-system 366 | (let* ((fringe-spec '(left-fringe sesman-left-bar sesman-browser-highligh-face)) 367 | (dummy-string (propertize "|" 'display fringe-spec))) 368 | (overlay-put sesman-browser--section-overlay 'line-prefix dummy-string))) 369 | (add-hook 'sesman-post-command-hook 'sesman-browser-revert nil t) 370 | (setq-local display-buffer-base-action '(nil . ((inhibit-same-window . t)))) 371 | (setq-local sesman-browser--sort-types (default-value 'sesman-browser--sort-types)) 372 | (setq-local revert-buffer-function #'sesman-browser-revert)) 373 | 374 | (defun sesman-browser--insert-session (system ses i) 375 | (let ((ses-name (car ses)) 376 | (head-template "%17s") 377 | beg end) 378 | (setq beg (point)) 379 | 380 | ;; session header 381 | (insert (format "%3d: " i)) 382 | (insert (propertize (car ses) 383 | :sesman-stop ses-name 384 | :sesman-vertical-stop t 385 | :sesman-session-stop t 386 | 'face 'bold 387 | 'cursor-sensor-functions (list #'sesman-browser--sensor-function) 388 | 'mouse-face 'highlight) 389 | "\n") 390 | 391 | ;; links 392 | (insert (format head-template "linked-to: ")) 393 | (let ((link-groups (sesman-grouped-links system ses)) 394 | (vert-stop)) 395 | (dolist (grp link-groups) 396 | (let* ((type (car grp))) 397 | (dolist (link (cdr grp)) 398 | (when (> (current-column) fill-column) 399 | (insert "\n" (format head-template " ")) 400 | (setq vert-stop nil)) 401 | (let ((val (sesman--abbrev-path-maybe (sesman--lnk-value link)))) 402 | (insert (propertize (sesman--format-context type val 'sesman-browser-button-face) 403 | :sesman-stop (car link) 404 | :sesman-vertical-stop (unless vert-stop (setq vert-stop t)) 405 | :sesman-link link 406 | 'cursor-sensor-functions (list #'sesman-browser--sensor-function) 407 | 'mouse-face 'highlight))) 408 | (insert " "))))) 409 | (insert "\n") 410 | 411 | ;; objects 412 | (insert (format head-template "objects: ")) 413 | (let* ((info (sesman-session-info system ses)) 414 | (map (plist-get info :map)) 415 | (objects (plist-get info :objects)) 416 | (strings (or (plist-get info :strings) 417 | (mapcar (lambda (x) (format "%s" x)) objects))) 418 | (kvals (seq-mapn #'cons objects strings)) 419 | (kvals (seq-sort (lambda (a b) (string-lessp (cdr a) (cdr b))) 420 | kvals)) 421 | (vert-stop)) 422 | (dolist (kv kvals) 423 | (when (> (current-column) fill-column) 424 | (insert "\n" (format head-template " ")) 425 | (setq vert-stop nil)) 426 | (let ((str (replace-regexp-in-string ses-name "%s" (cdr kv) nil t))) 427 | (insert (propertize str 428 | :sesman-stop str 429 | :sesman-vertical-stop (unless vert-stop (setq vert-stop t)) 430 | :sesman-object (car kv) 431 | 'cursor-sensor-functions (list #'sesman-browser--sensor-function) 432 | 'face 'sesman-browser-button-face 433 | 'mouse-face 'highlight 434 | 'help-echo "mouse-2: visit in other window" 435 | 'keymap map) 436 | " ")))) 437 | 438 | ;; session properties 439 | (setq end (point)) 440 | (put-text-property beg end :sesman-session ses) 441 | (put-text-property beg end :sesman-session-name ses-name) 442 | (put-text-property beg end :sesman-fragment-beg beg) 443 | (put-text-property beg end :sesman-fragment-end end) 444 | (insert "\n\n"))) 445 | 446 | ;;;###autoload 447 | (defun sesman-browser () 448 | "Display an interactive session browser. 449 | See `sesman-browser-mode' for more details." 450 | (interactive) 451 | (let* ((system (sesman--system)) 452 | (pop-to (called-interactively-p 'any)) 453 | (sessions (sesman-sessions system)) 454 | (cur-session (when pop-to 455 | (sesman-current-session 'CIDER))) 456 | (buff (get-buffer-create (format "*sesman %s browser*" system)))) 457 | (with-current-buffer buff 458 | (setq-local sesman-system system) 459 | (sesman-browser-mode) 460 | (cursor-sensor-mode 1) 461 | (let ((inhibit-read-only t) 462 | (sessions (pcase sesman-browser-sort-type 463 | ('name (seq-sort (lambda (a b) (string-greaterp (car b) (car a))) 464 | sessions)) 465 | ('relevance (sesman--sort-sessions system sessions)) 466 | (_ (error "Invalid `sesman-browser-sort-type'")))) 467 | (i 0)) 468 | (erase-buffer) 469 | (insert "\n ") 470 | (insert (propertize (format "%s Sessions:" system) 471 | 'face '(bold font-lock-keyword-face))) 472 | (insert "\n\n") 473 | (dolist (ses sessions) 474 | (setq i (1+ i)) 475 | (sesman-browser--insert-session system ses i)) 476 | (when pop-to 477 | (pop-to-buffer buff) 478 | (sesman-browser--goto-stop (car cur-session))) 479 | (sesman-browser--sensor-function))))) 480 | 481 | (provide 'sesman-browser) 482 | ;;; sesman-browser.el ends here 483 | -------------------------------------------------------------------------------- /sesman-test.el: -------------------------------------------------------------------------------- 1 | ;;; sesman-test.el --- Tests 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 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;; 32 | ;;; Code: 33 | 34 | (require 'ert) 35 | (require 'sesman) 36 | (require 'cl) 37 | 38 | 39 | ;;; UTILS 40 | 41 | (defmacro with-empty-sesman-vars (&rest body) 42 | (declare (debug (body))) 43 | `(let ((sesman-links-alist) 44 | (sesman-sessions-hashmap (make-hash-table :test #'equal))) 45 | ,@body)) 46 | 47 | 48 | ;;; SYSTEMS 49 | 50 | ;; A 51 | (cl-defmethod sesman-start-session ((system (eql A))) 52 | (let ((name (gensym "A-"))) 53 | (sesman-register 'A (list name "A-stuff-1" (gensym "A-stuff-"))))) 54 | 55 | (cl-defmethod sesman-quit-session ((system (eql A)) session) 56 | (setcdr session '("[A killed]"))) 57 | 58 | (cl-defmethod sesman-project ((system (eql A))) 59 | (file-name-directory (directory-file-name default-directory))) 60 | 61 | ;; B 62 | (cl-defmethod sesman-start-session ((system (eql B))) 63 | (let ((name (gensym "B-"))) 64 | (sesman-register 'B 65 | (list name 66 | (get-buffer-create (symbol-name (gensym "B-buf-"))) 67 | (get-buffer-create (symbol-name (gensym "B-buf-"))))))) 68 | 69 | (cl-defmethod sesman-quit-session ((system (eql B)) session) 70 | (mapc #'kill-buffer (cdr session))) 71 | 72 | (cl-defmethod sesman-more-relevant-p ((_system (eql B)) session1 session2) 73 | (sesman-more-recent-p (cdr session1) (cdr session2))) 74 | 75 | (cl-defmethod sesman-project ((system (eql B))) 76 | nil) 77 | 78 | 79 | ;;; LIFE CYCLE 80 | 81 | (ert-deftest sesman-start-test () 82 | (with-empty-sesman-vars 83 | (let ((sesman-system 'A)) 84 | (sesman-start) 85 | (let ((sess (sesman-sessions 'A))) 86 | (should (= (length sess) 1)) 87 | (should (string= (cadr (car sess)) "A-stuff-1")) 88 | (sesman-start) 89 | (let ((sess (sesman-sessions 'A))) 90 | (should (= (length sess) 2)) 91 | (should (string= (cadr (cadr sess)) "A-stuff-1"))) 92 | (let ((sesman-system 'B)) 93 | (sesman-start) 94 | (let ((sess (sesman-sessions 'A))) 95 | (should (= (length sess) 2)) 96 | (should (string= (cadr (cadr sess)) "A-stuff-1"))) 97 | (let ((sess (sesman-sessions 'B))) 98 | (should (= (length sess) 1)) 99 | (should (bufferp (cadr (car sess)))))))))) 100 | 101 | (ert-deftest sesman-quit-test () 102 | (with-empty-sesman-vars 103 | 104 | ;; alphabetic relevance 105 | (let ((sesman-system 'A)) 106 | (sesman-start) 107 | (let ((ses (car (sesman-sessions 'A)))) 108 | (sesman-start) 109 | (sesman-quit) 110 | (should (= (length (sesman-sessions 'A)) 1)) 111 | (should-not (string= 112 | (car ses) 113 | (car (sesman-current-session 'A)))))) 114 | 115 | ;; recency relevance 116 | (let ((sesman-system 'B)) 117 | (sesman-start) 118 | (let ((ses (car (sesman-sessions 'B)))) 119 | (switch-to-buffer (cadr (sesman-start))) 120 | (sesman-quit) 121 | (should (= (length (sesman-sessions 'B)) 1)) 122 | (should (eq 123 | (car ses) 124 | (car (sesman-current-session 'B)))))))) 125 | 126 | (ert-deftest sesman-restart-test () 127 | (with-empty-sesman-vars 128 | (let ((sesman-system 'A)) 129 | (sesman-start) 130 | (sesman-start) 131 | (let ((ses-name (car (sesman-current-session 'A)))) 132 | (sesman-restart) 133 | (should (eq (car (sesman-current-session 'A)) 134 | ses-name)))))) 135 | 136 | 137 | ;;; LINKING 138 | (ert-deftest sesman-link-with-project-test () 139 | (with-empty-sesman-vars 140 | (let ((sesman-system 'A)) 141 | (let ((default-directory "/path/to/project/A") 142 | (other-dir "/path/to/other/project/B")) 143 | (sesman-start) 144 | 145 | (sesman-link-with-project nil (sesman-current-session 'A)) 146 | (should (= (length (sesman-links 'A)) 1)) 147 | (let ((lnk (car (sesman-links 'A)))) 148 | (should (string= (sesman--lnk-value lnk) (file-name-directory default-directory))) 149 | (should (eq (sesman--lnk-context-type lnk) 'project)) 150 | (should (eq (sesman--lnk-system-name lnk) 'A))) 151 | 152 | (sesman-link-with-project other-dir (sesman-current-session 'A)) 153 | (should (= (length (sesman-links 'A)) 2)) 154 | (let ((lnk (car (sesman-links 'A)))) 155 | (should (string= (sesman--lnk-value lnk) other-dir)) 156 | (should (eq (sesman--lnk-context-type lnk) 'project)) 157 | (should (eq (sesman--lnk-system-name lnk) 'A))))) 158 | 159 | (let ((sesman-system 'B)) 160 | (let ((default-directory "/path/to/project/A") 161 | (other-dir "/path/to/other/project/B")) 162 | (sesman-start) 163 | (should-error (sesman-link-with-project nil (sesman-current-session 'B))))))) 164 | 165 | (ert-deftest sesman-link-with-directory-test () 166 | (with-empty-sesman-vars 167 | (let ((sesman-system 'A)) 168 | (let ((default-directory "/path/to/project/A") 169 | (other-dir "/path/to/other/project/B")) 170 | (sesman-start) 171 | 172 | (sesman-link-with-directory nil (sesman-current-session 'A)) 173 | (should (= (length (sesman-links 'A)) 2)) 174 | (should (= (length (sesman-links 'A nil 'directory)) 1)) 175 | (let ((lnk (car (sesman-links 'A)))) 176 | (should (string= (sesman--lnk-value lnk) default-directory)) 177 | (should (eq (sesman--lnk-context-type lnk) 'directory)) 178 | (should (eq (sesman--lnk-system-name lnk) 'A))) 179 | 180 | (sesman-link-with-directory other-dir (sesman-current-session 'A)) 181 | (should (= (length (sesman-links 'A)) 3)) 182 | (should (= (length (sesman-links 'A nil 'directory)) 2)) 183 | (let ((lnk (car (sesman-links 'A)))) 184 | (should (string= (sesman--lnk-value lnk) other-dir)) 185 | (should (eq (sesman--lnk-context-type lnk) 'directory)) 186 | (should (eq (sesman--lnk-system-name lnk) 'A))))) 187 | 188 | (let ((sesman-system 'B)) 189 | (let ((default-directory "/path/to/project/B1") 190 | (other-dir "/path/to/other/project/B2")) 191 | (sesman-start) 192 | 193 | (sesman-link-with-directory nil (sesman-current-session 'B)) 194 | (should (= (length (sesman-links 'B)) 1)) 195 | (let ((lnk (car (sesman-links 'B)))) 196 | (should (string= (sesman--lnk-value lnk) default-directory)) 197 | (should (eq (sesman--lnk-context-type lnk) 'directory)) 198 | (should (eq (sesman--lnk-system-name lnk) 'B))))) 199 | 200 | (should (= (length sesman-links-alist) 4)))) 201 | 202 | (ert-deftest sesman-link-with-buffer-test () 203 | (with-empty-sesman-vars 204 | (let ((buf-1 (get-buffer-create "tmp-buf-1")) 205 | (buf-2 (get-buffer-create "tmp-buf-2")) 206 | (sesman-system 'A)) 207 | (with-current-buffer buf-1 208 | (let ((default-directory "/path/to/project/A") 209 | (other-dir "/path/to/other/project/B")) 210 | (sesman-start) 211 | (sesman-link-with-buffer nil (sesman-current-session 'A)) 212 | (should (= (length (sesman-links 'A)) 2)) 213 | (should (= (length (sesman-links 'A nil 'project)) 1)) 214 | (should (= (length (sesman-links 'A nil 'directory)) 0)) 215 | (should (= (length (sesman-links 'A nil 'buffer)) 1)) 216 | (let ((lnk (car (sesman-links 'A nil 'buffer)))) 217 | (should (eq (sesman--lnk-value lnk) buf-1)) 218 | (should (eq (sesman--lnk-context-type lnk) 'buffer)) 219 | (should (eq (sesman--lnk-system-name lnk) 'A))) 220 | 221 | (sesman-link-with-buffer buf-2 (sesman-current-session 'A)) 222 | (should (= (length (sesman-links 'A)) 3)) 223 | (should (= (length (sesman-links 'A nil 'buffer)) 2)) 224 | (let ((lnk (car (sesman-links 'A nil 'buffer)))) 225 | (should (eq (sesman--lnk-value lnk) buf-2)) 226 | (should (eq (sesman--lnk-context-type lnk) 'buffer)) 227 | (should (eq (sesman--lnk-system-name lnk) 'A)))) 228 | 229 | (let ((sesman-system 'B)) 230 | (let ((default-directory "/path/to/project/B1") 231 | (other-dir "/path/to/other/project/B2")) 232 | (sesman-start) 233 | (should (= (length (sesman-links 'B nil 'buffer)) 0)) 234 | (sesman-link-with-buffer nil (sesman-current-session 'B)) 235 | (should (= (length (sesman-links 'B)) 2)) 236 | (should (= (length (sesman-links 'B nil 'project)) 0)) 237 | (should (= (length (sesman-links 'B nil 'directory)) 1)) 238 | (should (= (length (sesman-links 'B nil 'buffer)) 1)) 239 | (sesman-link-with-buffer buf-2 (sesman-current-session 'B)) 240 | (should (= (length (sesman-links 'B nil 'buffer)) 2)) 241 | (let ((lnk (car (sesman-links 'B nil 'buffer)))) 242 | (should (eq (sesman--lnk-value lnk) buf-2)) 243 | (should (eq (sesman--lnk-context-type lnk) 'buffer)) 244 | (should (eq (sesman--lnk-system-name lnk) 'B))))))) 245 | 246 | (should (= (length sesman-links-alist) 6)))) 247 | 248 | 249 | ;;; FILE PATHS 250 | 251 | (cl-defmethod sesman-project ((system (eql C))) 252 | (directory-file-name default-directory)) 253 | 254 | (ert-deftest sesman-symlinked-projects-tests () 255 | (let* ((dir1 (make-temp-file "1-" 'dir)) 256 | (dir2 (make-temp-file "2-" 'dir)) 257 | (dir1-link (format "%s/dir1" dir2))) 258 | 259 | ;; dir1 link in dir2 260 | (should (equal (shell-command (format "ln -s %s %s" dir1 dir1-link)) 261 | 0)) 262 | 263 | (let ((sesman-follow-symlinks nil) 264 | (vc-follow-symlinks t)) 265 | (should (equal (sesman-expand-path dir1-link) 266 | dir1-link))) 267 | (let ((sesman-follow-symlinks t) 268 | (vc-follow-symlinks nil)) 269 | (should (equal (sesman-expand-path dir1-link) 270 | dir1))) 271 | (let ((sesman-follow-symlinks 'vc) 272 | (vc-follow-symlinks t)) 273 | (should (equal (sesman-expand-path dir1-link) 274 | dir1))) 275 | (let ((sesman-follow-symlinks 'vc) 276 | (vc-follow-symlinks nil)) 277 | (should (equal (sesman-expand-path dir1-link) 278 | dir1-link))) 279 | 280 | (let ((sesman-follow-symlinks nil) 281 | (default-directory dir1-link)) 282 | (should (equal (sesman-context 'project 'C) 283 | dir1-link))) 284 | (let ((sesman-follow-symlinks t) 285 | (default-directory dir1-link)) 286 | (should (equal (sesman-context 'project 'C) 287 | dir1))) 288 | (let ((sesman-follow-symlinks 'vc) 289 | (vc-follow-symlinks t) 290 | (default-directory dir1-link)) 291 | (should (equal (sesman-context 'project 'C) 292 | dir1))) 293 | (let ((sesman-follow-symlinks 'vc) 294 | (vc-follow-symlinks nil) 295 | (default-directory dir1-link)) 296 | (should (equal (sesman-context 'project 'C) 297 | dir1-link))) 298 | 299 | (delete-directory dir1 t) 300 | (delete-directory dir2 t))) 301 | 302 | (provide 'sesman-test) 303 | 304 | ;;; sesman-test.el ends here 305 | -------------------------------------------------------------------------------- /sesman.el: -------------------------------------------------------------------------------- 1 | ;;; sesman.el --- Generic Session Manager -*- lexical-binding: t -*- 2 | ;; 3 | ;; Copyright (C) 2018, Vitalie Spinu 4 | ;; Author: Vitalie Spinu 5 | ;; URL: https://github.com/vspinu/sesman 6 | ;; Keywords: process 7 | ;; Version: 0.3.3-DEV 8 | ;; Package-Requires: ((emacs "25")) 9 | ;; Keywords: processes, tools, vc 10 | ;; 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | ;; 13 | ;; This file is *NOT* part of GNU Emacs. 14 | ;; 15 | ;; This program is free software; you can redistribute it and/or 16 | ;; modify it under the terms of the GNU General Public License as 17 | ;; published by the Free Software Foundation; either version 3, or 18 | ;; (at your option) any later version. 19 | ;; 20 | ;; This program is distributed in the hope that it will be useful, 21 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 22 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 23 | ;; General Public License for more details. 24 | ;; 25 | ;; You should have received a copy of the GNU General Public License 26 | ;; along with this program; see the file COPYING. If not, write to 27 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth 28 | ;; Floor, Boston, MA 02110-1301, USA. 29 | ;; 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;; 32 | ;;; Commentary: 33 | ;; 34 | ;; Sesman provides facilities for session management and interactive session 35 | ;; association with the current contexts (project, directory, buffers etc). 36 | ;; See project's readme for more details. 37 | ;; 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | ;; 40 | ;;; Code: 41 | 42 | (require 'cl-generic) 43 | (require 'seq) 44 | (require 'subr-x) 45 | (require 'vc) 46 | 47 | (defgroup sesman nil 48 | "Generic Session Manager." 49 | :prefix "sesman-" 50 | :group 'tools 51 | :link '(url-link :tag "GitHub" "https://github.com/vspinu/sesman")) 52 | 53 | (defface sesman-project-face 54 | '((default (:inherit font-lock-doc-face))) 55 | "Face used to mark projects." 56 | :group 'sesman) 57 | 58 | (defface sesman-directory-face 59 | '((default (:inherit font-lock-type-face))) 60 | "Face used to mark directories." 61 | :group 'sesman) 62 | 63 | (defface sesman-buffer-face 64 | '((default (:inherit font-lock-preprocessor-face))) 65 | "Face used to mark buffers." 66 | :group 'sesman) 67 | 68 | (defcustom sesman-use-friendly-sessions t 69 | "If non-nil consider friendly sessions when looking for current sessions. 70 | The definition of friendly sessions is system dependent but usually means 71 | sessions running in dependent projects." 72 | :group 'sesman 73 | :type 'boolean 74 | :package-version '(sesman . "0.3.2")) 75 | 76 | (defcustom sesman-follow-symlinks 'vc 77 | "When non-nil, follow symlinks during the file expansion. 78 | When nil, don't follow symlinks. When 'vc, follow symlinks only when 79 | `vc-follow-symlinks' is non-nil. When t, always follow symlinks." 80 | :group 'sesman 81 | :type '(choice (const :tag "Comply with `vc-follow-symlinks'" vc) 82 | (const :tag "Don't follow symlinks" nil) 83 | (const :tag "Follow symlinks" t)) 84 | :package-version '(sesman . "0.3.3")) 85 | (put 'sesman-follow-symlinks 'safe-local-variable (lambda (x) (memq x '(vc nil t)))) 86 | 87 | ;; (defcustom sesman-disambiguate-by-relevance t 88 | ;; "If t choose most relevant session in ambiguous situations, otherwise ask. 89 | ;; Ambiguity arises when multiple sessions are associated with current context. 90 | ;; By default only projects could be associated with multiple sessions. See 91 | ;; `sesman-single-link-contexts' in order to change that. Relevance is decided 92 | ;; by system's implementation, see `sesman-more-relevant-p'." 93 | ;; :group 'sesman 94 | ;; :type 'boolean) 95 | 96 | (defcustom sesman-single-link-context-types '(buffer) 97 | "List of context types to which at most one session can be linked." 98 | :group 'sesman 99 | :type '(repeat symbol) 100 | :package-version '(sesman . "0.1.0")) 101 | 102 | ;; FIXME: 103 | ;; (defcustom sesman-abbreviate-paths 2 104 | ;; "Abbreviate paths to that many parents. 105 | ;; When set to nil, don't abbreviate directories." 106 | ;; :group 'sesman 107 | ;; :type '(choice number 108 | ;; (const :tag "Don't abbreviate" nil))) 109 | 110 | (defvar sesman-sessions-hashmap (make-hash-table :test #'equal) 111 | "Hash-table of all sesman sessions. 112 | Key is a cons (system-name . session-name).") 113 | 114 | (defvar sesman-links-alist nil 115 | "An alist of all sesman links. 116 | Each element is of the form (key cxt-type cxt-value) where 117 | \"key\" is of the form (system-name . session-name). system-name 118 | and cxt-type must be symbols.") 119 | 120 | (defvar-local sesman-system nil 121 | "Name of the system managed by `sesman'. 122 | Can be either a symbol, or a function returning a symbol.") 123 | (put 'sesman-system 'permanent-local 't) 124 | 125 | 126 | ;;; Internal Utilities 127 | 128 | (defun sesman--on-C-u-u-sessions (system which) 129 | (cond 130 | ((null which) 131 | (let ((ses (sesman-current-session system))) 132 | (when ses 133 | (list ses)))) 134 | ((or (equal which '(4)) (eq which 'linked)) 135 | (sesman--linked-sessions system 'sort)) 136 | ((or (equal which '(16)) (eq which 'all) (eq which t)) 137 | (sesman--all-system-sessions system 'sort)) 138 | ;; session itself 139 | ((and (listp which) 140 | (or (stringp (car which)) 141 | (symbolp (car which)))) 142 | (list which)) 143 | ;; session name 144 | ((or (stringp which) 145 | (symbolp which) 146 | (gethash (cons system which) sesman-sessions-hashmap))) 147 | (t (error "Invalid which argument (%s)" which)))) 148 | 149 | (defun sesman--cap-system-name (system) 150 | (let ((name (symbol-name system))) 151 | (if (string-match-p "^[[:upper:]]" name) 152 | name 153 | (capitalize name)))) 154 | 155 | (defun sesman--least-specific-context (system) 156 | (seq-some (lambda (ctype) 157 | (when-let (val (sesman-context ctype system)) 158 | (cons ctype val))) 159 | (reverse (sesman-context-types system)))) 160 | 161 | (defun sesman--link-session-interactively (session cxt-type cxt-val) 162 | (let ((system (sesman--system))) 163 | (unless cxt-type 164 | (let ((cxt (sesman--least-specific-context system))) 165 | (setq cxt-type (car cxt) 166 | cxt-val (cdr cxt)))) 167 | (let ((cxt-name (symbol-name cxt-type))) 168 | (if (member cxt-type (sesman-context-types system)) 169 | (let ((session (or session 170 | (sesman-ask-for-session 171 | system 172 | (format "Link with %s %s: " 173 | cxt-name (sesman--abbrev-path-maybe 174 | (sesman-context cxt-type system))) 175 | (sesman--all-system-sessions system 'sort) 176 | 'ask-new)))) 177 | (sesman-link-session system session cxt-type cxt-val)) 178 | (error (format "%s association not allowed for this system (%s)" 179 | (capitalize cxt-name) 180 | system)))))) 181 | 182 | ;; FIXME: incorporate `sesman-abbreviate-paths' 183 | (defun sesman--abbrev-path-maybe (obj) 184 | (if (stringp obj) 185 | (abbreviate-file-name obj) 186 | obj)) 187 | 188 | (defun sesman--system-in-buffer (&optional buffer) 189 | (with-current-buffer (or buffer (current-buffer)) 190 | (if (functionp sesman-system) 191 | (funcall sesman-system) 192 | sesman-system))) 193 | 194 | (defun sesman-get-system () 195 | (if sesman-system 196 | (if (functionp sesman-system) 197 | (funcall sesman-system) 198 | sesman-system) 199 | (error "No `sesman-system' in buffer `%s'" (current-buffer)))) 200 | 201 | (defalias 'sesman--system #'sesman-get-system) 202 | 203 | (defun sesman--linked-sessions (system &optional sort cxt-types) 204 | (let* ((system (or system (sesman--system))) 205 | (cxt-types (or cxt-types (sesman-context-types system)))) 206 | ;; just in case some links are lingering due to user errors 207 | (sesman--clear-links) 208 | (delete-dups 209 | (mapcar (lambda (assoc) 210 | (gethash (car assoc) sesman-sessions-hashmap)) 211 | (sesman-current-links system nil sort cxt-types))))) 212 | 213 | (defun sesman--friendly-sessions (system &optional sort) 214 | (let ((sessions (seq-filter (lambda (ses) (sesman-friendly-session-p system ses)) 215 | (sesman--all-system-sessions system)))) 216 | (if sort 217 | (sesman--sort-sessions system sessions) 218 | sessions))) 219 | 220 | (defun sesman--all-system-sessions (&optional system sort) 221 | "Return a list of sessions registered with SYSTEM. 222 | If SORT is non-nil, sort in relevance order." 223 | (let ((system (or system (sesman--system))) 224 | sessions) 225 | (maphash 226 | (lambda (k s) 227 | (when (eql (car k) system) 228 | (push s sessions))) 229 | sesman-sessions-hashmap) 230 | (if sort 231 | (sesman--sort-sessions system sessions) 232 | sessions))) 233 | 234 | ;; FIXME: make this a macro 235 | (defun sesman--link-lookup-fn (&optional system ses-name cxt-type cxt-val x) 236 | (let ((system (or system (caar x))) 237 | (ses-name (or ses-name (cdar x))) 238 | (cxt-type (or cxt-type (nth 1 x))) 239 | (cxt-val (or cxt-val (nth 2 x)))) 240 | (lambda (el) 241 | (and (or (null system) (eq (caar el) system)) 242 | (or (null ses-name) (equal (cdar el) ses-name)) 243 | (or (null cxt-type) 244 | (if (listp cxt-type) 245 | (member (nth 1 el) cxt-type) 246 | (eq (nth 1 el) cxt-type))) 247 | (or (null cxt-val) (equal (nth 2 el) cxt-val)))))) 248 | 249 | (defun sesman--unlink (x) 250 | (setq sesman-links-alist 251 | (seq-remove (sesman--link-lookup-fn nil nil nil nil x) 252 | sesman-links-alist))) 253 | 254 | (defun sesman--clear-links () 255 | (setq sesman-links-alist 256 | (seq-filter (lambda (x) 257 | (gethash (car x) sesman-sessions-hashmap)) 258 | sesman-links-alist))) 259 | 260 | (defun sesman--format-session-objects (system session &optional sep) 261 | (let ((info (sesman-session-info system session))) 262 | (if (and (listp info) 263 | (keywordp (car info))) 264 | (let ((ses-name (car session)) 265 | (sep (or sep " ")) 266 | (strings (or (plist-get info :strings) 267 | (mapcar (lambda (x) (format "%s" x)) 268 | (plist-get info :objects))))) 269 | (mapconcat (lambda (str) 270 | (replace-regexp-in-string ses-name "..." str nil t)) 271 | strings sep)) 272 | (format "%s" info)))) 273 | 274 | (defun sesman--format-session (system ses &optional prefix) 275 | (format (propertize "%s%s [%s] linked-to %s" 'face 'bold) 276 | (or prefix "") 277 | (propertize (car ses) 'face 'bold) 278 | (propertize (sesman--format-session-objects system ses ", ") 'face 'italic) 279 | (sesman-grouped-links system ses t t))) 280 | 281 | (defun sesman--format-link (link) 282 | (let* ((system (sesman--lnk-system-name link)) 283 | (session (gethash (car link) sesman-sessions-hashmap))) 284 | (format "%s(%s) -> %s [%s]" 285 | (sesman--lnk-context-type link) 286 | (propertize (format "%s" (sesman--abbrev-path-maybe (sesman--lnk-value link))) 287 | 'face 'bold) 288 | (propertize (sesman--lnk-session-name link) 'face 'bold) 289 | (if session 290 | (sesman--format-session-objects system session) 291 | "invalid")))) 292 | 293 | (defun sesman--ask-for-link (prompt links &optional ask-all) 294 | (let* ((name.keys (mapcar (lambda (link) 295 | (cons (sesman--format-link link) link)) 296 | links)) 297 | (name.keys (append name.keys 298 | (when (and ask-all (> (length name.keys) 1)) 299 | '(("*all*"))))) 300 | (nms (mapcar #'car name.keys)) 301 | (sel (completing-read prompt nms nil t nil nil (car nms)))) 302 | (cond ((string= sel "*all*") 303 | links) 304 | (ask-all 305 | (list (cdr (assoc sel name.keys)))) 306 | (t 307 | (cdr (assoc sel name.keys)))))) 308 | 309 | (defun sesman--sort-sessions (system sessions) 310 | (seq-sort (lambda (x1 x2) 311 | (sesman-more-relevant-p system x1 x2)) 312 | sessions)) 313 | 314 | (defun sesman--sort-links (system links) 315 | (seq-sort (lambda (x1 x2) 316 | (sesman-more-relevant-p system 317 | (gethash (car x1) sesman-sessions-hashmap) 318 | (gethash (car x2) sesman-sessions-hashmap))) 319 | links)) 320 | 321 | ;; link data structure accessors 322 | (defun sesman--lnk-system-name (lnk) 323 | (caar lnk)) 324 | (defun sesman--lnk-session-name (lnk) 325 | (cdar lnk)) 326 | (defun sesman--lnk-context-type (lnk) 327 | (cadr lnk)) 328 | (defun sesman--lnk-value (lnk) 329 | (nth 2 lnk)) 330 | 331 | 332 | ;;; User Interface 333 | 334 | (defun sesman-post-command-hook nil 335 | "Normal hook ran after every state-changing Sesman command.") 336 | 337 | ;;;###autoload 338 | (defun sesman-start () 339 | "Start a Sesman session." 340 | (interactive) 341 | (let ((system (sesman--system))) 342 | (message "Starting new %s session ..." system) 343 | (prog1 (sesman-start-session system) 344 | (run-hooks 'sesman-post-command-hook)))) 345 | 346 | ;;;###autoload 347 | (defun sesman-restart (&optional which) 348 | "Restart sesman session. 349 | When WHICH is nil, restart the current session; when a single universal 350 | argument or 'linked, restart all linked sessions; when a double universal 351 | argument, t or 'all, restart all sessions. For programmatic use, WHICH can also 352 | be a session or a name of the session, in which case that session is restarted." 353 | (interactive "P") 354 | (let* ((system (sesman--system)) 355 | (sessions (sesman--on-C-u-u-sessions system which))) 356 | (if (null sessions) 357 | (message "No %s sessions found" system) 358 | (with-temp-message (format "Restarting %s %s %s" system 359 | (if (= 1 (length sessions)) "session" "sessions") 360 | (mapcar #'car sessions)) 361 | (mapc (lambda (s) 362 | (sesman-restart-session system s)) 363 | sessions)) 364 | ;; restarting is not guaranteed to finish here, but what can we do? 365 | (run-hooks 'sesman-post-command-hook)))) 366 | 367 | ;;;###autoload 368 | (defun sesman-quit (&optional which) 369 | "Terminate a Sesman session. 370 | When WHICH is nil, kill only the current session; when a single universal 371 | argument or 'linked, kill all linked sessions; when a double universal argument, 372 | t or 'all, kill all sessions. For programmatic use, WHICH can also be a session 373 | or a name of the session, in which case that session is killed." 374 | (interactive "P") 375 | (let* ((system (sesman--system)) 376 | (sessions (sesman--on-C-u-u-sessions system which))) 377 | (if (null sessions) 378 | (message "No %s sessions found" system) 379 | (with-temp-message (format "Killing %s %s %s" system 380 | (if (= 1 (length sessions)) "session" "sessions") 381 | (mapcar #'car sessions)) 382 | (mapc (lambda (s) 383 | (sesman-unregister system s) 384 | (sesman-quit-session system s)) 385 | sessions)) 386 | (run-hooks 'sesman-post-command-hook)))) 387 | 388 | ;;;###autoload 389 | (defun sesman-info (&optional all) 390 | "Display info for all current sessions (`sesman-current-sessions'). 391 | In the resulting minibuffer display linked sessions are numbered and the 392 | other (friendly) sessions are not. When ALL is non-nil, show info for all 393 | sessions." 394 | (interactive "P") 395 | (let* ((system (sesman--system)) 396 | (i 1) 397 | (sessions (if all 398 | (sesman-sessions system t) 399 | (sesman-current-sessions system))) 400 | (empty-prefix (if (> (length sessions) 1) " " ""))) 401 | (if sessions 402 | (message (mapconcat (lambda (ses) 403 | (let ((prefix (if (sesman-relevant-session-p system ses) 404 | (prog1 (format "%d " i) 405 | (setq i (1+ i))) 406 | empty-prefix))) 407 | (sesman--format-session system ses prefix))) 408 | sessions 409 | "\n")) 410 | (message "No %s%s sessions" 411 | (if all "" "current ") 412 | system)))) 413 | 414 | ;;;###autoload 415 | (defun sesman-link-with-buffer (&optional buffer session) 416 | "Ask for SESSION and link with BUFFER. 417 | BUFFER defaults to current buffer. On universal argument, or if BUFFER is 'ask, 418 | ask for buffer." 419 | (interactive "P") 420 | (let ((buf (if (or (eq buffer 'ask) 421 | (equal buffer '(4))) 422 | (let ((this-system (sesman--system))) 423 | (read-buffer "Link buffer: " (current-buffer) t 424 | (lambda (buf-cons) 425 | (equal this-system 426 | (sesman--system-in-buffer (cdr buf-cons)))))) 427 | (or buffer (current-buffer))))) 428 | (sesman--link-session-interactively session 'buffer buf))) 429 | 430 | ;;;###autoload 431 | (defun sesman-link-with-directory (&optional dir session) 432 | "Ask for SESSION and link with DIR. 433 | DIR defaults to `default-directory'. On universal argument, or if DIR is 'ask, 434 | ask for directory." 435 | (interactive "P") 436 | (let ((dir (if (or (eq dir 'ask) 437 | (equal dir '(4))) 438 | (read-directory-name "Link directory: ") 439 | (or dir default-directory)))) 440 | (sesman--link-session-interactively session 'directory dir))) 441 | 442 | ;;;###autoload 443 | (defun sesman-link-with-project (&optional project session) 444 | "Ask for SESSION and link with PROJECT. 445 | PROJECT defaults to current project. On universal argument, or if PROJECT is 446 | 'ask, ask for the project. SESSION defaults to the current session." 447 | (interactive "P") 448 | (let* ((system (sesman--system)) 449 | (project (expand-file-name 450 | (if (or (eq project 'ask) 451 | (equal project '(4))) 452 | ;; FIXME: should be a completion over all known projects for this system 453 | (read-directory-name "Project: " (sesman-project system)) 454 | (or project (sesman-project system)))))) 455 | (sesman--link-session-interactively session 'project project))) 456 | 457 | ;;;###autoload 458 | (defun sesman-link-with-least-specific (&optional session) 459 | "Ask for SESSION and link with the least specific context available. 460 | Normally the least specific context is the project. If not in a project, link 461 | with the `default-directory'. If `default-directory' is nil, link with current 462 | buffer." 463 | (interactive "P") 464 | (sesman--link-session-interactively session nil nil)) 465 | 466 | ;;;###autoload 467 | (defun sesman-unlink (&optional links) 468 | "Break sesman LINKS. 469 | If LINKS is nil, ask interactively for a link. With a prefix argument break all 470 | links." 471 | (interactive) 472 | (mapc #'sesman--unlink (or (when current-prefix-arg 473 | (sesman-current-links (sesman--system))) 474 | links 475 | (sesman--ask-for-link "Unlink: " 476 | (or (sesman-current-links (sesman--system)) 477 | (user-error "No %s links found" (sesman--system))) 478 | 'ask-all))) 479 | (run-hooks 'sesman-post-command-hook)) 480 | 481 | (declare-function sesman-browser "sesman-browser") 482 | ;;;###autoload (autoload 'sesman-map "sesman" "Session management prefix keymap." t 'keymap) 483 | (defvar sesman-map 484 | (let (sesman-map) 485 | (define-prefix-command 'sesman-map) 486 | (define-key sesman-map (kbd "C-i") #'sesman-info) 487 | (define-key sesman-map (kbd "i") #'sesman-info) 488 | (define-key sesman-map (kbd "C-w") #'sesman-browser) 489 | (define-key sesman-map (kbd "w") #'sesman-browser) 490 | (define-key sesman-map (kbd "C-s") #'sesman-start) 491 | (define-key sesman-map (kbd "s") #'sesman-start) 492 | (define-key sesman-map (kbd "C-r") #'sesman-restart) 493 | (define-key sesman-map (kbd "r") #'sesman-restart) 494 | (define-key sesman-map (kbd "C-q") #'sesman-quit) 495 | (define-key sesman-map (kbd "q") #'sesman-quit) 496 | (define-key sesman-map (kbd "C-l") #'sesman-link-with-least-specific) 497 | (define-key sesman-map (kbd "l") #'sesman-link-with-least-specific) 498 | (define-key sesman-map (kbd "C-b") #'sesman-link-with-buffer) 499 | (define-key sesman-map (kbd "b") #'sesman-link-with-buffer) 500 | (define-key sesman-map (kbd "C-d") #'sesman-link-with-directory) 501 | (define-key sesman-map (kbd "d") #'sesman-link-with-directory) 502 | (define-key sesman-map (kbd "C-p") #'sesman-link-with-project) 503 | (define-key sesman-map (kbd "p") #'sesman-link-with-project) 504 | (define-key sesman-map (kbd "C-u") #'sesman-unlink) 505 | (define-key sesman-map (kbd " u") #'sesman-unlink) 506 | sesman-map) 507 | "Session management prefix keymap.") 508 | 509 | (defvar sesman-menu 510 | '("Sesman" 511 | ["Show Session Info" sesman-info] 512 | "--" 513 | ["Start" sesman-start] 514 | ["Restart" sesman-restart :active (sesman-current-session (sesman--system))] 515 | ["Quit" sesman-quit :active (sesman-current-session (sesman--system))] 516 | "--" 517 | ["Link with Buffer" sesman-link-with-buffer :active (sesman-current-session (sesman--system))] 518 | ["Link with Directory" sesman-link-with-directory :active (sesman-current-session (sesman--system))] 519 | ["Link with Project" sesman-link-with-project :active (sesman-current-session (sesman--system))] 520 | ["Unlink" sesman-unlink :active (sesman-current-session (sesman--system))] 521 | "--" 522 | ["Browser" sesman-browser :active (sesman-current-session (sesman--system))]) 523 | "Sesman Menu.") 524 | 525 | (defun sesman-install-menu (map) 526 | "Install `sesman-menu' into MAP." 527 | (easy-menu-do-define 'sesman-menu-open 528 | map 529 | (get 'sesman-menu 'variable-documentation) 530 | sesman-menu)) 531 | 532 | 533 | ;;; System Generic 534 | 535 | (cl-defgeneric sesman-start-session (system) 536 | "Start and return SYSTEM SESSION.") 537 | 538 | (cl-defgeneric sesman-quit-session (system session) 539 | "Terminate SYSTEM SESSION.") 540 | 541 | (cl-defgeneric sesman-restart-session (system session) 542 | "Restart SYSTEM SESSION. 543 | By default, calls `sesman-quit-session' and then 544 | `sesman-start-session'." 545 | (let ((old-name (car session))) 546 | (sesman-quit-session system session) 547 | (let ((new-session (sesman-start-session system))) 548 | (setcar new-session old-name)))) 549 | 550 | (cl-defgeneric sesman-session-info (_system session) 551 | "Return a plist with :objects key containing user \"visible\" objects. 552 | Optional :strings value is a list of string representations of objects. Optional 553 | :map key is a local keymap to place on every object in the session browser. 554 | Optional :buffers is a list of buffers which will be used for navigation from 555 | the session browser. If :buffers is missing, buffers from :objects are used 556 | instead." 557 | (list :objects (cdr session))) 558 | 559 | (cl-defgeneric sesman-project (_system) 560 | "Retrieve project root in current directory (`default-directory') for SYSTEM. 561 | Return a string or nil if no project has been found." 562 | nil) 563 | 564 | (cl-defgeneric sesman-more-relevant-p (_system session1 session2) 565 | "Return non-nil if SESSION1 should be sorted before SESSION2. 566 | By default, sort by session name. Systems should overwrite this method to 567 | provide a more meaningful ordering. If your system objects are buffers you can 568 | use `sesman-more-recent-p' utility in this method." 569 | (not (string-greaterp (car session1) (car session2)))) 570 | 571 | (cl-defgeneric sesman-friendly-session-p (_system _session) 572 | "Return non-nil if SESSION is a friendly session in current context. 573 | The \"friendship\" is system dependent but usually means sessions running in 574 | dependent projects. Unless SYSTEM has defined a method for this generic, there 575 | are no friendly sessions." 576 | nil) 577 | 578 | (cl-defgeneric sesman-context-types (_system) 579 | "Return a list of context types understood by SYSTEM. 580 | Contexts must be sorted from most specific to least specific." 581 | '(buffer directory project)) 582 | 583 | 584 | ;;; System API 585 | 586 | (defun sesman-session (system session-name) 587 | "Retrieve SYSTEM's session with SESSION-NAME from global hash." 588 | (let ((system (or system (sesman--system)))) 589 | (gethash (cons system session-name) sesman-sessions-hashmap))) 590 | 591 | (defun sesman-sessions (system &optional sort type cxt-types) 592 | "Return a list of sessions registered with SYSTEM. 593 | When TYPE is either 'all or nil return all sessions registered with the SYSTEM, 594 | when 'linked, only linked to the current context sessions, when 'friendly - only 595 | friendly sessions. If SORT is non-nil, sessions are sorted in the relevance 596 | order with linked sessions leading the list. CXT-TYPES is a list of context 597 | types to consider for linked sessions." 598 | (let ((system (or system (sesman--system)))) 599 | (cond 600 | ((eq type 'linked) 601 | (sesman--linked-sessions system sort cxt-types)) 602 | ((eq type 'friendly) 603 | (sesman--friendly-sessions system sort)) 604 | ((memq type '(all nil)) 605 | (if sort 606 | (delete-dups 607 | (append (sesman--linked-sessions system 'sort cxt-types) 608 | (sesman--all-system-sessions system 'sort))) 609 | (sesman--all-system-sessions system))) 610 | (t (error "Invalid session TYPE argument %s" type))))) 611 | 612 | (defun sesman-current-sessions (system &optional cxt-types) 613 | "Return a list of SYSTEM sessions active in the current context. 614 | Sessions are ordered by the relevance order and linked sessions come first. If 615 | `sesman-use-friendly-sessions' current sessions consist of linked and friendly 616 | sessions, otherwise only of linked sessions. CXT-TYPES is a list of context 617 | types to consider. Defaults to the list returned from `sesman-context-types'." 618 | (if sesman-use-friendly-sessions 619 | (delete-dups 620 | (append (sesman--linked-sessions system 'sort cxt-types) 621 | (sesman--friendly-sessions system 'sort))) 622 | (sesman--linked-sessions system 'sort cxt-types))) 623 | 624 | (defun sesman-current-session (system &optional cxt-types) 625 | "Get the most relevant current session for the SYSTEM. 626 | CXT-TYPES is a list of context types to consider." 627 | (or (car (sesman--linked-sessions system 'sort cxt-types)) 628 | (when sesman-use-friendly-sessions 629 | (car (sesman--friendly-sessions system 'sort))))) 630 | 631 | (defun sesman-ensure-session (system &optional cxt-types) 632 | "Get the most relevant linked session for SYSTEM or throw if none exists. 633 | CXT-TYPES is a list of context types to consider." 634 | (or (sesman-current-session system cxt-types) 635 | (user-error "No linked %s sessions" system))) 636 | 637 | (defun sesman-has-sessions-p (system) 638 | "Return t if there is at least one session registered with SYSTEM." 639 | (let ((system (or system (sesman--system))) 640 | (found)) 641 | (condition-case nil 642 | (maphash (lambda (k _) 643 | (when (eq (car k) system) 644 | (setq found t) 645 | (throw 'found nil))) 646 | sesman-sessions-hashmap) 647 | (error)) 648 | found)) 649 | 650 | (defvar sesman--select-session-history nil) 651 | (defun sesman-ask-for-session (system prompt &optional sessions ask-new ask-all) 652 | "Ask for a SYSTEM session with PROMPT. 653 | SESSIONS defaults to value returned from `sesman-sessions'. If 654 | ASK-NEW is non-nil, offer *new* option to start a new session. If 655 | ASK-ALL is non-nil offer *all* option. If ASK-ALL is non-nil, 656 | return a list of sessions, otherwise a single session." 657 | (let* ((sessions (or sessions (sesman-sessions system))) 658 | (name.syms (mapcar (lambda (s) 659 | (let ((name (car s))) 660 | (cons (if (symbolp name) (symbol-name name) name) 661 | name))) 662 | sessions)) 663 | (nr (length name.syms)) 664 | (syms (if (and (not ask-new) (= nr 0)) 665 | (error "No %s sessions found" system) 666 | (append name.syms 667 | (when ask-new '(("*new*"))) 668 | (when (and ask-all (> nr 1)) 669 | '(("*all*")))))) 670 | (def (caar syms)) 671 | ;; (def (if (assoc (car sesman--select-session-history) syms) 672 | ;; (car sesman--select-session-history) 673 | ;; (caar syms))) 674 | (sel (completing-read 675 | prompt (mapcar #'car syms) nil t nil 'sesman--select-session-history def))) 676 | (cond 677 | ((string= sel "*new*") 678 | (let ((ses (sesman-start-session system))) 679 | (message "Started %s" (car ses)) 680 | (if ask-all (list ses) ses))) 681 | ((string= sel "*all*") 682 | sessions) 683 | (t 684 | (let* ((sym (cdr (assoc sel syms))) 685 | (ses (assoc sym sessions))) 686 | (if ask-all (list ses) ses)))))) 687 | 688 | (defvar sesman--cxt-abbrevs '(buffer "buf" project "proj" directory "dir")) 689 | (defun sesman--format-context (cxt-type cxt-val extra-face) 690 | (let* ((face (intern (format "sesman-%s-face" cxt-type))) 691 | (short-type (propertize (or (plist-get sesman--cxt-abbrevs cxt-type) 692 | (symbol-value cxt-type)) 693 | 'face (list (if (facep face) 694 | face 695 | 'font-lock-function-name-face) 696 | extra-face)))) 697 | (concat short-type 698 | (propertize (format "(%s)" cxt-val) 699 | 'face extra-face)))) 700 | 701 | (defun sesman-grouped-links (system session &optional current-first as-string) 702 | "Retrieve all links for SYSTEM's SESSION from the global `sesman-links-alist'. 703 | Return an alist of the form 704 | 705 | ((buffer buffers..) 706 | (directory directories...) 707 | (project projects...)). 708 | 709 | When `CURRENT-FIRST' is non-nil, a cons of two lists as above is returned with 710 | car containing links relevant in current context and cdr all other links. If 711 | AS-STRING is non-nil, return an equivalent string representation." 712 | (let* ((system (or system (sesman--system))) 713 | (session (or session (sesman-current-session system))) 714 | (ses-name (car session)) 715 | (links (thread-last sesman-links-alist 716 | (seq-filter (sesman--link-lookup-fn system ses-name)) 717 | (sesman--sort-links system) 718 | (reverse))) 719 | (out (mapcar (lambda (x) (list x)) 720 | (sesman-context-types system))) 721 | (out-rel (when current-first 722 | (copy-alist out)))) 723 | (mapc (lambda (link) 724 | (let* ((type (sesman--lnk-context-type link)) 725 | (entry (if (and current-first 726 | (sesman-relevant-link-p link)) 727 | (assoc type out-rel) 728 | (assoc type out)))) 729 | (when entry 730 | (setcdr entry (cons link (cdr entry)))))) 731 | links) 732 | (let ((out (delq nil (mapcar (lambda (el) (and (cdr el) el)) out))) 733 | (out-rel (delq nil (mapcar (lambda (el) (and (cdr el) el)) out-rel)))) 734 | (if as-string 735 | (let ((fmt-fn (lambda (typed-links) 736 | (let* ((type (car typed-links))) 737 | (mapconcat (lambda (lnk) 738 | (let ((val (sesman--abbrev-path-maybe 739 | (sesman--lnk-value lnk)))) 740 | (sesman--format-context type val 'italic))) 741 | (cdr typed-links) 742 | ", "))))) 743 | (if out-rel 744 | (concat (mapconcat fmt-fn out-rel ", ") 745 | (when out " | ") 746 | (mapconcat fmt-fn out ", ")) 747 | (mapconcat fmt-fn out ", "))) 748 | (if current-first 749 | (cons out-rel out) 750 | out))))) 751 | 752 | (defun sesman-link-session (system session &optional cxt-type cxt-val) 753 | "Link SYSTEM's SESSION to context give by CXT-TYPE and CXT-VAL. 754 | If CXT-TYPE is nil, use the least specific type available in the current 755 | context. If CXT-TYPE is non-nil, and CXT-VAL is not given, retrieve it with 756 | `sesman-context'. See also `sesman-link-with-project', 757 | `sesman-link-with-directory' and `sesman-link-with-buffer'." 758 | (let* ((ses-name (or (car-safe session) 759 | (error "SESSION must be a headed list"))) 760 | (cxt-val (or cxt-val 761 | (or (if cxt-type 762 | (sesman-context cxt-type system) 763 | (let ((cxt (sesman--least-specific-context system))) 764 | (setq cxt-type (car cxt)) 765 | (cdr cxt))) 766 | (error "No local context of type %s" cxt-type)))) 767 | (cxt-val (if (stringp cxt-val) 768 | (expand-file-name cxt-val) 769 | cxt-val)) 770 | (key (cons system ses-name)) 771 | (link (list key cxt-type cxt-val))) 772 | (if (member cxt-type sesman-single-link-context-types) 773 | (thread-last sesman-links-alist 774 | (seq-remove (sesman--link-lookup-fn system nil cxt-type cxt-val)) 775 | (cons link) 776 | (setq sesman-links-alist)) 777 | (unless (seq-filter (sesman--link-lookup-fn system ses-name cxt-type cxt-val) 778 | sesman-links-alist) 779 | (setq sesman-links-alist (cons link sesman-links-alist)))) 780 | (run-hooks 'sesman-post-command-hook) 781 | link)) 782 | 783 | (defun sesman-links (system &optional session-or-name cxt-types sort) 784 | "Retrieve all links for SYSTEM, SESSION-OR-NAME and CXT-TYPES. 785 | SESSION-OR-NAME can be either a session or a name of the session. If SORT is 786 | non-nil links are sorted in relevance order and `sesman-current-links' lead the 787 | list, otherwise links are returned in the creation order." 788 | (let* ((ses-name (if (listp session-or-name) 789 | (car session-or-name) 790 | session-or-name)) 791 | (lfn (sesman--link-lookup-fn system ses-name cxt-types))) 792 | (if sort 793 | (delete-dups (append 794 | (sesman-current-links system ses-name) 795 | (sesman--sort-links system (seq-filter lfn sesman-links-alist)))) 796 | (seq-filter lfn sesman-links-alist)))) 797 | 798 | (defun sesman-current-links (system &optional session-or-name sort cxt-types) 799 | "Retrieve all active links in current context for SYSTEM and SESSION-OR-NAME. 800 | SESSION-OR-NAME can be either a session or a name of the session. CXT-TYPES is a 801 | list of context types to consider. Returned links are a subset of 802 | `sesman-links-alist' sorted in order of relevance if SORT is non-nil." 803 | ;; mapcan is a built-in in 26.1; don't want to require cl-lib for one function 804 | (let ((ses-name (if (listp session-or-name) 805 | (car session-or-name) 806 | session-or-name))) 807 | (seq-mapcat 808 | (lambda (cxt-type) 809 | (let* ((lfn (sesman--link-lookup-fn system ses-name cxt-type)) 810 | (links (seq-filter (lambda (l) 811 | (and (funcall lfn l) 812 | (sesman-relevant-context-p cxt-type (sesman--lnk-value l)))) 813 | sesman-links-alist))) 814 | (if sort 815 | (sesman--sort-links system links) 816 | links))) 817 | (or cxt-types (sesman-context-types system))))) 818 | 819 | (defun sesman-has-links-p (system &optional cxt-types) 820 | "Return t if there is at least one linked session. 821 | CXT-TYPES defaults to `sesman-context-types' for current SYSTEM." 822 | (let ((cxt-types (or cxt-types (sesman-context-types system))) 823 | (found)) 824 | (condition-case nil 825 | (mapc (lambda (l) 826 | (when (eq system (sesman--lnk-system-name l)) 827 | (let ((cxt (sesman--lnk-context-type l))) 828 | (when (and (member cxt cxt-types) 829 | (sesman-relevant-context-p cxt (sesman--lnk-value l))) 830 | (setq found t) 831 | (throw 'found nil))))) 832 | sesman-links-alist) 833 | (error)) 834 | found)) 835 | 836 | (defun sesman-register (system session) 837 | "Register SESSION into `sesman-sessions-hashmap' and `sesman-links-alist'. 838 | SYSTEM defaults to current system. If a session with same name is already 839 | registered in `sesman-sessions-hashmap', change the name by appending \"#1\", 840 | \"#2\" ... to the name. This function should be called by system-specific 841 | connection initializers (\"run-xyz\", \"xyz-jack-in\" etc.)." 842 | (let* ((system (or system (sesman--system))) 843 | (ses-name (car session)) 844 | (ses-name0 (car session)) 845 | (i 1)) 846 | (while (sesman-session system ses-name) 847 | (setq ses-name (format "%s#%d" ses-name0 i) 848 | i (1+ i))) 849 | (setq session (cons ses-name (cdr session))) 850 | (puthash (cons system ses-name) session sesman-sessions-hashmap) 851 | (sesman-link-session system session) 852 | session)) 853 | 854 | (defun sesman-unregister (system session) 855 | "Unregister SESSION. 856 | SYSTEM defaults to current system. Remove session from 857 | `sesman-sessions-hashmap' and `sesman-links-alist'." 858 | (let ((ses-key (cons system (car session)))) 859 | (remhash ses-key sesman-sessions-hashmap) 860 | (sesman--clear-links) 861 | session)) 862 | 863 | (defun sesman-add-object (system session-name object &optional allow-new) 864 | "Add (destructively) OBJECT to session SESSION-NAME of SYSTEM. 865 | If ALLOW-NEW is nil and session with SESSION-NAME does not exist 866 | throw an error, otherwise register a new session with 867 | session (list SESSION-NAME OBJECT)." 868 | (let* ((system (or system (sesman--system))) 869 | (session (sesman-session system session-name))) 870 | (if session 871 | (setcdr session (cons object (cdr session))) 872 | (if allow-new 873 | (sesman-register system (list session-name object)) 874 | (error "%s session '%s' does not exist" 875 | (sesman--cap-system-name system) session-name))))) 876 | 877 | (defun sesman-remove-object (system session-name object &optional auto-unregister no-error) 878 | "Remove (destructively) OBJECT from session SESSION-NAME of SYSTEM. 879 | If SESSION-NAME is nil, retrieve the session with 880 | `sesman-session-for-object'. If OBJECT is the last object in sesman 881 | session, `sesman-unregister' the session. If AUTO-UNREGISTER is non-nil 882 | unregister sessions of length 0 and remove all the links with the session. 883 | If NO-ERROR is non-nil, don't throw an error if OBJECT is not found in any 884 | session. This is useful if there are several \"concurrent\" parties which 885 | can remove the object." 886 | (let* ((system (or system (sesman--system))) 887 | (session (if session-name 888 | (sesman-session system session-name) 889 | (sesman-session-for-object system object no-error))) 890 | (new-session (delete object session))) 891 | (cond ((null new-session)) 892 | ((= (length new-session) 1) 893 | (when auto-unregister 894 | (sesman-unregister system session))) 895 | (t 896 | (puthash (cons system (car session)) new-session sesman-sessions-hashmap))))) 897 | 898 | (defun sesman-session-for-object (system object &optional no-error) 899 | "Retrieve SYSTEM session which contains OBJECT. 900 | When NO-ERROR is non-nil, don't throw an error if OBJECT is not part of any 901 | session. In such case, return nil." 902 | (let* ((system (or system (sesman--system))) 903 | (sessions (sesman--all-system-sessions system))) 904 | (or (seq-find (lambda (ses) 905 | (seq-find (lambda (x) (equal object x)) (cdr ses))) 906 | sessions) 907 | (unless no-error 908 | (error "%s is not part of any %s sessions" 909 | object system))))) 910 | 911 | (defun sesman-session-name-for-object (system object &optional no-error) 912 | "Retrieve the name of the SYSTEM's session containing OBJECT. 913 | When NO-ERROR is non-nil, don't throw an error if OBJCECT is not part of 914 | any session. In such case, return nil." 915 | (car (sesman-session-for-object system object no-error))) 916 | 917 | (defun sesman-more-recent-p (bufs1 bufs2) 918 | "Return t if BUFS1 is more recent than BUFS2. 919 | BUFS1 and BUFS2 are either buffers or lists of buffers. When lists of 920 | buffers, most recent buffers from each list are considered. To be used 921 | primarily in `sesman-more-relevant-p' methods when session objects are 922 | buffers." 923 | (let ((bufs1 (if (bufferp bufs1) (list bufs1) bufs1)) 924 | (bufs2 (if (bufferp bufs2) (list bufs2) bufs2))) 925 | (eq 1 (seq-some (lambda (b) 926 | (if (member b bufs1) 927 | 1 928 | (when (member b bufs2) 929 | -1))) 930 | (buffer-list))))) 931 | 932 | ;; path caching because file-truename is very slow 933 | (defvar sesman--path-cache (make-hash-table :test #'equal)) 934 | (defun sesman-expand-path (path) 935 | "Expand PATH with optionally follow symlinks. 936 | Whether symlinks are followed is controlled by `sesman-follow-symlinks' custom 937 | variable. Always return the expansion without the trailing directory slash." 938 | (directory-file-name 939 | (if sesman-follow-symlinks 940 | (let ((true-name (or (gethash path sesman--path-cache) 941 | (puthash path (file-truename path) sesman--path-cache)))) 942 | (if (or (eq sesman-follow-symlinks t) 943 | vc-follow-symlinks) 944 | true-name 945 | ;; sesman-follow-symlinks is 'vc but vc-follow-symlinks is nil 946 | (expand-file-name path))) 947 | (expand-file-name path)))) 948 | 949 | 950 | ;;; Contexts 951 | 952 | (cl-defgeneric sesman-context (_cxt-type _system) 953 | "Given SYSTEM and context type CXT-TYPE return the context.") 954 | (cl-defmethod sesman-context ((_cxt-type (eql buffer)) _system) 955 | "Return current buffer." 956 | (current-buffer)) 957 | (cl-defmethod sesman-context ((_cxt-type (eql directory)) _system) 958 | "Return current directory." 959 | (sesman-expand-path default-directory)) 960 | (cl-defmethod sesman-context ((_cxt-type (eql project)) system) 961 | "Return current project." 962 | (let* ((default-directory (sesman-expand-path default-directory)) 963 | (proj (or 964 | (sesman-project (or system (sesman--system))) 965 | ;; Normally we would use (project-roots (project-current)) but currently 966 | ;; project-roots fails on nil and doesn't work on custom `('foo . 967 | ;; "path/to/project"). So, use vc as a fallback and don't use project.el at 968 | ;; all for now. 969 | ;; NB: `vc-root-dir' doesn't work from symlinked files. Emacs Bug? 970 | (vc-root-dir)))) 971 | (when proj 972 | (expand-file-name proj)))) 973 | 974 | (cl-defgeneric sesman-relevant-context-p (_cxt-type cxt) 975 | "Non-nil if context CXT is relevant to current context of type CXT-TYPE.") 976 | (cl-defmethod sesman-relevant-context-p ((_cxt-type (eql buffer)) buf) 977 | "Non-nil if BUF is `current-buffer'." 978 | (eq (current-buffer) buf)) 979 | (cl-defmethod sesman-relevant-context-p ((_cxt-type (eql directory)) dir) 980 | "Non-nil if DIR is the parent or equals the `default-directory'." 981 | (when (and dir default-directory) 982 | (string-match-p (concat "^" (sesman-expand-path dir)) 983 | (sesman-expand-path default-directory)))) 984 | (cl-defmethod sesman-relevant-context-p ((_cxt-type (eql project)) proj) 985 | "Non-nil if PROJ is the parent or equal to the `default-directory'." 986 | (when (and proj default-directory) 987 | (string-match-p (concat "^" (sesman-expand-path proj)) 988 | (sesman-expand-path default-directory)))) 989 | 990 | (defun sesman-relevant-link-p (link &optional cxt-types) 991 | "Return non-nil if LINK is relevant to the current context. 992 | If CXT-TYPES is non-nil, only check relevance for those contexts." 993 | (when (or (null cxt-types) 994 | (member (sesman--lnk-context-type link) cxt-types)) 995 | (sesman-relevant-context-p 996 | (sesman--lnk-context-type link) 997 | (sesman--lnk-value link)))) 998 | 999 | (defun sesman-relevant-session-p (system session &optional cxt-types) 1000 | "Return non-nil if SYSTEM's SESSION is relevant to the current context. 1001 | If CXT-TYPES is non-nil, only check relevance for those contexts." 1002 | (seq-some #'sesman-relevant-link-p 1003 | (sesman-links system session cxt-types))) 1004 | 1005 | (define-obsolete-function-alias 'sesman-linked-sessions 'sesman--linked-sessions "v0.3.2") 1006 | 1007 | (provide 'sesman) 1008 | 1009 | ;;; sesman.el ends here 1010 | -------------------------------------------------------------------------------- /targets/checkdoc.el: -------------------------------------------------------------------------------- 1 | 2 | (let ((sentence-end-double-space) 3 | (checkdoc-arguments-in-order-flag) 4 | (checkdoc-verb-check-experimental-flag) 5 | (checkdoc-force-docstrings-flag)) 6 | (checkdoc-file "sesman-test.el") 7 | (checkdoc-file "sesman.el")) 8 | -------------------------------------------------------------------------------- /targets/compile.el: -------------------------------------------------------------------------------- 1 | 2 | (byte-compile-file "sesman.el") 3 | --------------------------------------------------------------------------------