move some cycling into new mode & begin other parts of new lib

1 files changed, 304 insertions, 0 deletions

diff --git a/.emacs.d/site-lisp/transient-cycles.el b/.emacs.d/site-lisp/transient-cycles.el
index 709c5af0..2ef3351b 100644
--- a/.emacs.d/site-lisp/transient-cycles.el
+++ b/.emacs.d/site-lisp/transient-cycles.el
@@ -55,6 +55,12 @@
 ;; Emacs commands with transient cycling variants the author has found useful.
 ;; `transient-cycles-buffer-siblings-mode' implements a more complex version
 ;; of the transient cycling described in the preceding example.
+;;
+;; Definitions of command variants in this file only hide the fact that
+;; transient cycling went on -- in the example above, how the buffer list is
+;; undisturbed and how only the final buffer is pushed to the window's
+;; previous buffers -- to the extent that doing so does not require saving a
+;; lot of data when commencing transient cycling.
 
 ;;; Code:
 
@@ -75,6 +81,304 @@ commands augmented with transient cycling."
   :type 'key-sequence
   :group 'transient-cycles)
 
+(cl-defmacro transient-cycles-define-commands
+    (bindings commands cycler-generator
+     &key on-exit cycle-forwards-key cycle-backwards-key
+       (keymap '(current-global-map)))
+  "Define command variants closing over BINDINGS as specified by
+COMMANDS with transient cycling as supplied by CYCLER-GENERATOR.
+
+BINDINGS are established by means of `let*' at the beginning of
+each command variant.  Thus each command variant,
+CYCLER-GENERATOR and ON-EXIT close over each of BINDINGS.  The
+storage is intended to last for the duration of transient
+cycling, and may be used for cycling state or to save values from
+before cycling began for restoration during ON-EXIT.
+
+Each of COMMANDS defines a command variant, and should be of the
+form (ORIGINAL ARGS [INTERACTIVE] &body BODY) where ORIGINAL
+names the command for which a transient cycling variant should be
+defined, and ARGS, INTERACTIVE and BODY are as in `lambda'.  If
+INTERACTIVE is absent then the newly defined command is given
+ORIGINAL's interactive form.  As a special case, if ORIGINAL is
+of the form [remap COMMAND], then COMMAND is used as ORIGINAL and
+[remap COMMAND] is bound to the command variant in KEYMAP.
+
+CYCLER-GENERATOR defines a function which will be called with the
+return value of each command variant, and must return a function
+of one argument, which is known as the cycler.  After the call to
+the command variant, a transient map is established in which
+CYCLE-FORWARDS-KEY invokes the cycler with the numeric value of
+the prefix argument and CYCLE-BACKWARDS-KEY invokes the cycler
+with the numeric value of the prefix argument multiplied by -1.
+
+ON-EXIT, if present, is wrapped in a lambda expression with no
+arguments, i.e. (lambda () ON-EXIT), and passed as the third
+argument to `set-transient-map'."
+  (macroexp-progn
+   (cl-loop with on-exit = (and on-exit `(lambda () ,on-exit))
+	 and arg = (gensym) and cycler = (gensym) and tmap = (gensym)
+	 for (original args . body) in commands
+	 for remap-p = (and (vectorp original) (eq 'remap (aref original 0)))
+	 for original* = (if remap-p (aref original 1) original)
+	 for name = (intern
+		     (format "transient-cycles--%s-with-transient-cycling"
+			     (symbol-name original*)))
+	 collect
+	 `(defun ,name ()
+	    ,(format "Like `%s', but augmented with transient cycling."
+		     (symbol-name original*))
+	    (interactive)
+	    (let* (,@bindings
+		   (,arg (call-interactively
+			  (lambda ,args
+			    ,@(if (and (listp (car body))
+				       (eq 'interactive (caar body)))
+				  body
+				(cons (interactive-form original*) body))))))
+	      (when-let ((,cycler (funcall ,cycler-generator ,arg))
+			 (,tmap (make-sparse-keymap)))
+		;; It might be additionally useful to bind something in the
+		;; transient map to kill the current buffer and cycle once.
+		;;
+		;; For the forward direction we could elide this lambda and
+		;; just bind the key to the cycler.  But this way means we are
+		;; consistent in always supplying an integer.
+		(define-key ,tmap
+		    ,(or cycle-forwards-key
+			 '(cond ((memq last-command-event '(up down))
+				 [down])
+				((memq last-command-event '(left right))
+				 [right])
+				(t
+				 transient-cycles-default-cycle-forwards-key)))
+		  (lambda (,arg)
+		    (interactive "p")
+		    (funcall ,cycler ,arg)))
+		(define-key ,tmap
+		    ,(or cycle-backwards-key
+			 '(cond ((memq last-command-event '(up down))
+				 [up])
+				((memq last-command-event '(left right))
+				 [left])
+				(t
+				 transient-cycles-default-cycle-backwards-key)))
+		  (lambda (,arg)
+		    (interactive "p")
+		    (funcall ,cycler (* -1 ,arg))))
+		(set-transient-map ,tmap t ,on-exit))))
+	 when remap-p collect `(define-key ,keymap ,original #',name))))
+(put 'transient-cycles-define-commands 'common-lisp-indent-function
+     '(4 (&whole 2 &rest (&whole 1 4 &body)) &body))
+
+(cl-defmacro transient-cycles-buffer-ring-cycler
+    (&key (start 0)
+       (ring '(transient-cycles-buffer-siblings-ring ret-val))
+       (action '(switch-to-buffer buffer t t)))
+  "Yield a lambda expression to cycle RING from START using ACTION.
+This macro is intended for use as the CYCLER-GENERATOR argument
+to `transient-cycles-define-keys'.
+
+RING is a form which evaluates to a ring of buffers.  It should
+be written in terms of `ret-val', which at time of evaluation
+will hold the return value of calling the command variant as
+described in the docstring of `transient-cycles-define-keys'.
+ACTION is a form in terms of `buffer', which should cycle to
+`buffer' in the relevant sense."
+  (let ((count (gensym))
+	(buffers (gensym))
+	(buffers-pos (gensym)))
+    `(lambda (ret-val)
+       (when-let ((,buffers ,ring)
+		  (,buffers-pos ,start))
+	 (lambda (,count)
+	   (interactive "p")
+	   (cl-incf ,buffers-pos ,count)
+	   (let ((buffer (ring-ref ,buffers ,buffers-pos)))
+	     ,action))))))
+
+(defcustom transient-cycles-buffer-siblings-major-modes
+  '(("\\`*unsent mail" . message-mode))
+  "Alist mapping regexps to major modes.
+Buffers whose names match a regexp are considered to have the
+associated major mode for the purpose of determining whether they
+should be associated with families of clones as generated by
+`transient-cycles-buffer-siblings-ring', which see."
+  :type '(alist :key-type regexp :value-type symbol)
+  :group 'transient-cycles)
+
+(defun transient-cycles-buffer-siblings-ring (buffer)
+  "Return ring of BUFFER clones and buffers sharing the clones' major mode.
+BUFFER itself is the first element of the ring, followed by the
+clones of BUFFER, and then buffers merely sharing the major mode
+of the family of clones.
+
+Clonehood is determined by similarity of buffer names.  Clones
+produced by `clone-buffer' and `clone-indirect-buffer' will be
+counted as siblings, but so will the two Eshell buffers produced
+if you type \\[project-eshell] then \\[universal-argument] \\[project-eshell],
+as the same naming scheme is used.  This is desirable for
+`transient-cycles-buffer-siblings-mode', which see.
+
+The singular major mode of the family of clones is determined
+using heuristics, as it is expected that clones of a buffer may
+have different major modes: visiting one file with more than one
+major mode is one of the primary uses of indirect clones."
+  (let* ((clones-hash (make-hash-table))
+	 (root-name (buffer-name buffer))
+	 (root-name (if (string-match "\\`\\(.+\\)<[0-9]+>\\'" root-name)
+			(match-string 1 root-name)
+		      root-name))
+	 (clones-regexp
+	  (concat "\\`" (regexp-quote root-name) "\\(<[0-9]+>\\)?\\'"))
+	 (clones-pred
+	  (lambda (b) (string-match clones-regexp (buffer-name b))))
+	 (buffers (cl-remove-if-not clones-pred (buffer-list)))
+	 (mode (or (cdr (assoc root-name
+			       transient-cycles-buffer-siblings-major-modes
+			       #'string-match))
+		   ;; If only one buffer or root clone is visiting a file, use
+		   ;; major mode of that one buffer or root clone.  The only
+		   ;; case we want here is the root of a family of indirect
+		   ;; clones.  Thus, don't consider arbitrary clones visiting
+		   ;; files, as this may be because the user cloned, edited
+		   ;; down, changed major mode and then wrote to a file.
+		   (and (= 1 (length buffers))
+			(with-current-buffer (car buffers) major-mode))
+		   (let ((root-clone
+			  (cl-find root-name buffers
+				   :key #'buffer-name :test #'string=)))
+		     (and root-clone (with-current-buffer root-clone
+				       (and (buffer-file-name) major-mode))))
+		   ;; See if the name of one of the clones is a substring of
+		   ;; its major mode, and if so, use that mode.
+		   ;; E.g. *eww* -> `eww-mode'.  Cases this heuristic will get
+		   ;; wrong should have entries in
+		   ;; `transient-cycles-buffer-sublings-major-modes'.
+		   (cl-loop
+		    with root-root-name = (regexp-quote
+					   (string-trim root-name "\\*" "\\*"))
+		    with case-fold-search = t
+		    for buffer in buffers
+		    for mode = (symbol-name
+				(with-current-buffer buffer major-mode))
+		    when (string-match root-root-name mode) return mode)
+		   ;; Fallback.
+		   (with-current-buffer buffer major-mode))))
+    (dolist (buffer buffers) (puthash buffer t clones-hash))
+    (dolist (buffer (buffer-list))
+      (with-current-buffer buffer
+	(when (and (eq mode major-mode) (not (gethash buffer clones-hash)))
+	  (push buffer buffers))))
+    (let ((ring (make-ring (length buffers)))
+	  ;; Often BUFFER will be the most recently selected buffer and so the
+	  ;; car of the buffer list, but not always, and we always want
+	  ;; cycling to begin from BUFFER.
+	  (reversed (nreverse (cons buffer (remove buffer buffers)))))
+      (dolist (buffer reversed ring) (ring-insert ring buffer)))))
+
+
+;;;; Minor modes
+
+(defvar transient-cycles-buffer-siblings-mode-map (make-sparse-keymap)
+  "Keymap for `transient-cycles-buffer-siblings-mode'.")
+
+;;;###autoload
+(define-minor-mode transient-cycles-buffer-siblings-mode
+    "Augment a number of standard buffer switching commands with
+transient cycling through buffer siblings.  After typing
+\\[switch-to-buffer], \\[display-buffer], \\[info] and some
+others, you can use the keys
+`transient-cycles-default-cycle-backwards-key' and
+`transient-cycles-default-cycle-forwards-key' to select a
+different, relevantly similar buffer to select or display
+instead.  See `transient-cycles-buffer-siblings-ring' for details
+of the notion of similarity employed.
+
+The purpose of this mode is to make it easier to handle large
+numbers of similarly-named buffers without having to take the
+time to manually rename them.  For example, suppose while reading
+Info you type \\<Info-mode-map>\\[clone-buffer] several times in
+order to view several pieces of information at once.  Later you
+need to refer back to one of those buffers, but \\[info] will
+always take you to `*info*', and if you use \\[switch-to-buffer]
+it might take you several tries to select the buffer you wanted.
+Thanks to this minor mode, after using either of those commands
+to switch to any `Info-mode' buffer you can quickly cycle through
+to the intended target.
+
+If any of the commands augmented by this minor mode have been
+rebound to key sequences ending in arrow keys, then the cycling
+keys will be the corresponding pair of arrow keys.  For example,
+if you have rebound `switch-to-buffer' to a key sequence ending
+in \\`<left>', then the cycling keys will be \\`<left>' and \\`<right>'."
+  :lighter nil :keymap transient-cycles-buffer-siblings-mode-map :global t
+  :group 'transient-cycles)
+
+(transient-cycles-define-commands (prev-buffers)
+  (([remap switch-to-buffer] (buffer &optional _norecord force-same-window)
+     (prog1 (switch-to-buffer buffer t force-same-window)
+       (setq prev-buffers (window-prev-buffers))))
+
+   ([remap switch-to-buffer-other-window] (buffer-or-name &rest _ignore)
+     (prog1 (switch-to-buffer-other-window buffer-or-name t)
+       (setq prev-buffers (window-prev-buffers))))
+
+   ([remap switch-to-buffer-other-tab] (buffer-or-name)
+     (prog1 (window-buffer (switch-to-buffer-other-tab buffer-or-name))
+       (setq prev-buffers (window-prev-buffers)))))
+
+  (transient-cycles-buffer-ring-cycler)
+  :on-exit (progn (switch-to-buffer (current-buffer) nil t)
+		  (set-window-next-buffers nil nil)
+		  (set-window-prev-buffers nil prev-buffers))
+  :keymap transient-cycles-buffer-siblings-mode-map)
+
+;; Here we don't try to restore the fundamental or frame buffer lists, but it
+;; would be possible to do so.  See (info "(elisp) Buffer List").
+(transient-cycles-define-commands (window prev-buffers)
+  (([remap display-buffer] (buffer-or-name &optional action frame)
+     (prog1 (setq window (display-buffer buffer-or-name action frame))
+       (setq prev-buffers (window-prev-buffers window))))
+
+   ([remap info] (&optional file-or-node buffer)
+    (prog2 (info file-or-node buffer)
+	(setq window (get-buffer-window buffer))
+      (setq prev-buffers (and window (window-prev-buffers window))))))
+
+  (transient-cycles-buffer-ring-cycler
+   :ring (transient-cycles-buffer-siblings-ring (window-buffer ret-val))
+   :action
+   (with-selected-window ret-val
+     (let ((display-buffer-overriding-action
+	    '((display-buffer-same-window) (inhibit-same-window . nil))))
+       (display-buffer buffer))))
+  :on-exit (progn (set-window-next-buffers window nil)
+		  (set-window-prev-buffers window prev-buffers))
+  :keymap transient-cycles-buffer-siblings-mode-map)
+
+(defvar transient-cycles-window-buffers-mode-map (make-sparse-keymap)
+  "Keymap for `transient-cycles-window-buffers-mode'.")
+
+;;;###autoload
+(define-minor-mode transient-cycles-window-buffers-mode
+    "Augment \\[previous-buffer] and \\[next-buffer] with transient
+cycling.  After typing those commands, you can use the cycling
+keys to move forwards and backwards in a virtual list of the
+window's previous, current and next buffers.  When transient
+cycling completes, your starting point will be stored, such that
+\\[transient-cycles-window-buffers-back-and-forth] can quickly
+take you back there.
+
+If either `previous-buffer' or `next-buffer' are bound to key
+sequences ending in arrow keys, then the cycling keys will be the
+corresponding pair of arrow keys.  Thus, by default, the cycling
+keys are \\`<left>' and \\`<right>'.  Otherwise the fallbacks
+`transient-cycles-default-cycle-backwards-key' and
+`transient-cycles-default-cycle-forwards-key' are used."
+  :lighter nil :keymap transient-cycles-window-buffers-mode-map :global t
+  :group 'transient-cycles)
+
 (provide 'transient-cycles)
 
 ;;; transient-cycles.el ends here