branch: elpa/sesman
commit d4b8a12249bcb87fc459927f4dbb2b69909bc959
Author: Vitalie Spinu <[email protected]>
Commit: Vitalie Spinu <[email protected]>
Allow prompting for context in sesman-link-with-xyz commands
---
sesman.el | 131 ++++++++++++++++++++++++++++++++++++++------------------------
1 file changed, 81 insertions(+), 50 deletions(-)
diff --git a/sesman.el b/sesman.el
index 34dc1b1c91..27707d60b1 100644
--- a/sesman.el
+++ b/sesman.el
@@ -107,19 +107,20 @@ Can be either a symbol, or a function returning a
symbol.")
name
(capitalize name))))
-(defun sesman--link-session (system session &optional cxt-type)
+(defun sesman--link-session (system session &optional cxt-type cxt-val)
(let* ((ses-name (or (car-safe session)
(error "SESSION must be a headed list")))
- (cxt-val (sesman--expand-path-maybe
- (or (if cxt-type
- (sesman-context cxt-type)
- ;; use the lest specific context-type available
- (seq-some (lambda (ctype)
- (let ((val (sesman-context ctype)))
- (setq cxt-type ctype)
- val))
- (reverse (sesman-context-types system))))
- (error "No local context of type %s" cxt-type))))
+ (cxt-val (or cxt-val
+ (sesman--expand-path-maybe
+ (or (if cxt-type
+ (sesman-context cxt-type)
+ ;; use the lest specific context-type available
+ (seq-some (lambda (ctype)
+ (let ((val (sesman-context ctype)))
+ (setq cxt-type ctype)
+ val))
+ (reverse (sesman-context-types
system))))
+ (error "No local context of type %s" cxt-type)))))
(key (cons system ses-name))
(link (list key cxt-type cxt-val)))
(if (member cxt-type sesman-single-link-context-types)
@@ -132,23 +133,22 @@ Can be either a symbol, or a function returning a
symbol.")
(setq sesman-links-alist (cons link sesman-links-alist))))
key))
-(defmacro sesman--link-session-interactively (cxt-type)
- (declare (indent 1)
- (debug (symbolp &rest)))
- (let ((cxt-name (symbol-name cxt-type)))
- `(let ((system (sesman--system)))
- (if (member ',cxt-type (sesman-context-types system))
- (let ((session (sesman-ask-for-session
- system
- (format "Link with %s %s: "
- ,cxt-name (sesman--abbrev-path-maybe
- (sesman-context ',cxt-type)))
- (sesman--all-system-sessions system)
- 'ask-new)))
- (sesman--link-session system session ',cxt-type))
- (error (format "%s association not allowed for this system (%s)"
- ,(capitalize (symbol-name cxt-type))
- system))))))
+(defun sesman--link-session-interactively (cxt-type cxt-value session)
+ (let ((system (sesman--system))
+ (cxt-name (symbol-name cxt-type)))
+ (if (member cxt-type (sesman-context-types system))
+ (let ((session (or session
+ (sesman-ask-for-session
+ system
+ (format "Link with %s %s: "
+ cxt-name (sesman--abbrev-path-maybe
+ (sesman-context cxt-type)))
+ (sesman--all-system-sessions system)
+ 'ask-new))))
+ (sesman--link-session system session cxt-type cxt-value))
+ (error (format "%s association not allowed for this system (%s)"
+ (capitalize cxt-name)
+ system)))))
(defun sesman--expand-path-maybe (obj)
(if (stringp obj)
@@ -161,6 +161,12 @@ Can be either a symbol, or a function returning a symbol.")
(abbreviate-file-name obj)
obj))
+(defun sesman--system-in-buffer (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if (functionp sesman-system)
+ (funcall sesman-system)
+ sesman-system)))
+
(defun sesman--system ()
(if sesman-system
(if (functionp sesman-system)
@@ -208,9 +214,9 @@ Can be either a symbol, or a function returning a symbol.")
(defun sesman--format-link (link)
(let ((val (sesman--abbrev-path-maybe
(sesman--lnk-value link))))
- (format "%s(%s)->%s"
+ (format "%s(%s) -> ses(%s)"
(sesman--lnk-context-type link)
- (if (listp val) (cdr val) val)
+ val
(propertize (sesman--lnk-session-name link) 'face 'bold))))
(defun sesman--ask-for-link (prompt links &optional ask-all)
@@ -267,12 +273,12 @@ Can be either a symbol, or a function returning a
symbol.")
"Restart sesman session."
(interactive)
(let* ((system (sesman--system))
- (old-session (sesman-ensure-session system "Restart session: ")))
+ (old-session (sesman-ensure-session system)))
(message "Restarting %s '%s' session" system (car old-session))
(sesman-restart-session system old-session)))
;;;###autoload
-(defun sesman-quit (which)
+(defun sesman-quit (&optional which)
"Terminate sesman session.
When WHICH is nil, kill only the current session; when a single universal
argument or 'linked, kill all linked session; when a double universal argument,
@@ -292,7 +298,7 @@ t or 'all, kill all sessions."
(mapcar #'car sessions)))))
;;;###autoload
-(defun sesman-show-session-info (which)
+(defun sesman-show-session-info (&optional which)
"Display session(s) info.
When WHICH is nil, show info for current session; when a single universal
argument or 'linked, show info for all linked sessions; when a double universal
@@ -322,22 +328,45 @@ argument or 'all, show info for all sessions."
(message "No %s links in the current context" system))))
;;;###autoload
-(defun sesman-link-with-buffer ()
- "Associate a session with current buffer."
- (interactive)
- (sesman--link-session-interactively buffer))
+(defun sesman-link-with-buffer (&optional buffer session)
+ "Associate SESSION with BUFFER.
+BUFFER defaults to current buffer. On universal argument, or if BUFFER is 'ask,
+ask for buffer."
+ (interactive "P")
+ (let ((buf (if (or (eq buffer 'ask)
+ (equal buffer '(4)))
+ (let ((this-system (sesman--system)))
+ (read-buffer "Link buffer: " (current-buffer) t
+ (lambda (b)
+ (equal this-system (sesman--system-in-buffer
b)))))
+ (or buffer (current-buffer)))))
+ (sesman--link-session-interactively 'buffer buf session)))
;;;###autoload
-(defun sesman-link-with-directory ()
- "Associate a session with current directory."
- (interactive)
- (sesman--link-session-interactively directory))
+(defun sesman-link-with-directory (&optional dir session)
+ "Associate a SESSION with DIR.
+DIR defaults to `default-directory'. On universal argument, or if DIR is 'ask,
+ask for directory."
+ (interactive "P")
+ (let ((dir (if (or (eq dir 'ask)
+ (equal dir '(4)))
+ (read-directory-name "Link directory: ")
+ (or dir default-directory))))
+ (sesman--link-session-interactively 'directory dir session)))
;;;###autoload
-(defun sesman-link-with-project ()
- "Associate a session with current project."
- (interactive)
- (sesman--link-session-interactively project))
+(defun sesman-link-with-project (&optional project session)
+ "Link the SESSION with PROJECT.
+PROJECT defaults to current project. On universal argument, or if PROJECT is
+'ask, ask for the project."
+ (interactive "P")
+ (let* ((system (sesman--system))
+ (project (if (or (eq project 'ask)
+ (equal project '(4)))
+ ;; FIXME: should be a completion over all known projects
for this system
+ (read-directory-name "Project: " (sesman-project system))
+ (or project (sesman-project system)))))
+ (sesman--link-session-interactively 'project project session)))
;;;###autoload
(defun sesman-unlink ()
@@ -417,7 +446,7 @@ By default, calls `sesman-quit-session' and then
(cl-defgeneric sesman-session-info (_system session)
(cdr session))
-(cl-defgeneric sesman-project (system)
+(cl-defgeneric sesman-project (_system)
"Retrieve project root for SYSTEM in directory DIR.
DIR defaults to `default-directory'. Return a string or nil if no project has
been found."
@@ -510,7 +539,7 @@ CXT-TYPES is as in `sesman-linked-sessions'."
(defun sesman-ensure-session (system &optional cxt-types)
"Get the most relevant linked session for SYSTEM or throw if none exists.
CXT-TYPES is as in `sesman-linked-sessions'."
- (or (car (sesman-linked-sessions system))
+ (or (car (sesman-linked-sessions system cxt-types))
(user-error "No linked %s sessions" system)))
(defun sesman-linked-sessions (system &optional cxt-types)
@@ -526,7 +555,7 @@ list returned from `sesman-context-types'."
(sesman-current-links system cxt-types))))
(defun sesman-session-links (system session &optional as-string)
- "Retrieve all links for SYSTEM's SESSION from the global `SESSION-LINKS'.
+ "Retrieve all links for SYSTEM's SESSION from the global
`sesman-links-alist'.
Return an alist of the form
((buffer buffers..)
(directory directories...)
@@ -696,6 +725,7 @@ buffers."
;;; Contexts
+(require 'project)
(cl-defgeneric sesman-context (_cxt-type)
"Given context type CXT-TYPE return the context.")
@@ -710,8 +740,9 @@ buffers."
(or
(sesman-project (sesman--system))
(progn
- (require 'project)
- (car (project-roots (project-current))))))
+ (let ((proj (project-current)))
+ (when proj
+ (car (project-roots proj)))))))
(cl-defgeneric sesman-relevant-context-p (_cxt-type cxt)
"Non-nil if context CXT is relevant to current context of type CXT-TYPE.")
