tvl-depot/configs/shared/emacs/.emacs.d/elpa/sesman-20180903.1826/sesman-browser.el

;;; sesman-browser.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.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Interactive session browser.
;;
;;; 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"))

(defface sesman-browser-highligh-face
  '((default (:inherit highlight :weight bold)))
  "Face used to highlight currently selected button."
  :group 'sesman-browser)

(defface sesman-browser-button-face
  '((default (:inherit button :slant italic)))
  "Face used to highlight currently selected object."
  :group 'sesman-browser)

(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)

(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))))

(defun sesman-browser-forward ()
  "Go to next button."
  (interactive)
  (sesman-browser--prev :sesman-stop))

(defun sesman-browser-backward ()
  "Go to previous button."
  (interactive)
  (sesman-browser--next :sesman-stop))

(defun sesman-browser-vertical-next ()
  "Go to next button section or row."
  (interactive)
  (sesman-browser--prev :sesman-vertical-stop))

(defun sesman-browser-vertical-prev ()
  "Go to previous button section or row."
  (interactive)
  (sesman-browser--next :sesman-vertical-stop))

(defun sesman-browser-session-next ()
  "Go to next session."
  (interactive)
  (sesman-browser--prev :sesman-session-stop))

(defun sesman-browser-session-prev ()
  "Go to previous session."
  (interactive)
  (sesman-browser--next :sesman-session-stop))


;;; Display

(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)))))))

(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

(defun sesman-browser-quit-session ()
  "Quite session at point."
  (interactive)
  (sesman-quit (sesman-browser-get 'session)))

(defun sesman-browser-restart-session ()
  "Restart session at point."
  (interactive)
  (sesman-restart (sesman-browser-get 'session)))

(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)))

(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)))

(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)))

(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--goto-stop (stop-value)
  (let ((search t))
    (goto-char (point-min))
    (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-value)
          (setq search nil))))))

(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)
    (sesman-browser--goto-stop stop)
    (sesman-browser--sensor-function))
  (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.
When applicable, system specific commands are locally bound to j when point is
on a session object."
  ;; ensure there is a sesman-system here
  (sesman--system)
  (delete-all-overlays)
  (setq-local sesman-browser--stop-overlay (make-overlay (point) (point)))
  (overlay-put sesman-browser--stop-overlay 'face 'sesman-browser-highligh-face)
  (setq-local sesman-browser--section-overlay (make-overlay (point) (point)))
  (when window-system
    (let* ((fringe-spec '(left-fringe sesman-left-bar sesman-browser-highligh-face))
           (dummy-string (propertize "|" 'display fringe-spec)))
      (overlay-put sesman-browser--section-overlay 'line-prefix dummy-string)))
  (add-hook 'sesman-post-command-hook 'sesman-browser-revert nil t)
  (setq-local display-buffer-base-action '(nil . ((inhibit-same-window . 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)))
          (dolist (link (cdr grp))
            (when (> (current-column) fill-column)
              (insert "\n" (format head-template " "))
              (setq vert-stop nil))
            (let ((val (sesman--abbrev-path-maybe (sesman--lnk-value link))))
              (insert (propertize (sesman--format-context type val 'sesman-browser-button-face)
                                  :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)))
            (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-face
                              '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.
See `sesman-browser-mode' for more details."
  (interactive)
  (let* ((system (sesman--system))
         (pop-to (called-interactively-p 'any))
         (sessions (sesman-sessions system))
         (cur-session (when pop-to
                        (sesman-current-session 'CIDER)))
         (buff (get-buffer-create (format "*sesman %s browser*" system))))
    (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 "\n ")
        (insert (propertize (format "%s Sessions:" system)
                            'face '(bold font-lock-keyword-face)))
        (insert "\n\n")
        (dolist (ses sessions)
          (setq i (1+ i))
          (sesman-browser--insert-session system ses i))
        (when pop-to
          (pop-to-buffer buff)
          (sesman-browser--goto-stop (car cur-session)))
        (sesman-browser--sensor-function)))))

(provide 'sesman-browser)
;;; sesman-browser.el ends here