645 lines
26 KiB
EmacsLisp
645 lines
26 KiB
EmacsLisp
;;; helm-ring.el --- kill-ring, mark-ring, and register browsers for helm. -*- lexical-binding: t -*-
|
||
|
||
;; Copyright (C) 2012 ~ 2023 Thierry Volpiatto
|
||
|
||
;; 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 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
(require 'helm)
|
||
(require 'helm-utils)
|
||
(require 'helm-help)
|
||
(require 'helm-elisp)
|
||
|
||
(declare-function undo-tree-restore-state-from-register "ext:undo-tree.el" (register))
|
||
(declare-function kmacro--keys "kmacro.el")
|
||
(declare-function frameset-register-p "frameset")
|
||
|
||
(defgroup helm-ring nil
|
||
"Ring related Applications and libraries for Helm."
|
||
:group 'helm)
|
||
|
||
(defcustom helm-kill-ring-threshold 3
|
||
"Minimum length of a candidate to be listed by `helm-source-kill-ring'."
|
||
:type 'integer
|
||
:group 'helm-ring)
|
||
|
||
(defcustom helm-kill-ring-max-offset 400
|
||
"Max number of chars displayed per candidate in kill-ring browser.
|
||
When `t', don't truncate candidate, show all.
|
||
By default it is approximatively the number of bits contained in five lines
|
||
of 80 chars each, i.e. 80*5.
|
||
Note that if you set this to nil multiline will be disabled, i.e. you
|
||
will not have separators between candidates any more."
|
||
:type '(choice (const :tag "Disabled" t)
|
||
(integer :tag "Max candidate offset"))
|
||
:group 'helm-ring)
|
||
|
||
(defcustom helm-kill-ring-actions
|
||
'(("Yank marked" . helm-kill-ring-action-yank)
|
||
("Delete marked" . helm-kill-ring-action-delete)
|
||
("Search from candidate" . helm-kill-ring-search-from-string))
|
||
"List of actions for kill ring source."
|
||
:group 'helm-ring
|
||
:type '(alist :key-type string :value-type function))
|
||
|
||
(defcustom helm-kill-ring-separator "\n"
|
||
"The separator used to separate marked candidates when yanking."
|
||
:group 'helm-ring
|
||
:type 'string)
|
||
|
||
(defcustom helm-register-max-offset 160
|
||
"Max size of string register entries before truncating."
|
||
:group 'helm-ring
|
||
:type 'integer)
|
||
|
||
;;; Kill ring
|
||
;;
|
||
;;
|
||
(defvar helm-kill-ring-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(set-keymap-parent map helm-map)
|
||
(define-key map (kbd "M-y") 'helm-next-line)
|
||
(define-key map (kbd "M-u") 'helm-previous-line)
|
||
(define-key map (kbd "M-D") 'helm-kill-ring-delete)
|
||
(define-key map (kbd "C-s") 'helm-kill-ring-run-search-from-string)
|
||
(define-key map (kbd "C-]") 'helm-kill-ring-toggle-truncated)
|
||
(define-key map (kbd "C-c C-k") 'helm-kill-ring-kill-selection)
|
||
(define-key map (kbd "C-c d") 'helm-kill-ring-run-persistent-delete)
|
||
map)
|
||
"Keymap for `helm-show-kill-ring'.")
|
||
|
||
(defvar helm-source-kill-ring
|
||
(helm-build-sync-source "Kill Ring"
|
||
:init (lambda ()
|
||
(helm-set-attr 'last-command last-command)
|
||
(helm-set-attr 'multiline helm-kill-ring-max-offset))
|
||
:candidates #'helm-kill-ring-candidates
|
||
:filtered-candidate-transformer #'helm-kill-ring-transformer
|
||
:action 'helm-kill-ring-actions
|
||
:persistent-action 'ignore
|
||
:help-message 'helm-kill-ring-help-message
|
||
:persistent-help "DoNothing"
|
||
:keymap helm-kill-ring-map
|
||
:migemo t
|
||
:multiline 'helm-kill-ring-max-offset
|
||
:group 'helm-ring)
|
||
"Source for browse and insert contents of kill-ring.")
|
||
|
||
(defun helm-kill-ring-candidates ()
|
||
(cl-loop with cands = (helm-fast-remove-dups kill-ring :test 'equal)
|
||
for kill in (if (eq (helm-get-attr 'last-command) 'yank)
|
||
(cdr cands)
|
||
cands)
|
||
unless (or (< (length kill) helm-kill-ring-threshold)
|
||
(string-match "\\`[\n[:blank:]]+\\'" kill))
|
||
collect kill))
|
||
|
||
(defun helm-kill-ring-transformer (candidates _source)
|
||
"Ensure CANDIDATES are not read-only."
|
||
(cl-loop for i in candidates
|
||
when (get-text-property 0 'read-only i)
|
||
do (set-text-properties 0 (length i) '(read-only nil) i)
|
||
collect i))
|
||
|
||
(defvar helm-kill-ring--truncated-flag nil)
|
||
(defun helm-kill-ring-toggle-truncated ()
|
||
"Toggle truncated view of candidates in helm kill-ring browser."
|
||
(interactive)
|
||
(with-helm-alive-p
|
||
(setq helm-kill-ring--truncated-flag (not helm-kill-ring--truncated-flag))
|
||
(let* ((cur-cand (helm-get-selection))
|
||
(presel-fn (lambda ()
|
||
(helm-kill-ring--preselect-fn cur-cand)))
|
||
helm-display-source-at-screen-top)
|
||
(helm-set-attr 'multiline
|
||
(if helm-kill-ring--truncated-flag
|
||
15000000
|
||
helm-kill-ring-max-offset))
|
||
(helm-update presel-fn))))
|
||
(put 'helm-kill-ring-toggle-truncated 'helm-only t)
|
||
|
||
(defun helm-kill-ring-kill-selection ()
|
||
"Store the real value of candidate in kill-ring.
|
||
Same as `helm-kill-selection-and-quit' called with a prefix arg."
|
||
(interactive)
|
||
(helm-kill-selection-and-quit t))
|
||
(put 'helm-kill-ring-kill-selection 'helm-only t)
|
||
|
||
(defun helm-kill-ring--preselect-fn (candidate)
|
||
"Internal, used to preselect CANDIDATE when toggling truncated view."
|
||
;; Preselection by regexp may not work if candidate is huge, so walk
|
||
;; the helm buffer until selection is on CANDIDATE.
|
||
(helm-awhile (condition-case-unless-debug nil
|
||
(and (not (helm-pos-header-line-p))
|
||
(helm-get-selection))
|
||
(error nil))
|
||
(if (string= it candidate)
|
||
(cl-return)
|
||
(helm-next-line))))
|
||
|
||
(defun helm-kill-ring-action-yank (_str)
|
||
"Insert concatenated marked candidates in current-buffer.
|
||
|
||
When two prefix args are given prompt to choose separator, otherwise
|
||
use `helm-kill-ring-separator' as default."
|
||
(let ((marked (helm-marked-candidates))
|
||
(sep (if (equal helm-current-prefix-arg '(16))
|
||
(read-string "Separator: ")
|
||
helm-kill-ring-separator)))
|
||
(helm-kill-ring-action-yank-1
|
||
(cl-loop for c in (butlast marked)
|
||
concat (concat c sep) into str
|
||
finally return (concat str (car (last marked)))))))
|
||
|
||
(defun helm-kill-ring-action-yank-1 (str)
|
||
"Insert STR in `kill-ring' and set STR to the head.
|
||
|
||
When called with a prefix arg, point and mark are exchanged
|
||
without activating region.
|
||
If this action is executed just after `yank', replace with STR as
|
||
yanked string."
|
||
(let ((yank-fn (lambda (&optional before yank-pop)
|
||
(insert-for-yank str)
|
||
;; Set the window start back where it was in
|
||
;; the yank command, if possible.
|
||
(when yank-pop
|
||
(set-window-start (selected-window) yank-window-start t))
|
||
(when (or (equal helm-current-prefix-arg '(4)) before)
|
||
;; Same as exchange-point-and-mark but without
|
||
;; activating region.
|
||
(goto-char (prog1 (mark t)
|
||
(set-marker (mark-marker)
|
||
(point)
|
||
helm-current-buffer)))))))
|
||
;; Prevent inserting and saving highlighted items.
|
||
(set-text-properties 0 (length str) nil str)
|
||
(with-helm-current-buffer
|
||
(unwind-protect
|
||
(progn
|
||
(setq kill-ring (delete str kill-ring))
|
||
;; Adding a `delete-selection' property
|
||
;; to `helm-kill-ring-action' is not working
|
||
;; because `this-command' will be `helm-maybe-exit-minibuffer',
|
||
;; so use this workaround (Bug#1520).
|
||
(when (and (region-active-p) delete-selection-mode)
|
||
(delete-region (region-beginning) (region-end)))
|
||
(if (not (eq (helm-get-attr 'last-command helm-source-kill-ring) 'yank))
|
||
(progn
|
||
;; Ensure mark is at beginning of inserted text.
|
||
(push-mark)
|
||
;; When yanking in a helm minibuffer we need a small
|
||
;; delay to detect the mark in previous minibuffer. [1]
|
||
(run-with-timer 0.01 nil yank-fn))
|
||
;; from `yank-pop'
|
||
(let ((inhibit-read-only t)
|
||
(before (< (point) (mark t))))
|
||
(if before
|
||
(funcall (or yank-undo-function 'delete-region) (point) (mark t))
|
||
(funcall (or yank-undo-function 'delete-region) (mark t) (point)))
|
||
(setq yank-undo-function nil)
|
||
(set-marker (mark-marker) (point) helm-current-buffer)
|
||
;; Same as [1] but use the same mark and point as in
|
||
;; the initial yank according to BEFORE even if no
|
||
;; prefix arg is given.
|
||
(run-with-timer 0.01 nil yank-fn before 'pop))))
|
||
(kill-new str)))))
|
||
(define-obsolete-function-alias 'helm-kill-ring-action 'helm-kill-ring-action-yank "2.4.0")
|
||
|
||
(defun helm-kill-ring-search-from-string (candidate)
|
||
(let ((str (car (split-string candidate "\n"))))
|
||
(helm-multi-occur-1
|
||
(list (current-buffer))
|
||
(regexp-quote (substring-no-properties str)))))
|
||
|
||
(helm-make-command-from-action helm-kill-ring-run-search-from-string
|
||
"Run helm-occur from kill ring."
|
||
'helm-kill-ring-search-from-string)
|
||
|
||
(defun helm-kill-ring-action-delete (_candidate)
|
||
"Delete marked candidates from `kill-ring'."
|
||
(cl-loop for c in (helm-marked-candidates)
|
||
do (setq kill-ring
|
||
(delete c kill-ring))))
|
||
|
||
(defun helm-kill-ring-persistent-delete (_candidate)
|
||
(unwind-protect
|
||
(cl-loop for c in (helm-marked-candidates)
|
||
do (progn
|
||
(helm-preselect (format "^%s" (regexp-quote c)))
|
||
(setq kill-ring (delete c kill-ring))
|
||
(helm-delete-current-selection)
|
||
(helm--remove-marked-and-update-mode-line c)))
|
||
(with-helm-buffer
|
||
(setq helm-marked-candidates nil
|
||
helm-visible-mark-overlays nil))
|
||
(helm-force-update (helm-aif (helm-get-selection nil t) (regexp-quote it)))))
|
||
|
||
(helm-make-persistent-command-from-action helm-kill-ring-run-persistent-delete
|
||
"Delete current candidate without quitting."
|
||
'quick-delete 'helm-kill-ring-persistent-delete)
|
||
|
||
(helm-make-command-from-action helm-kill-ring-delete
|
||
"Delete marked candidates from `kill-ring'."
|
||
'helm-kill-ring-action-delete)
|
||
|
||
|
||
;;;; <Mark ring>
|
||
;; DO NOT use these sources with other sources use
|
||
;; the commands `helm-mark-ring', `helm-global-mark-ring' or
|
||
;; `helm-all-mark-rings' instead.
|
||
|
||
(defun helm-mark-ring-line-string-at-pos (pos)
|
||
"Return line string at position POS."
|
||
(save-excursion
|
||
(goto-char pos)
|
||
(forward-line 0)
|
||
(let ((line (car (split-string (thing-at-point 'line) "[\n\r]"))))
|
||
(remove-text-properties 0 (length line) '(read-only) line)
|
||
(if (string= "" line)
|
||
"<EMPTY LINE>"
|
||
line))))
|
||
|
||
(defun helm-mark-ring-get-candidates ()
|
||
(with-helm-current-buffer
|
||
(cl-loop with marks = (if (mark t)
|
||
(cons (mark-marker) mark-ring)
|
||
mark-ring)
|
||
for marker in marks
|
||
with max-line-number = (line-number-at-pos (point-max))
|
||
with width = (length (number-to-string max-line-number))
|
||
for m = (format (concat "%" (number-to-string width) "d: %s")
|
||
(line-number-at-pos marker)
|
||
(helm-mark-ring-line-string-at-pos marker))
|
||
unless (and recip (assoc m recip))
|
||
collect (cons m marker) into recip
|
||
finally return recip)))
|
||
|
||
(defun helm-mark-ring-default-action (candidate)
|
||
(let ((target (copy-marker candidate)))
|
||
(helm-aif (marker-buffer candidate)
|
||
(progn
|
||
(switch-to-buffer it)
|
||
(with-selected-window (get-buffer-window it)
|
||
(unless helm-in-persistent-action
|
||
(helm-log-run-hook
|
||
"helm-mark-ring-default-action" 'helm-goto-line-before-hook))
|
||
(helm-match-line-cleanup)
|
||
(unless helm-yank-point (setq helm-yank-point (point)))
|
||
(helm-goto-char target)
|
||
(helm-highlight-current-line)))
|
||
;; marker points to no buffer, no need to dereference it, just
|
||
;; delete it.
|
||
(setq mark-ring (delete target mark-ring))
|
||
(error "Marker points to no buffer"))))
|
||
|
||
(defvar helm-source-mark-ring
|
||
(helm-build-sync-source "mark-ring"
|
||
:candidates #'helm-mark-ring-get-candidates
|
||
:action '(("Goto line" . helm-mark-ring-default-action))
|
||
:persistent-help "Show this line"
|
||
:group 'helm-ring))
|
||
|
||
;;; Global-mark-ring
|
||
(defvar helm-source-global-mark-ring
|
||
(helm-build-sync-source "global-mark-ring"
|
||
:candidates #'helm-global-mark-ring-get-candidates
|
||
:action '(("Goto line" . helm-mark-ring-default-action))
|
||
:persistent-help "Show this line"
|
||
:group 'helm-ring))
|
||
|
||
(defun helm-global-mark-ring-format-buffer (marker)
|
||
(with-current-buffer (marker-buffer marker)
|
||
(goto-char marker)
|
||
(forward-line 0)
|
||
(let ((line (helm-acase (thing-at-point 'line)
|
||
((guard (and (stringp it)
|
||
(not (string-match-p "\\`\n?\\'" it))))
|
||
(car (split-string it "[\n\r]")))
|
||
(t "<EMPTY LINE>"))))
|
||
(remove-text-properties 0 (length line) '(read-only) line)
|
||
(format "%7d:%s: %s"
|
||
(line-number-at-pos) (marker-buffer marker) line))))
|
||
|
||
(defun helm-global-mark-ring-get-candidates ()
|
||
(let ((marks global-mark-ring))
|
||
(when marks
|
||
(cl-loop for marker in marks
|
||
for mb = (marker-buffer marker)
|
||
for gm = (unless (or (string-match "^ " (format "%s" mb))
|
||
(null mb))
|
||
(helm-global-mark-ring-format-buffer marker))
|
||
when (and gm (not (assoc gm recip)))
|
||
collect (cons gm marker) into recip
|
||
finally return recip))))
|
||
|
||
;;;; <Register>
|
||
;;; Insert from register
|
||
(defvar helm-source-register
|
||
(helm-build-sync-source "Registers"
|
||
:candidates #'helm-register-candidates
|
||
:action-transformer #'helm-register-action-transformer
|
||
:persistent-help ""
|
||
:multiline t
|
||
:action '(("Delete Register(s)" .
|
||
(lambda (_candidate)
|
||
(cl-loop for candidate in (helm-marked-candidates)
|
||
for register = (car candidate)
|
||
do (setq register-alist
|
||
(delq (assoc register register-alist)
|
||
register-alist))))))
|
||
:group 'helm-ring)
|
||
"See (info \"(emacs)Registers\")")
|
||
|
||
(defun helm-register-candidates ()
|
||
"Collecting register contents and appropriate commands."
|
||
(require 'frameset)
|
||
(cl-loop for (char . rval) in register-alist
|
||
for key = (single-key-description char)
|
||
for e27 = (registerv-p rval)
|
||
for val = (if e27 ; emacs-27
|
||
(registerv-data rval)
|
||
rval)
|
||
for string-actions =
|
||
(cond
|
||
((numberp val)
|
||
(list (int-to-string val)
|
||
'insert-register
|
||
'increment-register))
|
||
((markerp val)
|
||
(let ((buf (marker-buffer val)))
|
||
(if (null buf)
|
||
(list "a marker in no buffer")
|
||
(list (concat
|
||
"a buffer position:"
|
||
(buffer-name buf)
|
||
", position "
|
||
(int-to-string (marker-position val)))
|
||
'jump-to-register
|
||
'insert-register))))
|
||
((and (consp val) (window-configuration-p (car val)))
|
||
(list (if (fboundp 'describe-register-1)
|
||
(describe-register-1 char) "window configuration.")
|
||
'jump-to-register))
|
||
((and (vectorp val)
|
||
(fboundp 'undo-tree-register-data-p)
|
||
(undo-tree-register-data-p (if e27 val (elt val 1))))
|
||
(list
|
||
"Undo-tree entry."
|
||
'undo-tree-restore-state-from-register))
|
||
((or (and (vectorp val) (eq 'registerv (aref val 0)))
|
||
(and (consp val) (frame-configuration-p (car val)))
|
||
(or (frame-configuration-p val)
|
||
(frameset-register-p val)))
|
||
(list (if (fboundp 'describe-register-1)
|
||
(describe-register-1 char) "Frame configuration")
|
||
'jump-to-register))
|
||
((and (consp val) (eq (car val) 'file))
|
||
(list (concat "file:"
|
||
(prin1-to-string (cdr val))
|
||
".")
|
||
'jump-to-register))
|
||
((and (consp val) (eq (car val) 'buffer))
|
||
(list (concat "buffer:"
|
||
(prin1-to-string (cdr val))
|
||
".")
|
||
'jump-to-register))
|
||
((and (consp val) (eq (car val) 'file-query))
|
||
(list (concat "file:a file-query reference: file "
|
||
(car (cdr val))
|
||
", position "
|
||
(int-to-string (car (cdr (cdr val))))
|
||
".")
|
||
'jump-to-register))
|
||
((consp val)
|
||
(let ((lines (format "%4d" (length val))))
|
||
(list (format "%s: %s\n" lines
|
||
(truncate-string-to-width
|
||
(mapconcat 'identity (list (car val))
|
||
"^J")
|
||
(- (window-width) 15)))
|
||
'insert-register)))
|
||
((stringp val)
|
||
(list
|
||
(concat (substring-no-properties
|
||
val 0 (min (length val) helm-register-max-offset))
|
||
(if (> (length val) helm-register-max-offset)
|
||
"[...]" ""))
|
||
'insert-register
|
||
'kill-new
|
||
'append-to-register
|
||
'prepend-to-register)))
|
||
unless (null string-actions) ; Fix Bug#1107.
|
||
collect (cons (format "Register %3s:\n %s" key (car string-actions))
|
||
(cons char (cdr string-actions)))))
|
||
|
||
(defun helm-register-action-transformer (actions register-and-functions)
|
||
"Decide actions by the contents of register."
|
||
(cl-loop with func-actions =
|
||
'((insert-register
|
||
"Insert Register" .
|
||
(lambda (c) (insert-register (car c))))
|
||
(kill-new
|
||
"Kill Register" .
|
||
(lambda (c) (with-temp-buffer
|
||
(insert-register (car c))
|
||
(kill-new (buffer-string)))))
|
||
(jump-to-register
|
||
"Jump to Register" .
|
||
(lambda (c) (jump-to-register (car c))))
|
||
(append-to-register
|
||
"Append Region to Register" .
|
||
(lambda (c) (append-to-register
|
||
(car c) (region-beginning) (region-end))))
|
||
(prepend-to-register
|
||
"Prepend Region to Register" .
|
||
(lambda (c) (prepend-to-register
|
||
(car c) (region-beginning) (region-end))))
|
||
(increment-register
|
||
"Increment Prefix Arg to Register" .
|
||
(lambda (c) (increment-register
|
||
helm-current-prefix-arg (car c))))
|
||
(undo-tree-restore-state-from-register
|
||
"Restore Undo-tree register" .
|
||
(lambda (c) (and (fboundp 'undo-tree-restore-state-from-register)
|
||
(undo-tree-restore-state-from-register (car c))))))
|
||
for func in (cdr register-and-functions)
|
||
when (assq func func-actions)
|
||
collect (cdr it) into transformer-actions
|
||
finally return (append transformer-actions actions)))
|
||
|
||
;;;###autoload
|
||
(defun helm-mark-ring ()
|
||
"Preconfigured `helm' for `helm-source-mark-ring'."
|
||
(interactive)
|
||
(helm :sources 'helm-source-mark-ring
|
||
:resume 'noresume
|
||
:buffer "*helm mark*"))
|
||
|
||
;;;###autoload
|
||
(defun helm-global-mark-ring ()
|
||
"Preconfigured `helm' for `helm-source-global-mark-ring'."
|
||
(interactive)
|
||
(helm :sources 'helm-source-global-mark-ring
|
||
:resume 'noresume
|
||
:buffer "*helm global mark*"))
|
||
|
||
;;;###autoload
|
||
(defun helm-all-mark-rings ()
|
||
"Preconfigured `helm' for mark rings.
|
||
Source used are `helm-source-global-mark-ring' and
|
||
`helm-source-mark-ring'."
|
||
(interactive)
|
||
(helm :sources '(helm-source-mark-ring
|
||
helm-source-global-mark-ring)
|
||
:resume 'noresume
|
||
:buffer "*helm mark ring*"))
|
||
|
||
;;;###autoload
|
||
(defun helm-register ()
|
||
"Preconfigured `helm' for Emacs registers."
|
||
(interactive)
|
||
(helm :sources 'helm-source-register
|
||
:resume 'noresume
|
||
:buffer "*helm register*"))
|
||
|
||
;;;###autoload
|
||
(defun helm-show-kill-ring ()
|
||
"Preconfigured `helm' for `kill-ring'.
|
||
It is drop-in replacement of `yank-pop'.
|
||
|
||
First call open the kill-ring browser, next calls move to next line."
|
||
(interactive)
|
||
(setq helm-kill-ring--truncated-flag nil)
|
||
(let ((enable-recursive-minibuffers t))
|
||
(helm :sources helm-source-kill-ring
|
||
:buffer "*helm kill ring*"
|
||
;; :display-source-at-screen-top nil
|
||
:resume 'noresume
|
||
:allow-nest t)))
|
||
|
||
;;;###autoload
|
||
(defun helm-execute-kmacro ()
|
||
"Preconfigured helm for keyboard macros.
|
||
Define your macros with `f3' and `f4'.
|
||
See (info \"(emacs) Keyboard Macros\") for detailed infos."
|
||
(interactive)
|
||
(let ((helm-quit-if-no-candidate
|
||
(lambda () (message "No kbd macro has been defined"))))
|
||
(helm :sources
|
||
(helm-build-sync-source "Kmacro"
|
||
:candidates (lambda ()
|
||
(delq nil
|
||
(helm-fast-remove-dups
|
||
(cons (kmacro-ring-head)
|
||
kmacro-ring)
|
||
:test 'equal)))
|
||
|
||
:multiline t
|
||
:candidate-transformer
|
||
(lambda (candidates)
|
||
(cl-loop for c in candidates
|
||
for keys = (if (functionp c)
|
||
;; Emacs-29+ (Oclosure).
|
||
(kmacro--keys c)
|
||
;; Emacs-28 and below (list).
|
||
(car c))
|
||
collect (propertize (help-key-description keys nil)
|
||
'helm-realvalue c)))
|
||
:persistent-action 'ignore
|
||
:persistent-help "Do nothing"
|
||
:help-message 'helm-kmacro-help-message
|
||
:action
|
||
(helm-make-actions
|
||
"Execute kmacro (`C-u <n>' to execute <n> times)"
|
||
'helm-kbd-macro-execute
|
||
"Concat marked macros"
|
||
'helm-kbd-macro-concat-macros
|
||
"Delete marked macros"
|
||
'helm-kbd-macro-delete-macro
|
||
"Edit marked macro"
|
||
'helm-kbd-macro-edit-macro
|
||
"Insert kbd macro"
|
||
'helm-kbd-macro-insert-macro)
|
||
:group 'helm-ring)
|
||
:buffer "*helm kmacro*")))
|
||
|
||
(defun helm-kbd-macro-make-current (candidate)
|
||
"Make CANDIDATE macro the current one."
|
||
(setq kmacro-ring (delete candidate kmacro-ring))
|
||
(kmacro-push-ring)
|
||
(kmacro-split-ring-element candidate))
|
||
|
||
(defun helm-kbd-macro-insert-macro (candidate)
|
||
"Insert macro at point in `helm-current-buffer'."
|
||
(let ((desc (read-string "Describe macro briefly: "))
|
||
name key)
|
||
(while (fboundp (setq name (intern (read-string "New name for macro: "))))
|
||
(message "Symbol `%s' already exists, choose another name" name)
|
||
(sit-for 1.5))
|
||
(helm-kbd-macro-make-current candidate)
|
||
(kmacro-name-last-macro name)
|
||
(when (y-or-n-p "Bind macro to a new key?")
|
||
(helm-awhile (key-binding
|
||
(setq key (read-key-sequence-vector "Bind macro to key: ")))
|
||
(message "`%s' already run command `%s', choose another one"
|
||
(help-key-description key nil) it)
|
||
(sit-for 1.5))
|
||
(global-set-key key name))
|
||
(with-helm-current-buffer
|
||
(insert (format ";; %s%s\n"
|
||
desc
|
||
(and key (format " (bound to `%s')"
|
||
(help-key-description key nil)))))
|
||
(insert-kbd-macro name (not (null key))))))
|
||
|
||
(defun helm-kbd-macro-execute (candidate)
|
||
;; Move candidate on top of list for next use.
|
||
(helm-kbd-macro-make-current candidate)
|
||
(kmacro-exec-ring-item
|
||
candidate helm-current-prefix-arg))
|
||
|
||
(defun helm-kbd-macro-concat-macros (_candidate)
|
||
(let ((mkd (helm-marked-candidates)))
|
||
(when (cdr mkd)
|
||
(kmacro-push-ring)
|
||
(setq last-kbd-macro
|
||
(cl-loop for km in mkd
|
||
for keys = (if (functionp km)
|
||
(kmacro--keys km)
|
||
(helm-acase (car km)
|
||
((guard (vectorp it)) it)
|
||
((guard (stringp it))
|
||
(kmacro--to-vector it))))
|
||
vconcat keys)))))
|
||
|
||
(defun helm-kbd-macro-delete-macro (_candidate)
|
||
(let ((mkd (helm-marked-candidates))
|
||
(head (kmacro-ring-head)))
|
||
(cl-loop for km in mkd
|
||
do (setq kmacro-ring (delete km kmacro-ring)))
|
||
(when (member head mkd)
|
||
(kmacro-delete-ring-head))))
|
||
|
||
(defun helm-kbd-macro-edit-macro (candidate)
|
||
(kmacro-push-ring)
|
||
(setq kmacro-ring (delete candidate kmacro-ring))
|
||
(kmacro-split-ring-element candidate)
|
||
(kmacro-edit-macro))
|
||
|
||
(provide 'helm-ring)
|
||
|
||
;;; helm-ring.el ends here
|