branch: elpa/sesman
commit 30ec72e2fe1ca92b83a63d032a794c1c07d9ca65
Author: Vitalie Spinu <spinu...@gmail.com>
Commit: Vitalie Spinu <spinu...@gmail.com>
[Fix #5] Implement session-browser
Also closes #8
---
sesman-browser.el | 464 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
sesman.el | 5 +-
2 files changed, 467 insertions(+), 2 deletions(-)
diff --git a/sesman-browser.el b/sesman-browser.el
new file mode 100644
index 0000000000..64c7bfc233
--- /dev/null
+++ b/sesman-browser.el
@@ -0,0 +1,464 @@
+;;; sesman-broser.el --- Interactive Browser for Sesman -*- lexical-binding: t
-*-
+;;
+;; Copyright (C) 2018, Vitalie Spinu
+;; Author: Vitalie Spinu
+;; URL: https://github.com/vspinu/sesman
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; 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.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Code:
+
+(require 'seq)
+(require 'sesman)
+
+(defgroup sesman-browser nil
+ "Browser for Sesman."
+ :prefix "sesman-browser-"
+ :group 'sesman
+ :link '(url-link :tag "GitHub" "https://github.com/vspinu/sesman";))
+
+(defvar-local sesman-browser--sort-types '(name relevance))
+(defcustom sesman-browser-sort-type 'name
+ "Default sorting type in sesman browser buffers.
+Currently can be either 'name or 'relevance."
+ :type '(choice (const name) (const relevance))
+ :group 'sesman-browser)
+
+(defface sesman-browser-highligh
+ '((default (:inherit highlight :weight bold)))
+ "Face used to highlight currently selected button."
+ :group 'sesman-browser)
+
+(defface sesman-browser-button
+ '((default (:inherit button :slant italic)))
+ "Face used to highlight currently selected object."
+ :group 'sesman-browser)
+
+(defvar sesman-browser-map
+ (let (sesman-browser-map)
+ (define-prefix-command 'sesman-browser-map)
+ (define-key sesman-browser-map (kbd "r") #'sesman-browser-restart-session)
+ (define-key sesman-browser-map (kbd "q") #'sesman-browser-quit-session)
+ (define-key sesman-browser-map (kbd "b") #'sesman-browser-link-with-buffer)
+ (define-key sesman-browser-map (kbd "d")
#'sesman-browser-link-with-directory)
+ (define-key sesman-browser-map (kbd "p")
#'sesman-browser-link-with-project)
+ (define-key sesman-browser-map (kbd "u") #'sesman-browser-unlink)
+ sesman-browser-map)
+ "Prefix keymap for sesman commands from sesman browser.")
+
+(defvar sesman-browser-mode-map
+ (let ((sesman-browser-mode-map (make-sparse-keymap)))
+ (define-key sesman-browser-mode-map (kbd "n")
#'sesman-browser-vertical-next)
+ (define-key sesman-browser-mode-map (kbd "p")
#'sesman-browser-vertical-prev)
+ (define-key sesman-browser-mode-map (kbd "f") #'sesman-browser-forward)
+ (define-key sesman-browser-mode-map (kbd "b") #'sesman-browser-backward)
+ (define-key sesman-browser-mode-map [remap forward-paragraph]
#'sesman-browser-session-next)
+ (define-key sesman-browser-mode-map [remap backward-paragraph]
#'sesman-browser-session-prev)
+ (define-key sesman-browser-mode-map (kbd "C-M-n")
#'sesman-browser-session-next)
+ (define-key sesman-browser-mode-map (kbd "C-M-p")
#'sesman-browser-session-prev)
+ (define-key sesman-browser-mode-map (kbd "<tab>") #'sesman-browser-forward)
+ (define-key sesman-browser-mode-map (kbd "<backtab>")
#'sesman-browser-backward)
+ (define-key sesman-browser-mode-map (kbd "<RET>") #'sesman-goto)
+ (define-key sesman-browser-mode-map (kbd "o") #'sesman-show)
+ (define-key sesman-browser-mode-map (kbd "t") #'sesman-browser-toggle-sort)
+ (define-key sesman-browser-mode-map (kbd "S") #'sesman-browser-toggle-sort)
+ (define-key sesman-browser-mode-map (kbd "l b")
#'sesman-browser-link-with-buffer)
+ (define-key sesman-browser-mode-map (kbd "l d")
#'sesman-browser-link-with-directory)
+ (define-key sesman-browser-mode-map (kbd "l p")
#'sesman-browser-link-with-project)
+ (define-key sesman-browser-mode-map (kbd "u") #'sesman-browser-unlink)
+ (define-key sesman-browser-mode-map (kbd "s") 'sesman-browser-map)
+ (define-key sesman-browser-mode-map (kbd "C-c C-s") 'sesman-browser-map)
+ sesman-browser-mode-map)
+ "Local keymap in `sesman-browser-mode'.")
+
+
+;;; Utilities
+
+(defun sesman-browser--closeby-pos (prop lax)
+ (or (when (get-text-property (point) prop)
+ (point))
+ (when (and (not (bobp))
+ (get-text-property (1- (point)) prop))
+ (1- (point)))
+ (when lax
+ (let ((next (save-excursion
+ (and
+ (goto-char (next-single-char-property-change (point)
prop))
+ (get-text-property (point) prop)
+ (point))))
+ (prev (save-excursion
+ (and
+ (goto-char (previous-single-char-property-change
(point) prop))
+ (not (bobp))
+ (get-text-property (1- (point)) prop)
+ (1- (point))))))
+ (if next
+ (if prev
+ (if (< (- (point) prev) (- next (point)))
+ prev
+ next)
+ next)
+ prev)))))
+
+(defun sesman-browser--closeby-value (prop lax)
+ (when-let ((pos (sesman-browser--closeby-pos prop lax)))
+ (get-text-property pos prop)))
+
+(defun sesman-browser-get (what &optional no-error lax)
+ "Get value of the property WHAT at point.
+If NO-ERROR is non-nil, don't throw an error if no value has been found and
+return nil. If LAX is non-nil, search nearby and return the closest value."
+ (when (derived-mode-p 'sesman-browser-mode)
+ (or (let ((prop (pcase what
+ ('session :sesman-session)
+ ('link :sesman-link)
+ ('object :sesman-object)
+ (_ what))))
+ (sesman-browser--closeby-value prop 'lax))
+ (unless no-error
+ (user-error "No %s %s" what (if lax "nearby" "at point"))))))
+
+
+;;; Navigation
+
+(defvar-local sesman-browser--section-overlay nil)
+(defvar-local sesman-browser--stop-overlay nil)
+
+(when (fboundp 'define-fringe-bitmap)
+ (define-fringe-bitmap 'sesman-left-bar
+ [#b00001100] nil nil '(top t)))
+
+(defun sesman-browser--next (prop)
+ (let ((pos (point)))
+ (goto-char (previous-single-char-property-change (point) prop))
+ (unless (get-text-property (point) prop)
+ (goto-char (previous-single-char-property-change (point) prop)))
+ (when (bobp)
+ (goto-char pos))))
+
+(defun sesman-browser--prev (prop)
+ (let ((pos (point)))
+ (goto-char (next-single-char-property-change (point) prop))
+ (unless (get-text-property (point) prop)
+ (goto-char (next-single-char-property-change (point) prop)))
+ (when (eobp)
+ (goto-char pos))))
+
+;;;###autoload
+(defun sesman-browser-forward ()
+ "Go to next button."
+ (interactive)
+ (sesman-browser--prev :sesman-stop))
+
+;;;###autoload
+(defun sesman-browser-backward ()
+ "Go to previous button."
+ (interactive)
+ (sesman-browser--next :sesman-stop))
+
+;;;###autoload
+(defun sesman-browser-vertical-next ()
+ "Go to next button section or row."
+ (interactive)
+ (sesman-browser--prev :sesman-vertical-stop))
+
+;;;###autoload
+(defun sesman-browser-vertical-prev ()
+ "Go to previous button section or row."
+ (interactive)
+ (sesman-browser--next :sesman-vertical-stop))
+
+;;;###autoload
+(defun sesman-browser-session-next ()
+ "Go to next session."
+ (interactive)
+ (sesman-browser--prev :sesman-session-stop))
+
+;;;###autoload
+(defun sesman-browser-session-prev ()
+ "Go to previous session."
+ (interactive)
+ (sesman-browser--next :sesman-session-stop))
+
+
+;;; Display
+
+;;;###autoload
+(defun sesman-goto (&optional no-switch)
+ "Go to most relevant buffer for session at point.
+If NO-SWITCH is non-nil, only display the buffer."
+ (interactive "P")
+ (let ((object (get-text-property (point) :sesman-object)))
+ (if (and object (bufferp object))
+ (if no-switch
+ (display-buffer object)
+ (pop-to-buffer object))
+ (let* ((session (sesman-browser-get 'session))
+ (info (sesman-session-info (sesman--system) session))
+ (buffers (or (plist-get info :buffers)
+ (let ((objects (plist-get info :objects)))
+ (seq-filter #'bufferp objects)))))
+ (if buffers
+ (let ((most-recent-buf (seq-find (lambda (b)
+ (member b buffers))
+ (buffer-list))))
+ (if no-switch
+ (display-buffer most-recent-buf)
+ (pop-to-buffer most-recent-buf)))
+ (user-error "Cannot jump to session %s; it doesn't contain any
buffers" (car session)))))))
+
+;;;###autoload
+(defun sesman-show ()
+ "Show the most relevant buffer for the session at point."
+ (interactive)
+ (sesman-goto 'no-switch))
+
+(defun sesman-browser--sensor-function (&rest ignore)
+ (let ((beg (or (when (get-text-property (point) :sesman-stop)
+ (if (get-text-property (1- (point)) :sesman-stop)
+ (previous-single-char-property-change (point)
:sesman-stop)
+ (point)))
+ (next-single-char-property-change (point) :sesman-stop)))
+ (end (next-single-char-property-change (point) :sesman-stop)))
+ (move-overlay sesman-browser--stop-overlay beg end)
+ (when window-system
+ (when-let* ((beg (get-text-property (point) :sesman-fragment-beg))
+ (end (get-text-property (point) :sesman-fragment-end)))
+ (move-overlay sesman-browser--section-overlay beg end)))))
+
+
+;;; Sesman UI
+
+;;;###autoload
+(defun sesman-browser-quit-session ()
+ "Quite session at point."
+ (interactive)
+ (sesman-quit (sesman-browser-get 'session)))
+
+;;;###autoload
+(defun sesman-browser-restart-session ()
+ "Restart session at point."
+ (interactive)
+ (sesman-restart (sesman-browser-get 'session)))
+
+;;;###autoload
+(defun sesman-browser-link-with-buffer ()
+ "Ask for buffer to link session at point to."
+ (interactive)
+ (let ((session (sesman-browser-get 'session)))
+ (sesman-link-with-buffer 'ask session)))
+
+;;;###autoload
+(defun sesman-browser-link-with-directory ()
+ "Ask for directory to link session at point to."
+ (interactive)
+ (let ((session (sesman-browser-get 'session)))
+ (sesman-link-with-directory 'ask session)))
+
+;;;###autoload
+(defun sesman-browser-link-with-project ()
+ "Ask for project to link session at point to."
+ (interactive)
+ (let ((session (sesman-browser-get 'session)))
+ (sesman-link-with-project 'ask session)))
+
+;;;###autoload
+(defun sesman-browser-unlink ()
+ "Unlink the link at point or ask for link to unlink."
+ (interactive)
+ (if-let ((link (sesman-browser-get 'link 'no-error)))
+ (sesman--unlink link)
+ (if-let ((links (sesman-links (sesman--system)
+ (sesman-browser-get 'session))))
+ (mapc #'sesman--unlink
+ (sesman--ask-for-link "Unlink: " links 'ask-all))
+ (user-error "No links for session %s" (car (sesman-browser-get
'session)))))
+ (run-hooks 'sesman-post-command-hook))
+
+
+;;; Major Mode
+
+(defun sesman-browser-revert (&rest _ignore)
+ "Refresh current browser buffer."
+ (let ((pos (point)))
+ (sesman-browser)
+ ;; simple but not particularly reliable or useful
+ (goto-char (min pos (point-max)))))
+
+(defun sesman-browser-revert-all (system)
+ "Refresh all Sesman SYSTEM browsers."
+ (mapc (lambda (b)
+ (with-current-buffer b
+ (when (and (derived-mode-p 'sesman-browser-mode)
+ (eq system (sesman--system)))
+ (sesman-browser-revert))))
+ (buffer-list)))
+
+(defun sesman-browser-toggle-sort ()
+ "Toggle sorting of sessions.
+See `sesman-browser-sort-type' for the default sorting type."
+ (interactive)
+ (when (eq sesman-browser-sort-type
+ (car sesman-browser--sort-types))
+ (pop sesman-browser--sort-types))
+ (unless sesman-browser--sort-types
+ (setq-local sesman-browser--sort-types (default-value
'sesman-browser--sort-types)))
+ (setq sesman-browser-sort-type (pop sesman-browser--sort-types))
+ (let ((stop (sesman-browser-get :sesman-stop nil 'lax)))
+ (sesman-browser)
+ (goto-char (point-min))
+ (let ((search t))
+ (while search
+ (goto-char (next-single-char-property-change (point) :sesman-stop))
+ (if (eobp)
+ (progn (setq search nil)
+ (goto-char (next-single-char-property-change (point-min)
:sesman-stop)))
+ (when (equal (get-text-property (point) :sesman-stop) stop)
+ (setq search nil))))))
+ (message "Sorted by %s"
+ (propertize (symbol-name sesman-browser-sort-type) 'face 'bold)))
+
+(define-derived-mode sesman-browser-mode special-mode "SesmanBrowser"
+ "Interactive view of Sesman sessions."
+ ;; ensure there is a sesman-system here
+ (sesman--system)
+ (add-hook 'sesman-post-command-hook 'sesman-browser-revert nil t)
+ (setq-local sesman-browser--sort-types (default-value
'sesman-browser--sort-types))
+ (setq-local revert-buffer-function #'sesman-browser-revert))
+
+(defun sesman-browser--insert-session (system ses i)
+ (let ((ses-name (car ses))
+ (head-template "%17s")
+ beg end)
+ (setq beg (point))
+
+ ;; session header
+ (insert (format "%3d: " i))
+ (insert (propertize (car ses)
+ :sesman-stop ses-name
+ :sesman-vertical-stop t
+ :sesman-session-stop t
+ 'face 'bold
+ 'cursor-sensor-functions (list
#'sesman-browser--sensor-function)
+ 'mouse-face 'highlight)
+ "\n")
+
+ ;; links
+ (insert (format head-template "linked-to: "))
+ (let ((link-groups (sesman-grouped-links system ses))
+ (vert-stop))
+ (dolist (grp link-groups)
+ (let* ((type (car grp))
+ (short-type (or (plist-get sesman--cxt-abbrevs type) type)))
+ (dolist (link (cdr grp))
+ (when (> (current-column) fill-column)
+ (insert "\n" (format head-template " "))
+ (setq vert-stop nil))
+ (insert (propertize (format "%s(%s)" short-type
+ (sesman--abbrev-path-maybe
+ (sesman--lnk-value link)))
+ :sesman-stop (car link)
+ :sesman-vertical-stop (unless vert-stop (setq
vert-stop t))
+ :sesman-link link
+ 'cursor-sensor-functions (list
#'sesman-browser--sensor-function)
+ 'mouse-face 'highlight
+ 'face 'sesman-browser-button))
+ (insert " ")))))
+ (insert "\n")
+
+ ;; objects
+ (insert (format head-template "objects: "))
+ (let* ((info (sesman-session-info system ses))
+ (map (plist-get info :map))
+ (objects (plist-get info :objects))
+ (strings (or (plist-get info :strings)
+ (mapcar (lambda (x) (format "%s" x)) objects)))
+ (kvals (seq-mapn #'cons objects strings))
+ (kvals (seq-sort (lambda (a b) (string-lessp (cdr a) (cdr b)))
+ kvals))
+ (vert-stop))
+ (dolist (kv kvals)
+ (when (> (current-column) fill-column)
+ (insert "\n" (format head-template " "))
+ (setq vert-stop nil))
+ (let ((str (replace-regexp-in-string ses-name "%s" (cdr kv) nil t)))
+ (insert (propertize str
+ :sesman-stop str
+ :sesman-vertical-stop (unless vert-stop (setq
vert-stop t))
+ :sesman-object (car kv)
+ 'cursor-sensor-functions (list
#'sesman-browser--sensor-function)
+ 'face 'sesman-browser-button
+ 'mouse-face 'highlight
+ 'help-echo "mouse-2: visit in other window"
+ 'keymap map)
+ " "))))
+
+ ;; session properties
+ (setq end (point))
+ (put-text-property beg end :sesman-session ses)
+ (put-text-property beg end :sesman-session-name ses-name)
+ (put-text-property beg end :sesman-fragment-beg beg)
+ (put-text-property beg end :sesman-fragment-end end)
+ (insert "\n\n")))
+
+;;;###autoload
+(defun sesman-browser ()
+ "Display an interactive session browser."
+ (interactive)
+ (let* ((system (sesman--system))
+ (sessions (sesman-sessions system))
+ (buff (get-buffer-create (format "*sesman %s browser*" system)))
+ (pop-to (called-interactively-p 'any)))
+ (with-current-buffer buff
+ (setq-local sesman-system system)
+ (sesman-browser-mode)
+ (cursor-sensor-mode 1)
+ (let ((inhibit-read-only t)
+ (sessions (pcase sesman-browser-sort-type
+ ('name (seq-sort (lambda (a b) (string-greaterp (car
b) (car a)))
+ sessions))
+ ('relevance (sesman--sort-sessions system sessions))
+ (_ (error "Invalid `sesman-browser-sort-type'"))))
+ (i 0))
+ (erase-buffer)
+ (insert (format "\n %s Sessions:\n\n" system))
+ (dolist (ses sessions)
+ (setq i (1+ i))
+ (sesman-browser--insert-session system ses i))
+ (when pop-to
+ (pop-to-buffer buff))
+ (let ((dummy-string (ess-tracebug--propertize "|" 'sesman-left-bar
+
'font-lock-keyword-face)))
+ (goto-char (next-single-property-change (point-min) :sesman-stop))
+ (setq-local sesman-browser--stop-overlay
+ (make-overlay (point) (next-single-property-change
(point) :sesman-stop)))
+ (overlay-put sesman-browser--stop-overlay 'face
'sesman-browser-highligh)
+ (when window-system
+ (setq-local sesman-browser--section-overlay
+ (make-overlay (get-text-property (point)
:sesman-fragment-beg)
+ (get-text-property (point)
:sesman-fragment-end)))
+ (overlay-put sesman-browser--section-overlay 'line-prefix
dummy-string)))))))
+
+(provide 'sesman-broser)
+
+;;; sesman-broser.el ends here
+
diff --git a/sesman.el b/sesman.el
index b289faa418..7aafed6fe6 100644
--- a/sesman.el
+++ b/sesman.el
@@ -434,6 +434,8 @@ PROJECT defaults to current project. On universal argument,
or if PROJECT is
(define-prefix-command 'sesman-map)
(define-key sesman-map (kbd "C-i") #'sesman-info)
(define-key sesman-map (kbd "i") #'sesman-info)
+ (define-key sesman-map (kbd "C-w") #'sesman-browser)
+ (define-key sesman-map (kbd "w") #'sesman-browser)
(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)
@@ -453,8 +455,7 @@ PROJECT defaults to current project. On universal argument,
or if PROJECT is
(defvar sesman-menu
'("Sesman"
- ["Show Session Info" sesman-show-session-info]
- ["Show Links" sesman-show-links]
+ ["Show Session Info" sesman-info]
"--"
["Start" sesman-start]
["Restart" sesman-restart :active (sesman-connected-p)]
