about summary refs log tree commit diff
path: root/configs/shared/emacs/.emacs.d/elpa/sesman-20180719.213/sesman.el
blob: 9279300d050a753d425ef601f8063c0b40f3ca80 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
;;; sesman.el --- Generic Session Manager -*- lexical-binding: t -*-
;;
;; Copyright (C) 2018, Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/vspinu/sesman
;; Package-Version: 20180719.213
;; Keywords: process
;; Version: 0.1.1-snapshot
;; Package-Requires: ((emacs "25"))
;; Keywords: processes, tools, vc
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This file is *NOT* part of GNU Emacs.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Sesman provides facilities for session management and interactive session
;; 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)

(defgroup sesman nil
  "Generic Session Manager."
  :prefix "sesman-"
  :group 'tools)

;; (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
;; system's implementation, see `sesman-more-relevant-p'."
;;   :group 'sesman
;;   :type 'boolean)

(defcustom sesman-single-link-context-types '(buffer)
  "List of context types to which at most one session can be linked."
  :group 'sesman
  :type '(repeat symbol))

;; fixme;
;; (defcustom sesman-abbreviate-paths 2
;;   "Abbreviate paths to that many parents.
;; When set to nil, don't abbreviate directories."
;;   :group 'sesman
;;   :type '(choice number
;;                  (const :tag "Don't abbreviate" nil)))

(defvar sesman-sessions-hashmap (make-hash-table :test #'equal)
  "Hash-table of all sesman sessions.
Key is a cons (system-name . session-name).")

(defvar sesman-links-alist nil
  "An alist of all sesman links.
Each element is of the form (key cxt-type cxt-value) where
\"key\" is of the form (system-name . session-name). system-name
and cxt-type must be symbols.")

(defvar-local sesman-system nil
  "Name of the system managed by `sesman'.
Can be either a symbol, or a function returning a symbol.")


;; Internal Utilities

(defun sesman--on-C-u-u-sessions (system which)
  (cond
   ((null which)
    (let ((ses (sesman-current-session system)))
      (when ses
        (list ses))))
   ((or (equal which '(4)) (eq which 'linked))
    (sesman-linked-sessions system))
   ((or (equal which '(16)) (eq which 'all) (eq which t))
    (sesman--all-system-sessions system))
   (t (error "Invalid which argument (%s)" which))))

(defun sesman--cap-system-name (system)
  (let ((name (symbol-name system)))
    (if (string-match-p "^[[:upper:]]" name)
        name
      (capitalize name))))

(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 (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)
        (thread-last sesman-links-alist
          (seq-remove (sesman--link-lookup-fn system nil cxt-type cxt-val))
          (cons link)
          (setq sesman-links-alist))
      (unless (seq-filter (sesman--link-lookup-fn system ses-name cxt-type cxt-val)
                          sesman-links-alist)
        (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--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
   ((stringp obj) (abbreviate-file-name obj))
   ((and (consp obj) (stringp (cdr obj)))
    (cons (car obj) (abbreviate-file-name (cdr obj))))
   (t obj)))

(defun sesman--system ()
  (if sesman-system
      (if (functionp sesman-system)
          (funcall sesman-system)
        sesman-system)
    (error "No `sesman-system' in buffer `%s'" (current-buffer))))

(defun sesman--all-system-sessions (&optional system)
  "Return a list of sessions registered with SYSTEM."
  (let ((system (or system (sesman--system)))
        sessions)
    (maphash
     (lambda (k s)
       (when (eql (car k) system)
         (push s sessions)))
     sesman-sessions-hashmap)
    (sesman--sort-sessions system sessions)))

;; FIXME: make this a macro
(defun sesman--link-lookup-fn (&optional system ses-name cxt-type cxt-val x)
  (let ((system (or system (caar x)))
        (ses-name (or ses-name (cdar x)))
        (cxt-type (or cxt-type (nth 1 x)))
        (cxt-val (or cxt-val (nth 2 x))))
    (lambda (el)
      (and (or (null system) (eq (caar el) system))
           (or (null ses-name) (equal (cdar el) ses-name))
           (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)
  (setq sesman-links-alist
        (seq-remove (sesman--link-lookup-fn nil nil nil nil x)
                    sesman-links-alist)))

(defun sesman--clear-links ()
  (setq sesman-links-alist
        (seq-filter (lambda (x)
                      (gethash (car x) sesman-sessions-hashmap))
                    sesman-links-alist)))

(defun sesman--format-link (link)
  (let ((val (sesman--abbrev-path-maybe
              (sesman--lnk-value link))))
    (format "%s(%s)->%s"
            (sesman--lnk-context-type link)
            (if (listp val) (cdr val) val)
            (propertize (sesman--lnk-session-name link) 'face 'bold))))

(defun sesman--ask-for-link (prompt links &optional ask-all)
  (let* ((name.keys (mapcar (lambda (link)
                              (cons (sesman--format-link link) link))
                            links))
         (name.keys (append name.keys
                            (when (and ask-all (> (length name.keys) 1))
                              '(("*all*")))))
         (nms (mapcar #'car name.keys))
         (sel (completing-read prompt nms nil t nil nil (car nms))))
    (cond ((string= sel "*all*")
           links)
          (ask-all
           (list (cdr (assoc sel name.keys))))
          (t
           (cdr (assoc sel name.keys))))))

(defun sesman--sort-sessions (system sessions)
  (seq-sort (lambda (x1 x2)
              (sesman-more-relevant-p system x1 x2))
            sessions))

(defun sesman--sort-links (system links)
  (seq-sort (lambda (x1 x2)
              (sesman-more-relevant-p system
                                      (gethash (car x1) sesman-sessions-hashmap)
                                      (gethash (car x2) sesman-sessions-hashmap)))
            links))

;; link data structure accessors
(defun sesman--lnk-system-name (lnk)
  (caar lnk))
(defun sesman--lnk-session-name (lnk)
  (cdar lnk))
(defun sesman--lnk-context-type (lnk)
  (cadr lnk))
(defun sesman--lnk-value (lnk)
  (nth 2 lnk))


;;; User Interface

 ;;;###autoload
(defun sesman-start ()
  "Start sesman session."
  (interactive)
  (let* ((system (sesman--system)))
    (message "Starting new %s session ..." system)
    (sesman-start-session system)))

 ;;;###autoload
(defun sesman-restart ()
  "Restart sesman session."
  (interactive)
  (let* ((system (sesman--system))
         (old-session (sesman-ensure-session system "Restart session: ")))
    (message "Restarting %s '%s' session" system (car old-session))
    (sesman-restart-session system old-session)))

 ;;;###autoload
(defun sesman-quit (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,
t or 'all, kill all sessions."
  (interactive "P")
  (let* ((system (sesman--system))
         (sessions (sesman--on-C-u-u-sessions system which)))
    (if (null sessions)
        (message "No more %s sessions" system)
      (mapc (lambda (s)
              (sesman-unregister system s)
              (sesman-quit-session system s))
            sessions)
      (message
       "Killed %s %s %s"  system
       (if (= 1 (length sessions)) "session" "sessions")
       (mapcar #'car sessions)))))

 ;;;###autoload
(defun sesman-show-session-info (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
argument or 'all, show info for all sessions."
  (interactive "P")
  (let* ((system (sesman--system))
         (sessions (sesman--on-C-u-u-sessions system which)))
    (if sessions
        (message (mapconcat
                  (lambda (ses)
                    (format "%s [linked: %s]\n%s"
                            (propertize (car ses) 'face 'bold)
                            (sesman-session-links system ses t)
                            (sesman-session-info system ses)))
                  (delete-consecutive-dups sessions)
                  "\n"))
      (message "No %s sessions" system))))

 ;;;###autoload
(defun sesman-show-links ()
  "Display links active in the current context."
  (interactive)
  (let* ((system (sesman--system))
         (links (sesman-current-links system)))
    (if links
        (message (mapconcat #'sesman--format-link links "\n"))
      (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))

 ;;;###autoload
(defun sesman-link-with-directory ()
  "Associate a session with current directory."
  (interactive)
  (sesman--link-session-interactively directory))

 ;;;###autoload
(defun sesman-link-with-project ()
  "Associate a session with current project."
  (interactive)
  (sesman--link-session-interactively project))

 ;;;###autoload
(defun sesman-unlink ()
  "Break any of the previously created links."
  (interactive)
  (let* ((system (sesman--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))))

(defvar sesman-map
  (let (sesman-map)
    (define-prefix-command 'sesman-map)
    (define-key sesman-map (kbd "C-i") 'sesman-show-session-info)
    (define-key sesman-map (kbd   "i") 'sesman-show-session-info)
    (define-key sesman-map (kbd "C-l") 'sesman-show-links)
    (define-key sesman-map (kbd   "l") 'sesman-show-links)
    (define-key sesman-map (kbd "C-s") 'sesman-start)
    (define-key sesman-map (kbd   "s") 'sesman-start)
    (define-key sesman-map (kbd "C-r") 'sesman-restart)
    (define-key sesman-map (kbd   "r") 'sesman-restart)
    (define-key sesman-map (kbd "C-q") 'sesman-quit)
    (define-key sesman-map (kbd   "q") 'sesman-quit)
    (define-key sesman-map (kbd "C-b") 'sesman-link-with-buffer)
    (define-key sesman-map (kbd   "b") 'sesman-link-with-buffer)
    (define-key sesman-map (kbd "C-d") 'sesman-link-with-directory)
    (define-key sesman-map (kbd   "d") 'sesman-link-with-directory)
    (define-key sesman-map (kbd "C-p") 'sesman-link-with-project)
    (define-key sesman-map (kbd   "p") 'sesman-link-with-project)
    (define-key sesman-map (kbd "C-u") 'sesman-unlink)
    (define-key sesman-map (kbd "  u") 'sesman-unlink)
    sesman-map)
  "Session management prefix keymap.")

(defvar sesman-menu
  '("Sesman"
    ["Show Session Info" sesman-show-session-info]
    ["Show Links" sesman-show-links]
    "--"
    ["Start" sesman-start]
    ["Restart" sesman-restart :active (sesman-connected-p)]
    ["Quit" sesman-quit :active (sesman-connected-p)]
    "--"
    ["Link with Buffer" sesman-link-with-buffer :active (sesman-connected-p)]
    ["Link with Directory" sesman-link-with-directory :active (sesman-connected-p)]
    ["Link with Project" sesman-link-with-project :active (sesman-connected-p)]
    "--"
    ["Unlink" sesman-unlink :active (sesman-connected-p)])
  "Sesman Menu.")

(defun sesman-install-menu (map)
  "Install `sesman-menu' into MAP."
  (easy-menu-do-define 'seman-menu-open
                       map
                       (get 'sesman-menu 'variable-documentation)
                       sesman-menu))


;;; System Generic

(cl-defgeneric sesman-start-session (system)
  "Start and return SYSTEM SESSION.")

(cl-defgeneric sesman-quit-session (system session)
  "Terminate SYSTEM SESSION.")

(cl-defgeneric sesman-restart-session (system session)
  "Restart SYSTEM SESSION.
By default, calls `sesman-quit-session' and then
`sesman-start-session'."
  (let ((old-name (car session)))
    (sesman-quit-session system session)
    (let ((new-session (sesman-start-session system)))
      (setcar new-session old-name))))

(cl-defgeneric sesman-session-info (_system session)
  (cdr session))

(cl-defgeneric sesman-context-types (_system)
  "Return a list of context types understood by SYSTEM."
  '(buffer directory project))

(cl-defgeneric sesman-more-relevant-p (_system session1 session2)
  "Return non-nil if SESSION1 should be sorted before SESSION2.
By default, sort by session name. Systems should overwrite this method to
provide a more meaningful ordering. If your system objects are buffers you
can use `sesman-more-relevant-p' utility in this method."
  (not (string-greaterp (car session1) (car session2))))


;;; System API

(defun sesman-session (system session-name)
  "Retrieve SYSTEM's session with SESSION-NAME from global hash."
  (let ((system (or system (sesman--system))))
    (gethash (cons system session-name) sesman-sessions-hashmap)))

(defun sesman-sessions (system)
  "Return a list of all sessions registered with SYSTEM.
`sesman-linked-sessions' lead the list."
  (let ((system (or system (sesman--system))))
    (delete-dups
     (append (sesman-linked-sessions system)
             ;; (sesman-friendly-sessions system)
             (sesman--all-system-sessions system)))))

(defun sesman-has-sessions-p (system)
  "Return t if there is at least one session registered with SYSTEM."
  (let ((system (or system (sesman--system)))
        (found))
    (condition-case nil
        (maphash (lambda (k _)
                   (when (eq (car k) system)
                     (setq found t)
                     (throw 'found nil)))
                 sesman-sessions-hashmap)
      (error))
    found))

(defvar sesman--select-session-history nil)
(defun sesman-ask-for-session (system prompt &optional sessions ask-new ask-all)
  "Ask for a SYSTEM session with PROMPT.
SESSIONS defaults to value returned from `sesman-sessions'.  If
ASK-NEW is non-nil, offer *new* option to start a new session.  If
ASK-ALL is non-nil offer *all* option.  If ASK-ALL is non-nil,
return a list of sessions, otherwise a single session."
  (let* ((sessions (or sessions (sesman-sessions system)))
         (name.syms (mapcar (lambda (s)
                              (let ((name (car s)))
                                (cons (if (symbolp name) (symbol-name name) name)
                                      name)))
                            sessions))
         (nr (length name.syms))
         (syms (if (and (not ask-new) (= nr 0))
                   (error "No %s sessions found" system)
                 (append name.syms
                         (when ask-new '(("*new*")))
                         (when (and ask-all (> nr 1))
                           '(("*all*"))))))
         (def (caar syms))
         ;; (def (if (assoc (car sesman--select-session-history) syms)
         ;;          (car sesman--select-session-history)
         ;;        (caar syms)))
         (sel (completing-read
               prompt (mapcar #'car syms) nil t nil 'sesman--select-session-history def)))
    (cond
     ((string= sel "*new*")
      (let ((ses (sesman-start-session system)))
        (message "Started %s" (car ses))
        (if ask-all (list ses) ses)))
     ((string= sel "*all*")
      sessions)
     (t
      (let* ((sym (cdr (assoc sel syms)))
             (ses (assoc sym sessions)))
        (if ask-all (list ses) ses))))))

(defun sesman-current-session (system &optional cxt-types)
  "Get the most relevant linked session for SYSTEM.
CXT-TYPES is as in `sesman-linked-sessions'."
  (car (sesman-linked-sessions system cxt-types)))

(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))
      (user-error "No linked %s sessions" system)))

(defun sesman-linked-sessions (system &optional cxt-types)
  "Return a list of SYSTEM sessions linked in current context.
CXT-TYPES is a list of context types to consider.  Defaults to the
list returned from `sesman-context-types'."
  (let* ((system (or system (sesman--system)))
         (cxt-types (or cxt-types (sesman-context-types system))))
    ;; just in case some links are lingering due to user errors
    (sesman--clear-links)
    (mapcar (lambda (assoc)
              (gethash (car assoc) sesman-sessions-hashmap))
            (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'.
Return an alist of the form
   ((buffer buffers..)
    (directory directories...)
    (project projects...)).
If AS-STRING is non-nil, return an equivalent string representation."
  (let* ((system (or system (sesman--system)))
         (session (or session (sesman-current-session system)))
         (ses-name (car session))
         (links (thread-last sesman-links-alist
                  (seq-filter (sesman--link-lookup-fn system ses-name))
                  (sesman--sort-links system)
                  (reverse)))
         (out (mapcar (lambda (x) (list x))
                      (sesman-context-types system))))
    (mapc (lambda (link)
            (let* ((type (sesman--lnk-context-type link))
                   (val (sesman--lnk-value link))
                   (entry (assoc type out)))
              (when entry
                (setcdr entry (cons val (cdr entry))))))
          links)
    (let ((out (delq nil (mapcar (lambda (el) (and (cdr el) el)) out))))
      (if as-string
          (mapconcat (lambda (link-vals)
                       (let ((type (car link-vals)))
                         (mapconcat (lambda (l)
                                      (let ((l (if (listp l) (cdr l) l)))
                                        (format "%s(%s)" type l)))
                                    (cdr link-vals)
                                    " ")))
                     out
                     " ")
        out))))

(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."
  ;; mapcan is a built-in in 26.1; don't want to require cl-lib for one function
  (seq-mapcat
   (lambda (cxt-type)
     (let ((lfn (sesman--link-lookup-fn system nil cxt-type)))
       (sesman--sort-links
        system
        (seq-filter (lambda (l)
                      (and (funcall lfn l)
                           (sesman-relevant-context-p cxt-type (nth 2 l))))
                    sesman-links-alist))))
   (or cxt-types (sesman-context-types system))))

(defun sesman-has-links-p (system &optional cxt-types)
  "Return t if there is at least one linked session.
CXT-TYPES defaults to `sesman-context-types' for current SYSTEM."
  (let ((cxt-types (or cxt-types (sesman-context-types system)))
        (found))
    (condition-case nil
        (mapc (lambda (l)
                (when (eq system (sesman--lnk-system-name l))
                  (let ((cxt (sesman--lnk-context-type l)))
                    (when (and (member cxt cxt-types)
                               (sesman-relevant-context-p cxt (sesman--lnk-value l)))
                      (setq found t)
                      (throw 'found nil)))))
              sesman-links-alist)
      (error))
    found))

(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
registered in `sesman-sessions-hashmap', change the name by appending \"#1\",
\"#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))
         (ses-name0 (car session))
         (i 1))
    (while (sesman-session system ses-name)
      (setq ses-name (format "%s#%d" ses-name0 i)))
    (setq session (cons ses-name (cdr session)))
    (puthash (cons system ses-name) session sesman-sessions-hashmap)
    (sesman--link-session system session)
    session))

(defun sesman-unregister (system session)
  "Unregister SESSION.
SYSTEM defaults to current system.  Remove session from
`sesman-sessions-hashmap' and `sesman-links-alist'."
  (let ((ses-key (cons system (car session))))
    (remhash ses-key sesman-sessions-hashmap)
    (sesman--clear-links)
    session))

(defun sesman-add-object (system session-name object &optional allow-new)
  "Add (destructively) OBJECT to session SESSION-NAME of SYSTEM.
If ALLOW-NEW is nil and session with SESSION-NAME does not exist
throw an error, otherwise register a new session with
session (list SESSION-NAME OBJECT)."
  (let* ((system (or system (sesman--system)))
         (session (sesman-session system session-name)))
    (if session
        (setcdr session (cons object (cdr session)))
      (if allow-new
          (sesman-register system (list session-name object))
        (error "%s session '%s' does not exist"
               (sesman--cap-system-name system) session-name)))))

(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 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)
                    (sesman-session-for-object system object no-error)))
         (new-session (delete object session)))
    (cond ((null new-session))
          ((= (length new-session) 1)
           (when auto-unregister
             (sesman-unregister system session)))
          (t
           (puthash (cons system (car session)) new-session sesman-sessions-hashmap)))))

(defun sesman-session-for-object (system object &optional no-error)
  "Retrieve SYSTEM session which contains OBJECT.
When NO-ERROR is non-nil, don't throw an error if OBJECT is not part of any
session.  In such case, return nil."
  (let* ((system (or system (sesman--system)))
         (sessions (sesman--all-system-sessions system)))
    (or (seq-find (lambda (ses)
                    (seq-find (lambda (x) (equal object x)) (cdr ses)))
                  sessions)
        (unless no-error
          (error "%s is not part of any %s sessions"
                 object system)))))

(defun sesman-session-name-for-object (system object &optional no-error)
  "Retrieve the name of the SYSTEM's session containing OBJECT.
When NO-ERROR is non-nil, don't throw an error if OBJCECT is not part of
any session.  In such case, return nil."
  (car (sesman-session-for-object system object no-error)))

(defun sesman-more-recent-p (bufs1 bufs2)
  "Return t if BUFS1 is more recent than BUFS2.
BUFS1 and BUFS2 are either buffers or lists of buffers.  When lists of
buffers, most recent buffers from each list are considered.  To be used
primarily in `sesman-more-relevant-p' methods when session objects are
buffers."
  (let ((bufs1 (if (bufferp bufs1) (list bufs1) bufs1))
        (bufs2 (if (bufferp bufs2) (list bufs2) bufs2)))
    (eq 1 (seq-some (lambda (b)
                      (if (member b bufs1)
                          1
                        (when (member b bufs2)
                          -1)))
                    (buffer-list)))))


;;; Contexts

(cl-defgeneric sesman-context (_cxt-type)
  "Given context type CXT-TYPE return the context.")
(cl-defmethod sesman-context ((_cxt-type (eql buffer)))
  "Return current buffer."
  (current-buffer))
(cl-defmethod sesman-context ((_cxt-type (eql directory)))
  "Return current directory."
  default-directory)
(cl-defmethod sesman-context ((_cxt-type (eql project)))
  "Return current project."
  (project-current))

(cl-defgeneric sesman-relevant-context-p (_cxt-type cxt)
  "Non-nil if context CXT is relevant to current context of type CXT-TYPE.")
(cl-defmethod sesman-relevant-context-p ((_cxt-type (eql buffer)) buf)
  "Non-nil if BUF is `current-buffer'."
  (eq (current-buffer) buf))
(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) (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 "^" (cdr proj))
                    (expand-file-name default-directory))))


(provide 'sesman)

;;; sesman.el ends here