[nongnu] elpa/sesman cdb8e0973a 018/100: Port back from CIDER

[ELPA Syncer]

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

    Port back from CIDER
---
 sesman.el | 76 ++++++++++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 48 insertions(+), 28 deletions(-)

diff --git a/sesman.el b/sesman.el
index 925236a0de..852db93938 100644
--- a/sesman.el
+++ b/sesman.el
@@ -32,13 +32,14 @@
 ;;; Commentary:
 ;;
 ;; Sesman provides facilities for session management and interactive session
-;; association with the current contexts (project, directory, buffers etc). See
+;; association with the current contexts (project, directory, buffers etc).  
See
 ;; project's readme for more details.
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;; Code:
 
+(require 'cl-generic)
 (require 'project)
 (require 'seq)
 (require 'subr-x)
@@ -50,9 +51,9 @@
 
 (defcustom sesman-disambiguate-by-relevance t
   "If t choose most relevant session in ambiguous situations, otherwise ask.
-Ambiguity arises when multiple sessions are associated with current context. By
-default only projects could be associated with multiple sessions. See
-`sesman-single-link-contexts' in order to change that. Relevance is decided by
+Ambiguity arises when multiple sessions are associated with current context.  
By
+default only projects could be associated with multiple sessions.  See
+`sesman-single-link-contexts' in order to change that.  Relevance is decided by
 system's implementation, see `sesman-more-relevant-p'."
   :group 'sesman
   :type 'boolean)
@@ -108,14 +109,16 @@ Can be either a symbol, or a function returning a 
symbol.")
 (defun sesman--link-session (system session &optional cxt-type)
   (let* ((ses-name (or (car-safe session)
                        (error "SESSION must be a headed list")))
-         (cxt-val (or (if cxt-type
-                          (sesman-context cxt-type)
-                        (seq-some (lambda (ctype)
-                                    (let ((val (sesman-context ctype)))
-                                      (setq cxt-type ctype)
-                                      val))
-                                  (reverse (sesman-context-types system))))
-                      (user-error "No local context of type %s" cxt-type)))
+         (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))))
+                       (user-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)
@@ -146,6 +149,13 @@ Can be either a symbol, or a function returning a symbol.")
                         ,(capitalize (symbol-name cxt-type))
                         system))))))
 
+(defun sesman--expand-path-maybe (obj)
+  (cond
+   ((stringp obj) (expand-file-name obj))
+   ((and (consp obj) (stringp (cdr obj)))
+    (cons (car obj) (expand-file-name (cdr obj))))
+   (t obj)))
+
 ;; FIXME: incorporate `sesman-abbreviate-paths'
 (defun sesman--abbrev-path-maybe (obj)
   (cond
@@ -181,7 +191,10 @@ Can be either a symbol, or a function returning a symbol.")
     (lambda (el)
       (and (or (null system) (eq (caar el) system))
            (or (null ses-name) (equal (cdar el) ses-name))
-           (or (null cxt-type) (eq (nth 1 el) cxt-type))
+           (or (null cxt-type)
+               (if (listp cxt-type)
+                   (member (nth 1 el) cxt-type)
+                 (eq (nth 1 el) cxt-type)))
            (or (null cxt-val) (equal (nth 2 el) cxt-val))))))
 
 (defun sesman--unlink (x)
@@ -304,7 +317,7 @@ sessions."
   "Display links active in the current context."
   (interactive)
   (let* ((system (sesman--system))
-         (links (sesman-links system)))
+         (links (sesman-current-links system)))
     (if links
         (message (mapconcat #'sesman--format-link links "\n"))
       (message "No %s links in the current context" system))))
@@ -328,7 +341,7 @@ sessions."
   "Break any of the previously created links."
   (interactive)
   (let* ((system (sesman--system))
-         (links (or (sesman-links system)
+         (links (or (sesman-current-links system)
                     (user-error "No %s links found" system))))
     (mapc #'sesman--unlink
           (sesman--ask-for-link "Unlink: " links 'ask-all))))
@@ -495,7 +508,7 @@ list returned from `sesman-context-types'."
     (sesman--clear-links)
     (mapcar (lambda (assoc)
               (gethash (car assoc) sesman-sessions-hashmap))
-            (sesman-links system cxt-types))))
+            (sesman-current-links system cxt-types))))
 
 (defun sesman-ensure-linked-session (system &optional prompt ask-new ask-all)
   "Ensure that at least one SYSTEM session is linked to the current context.
@@ -509,7 +522,7 @@ nil, in which case ASK-NEW and ASK-ALL are passed directly 
to
     (cond
      ;; 0. No sessions; throw
      ((null sessions)
-      (user-error "No linked %s sessions for current context" system))
+      (user-error "No linked %s sessions in current context" system))
      ;; 1. Single association, or auto-disambiguate; return first
      ((or sesman-disambiguate-by-relevance
           (eq (length sessions) 1))
@@ -556,7 +569,12 @@ If AS-STRING is non-nil, return an equivalent string 
representation."
                      " ")
         out))))
 
