[nongnu] elpa/sesman d4b8a12249 036/100: Allow prompting for context in sesman-link-with-xyz commands

[ELPA Syncer]

branch: elpa/sesman
commit d4b8a12249bcb87fc459927f4dbb2b69909bc959
Author: Vitalie Spinu <spinuvit@gmail.com>
Commit: Vitalie Spinu <spinuvit@gmail.com>

    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.")