-(defun sesman-links (system &optional cxt-types)
+(defun sesman-links (system &optional session-name cxt-types)
+  "Retrieve all links for SYSTEM, SESSION-NAME and CXT-TYPES."
+  (let ((lfn (sesman--link-lookup-fn system session-name cxt-types)))
+    (seq-filter lfn sesman-links-alist)))
+
+(defun sesman-current-links (system &optional cxt-types)
   "Retrieve all active links in current context for SYSTEM.
 CXT-TYPES is a list of context types to consider.  Returned links
 are a subset of `sesman-links-alist' sorted in order of relevance."
@@ -591,9 +609,9 @@ CXT-TYPES defaults to `sesman-context-types' for current 
SYSTEM."
 
 (defun sesman-register (system session)
   "Register SESSION into `sesman-sessions-hashmap' and `sesman-links-alist'.
-SYSTEM defaults to current system. If a session with same name is already
+SYSTEM defaults to current system.  If a session with same name is already
 registered in `sesman-sessions-hashmap', change the name by appending \"#1\",
-\"#2\" ... to the name. This function should be called by system-specific
+\"#2\" ... to the name.  This function should be called by system-specific
 connection initializers (\"run-xyz\", \"xyz-jack-in\" etc.)."
   (let* ((system (or system (sesman--system)))
          (ses-name (car session))
@@ -631,11 +649,13 @@ session (list SESSION-NAME OBJECT)."
 
 (defun sesman-remove-object (system session-name object &optional 
auto-unregister no-error)
   "Remove (destructively) OBJECT from session SESSION-NAME of SYSTEM.
-If SESSION-NAME is nil, retrieve the session with `sesman-session-for-object'.
-If OBJECT is the last object in sesman session, `sesman-unregister' the 
session.
-If AUTO-UNREGISTER is non-nil unregister sessions of length 0. If NO-ERROR is
-non-nil, don't throw an error if OBJECT is not found in any session. This is
-useful if there are several \"concurrent\" parties which can remove the 
object."
+If SESSION-NAME is nil, retrieve the session with
+`sesman-session-for-object'.  If OBJECT is the last object in sesman
+session, `sesman-unregister' the session.  If AUTO-UNREGISTER is non-nil
+unregister sessions of length 0 and remove all the links with the session.
+If NO-ERROR is non-nil, don't throw an error if OBJECT is not found in any
+session.  This is useful if there are several \"concurrent\" parties which
+can remove the object."
   (let* ((system (or system (sesman--system)))
          (session (if session-name
                       (sesman-session system session-name)
@@ -705,12 +725,12 @@ buffers."
 (cl-defmethod sesman-relevant-context-p ((_cxt-type (eql directory)) dir)
   "Non-nil if DIR is the parent or equals the `default-directory'."
   (when (and dir default-directory)
-    (string-match-p (concat "^" dir) default-directory)))
+    (string-match-p (concat "^" dir) (expand-file-name default-directory))))
 (cl-defmethod sesman-relevant-context-p ((_cxt-type (eql project)) proj)
   "Non-nil if PROJ is the parent or equals the `default-directory'."
   (when (and proj default-directory)
-    (string-match-p (concat "^" (expand-file-name (cdr proj)))
-                    default-directory)))
+    (string-match-p (concat "^" (cdr proj))
+                    (expand-file-name default-directory))))
 
 
 (provide 'sesman)